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
);
1075 /* Resolve an actual argument list. Most of the time, this is just
1076 resolving the expressions in the list.
1077 The exception is that we sometimes have to decide whether arguments
1078 that look like procedure arguments are really simple variable
1082 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1083 bool no_formal_args
)
1086 gfc_symtree
*parent_st
;
1088 int save_need_full_assumed_size
;
1090 for (; arg
; arg
= arg
->next
)
1095 /* Check the label is a valid branching target. */
1098 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1100 gfc_error ("Label %d referenced at %L is never defined",
1101 arg
->label
->value
, &arg
->label
->where
);
1108 if (e
->expr_type
== EXPR_VARIABLE
1109 && e
->symtree
->n
.sym
->attr
.generic
1111 && count_specific_procs (e
) != 1)
1114 if (e
->ts
.type
!= BT_PROCEDURE
)
1116 save_need_full_assumed_size
= need_full_assumed_size
;
1117 if (e
->expr_type
!= EXPR_VARIABLE
)
1118 need_full_assumed_size
= 0;
1119 if (gfc_resolve_expr (e
) != SUCCESS
)
1121 need_full_assumed_size
= save_need_full_assumed_size
;
1125 /* See if the expression node should really be a variable reference. */
1127 sym
= e
->symtree
->n
.sym
;
1129 if (sym
->attr
.flavor
== FL_PROCEDURE
1130 || sym
->attr
.intrinsic
1131 || sym
->attr
.external
)
1135 /* If a procedure is not already determined to be something else
1136 check if it is intrinsic. */
1137 if (!sym
->attr
.intrinsic
1138 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1139 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1140 && gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1141 sym
->attr
.intrinsic
= 1;
1143 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1145 gfc_error ("Statement function '%s' at %L is not allowed as an "
1146 "actual argument", sym
->name
, &e
->where
);
1149 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1150 sym
->attr
.subroutine
);
1151 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1153 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1154 "actual argument", sym
->name
, &e
->where
);
1157 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1158 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1160 gfc_error ("Internal procedure '%s' is not allowed as an "
1161 "actual argument at %L", sym
->name
, &e
->where
);
1164 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1166 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1167 "allowed as an actual argument at %L", sym
->name
,
1171 /* Check if a generic interface has a specific procedure
1172 with the same name before emitting an error. */
1173 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1176 /* Just in case a specific was found for the expression. */
1177 sym
= e
->symtree
->n
.sym
;
1179 if (sym
->attr
.entry
&& sym
->ns
->entries
1180 && sym
->ns
== gfc_current_ns
1181 && !sym
->ns
->entries
->sym
->attr
.recursive
)
1183 gfc_error ("Reference to ENTRY '%s' at %L is recursive, but procedure "
1184 "'%s' is not declared as RECURSIVE",
1185 sym
->name
, &e
->where
, sym
->ns
->entries
->sym
->name
);
1188 /* If the symbol is the function that names the current (or
1189 parent) scope, then we really have a variable reference. */
1191 if (sym
->attr
.function
&& sym
->result
== sym
1192 && (sym
->ns
->proc_name
== sym
1193 || (sym
->ns
->parent
!= NULL
1194 && sym
->ns
->parent
->proc_name
== sym
)))
1197 /* If all else fails, see if we have a specific intrinsic. */
1198 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1200 gfc_intrinsic_sym
*isym
;
1202 isym
= gfc_find_function (sym
->name
);
1203 if (isym
== NULL
|| !isym
->specific
)
1205 gfc_error ("Unable to find a specific INTRINSIC procedure "
1206 "for the reference '%s' at %L", sym
->name
,
1211 sym
->attr
.intrinsic
= 1;
1212 sym
->attr
.function
= 1;
1217 /* See if the name is a module procedure in a parent unit. */
1219 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1222 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1224 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1228 if (parent_st
== NULL
)
1231 sym
= parent_st
->n
.sym
;
1232 e
->symtree
= parent_st
; /* Point to the right thing. */
1234 if (sym
->attr
.flavor
== FL_PROCEDURE
1235 || sym
->attr
.intrinsic
1236 || sym
->attr
.external
)
1242 e
->expr_type
= EXPR_VARIABLE
;
1244 if (sym
->as
!= NULL
)
1246 e
->rank
= sym
->as
->rank
;
1247 e
->ref
= gfc_get_ref ();
1248 e
->ref
->type
= REF_ARRAY
;
1249 e
->ref
->u
.ar
.type
= AR_FULL
;
1250 e
->ref
->u
.ar
.as
= sym
->as
;
1253 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1254 primary.c (match_actual_arg). If above code determines that it
1255 is a variable instead, it needs to be resolved as it was not
1256 done at the beginning of this function. */
1257 save_need_full_assumed_size
= need_full_assumed_size
;
1258 if (e
->expr_type
!= EXPR_VARIABLE
)
1259 need_full_assumed_size
= 0;
1260 if (gfc_resolve_expr (e
) != SUCCESS
)
1262 need_full_assumed_size
= save_need_full_assumed_size
;
1265 /* Check argument list functions %VAL, %LOC and %REF. There is
1266 nothing to do for %REF. */
1267 if (arg
->name
&& arg
->name
[0] == '%')
1269 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1271 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1273 gfc_error ("By-value argument at %L is not of numeric "
1280 gfc_error ("By-value argument at %L cannot be an array or "
1281 "an array section", &e
->where
);
1285 /* Intrinsics are still PROC_UNKNOWN here. However,
1286 since same file external procedures are not resolvable
1287 in gfortran, it is a good deal easier to leave them to
1289 if (ptype
!= PROC_UNKNOWN
1290 && ptype
!= PROC_DUMMY
1291 && ptype
!= PROC_EXTERNAL
1292 && ptype
!= PROC_MODULE
)
1294 gfc_error ("By-value argument at %L is not allowed "
1295 "in this context", &e
->where
);
1300 /* Statement functions have already been excluded above. */
1301 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1302 && e
->ts
.type
== BT_PROCEDURE
)
1304 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1306 gfc_error ("Passing internal procedure at %L by location "
1307 "not allowed", &e
->where
);
1318 /* Do the checks of the actual argument list that are specific to elemental
1319 procedures. If called with c == NULL, we have a function, otherwise if
1320 expr == NULL, we have a subroutine. */
1323 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1325 gfc_actual_arglist
*arg0
;
1326 gfc_actual_arglist
*arg
;
1327 gfc_symbol
*esym
= NULL
;
1328 gfc_intrinsic_sym
*isym
= NULL
;
1330 gfc_intrinsic_arg
*iformal
= NULL
;
1331 gfc_formal_arglist
*eformal
= NULL
;
1332 bool formal_optional
= false;
1333 bool set_by_optional
= false;
1337 /* Is this an elemental procedure? */
1338 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1340 if (expr
->value
.function
.esym
!= NULL
1341 && expr
->value
.function
.esym
->attr
.elemental
)
1343 arg0
= expr
->value
.function
.actual
;
1344 esym
= expr
->value
.function
.esym
;
1346 else if (expr
->value
.function
.isym
!= NULL
1347 && expr
->value
.function
.isym
->elemental
)
1349 arg0
= expr
->value
.function
.actual
;
1350 isym
= expr
->value
.function
.isym
;
1355 else if (c
&& c
->ext
.actual
!= NULL
)
1357 arg0
= c
->ext
.actual
;
1359 if (c
->resolved_sym
)
1360 esym
= c
->resolved_sym
;
1362 esym
= c
->symtree
->n
.sym
;
1365 if (!esym
->attr
.elemental
)
1371 /* The rank of an elemental is the rank of its array argument(s). */
1372 for (arg
= arg0
; arg
; arg
= arg
->next
)
1374 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1376 rank
= arg
->expr
->rank
;
1377 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1378 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1379 set_by_optional
= true;
1381 /* Function specific; set the result rank and shape. */
1385 if (!expr
->shape
&& arg
->expr
->shape
)
1387 expr
->shape
= gfc_get_shape (rank
);
1388 for (i
= 0; i
< rank
; i
++)
1389 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1396 /* If it is an array, it shall not be supplied as an actual argument
1397 to an elemental procedure unless an array of the same rank is supplied
1398 as an actual argument corresponding to a nonoptional dummy argument of
1399 that elemental procedure(12.4.1.5). */
1400 formal_optional
= false;
1402 iformal
= isym
->formal
;
1404 eformal
= esym
->formal
;
1406 for (arg
= arg0
; arg
; arg
= arg
->next
)
1410 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1411 formal_optional
= true;
1412 eformal
= eformal
->next
;
1414 else if (isym
&& iformal
)
1416 if (iformal
->optional
)
1417 formal_optional
= true;
1418 iformal
= iformal
->next
;
1421 formal_optional
= true;
1423 if (pedantic
&& arg
->expr
!= NULL
1424 && arg
->expr
->expr_type
== EXPR_VARIABLE
1425 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1428 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1429 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1431 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1432 "MISSING, it cannot be the actual argument of an "
1433 "ELEMENTAL procedure unless there is a non-optional "
1434 "argument with the same rank (12.4.1.5)",
1435 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1440 for (arg
= arg0
; arg
; arg
= arg
->next
)
1442 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1445 /* Being elemental, the last upper bound of an assumed size array
1446 argument must be present. */
1447 if (resolve_assumed_size_actual (arg
->expr
))
1450 /* Elemental procedure's array actual arguments must conform. */
1453 if (gfc_check_conformance ("elemental procedure", arg
->expr
, e
)
1461 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1462 is an array, the intent inout/out variable needs to be also an array. */
1463 if (rank
> 0 && esym
&& expr
== NULL
)
1464 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1465 arg
= arg
->next
, eformal
= eformal
->next
)
1466 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1467 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1468 && arg
->expr
&& arg
->expr
->rank
== 0)
1470 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1471 "ELEMENTAL subroutine '%s' is a scalar, but another "
1472 "actual argument is an array", &arg
->expr
->where
,
1473 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1474 : "INOUT", eformal
->sym
->name
, esym
->name
);
1481 /* Go through each actual argument in ACTUAL and see if it can be
1482 implemented as an inlined, non-copying intrinsic. FNSYM is the
1483 function being called, or NULL if not known. */
1486 find_noncopying_intrinsics (gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
)
1488 gfc_actual_arglist
*ap
;
1491 for (ap
= actual
; ap
; ap
= ap
->next
)
1493 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1494 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
,
1496 ap
->expr
->inline_noncopying_intrinsic
= 1;
1500 /* This function does the checking of references to global procedures
1501 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1502 77 and 95 standards. It checks for a gsymbol for the name, making
1503 one if it does not already exist. If it already exists, then the
1504 reference being resolved must correspond to the type of gsymbol.
1505 Otherwise, the new symbol is equipped with the attributes of the
1506 reference. The corresponding code that is called in creating
1507 global entities is parse.c. */
1510 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1515 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1517 gsym
= gfc_get_gsymbol (sym
->name
);
1519 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1520 gfc_global_used (gsym
, where
);
1522 if (gsym
->type
== GSYM_UNKNOWN
)
1525 gsym
->where
= *where
;
1532 /************* Function resolution *************/
1534 /* Resolve a function call known to be generic.
1535 Section 14.1.2.4.1. */
1538 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
1542 if (sym
->attr
.generic
)
1544 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1547 expr
->value
.function
.name
= s
->name
;
1548 expr
->value
.function
.esym
= s
;
1550 if (s
->ts
.type
!= BT_UNKNOWN
)
1552 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1553 expr
->ts
= s
->result
->ts
;
1556 expr
->rank
= s
->as
->rank
;
1557 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1558 expr
->rank
= s
->result
->as
->rank
;
1560 gfc_set_sym_referenced (expr
->value
.function
.esym
);
1565 /* TODO: Need to search for elemental references in generic
1569 if (sym
->attr
.intrinsic
)
1570 return gfc_intrinsic_func_interface (expr
, 0);
1577 resolve_generic_f (gfc_expr
*expr
)
1582 sym
= expr
->symtree
->n
.sym
;
1586 m
= resolve_generic_f0 (expr
, sym
);
1589 else if (m
== MATCH_ERROR
)
1593 if (sym
->ns
->parent
== NULL
)
1595 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1599 if (!generic_sym (sym
))
1603 /* Last ditch attempt. See if the reference is to an intrinsic
1604 that possesses a matching interface. 14.1.2.4 */
1605 if (sym
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
1607 gfc_error ("There is no specific function for the generic '%s' at %L",
1608 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1612 m
= gfc_intrinsic_func_interface (expr
, 0);
1616 gfc_error ("Generic function '%s' at %L is not consistent with a "
1617 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
1624 /* Resolve a function call known to be specific. */
1627 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
1631 /* See if we have an intrinsic interface. */
1633 if (sym
->ts
.interface
!= NULL
&& sym
->ts
.interface
->attr
.intrinsic
)
1635 gfc_intrinsic_sym
*isym
;
1636 isym
= gfc_find_function (sym
->ts
.interface
->name
);
1638 /* Existence of isym should be checked already. */
1641 sym
->ts
.type
= isym
->ts
.type
;
1642 sym
->ts
.kind
= isym
->ts
.kind
;
1643 sym
->attr
.function
= 1;
1644 sym
->attr
.proc
= PROC_EXTERNAL
;
1648 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1650 if (sym
->attr
.dummy
)
1652 sym
->attr
.proc
= PROC_DUMMY
;
1656 sym
->attr
.proc
= PROC_EXTERNAL
;
1660 if (sym
->attr
.proc
== PROC_MODULE
1661 || sym
->attr
.proc
== PROC_ST_FUNCTION
1662 || sym
->attr
.proc
== PROC_INTERNAL
)
1665 if (sym
->attr
.intrinsic
)
1667 m
= gfc_intrinsic_func_interface (expr
, 1);
1671 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1672 "with an intrinsic", sym
->name
, &expr
->where
);
1680 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1683 expr
->value
.function
.name
= sym
->name
;
1684 expr
->value
.function
.esym
= sym
;
1685 if (sym
->as
!= NULL
)
1686 expr
->rank
= sym
->as
->rank
;
1693 resolve_specific_f (gfc_expr
*expr
)
1698 sym
= expr
->symtree
->n
.sym
;
1702 m
= resolve_specific_f0 (sym
, expr
);
1705 if (m
== MATCH_ERROR
)
1708 if (sym
->ns
->parent
== NULL
)
1711 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1717 gfc_error ("Unable to resolve the specific function '%s' at %L",
1718 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1724 /* Resolve a procedure call not known to be generic nor specific. */
1727 resolve_unknown_f (gfc_expr
*expr
)
1732 sym
= expr
->symtree
->n
.sym
;
1734 if (sym
->attr
.dummy
)
1736 sym
->attr
.proc
= PROC_DUMMY
;
1737 expr
->value
.function
.name
= sym
->name
;
1741 /* See if we have an intrinsic function reference. */
1743 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
1745 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1750 /* The reference is to an external name. */
1752 sym
->attr
.proc
= PROC_EXTERNAL
;
1753 expr
->value
.function
.name
= sym
->name
;
1754 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1756 if (sym
->as
!= NULL
)
1757 expr
->rank
= sym
->as
->rank
;
1759 /* Type of the expression is either the type of the symbol or the
1760 default type of the symbol. */
1763 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1765 if (sym
->ts
.type
!= BT_UNKNOWN
)
1769 ts
= gfc_get_default_type (sym
, sym
->ns
);
1771 if (ts
->type
== BT_UNKNOWN
)
1773 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1774 sym
->name
, &expr
->where
);
1785 /* Return true, if the symbol is an external procedure. */
1787 is_external_proc (gfc_symbol
*sym
)
1789 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
1790 && !(sym
->attr
.intrinsic
1791 || gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
))
1792 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1793 && !sym
->attr
.use_assoc
1801 /* Figure out if a function reference is pure or not. Also set the name
1802 of the function for a potential error message. Return nonzero if the
1803 function is PURE, zero if not. */
1805 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
1808 pure_function (gfc_expr
*e
, const char **name
)
1814 if (e
->symtree
!= NULL
1815 && e
->symtree
->n
.sym
!= NULL
1816 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1817 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
1819 if (e
->value
.function
.esym
)
1821 pure
= gfc_pure (e
->value
.function
.esym
);
1822 *name
= e
->value
.function
.esym
->name
;
1824 else if (e
->value
.function
.isym
)
1826 pure
= e
->value
.function
.isym
->pure
1827 || e
->value
.function
.isym
->elemental
;
1828 *name
= e
->value
.function
.isym
->name
;
1832 /* Implicit functions are not pure. */
1834 *name
= e
->value
.function
.name
;
1842 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
1843 int *f ATTRIBUTE_UNUSED
)
1847 /* Don't bother recursing into other statement functions
1848 since they will be checked individually for purity. */
1849 if (e
->expr_type
!= EXPR_FUNCTION
1851 || e
->symtree
->n
.sym
== sym
1852 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1855 return pure_function (e
, &name
) ? false : true;
1860 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
1862 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
1867 is_scalar_expr_ptr (gfc_expr
*expr
)
1869 gfc_try retval
= SUCCESS
;
1874 /* See if we have a gfc_ref, which means we have a substring, array
1875 reference, or a component. */
1876 if (expr
->ref
!= NULL
)
1879 while (ref
->next
!= NULL
)
1885 if (ref
->u
.ss
.length
!= NULL
1886 && ref
->u
.ss
.length
->length
!= NULL
1888 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1890 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1892 start
= (int) mpz_get_si (ref
->u
.ss
.start
->value
.integer
);
1893 end
= (int) mpz_get_si (ref
->u
.ss
.end
->value
.integer
);
1894 if (end
- start
+ 1 != 1)
1901 if (ref
->u
.ar
.type
== AR_ELEMENT
)
1903 else if (ref
->u
.ar
.type
== AR_FULL
)
1905 /* The user can give a full array if the array is of size 1. */
1906 if (ref
->u
.ar
.as
!= NULL
1907 && ref
->u
.ar
.as
->rank
== 1
1908 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
1909 && ref
->u
.ar
.as
->lower
[0] != NULL
1910 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
1911 && ref
->u
.ar
.as
->upper
[0] != NULL
1912 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
1914 /* If we have a character string, we need to check if
1915 its length is one. */
1916 if (expr
->ts
.type
== BT_CHARACTER
)
1918 if (expr
->ts
.cl
== NULL
1919 || expr
->ts
.cl
->length
== NULL
1920 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1)
1926 /* We have constant lower and upper bounds. If the
1927 difference between is 1, it can be considered a
1929 start
= (int) mpz_get_si
1930 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
1931 end
= (int) mpz_get_si
1932 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
1933 if (end
- start
+ 1 != 1)
1948 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
1950 /* Character string. Make sure it's of length 1. */
1951 if (expr
->ts
.cl
== NULL
1952 || expr
->ts
.cl
->length
== NULL
1953 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1) != 0)
1956 else if (expr
->rank
!= 0)
1963 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1964 and, in the case of c_associated, set the binding label based on
1968 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
1969 gfc_symbol
**new_sym
)
1971 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1972 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
1973 int optional_arg
= 0;
1974 gfc_try retval
= SUCCESS
;
1975 gfc_symbol
*args_sym
;
1976 gfc_typespec
*arg_ts
;
1977 gfc_ref
*parent_ref
;
1980 if (args
->expr
->expr_type
== EXPR_CONSTANT
1981 || args
->expr
->expr_type
== EXPR_OP
1982 || args
->expr
->expr_type
== EXPR_NULL
)
1984 gfc_error ("Argument to '%s' at %L is not a variable",
1985 sym
->name
, &(args
->expr
->where
));
1989 args_sym
= args
->expr
->symtree
->n
.sym
;
1991 /* The typespec for the actual arg should be that stored in the expr
1992 and not necessarily that of the expr symbol (args_sym), because
1993 the actual expression could be a part-ref of the expr symbol. */
1994 arg_ts
= &(args
->expr
->ts
);
1996 /* Get the parent reference (if any) for the expression. This happens for
1997 cases such as a%b%c. */
1998 parent_ref
= args
->expr
->ref
;
2000 if (parent_ref
!= NULL
)
2002 curr_ref
= parent_ref
->next
;
2003 while (curr_ref
!= NULL
&& curr_ref
->next
!= NULL
)
2005 parent_ref
= curr_ref
;
2006 curr_ref
= curr_ref
->next
;
2010 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
2011 is for a REF_COMPONENT, then we need to use it as the parent_ref for
2012 the name, etc. Otherwise, the current parent_ref should be correct. */
2013 if (curr_ref
!= NULL
&& curr_ref
->type
== REF_COMPONENT
)
2014 parent_ref
= curr_ref
;
2016 if (parent_ref
== args
->expr
->ref
)
2018 else if (parent_ref
!= NULL
&& parent_ref
->type
!= REF_COMPONENT
)
2019 gfc_internal_error ("Unexpected expression reference type in "
2020 "gfc_iso_c_func_interface");
2022 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2024 /* If the user gave two args then they are providing something for
2025 the optional arg (the second cptr). Therefore, set the name and
2026 binding label to the c_associated for two cptrs. Otherwise,
2027 set c_associated to expect one cptr. */
2031 sprintf (name
, "%s_2", sym
->name
);
2032 sprintf (binding_label
, "%s_2", sym
->binding_label
);
2038 sprintf (name
, "%s_1", sym
->name
);
2039 sprintf (binding_label
, "%s_1", sym
->binding_label
);
2043 /* Get a new symbol for the version of c_associated that
2045 *new_sym
= get_iso_c_sym (sym
, name
, binding_label
, optional_arg
);
2047 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2048 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2050 sprintf (name
, "%s", sym
->name
);
2051 sprintf (binding_label
, "%s", sym
->binding_label
);
2053 /* Error check the call. */
2054 if (args
->next
!= NULL
)
2056 gfc_error_now ("More actual than formal arguments in '%s' "
2057 "call at %L", name
, &(args
->expr
->where
));
2060 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2062 /* Make sure we have either the target or pointer attribute. */
2063 if (!(args_sym
->attr
.target
)
2064 && !(args_sym
->attr
.pointer
)
2065 && (parent_ref
== NULL
||
2066 !parent_ref
->u
.c
.component
->attr
.pointer
))
2068 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2069 "a TARGET or an associated pointer",
2071 sym
->name
, &(args
->expr
->where
));
2075 /* See if we have interoperable type and type param. */
2076 if (verify_c_interop (arg_ts
) == SUCCESS
2077 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2079 if (args_sym
->attr
.target
== 1)
2081 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2082 has the target attribute and is interoperable. */
2083 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2084 allocatable variable that has the TARGET attribute and
2085 is not an array of zero size. */
2086 if (args_sym
->attr
.allocatable
== 1)
2088 if (args_sym
->attr
.dimension
!= 0
2089 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2091 gfc_error_now ("Allocatable variable '%s' used as a "
2092 "parameter to '%s' at %L must not be "
2093 "an array of zero size",
2094 args_sym
->name
, sym
->name
,
2095 &(args
->expr
->where
));
2101 /* A non-allocatable target variable with C
2102 interoperable type and type parameters must be
2104 if (args_sym
&& args_sym
->attr
.dimension
)
2106 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2108 gfc_error ("Assumed-shape array '%s' at %L "
2109 "cannot be an argument to the "
2110 "procedure '%s' because "
2111 "it is not C interoperable",
2113 &(args
->expr
->where
), sym
->name
);
2116 else if (args_sym
->as
->type
== AS_DEFERRED
)
2118 gfc_error ("Deferred-shape array '%s' at %L "
2119 "cannot be an argument to the "
2120 "procedure '%s' because "
2121 "it is not C interoperable",
2123 &(args
->expr
->where
), sym
->name
);
2128 /* Make sure it's not a character string. Arrays of
2129 any type should be ok if the variable is of a C
2130 interoperable type. */
2131 if (arg_ts
->type
== BT_CHARACTER
)
2132 if (arg_ts
->cl
!= NULL
2133 && (arg_ts
->cl
->length
== NULL
2134 || arg_ts
->cl
->length
->expr_type
2137 (arg_ts
->cl
->length
->value
.integer
, 1)
2139 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2141 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2142 "at %L must have a length of 1",
2143 args_sym
->name
, sym
->name
,
2144 &(args
->expr
->where
));
2149 else if ((args_sym
->attr
.pointer
== 1 ||
2151 && parent_ref
->u
.c
.component
->attr
.pointer
))
2152 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2154 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2156 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2157 "associated scalar POINTER", args_sym
->name
,
2158 sym
->name
, &(args
->expr
->where
));
2164 /* The parameter is not required to be C interoperable. If it
2165 is not C interoperable, it must be a nonpolymorphic scalar
2166 with no length type parameters. It still must have either
2167 the pointer or target attribute, and it can be
2168 allocatable (but must be allocated when c_loc is called). */
2169 if (args
->expr
->rank
!= 0
2170 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2172 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2173 "scalar", args_sym
->name
, sym
->name
,
2174 &(args
->expr
->where
));
2177 else if (arg_ts
->type
== BT_CHARACTER
2178 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2180 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2181 "%L must have a length of 1",
2182 args_sym
->name
, sym
->name
,
2183 &(args
->expr
->where
));
2188 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2190 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2192 /* TODO: Update this error message to allow for procedure
2193 pointers once they are implemented. */
2194 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2196 args_sym
->name
, sym
->name
,
2197 &(args
->expr
->where
));
2200 else if (args_sym
->attr
.is_bind_c
!= 1)
2202 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2204 args_sym
->name
, sym
->name
,
2205 &(args
->expr
->where
));
2210 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2215 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2216 "iso_c_binding function: '%s'!\n", sym
->name
);
2223 /* Resolve a function call, which means resolving the arguments, then figuring
2224 out which entity the name refers to. */
2225 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2226 to INTENT(OUT) or INTENT(INOUT). */
2229 resolve_function (gfc_expr
*expr
)
2231 gfc_actual_arglist
*arg
;
2236 procedure_type p
= PROC_INTRINSIC
;
2237 bool no_formal_args
;
2241 sym
= expr
->symtree
->n
.sym
;
2243 if (sym
&& sym
->attr
.intrinsic
2244 && !gfc_find_function (sym
->name
)
2245 && gfc_find_subroutine (sym
->name
)
2246 && sym
->attr
.function
)
2248 gfc_error ("Intrinsic subroutine '%s' used as "
2249 "a function at %L", sym
->name
, &expr
->where
);
2253 if (sym
&& sym
->attr
.flavor
== FL_VARIABLE
)
2255 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2259 if (sym
&& sym
->attr
.abstract
)
2261 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2262 sym
->name
, &expr
->where
);
2266 /* If the procedure is external, check for usage. */
2267 if (sym
&& is_external_proc (sym
))
2268 resolve_global_procedure (sym
, &expr
->where
, 0);
2270 /* Switch off assumed size checking and do this again for certain kinds
2271 of procedure, once the procedure itself is resolved. */
2272 need_full_assumed_size
++;
2274 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2275 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2277 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
2278 if (resolve_actual_arglist (expr
->value
.function
.actual
,
2279 p
, no_formal_args
) == FAILURE
)
2282 /* Need to setup the call to the correct c_associated, depending on
2283 the number of cptrs to user gives to compare. */
2284 if (sym
&& sym
->attr
.is_iso_c
== 1)
2286 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
2290 /* Get the symtree for the new symbol (resolved func).
2291 the old one will be freed later, when it's no longer used. */
2292 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
2295 /* Resume assumed_size checking. */
2296 need_full_assumed_size
--;
2298 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2300 && sym
->ts
.cl
->length
== NULL
2302 && expr
->value
.function
.esym
== NULL
2303 && !sym
->attr
.contained
)
2305 /* Internal procedures are taken care of in resolve_contained_fntype. */
2306 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2307 "be used at %L since it is not a dummy argument",
2308 sym
->name
, &expr
->where
);
2312 /* See if function is already resolved. */
2314 if (expr
->value
.function
.name
!= NULL
)
2316 if (expr
->ts
.type
== BT_UNKNOWN
)
2322 /* Apply the rules of section 14.1.2. */
2324 switch (procedure_kind (sym
))
2327 t
= resolve_generic_f (expr
);
2330 case PTYPE_SPECIFIC
:
2331 t
= resolve_specific_f (expr
);
2335 t
= resolve_unknown_f (expr
);
2339 gfc_internal_error ("resolve_function(): bad function type");
2343 /* If the expression is still a function (it might have simplified),
2344 then we check to see if we are calling an elemental function. */
2346 if (expr
->expr_type
!= EXPR_FUNCTION
)
2349 temp
= need_full_assumed_size
;
2350 need_full_assumed_size
= 0;
2352 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
2355 if (omp_workshare_flag
2356 && expr
->value
.function
.esym
2357 && ! gfc_elemental (expr
->value
.function
.esym
))
2359 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2360 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2365 #define GENERIC_ID expr->value.function.isym->id
2366 else if (expr
->value
.function
.actual
!= NULL
2367 && expr
->value
.function
.isym
!= NULL
2368 && GENERIC_ID
!= GFC_ISYM_LBOUND
2369 && GENERIC_ID
!= GFC_ISYM_LEN
2370 && GENERIC_ID
!= GFC_ISYM_LOC
2371 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2373 /* Array intrinsics must also have the last upper bound of an
2374 assumed size array argument. UBOUND and SIZE have to be
2375 excluded from the check if the second argument is anything
2378 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2380 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
2381 && arg
->next
!= NULL
&& arg
->next
->expr
)
2383 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2386 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
2389 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2394 if (arg
->expr
!= NULL
2395 && arg
->expr
->rank
> 0
2396 && resolve_assumed_size_actual (arg
->expr
))
2402 need_full_assumed_size
= temp
;
2405 if (!pure_function (expr
, &name
) && name
)
2409 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2410 "FORALL %s", name
, &expr
->where
,
2411 forall_flag
== 2 ? "mask" : "block");
2414 else if (gfc_pure (NULL
))
2416 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2417 "procedure within a PURE procedure", name
, &expr
->where
);
2422 /* Functions without the RECURSIVE attribution are not allowed to
2423 * call themselves. */
2424 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
2426 gfc_symbol
*esym
, *proc
;
2427 esym
= expr
->value
.function
.esym
;
2428 proc
= gfc_current_ns
->proc_name
;
2431 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2432 "RECURSIVE", name
, &expr
->where
);
2436 if (esym
->attr
.entry
&& esym
->ns
->entries
&& proc
->ns
->entries
2437 && esym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2439 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2440 "'%s' is not declared as RECURSIVE",
2441 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
2446 /* Character lengths of use associated functions may contains references to
2447 symbols not referenced from the current program unit otherwise. Make sure
2448 those symbols are marked as referenced. */
2450 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
2451 && expr
->value
.function
.esym
->attr
.use_assoc
)
2453 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
2457 && !((expr
->value
.function
.esym
2458 && expr
->value
.function
.esym
->attr
.elemental
)
2460 (expr
->value
.function
.isym
2461 && expr
->value
.function
.isym
->elemental
)))
2462 find_noncopying_intrinsics (expr
->value
.function
.esym
,
2463 expr
->value
.function
.actual
);
2465 /* Make sure that the expression has a typespec that works. */
2466 if (expr
->ts
.type
== BT_UNKNOWN
)
2468 if (expr
->symtree
->n
.sym
->result
2469 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
)
2470 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
2477 /************* Subroutine resolution *************/
2480 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
2486 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2487 sym
->name
, &c
->loc
);
2488 else if (gfc_pure (NULL
))
2489 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
2495 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2499 if (sym
->attr
.generic
)
2501 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
2504 c
->resolved_sym
= s
;
2505 pure_subroutine (c
, s
);
2509 /* TODO: Need to search for elemental references in generic interface. */
2512 if (sym
->attr
.intrinsic
)
2513 return gfc_intrinsic_sub_interface (c
, 0);
2520 resolve_generic_s (gfc_code
*c
)
2525 sym
= c
->symtree
->n
.sym
;
2529 m
= resolve_generic_s0 (c
, sym
);
2532 else if (m
== MATCH_ERROR
)
2536 if (sym
->ns
->parent
== NULL
)
2538 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2542 if (!generic_sym (sym
))
2546 /* Last ditch attempt. See if the reference is to an intrinsic
2547 that possesses a matching interface. 14.1.2.4 */
2548 sym
= c
->symtree
->n
.sym
;
2550 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
2552 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2553 sym
->name
, &c
->loc
);
2557 m
= gfc_intrinsic_sub_interface (c
, 0);
2561 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2562 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
2568 /* Set the name and binding label of the subroutine symbol in the call
2569 expression represented by 'c' to include the type and kind of the
2570 second parameter. This function is for resolving the appropriate
2571 version of c_f_pointer() and c_f_procpointer(). For example, a
2572 call to c_f_pointer() for a default integer pointer could have a
2573 name of c_f_pointer_i4. If no second arg exists, which is an error
2574 for these two functions, it defaults to the generic symbol's name
2575 and binding label. */
2578 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
2579 char *name
, char *binding_label
)
2581 gfc_expr
*arg
= NULL
;
2585 /* The second arg of c_f_pointer and c_f_procpointer determines
2586 the type and kind for the procedure name. */
2587 arg
= c
->ext
.actual
->next
->expr
;
2591 /* Set up the name to have the given symbol's name,
2592 plus the type and kind. */
2593 /* a derived type is marked with the type letter 'u' */
2594 if (arg
->ts
.type
== BT_DERIVED
)
2597 kind
= 0; /* set the kind as 0 for now */
2601 type
= gfc_type_letter (arg
->ts
.type
);
2602 kind
= arg
->ts
.kind
;
2605 if (arg
->ts
.type
== BT_CHARACTER
)
2606 /* Kind info for character strings not needed. */
2609 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
2610 /* Set up the binding label as the given symbol's label plus
2611 the type and kind. */
2612 sprintf (binding_label
, "%s_%c%d", sym
->binding_label
, type
, kind
);
2616 /* If the second arg is missing, set the name and label as
2617 was, cause it should at least be found, and the missing
2618 arg error will be caught by compare_parameters(). */
2619 sprintf (name
, "%s", sym
->name
);
2620 sprintf (binding_label
, "%s", sym
->binding_label
);
2627 /* Resolve a generic version of the iso_c_binding procedure given
2628 (sym) to the specific one based on the type and kind of the
2629 argument(s). Currently, this function resolves c_f_pointer() and
2630 c_f_procpointer based on the type and kind of the second argument
2631 (FPTR). Other iso_c_binding procedures aren't specially handled.
2632 Upon successfully exiting, c->resolved_sym will hold the resolved
2633 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2637 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
2639 gfc_symbol
*new_sym
;
2640 /* this is fine, since we know the names won't use the max */
2641 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2642 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2643 /* default to success; will override if find error */
2644 match m
= MATCH_YES
;
2646 /* Make sure the actual arguments are in the necessary order (based on the
2647 formal args) before resolving. */
2648 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
2650 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
2651 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
2653 set_name_and_label (c
, sym
, name
, binding_label
);
2655 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
2657 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
2659 /* Make sure we got a third arg if the second arg has non-zero
2660 rank. We must also check that the type and rank are
2661 correct since we short-circuit this check in
2662 gfc_procedure_use() (called above to sort actual args). */
2663 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
2665 if(c
->ext
.actual
->next
->next
== NULL
2666 || c
->ext
.actual
->next
->next
->expr
== NULL
)
2669 gfc_error ("Missing SHAPE parameter for call to %s "
2670 "at %L", sym
->name
, &(c
->loc
));
2672 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
2674 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
2677 gfc_error ("SHAPE parameter for call to %s at %L must "
2678 "be a rank 1 INTEGER array", sym
->name
,
2685 if (m
!= MATCH_ERROR
)
2687 /* the 1 means to add the optional arg to formal list */
2688 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
2690 /* for error reporting, say it's declared where the original was */
2691 new_sym
->declared_at
= sym
->declared_at
;
2696 /* no differences for c_loc or c_funloc */
2700 /* set the resolved symbol */
2701 if (m
!= MATCH_ERROR
)
2702 c
->resolved_sym
= new_sym
;
2704 c
->resolved_sym
= sym
;
2710 /* Resolve a subroutine call known to be specific. */
2713 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2717 /* See if we have an intrinsic interface. */
2718 if (sym
->ts
.interface
!= NULL
&& !sym
->ts
.interface
->attr
.abstract
2719 && !sym
->ts
.interface
->attr
.subroutine
)
2721 gfc_intrinsic_sym
*isym
;
2723 isym
= gfc_find_function (sym
->ts
.interface
->name
);
2725 /* Existence of isym should be checked already. */
2728 sym
->ts
.type
= isym
->ts
.type
;
2729 sym
->ts
.kind
= isym
->ts
.kind
;
2730 sym
->attr
.subroutine
= 1;
2734 if(sym
->attr
.is_iso_c
)
2736 m
= gfc_iso_c_sub_interface (c
,sym
);
2740 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2742 if (sym
->attr
.dummy
)
2744 sym
->attr
.proc
= PROC_DUMMY
;
2748 sym
->attr
.proc
= PROC_EXTERNAL
;
2752 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
2755 if (sym
->attr
.intrinsic
)
2757 m
= gfc_intrinsic_sub_interface (c
, 1);
2761 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2762 "with an intrinsic", sym
->name
, &c
->loc
);
2770 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2772 c
->resolved_sym
= sym
;
2773 pure_subroutine (c
, sym
);
2780 resolve_specific_s (gfc_code
*c
)
2785 sym
= c
->symtree
->n
.sym
;
2789 m
= resolve_specific_s0 (c
, sym
);
2792 if (m
== MATCH_ERROR
)
2795 if (sym
->ns
->parent
== NULL
)
2798 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2804 sym
= c
->symtree
->n
.sym
;
2805 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2806 sym
->name
, &c
->loc
);
2812 /* Resolve a subroutine call not known to be generic nor specific. */
2815 resolve_unknown_s (gfc_code
*c
)
2819 sym
= c
->symtree
->n
.sym
;
2821 if (sym
->attr
.dummy
)
2823 sym
->attr
.proc
= PROC_DUMMY
;
2827 /* See if we have an intrinsic function reference. */
2829 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
2831 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
2836 /* The reference is to an external name. */
2839 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2841 c
->resolved_sym
= sym
;
2843 pure_subroutine (c
, sym
);
2849 /* Resolve a subroutine call. Although it was tempting to use the same code
2850 for functions, subroutines and functions are stored differently and this
2851 makes things awkward. */
2854 resolve_call (gfc_code
*c
)
2857 procedure_type ptype
= PROC_INTRINSIC
;
2858 gfc_symbol
*csym
, *sym
;
2859 bool no_formal_args
;
2861 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
2863 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
2865 gfc_error ("'%s' at %L has a type, which is not consistent with "
2866 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
2870 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
2872 gfc_find_symbol (csym
->name
, gfc_current_ns
, 1, &sym
);
2873 if (sym
&& csym
!= sym
2874 && sym
->ns
== gfc_current_ns
2875 && sym
->attr
.flavor
== FL_PROCEDURE
2876 && sym
->attr
.contained
)
2880 c
->symtree
->n
.sym
= sym
;
2884 /* If external, check for usage. */
2885 if (csym
&& is_external_proc (csym
))
2886 resolve_global_procedure (csym
, &c
->loc
, 1);
2888 /* Subroutines without the RECURSIVE attribution are not allowed to
2889 * call themselves. */
2890 if (csym
&& !csym
->attr
.recursive
)
2893 proc
= gfc_current_ns
->proc_name
;
2896 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2897 "RECURSIVE", csym
->name
, &c
->loc
);
2901 if (csym
->attr
.entry
&& csym
->ns
->entries
&& proc
->ns
->entries
2902 && csym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2904 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2905 "'%s' is not declared as RECURSIVE",
2906 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
2911 /* Switch off assumed size checking and do this again for certain kinds
2912 of procedure, once the procedure itself is resolved. */
2913 need_full_assumed_size
++;
2916 ptype
= csym
->attr
.proc
;
2918 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
2919 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
2920 no_formal_args
) == FAILURE
)
2923 /* Resume assumed_size checking. */
2924 need_full_assumed_size
--;
2927 if (c
->resolved_sym
== NULL
)
2929 c
->resolved_isym
= NULL
;
2930 switch (procedure_kind (csym
))
2933 t
= resolve_generic_s (c
);
2936 case PTYPE_SPECIFIC
:
2937 t
= resolve_specific_s (c
);
2941 t
= resolve_unknown_s (c
);
2945 gfc_internal_error ("resolve_subroutine(): bad function type");
2949 /* Some checks of elemental subroutine actual arguments. */
2950 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
2953 if (t
== SUCCESS
&& !(c
->resolved_sym
&& c
->resolved_sym
->attr
.elemental
))
2954 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
2959 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2960 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2961 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2962 if their shapes do not match. If either op1->shape or op2->shape is
2963 NULL, return SUCCESS. */
2966 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
2973 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
2975 for (i
= 0; i
< op1
->rank
; i
++)
2977 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
2979 gfc_error ("Shapes for operands at %L and %L are not conformable",
2980 &op1
->where
, &op2
->where
);
2991 /* Resolve an operator expression node. This can involve replacing the
2992 operation with a user defined function call. */
2995 resolve_operator (gfc_expr
*e
)
2997 gfc_expr
*op1
, *op2
;
2999 bool dual_locus_error
;
3002 /* Resolve all subnodes-- give them types. */
3004 switch (e
->value
.op
.op
)
3007 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3010 /* Fall through... */
3013 case INTRINSIC_UPLUS
:
3014 case INTRINSIC_UMINUS
:
3015 case INTRINSIC_PARENTHESES
:
3016 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3021 /* Typecheck the new node. */
3023 op1
= e
->value
.op
.op1
;
3024 op2
= e
->value
.op
.op2
;
3025 dual_locus_error
= false;
3027 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3028 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3030 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3034 switch (e
->value
.op
.op
)
3036 case INTRINSIC_UPLUS
:
3037 case INTRINSIC_UMINUS
:
3038 if (op1
->ts
.type
== BT_INTEGER
3039 || op1
->ts
.type
== BT_REAL
3040 || op1
->ts
.type
== BT_COMPLEX
)
3046 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3047 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3050 case INTRINSIC_PLUS
:
3051 case INTRINSIC_MINUS
:
3052 case INTRINSIC_TIMES
:
3053 case INTRINSIC_DIVIDE
:
3054 case INTRINSIC_POWER
:
3055 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3057 gfc_type_convert_binary (e
);
3062 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3063 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3064 gfc_typename (&op2
->ts
));
3067 case INTRINSIC_CONCAT
:
3068 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3069 && op1
->ts
.kind
== op2
->ts
.kind
)
3071 e
->ts
.type
= BT_CHARACTER
;
3072 e
->ts
.kind
= op1
->ts
.kind
;
3077 _("Operands of string concatenation operator at %%L are %s/%s"),
3078 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3084 case INTRINSIC_NEQV
:
3085 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3087 e
->ts
.type
= BT_LOGICAL
;
3088 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3089 if (op1
->ts
.kind
< e
->ts
.kind
)
3090 gfc_convert_type (op1
, &e
->ts
, 2);
3091 else if (op2
->ts
.kind
< e
->ts
.kind
)
3092 gfc_convert_type (op2
, &e
->ts
, 2);
3096 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3097 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3098 gfc_typename (&op2
->ts
));
3103 if (op1
->ts
.type
== BT_LOGICAL
)
3105 e
->ts
.type
= BT_LOGICAL
;
3106 e
->ts
.kind
= op1
->ts
.kind
;
3110 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3111 gfc_typename (&op1
->ts
));
3115 case INTRINSIC_GT_OS
:
3117 case INTRINSIC_GE_OS
:
3119 case INTRINSIC_LT_OS
:
3121 case INTRINSIC_LE_OS
:
3122 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3124 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3128 /* Fall through... */
3131 case INTRINSIC_EQ_OS
:
3133 case INTRINSIC_NE_OS
:
3134 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3135 && op1
->ts
.kind
== op2
->ts
.kind
)
3137 e
->ts
.type
= BT_LOGICAL
;
3138 e
->ts
.kind
= gfc_default_logical_kind
;
3142 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3144 gfc_type_convert_binary (e
);
3146 e
->ts
.type
= BT_LOGICAL
;
3147 e
->ts
.kind
= gfc_default_logical_kind
;
3151 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3153 _("Logicals at %%L must be compared with %s instead of %s"),
3154 (e
->value
.op
.op
== INTRINSIC_EQ
3155 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3156 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3159 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3160 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3161 gfc_typename (&op2
->ts
));
3165 case INTRINSIC_USER
:
3166 if (e
->value
.op
.uop
->op
== NULL
)
3167 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3168 else if (op2
== NULL
)
3169 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3170 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3172 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3173 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3174 gfc_typename (&op2
->ts
));
3178 case INTRINSIC_PARENTHESES
:
3180 if (e
->ts
.type
== BT_CHARACTER
)
3181 e
->ts
.cl
= op1
->ts
.cl
;
3185 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3188 /* Deal with arrayness of an operand through an operator. */
3192 switch (e
->value
.op
.op
)
3194 case INTRINSIC_PLUS
:
3195 case INTRINSIC_MINUS
:
3196 case INTRINSIC_TIMES
:
3197 case INTRINSIC_DIVIDE
:
3198 case INTRINSIC_POWER
:
3199 case INTRINSIC_CONCAT
:
3203 case INTRINSIC_NEQV
:
3205 case INTRINSIC_EQ_OS
:
3207 case INTRINSIC_NE_OS
:
3209 case INTRINSIC_GT_OS
:
3211 case INTRINSIC_GE_OS
:
3213 case INTRINSIC_LT_OS
:
3215 case INTRINSIC_LE_OS
:
3217 if (op1
->rank
== 0 && op2
->rank
== 0)
3220 if (op1
->rank
== 0 && op2
->rank
!= 0)
3222 e
->rank
= op2
->rank
;
3224 if (e
->shape
== NULL
)
3225 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3228 if (op1
->rank
!= 0 && op2
->rank
== 0)
3230 e
->rank
= op1
->rank
;
3232 if (e
->shape
== NULL
)
3233 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3236 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3238 if (op1
->rank
== op2
->rank
)
3240 e
->rank
= op1
->rank
;
3241 if (e
->shape
== NULL
)
3243 t
= compare_shapes(op1
, op2
);
3247 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3252 /* Allow higher level expressions to work. */
3255 /* Try user-defined operators, and otherwise throw an error. */
3256 dual_locus_error
= true;
3258 _("Inconsistent ranks for operator at %%L and %%L"));
3265 case INTRINSIC_PARENTHESES
:
3267 case INTRINSIC_UPLUS
:
3268 case INTRINSIC_UMINUS
:
3269 /* Simply copy arrayness attribute */
3270 e
->rank
= op1
->rank
;
3272 if (e
->shape
== NULL
)
3273 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3281 /* Attempt to simplify the expression. */
3284 t
= gfc_simplify_expr (e
, 0);
3285 /* Some calls do not succeed in simplification and return FAILURE
3286 even though there is no error; e.g. variable references to
3287 PARAMETER arrays. */
3288 if (!gfc_is_constant_expr (e
))
3295 if (gfc_extend_expr (e
) == SUCCESS
)
3298 if (dual_locus_error
)
3299 gfc_error (msg
, &op1
->where
, &op2
->where
);
3301 gfc_error (msg
, &e
->where
);
3307 /************** Array resolution subroutines **************/
3310 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3313 /* Compare two integer expressions. */
3316 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3320 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3321 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3324 /* If either of the types isn't INTEGER, we must have
3325 raised an error earlier. */
3327 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3330 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3340 /* Compare an integer expression with an integer. */
3343 compare_bound_int (gfc_expr
*a
, int b
)
3347 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3350 if (a
->ts
.type
!= BT_INTEGER
)
3351 gfc_internal_error ("compare_bound_int(): Bad expression");
3353 i
= mpz_cmp_si (a
->value
.integer
, b
);
3363 /* Compare an integer expression with a mpz_t. */
3366 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3370 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3373 if (a
->ts
.type
!= BT_INTEGER
)
3374 gfc_internal_error ("compare_bound_int(): Bad expression");
3376 i
= mpz_cmp (a
->value
.integer
, b
);
3386 /* Compute the last value of a sequence given by a triplet.
3387 Return 0 if it wasn't able to compute the last value, or if the
3388 sequence if empty, and 1 otherwise. */
3391 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3392 gfc_expr
*stride
, mpz_t last
)
3396 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3397 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3398 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3401 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3402 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3405 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
3407 if (compare_bound (start
, end
) == CMP_GT
)
3409 mpz_set (last
, end
->value
.integer
);
3413 if (compare_bound_int (stride
, 0) == CMP_GT
)
3415 /* Stride is positive */
3416 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3421 /* Stride is negative */
3422 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3427 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3428 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3429 mpz_sub (last
, end
->value
.integer
, rem
);
3436 /* Compare a single dimension of an array reference to the array
3440 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3444 /* Given start, end and stride values, calculate the minimum and
3445 maximum referenced indexes. */
3447 switch (ar
->dimen_type
[i
])
3453 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3455 gfc_warning ("Array reference at %L is out of bounds "
3456 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3457 mpz_get_si (ar
->start
[i
]->value
.integer
),
3458 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3461 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3463 gfc_warning ("Array reference at %L is out of bounds "
3464 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3465 mpz_get_si (ar
->start
[i
]->value
.integer
),
3466 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3474 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3475 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3477 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3479 /* Check for zero stride, which is not allowed. */
3480 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3482 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3486 /* if start == len || (stride > 0 && start < len)
3487 || (stride < 0 && start > len),
3488 then the array section contains at least one element. In this
3489 case, there is an out-of-bounds access if
3490 (start < lower || start > upper). */
3491 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3492 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3493 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3494 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3495 && comp_start_end
== CMP_GT
))
3497 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3499 gfc_warning ("Lower array reference at %L is out of bounds "
3500 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3501 mpz_get_si (AR_START
->value
.integer
),
3502 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3505 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3507 gfc_warning ("Lower array reference at %L is out of bounds "
3508 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3509 mpz_get_si (AR_START
->value
.integer
),
3510 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3515 /* If we can compute the highest index of the array section,
3516 then it also has to be between lower and upper. */
3517 mpz_init (last_value
);
3518 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
3521 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
3523 gfc_warning ("Upper array reference at %L is out of bounds "
3524 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3525 mpz_get_si (last_value
),
3526 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3527 mpz_clear (last_value
);
3530 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
3532 gfc_warning ("Upper array reference at %L is out of bounds "
3533 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3534 mpz_get_si (last_value
),
3535 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3536 mpz_clear (last_value
);
3540 mpz_clear (last_value
);
3548 gfc_internal_error ("check_dimension(): Bad array reference");
3555 /* Compare an array reference with an array specification. */
3558 compare_spec_to_ref (gfc_array_ref
*ar
)
3565 /* TODO: Full array sections are only allowed as actual parameters. */
3566 if (as
->type
== AS_ASSUMED_SIZE
3567 && (/*ar->type == AR_FULL
3568 ||*/ (ar
->type
== AR_SECTION
3569 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
3571 gfc_error ("Rightmost upper bound of assumed size array section "
3572 "not specified at %L", &ar
->where
);
3576 if (ar
->type
== AR_FULL
)
3579 if (as
->rank
!= ar
->dimen
)
3581 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3582 &ar
->where
, ar
->dimen
, as
->rank
);
3586 for (i
= 0; i
< as
->rank
; i
++)
3587 if (check_dimension (i
, ar
, as
) == FAILURE
)
3594 /* Resolve one part of an array index. */
3597 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
3604 if (gfc_resolve_expr (index
) == FAILURE
)
3607 if (check_scalar
&& index
->rank
!= 0)
3609 gfc_error ("Array index at %L must be scalar", &index
->where
);
3613 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
3615 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3616 &index
->where
, gfc_basic_typename (index
->ts
.type
));
3620 if (index
->ts
.type
== BT_REAL
)
3621 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
3622 &index
->where
) == FAILURE
)
3625 if (index
->ts
.kind
!= gfc_index_integer_kind
3626 || index
->ts
.type
!= BT_INTEGER
)
3629 ts
.type
= BT_INTEGER
;
3630 ts
.kind
= gfc_index_integer_kind
;
3632 gfc_convert_type_warn (index
, &ts
, 2, 0);
3638 /* Resolve a dim argument to an intrinsic function. */
3641 gfc_resolve_dim_arg (gfc_expr
*dim
)
3646 if (gfc_resolve_expr (dim
) == FAILURE
)
3651 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
3656 if (dim
->ts
.type
!= BT_INTEGER
)
3658 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
3662 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
3666 ts
.type
= BT_INTEGER
;
3667 ts
.kind
= gfc_index_integer_kind
;
3669 gfc_convert_type_warn (dim
, &ts
, 2, 0);
3675 /* Given an expression that contains array references, update those array
3676 references to point to the right array specifications. While this is
3677 filled in during matching, this information is difficult to save and load
3678 in a module, so we take care of it here.
3680 The idea here is that the original array reference comes from the
3681 base symbol. We traverse the list of reference structures, setting
3682 the stored reference to references. Component references can
3683 provide an additional array specification. */
3686 find_array_spec (gfc_expr
*e
)
3690 gfc_symbol
*derived
;
3693 as
= e
->symtree
->n
.sym
->as
;
3696 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3701 gfc_internal_error ("find_array_spec(): Missing spec");
3708 if (derived
== NULL
)
3709 derived
= e
->symtree
->n
.sym
->ts
.derived
;
3711 c
= derived
->components
;
3713 for (; c
; c
= c
->next
)
3714 if (c
== ref
->u
.c
.component
)
3716 /* Track the sequence of component references. */
3717 if (c
->ts
.type
== BT_DERIVED
)
3718 derived
= c
->ts
.derived
;
3723 gfc_internal_error ("find_array_spec(): Component not found");
3725 if (c
->attr
.dimension
)
3728 gfc_internal_error ("find_array_spec(): unused as(1)");
3739 gfc_internal_error ("find_array_spec(): unused as(2)");
3743 /* Resolve an array reference. */
3746 resolve_array_ref (gfc_array_ref
*ar
)
3748 int i
, check_scalar
;
3751 for (i
= 0; i
< ar
->dimen
; i
++)
3753 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
3755 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
3757 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
3759 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
3764 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
3768 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3772 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
3773 if (e
->expr_type
== EXPR_VARIABLE
3774 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
3775 ar
->start
[i
] = gfc_get_parentheses (e
);
3779 gfc_error ("Array index at %L is an array of rank %d",
3780 &ar
->c_where
[i
], e
->rank
);
3785 /* If the reference type is unknown, figure out what kind it is. */
3787 if (ar
->type
== AR_UNKNOWN
)
3789 ar
->type
= AR_ELEMENT
;
3790 for (i
= 0; i
< ar
->dimen
; i
++)
3791 if (ar
->dimen_type
[i
] == DIMEN_RANGE
3792 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3794 ar
->type
= AR_SECTION
;
3799 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
3807 resolve_substring (gfc_ref
*ref
)
3809 if (ref
->u
.ss
.start
!= NULL
)
3811 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
3814 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
3816 gfc_error ("Substring start index at %L must be of type INTEGER",
3817 &ref
->u
.ss
.start
->where
);
3821 if (ref
->u
.ss
.start
->rank
!= 0)
3823 gfc_error ("Substring start index at %L must be scalar",
3824 &ref
->u
.ss
.start
->where
);
3828 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
3829 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3830 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3832 gfc_error ("Substring start index at %L is less than one",
3833 &ref
->u
.ss
.start
->where
);
3838 if (ref
->u
.ss
.end
!= NULL
)
3840 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
3843 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
3845 gfc_error ("Substring end index at %L must be of type INTEGER",
3846 &ref
->u
.ss
.end
->where
);
3850 if (ref
->u
.ss
.end
->rank
!= 0)
3852 gfc_error ("Substring end index at %L must be scalar",
3853 &ref
->u
.ss
.end
->where
);
3857 if (ref
->u
.ss
.length
!= NULL
3858 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
3859 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3860 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3862 gfc_error ("Substring end index at %L exceeds the string length",
3863 &ref
->u
.ss
.start
->where
);
3872 /* This function supplies missing substring charlens. */
3875 gfc_resolve_substring_charlen (gfc_expr
*e
)
3878 gfc_expr
*start
, *end
;
3880 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
3881 if (char_ref
->type
== REF_SUBSTRING
)
3887 gcc_assert (char_ref
->next
== NULL
);
3891 if (e
->ts
.cl
->length
)
3892 gfc_free_expr (e
->ts
.cl
->length
);
3893 else if (e
->expr_type
== EXPR_VARIABLE
3894 && e
->symtree
->n
.sym
->attr
.dummy
)
3898 e
->ts
.type
= BT_CHARACTER
;
3899 e
->ts
.kind
= gfc_default_character_kind
;
3903 e
->ts
.cl
= gfc_get_charlen ();
3904 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
3905 gfc_current_ns
->cl_list
= e
->ts
.cl
;
3908 if (char_ref
->u
.ss
.start
)
3909 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
3911 start
= gfc_int_expr (1);
3913 if (char_ref
->u
.ss
.end
)
3914 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
3915 else if (e
->expr_type
== EXPR_VARIABLE
)
3916 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.cl
->length
);
3923 /* Length = (end - start +1). */
3924 e
->ts
.cl
->length
= gfc_subtract (end
, start
);
3925 e
->ts
.cl
->length
= gfc_add (e
->ts
.cl
->length
, gfc_int_expr (1));
3927 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
3928 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
3930 /* Make sure that the length is simplified. */
3931 gfc_simplify_expr (e
->ts
.cl
->length
, 1);
3932 gfc_resolve_expr (e
->ts
.cl
->length
);
3936 /* Resolve subtype references. */
3939 resolve_ref (gfc_expr
*expr
)
3941 int current_part_dimension
, n_components
, seen_part_dimension
;
3944 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3945 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
3947 find_array_spec (expr
);
3951 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3955 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
3963 resolve_substring (ref
);
3967 /* Check constraints on part references. */
3969 current_part_dimension
= 0;
3970 seen_part_dimension
= 0;
3973 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3978 switch (ref
->u
.ar
.type
)
3982 current_part_dimension
= 1;
3986 current_part_dimension
= 0;
3990 gfc_internal_error ("resolve_ref(): Bad array reference");
3996 if (current_part_dimension
|| seen_part_dimension
)
3998 if (ref
->u
.c
.component
->attr
.pointer
)
4000 gfc_error ("Component to the right of a part reference "
4001 "with nonzero rank must not have the POINTER "
4002 "attribute at %L", &expr
->where
);
4005 else if (ref
->u
.c
.component
->attr
.allocatable
)
4007 gfc_error ("Component to the right of a part reference "
4008 "with nonzero rank must not have the ALLOCATABLE "
4009 "attribute at %L", &expr
->where
);
4021 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4022 || ref
->next
== NULL
)
4023 && current_part_dimension
4024 && seen_part_dimension
)
4026 gfc_error ("Two or more part references with nonzero rank must "
4027 "not be specified at %L", &expr
->where
);
4031 if (ref
->type
== REF_COMPONENT
)
4033 if (current_part_dimension
)
4034 seen_part_dimension
= 1;
4036 /* reset to make sure */
4037 current_part_dimension
= 0;
4045 /* Given an expression, determine its shape. This is easier than it sounds.
4046 Leaves the shape array NULL if it is not possible to determine the shape. */
4049 expression_shape (gfc_expr
*e
)
4051 mpz_t array
[GFC_MAX_DIMENSIONS
];
4054 if (e
->rank
== 0 || e
->shape
!= NULL
)
4057 for (i
= 0; i
< e
->rank
; i
++)
4058 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
4061 e
->shape
= gfc_get_shape (e
->rank
);
4063 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4068 for (i
--; i
>= 0; i
--)
4069 mpz_clear (array
[i
]);
4073 /* Given a variable expression node, compute the rank of the expression by
4074 examining the base symbol and any reference structures it may have. */
4077 expression_rank (gfc_expr
*e
)
4082 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4083 could lead to serious confusion... */
4084 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4088 if (e
->expr_type
== EXPR_ARRAY
)
4090 /* Constructors can have a rank different from one via RESHAPE(). */
4092 if (e
->symtree
== NULL
)
4098 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4099 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4105 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4107 if (ref
->type
!= REF_ARRAY
)
4110 if (ref
->u
.ar
.type
== AR_FULL
)
4112 rank
= ref
->u
.ar
.as
->rank
;
4116 if (ref
->u
.ar
.type
== AR_SECTION
)
4118 /* Figure out the rank of the section. */
4120 gfc_internal_error ("expression_rank(): Two array specs");
4122 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4123 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4124 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4134 expression_shape (e
);
4138 /* Resolve a variable expression. */
4141 resolve_variable (gfc_expr
*e
)
4148 if (e
->symtree
== NULL
)
4151 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
4154 sym
= e
->symtree
->n
.sym
;
4155 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
4157 e
->ts
.type
= BT_PROCEDURE
;
4161 if (sym
->ts
.type
!= BT_UNKNOWN
)
4162 gfc_variable_attr (e
, &e
->ts
);
4165 /* Must be a simple variable reference. */
4166 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
4171 if (check_assumed_size_reference (sym
, e
))
4174 /* Deal with forward references to entries during resolve_code, to
4175 satisfy, at least partially, 12.5.2.5. */
4176 if (gfc_current_ns
->entries
4177 && current_entry_id
== sym
->entry_id
4180 && cs_base
->current
->op
!= EXEC_ENTRY
)
4182 gfc_entry_list
*entry
;
4183 gfc_formal_arglist
*formal
;
4187 /* If the symbol is a dummy... */
4188 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4190 entry
= gfc_current_ns
->entries
;
4193 /* ...test if the symbol is a parameter of previous entries. */
4194 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4195 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4197 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4201 /* If it has not been seen as a dummy, this is an error. */
4204 if (specification_expr
)
4205 gfc_error ("Variable '%s', used in a specification expression"
4206 ", is referenced at %L before the ENTRY statement "
4207 "in which it is a parameter",
4208 sym
->name
, &cs_base
->current
->loc
);
4210 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4211 "statement in which it is a parameter",
4212 sym
->name
, &cs_base
->current
->loc
);
4217 /* Now do the same check on the specification expressions. */
4218 specification_expr
= 1;
4219 if (sym
->ts
.type
== BT_CHARACTER
4220 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
4224 for (n
= 0; n
< sym
->as
->rank
; n
++)
4226 specification_expr
= 1;
4227 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
4229 specification_expr
= 1;
4230 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
4233 specification_expr
= 0;
4236 /* Update the symbol's entry level. */
4237 sym
->entry_id
= current_entry_id
+ 1;
4244 /* Checks to see that the correct symbol has been host associated.
4245 The only situation where this arises is that in which a twice
4246 contained function is parsed after the host association is made.
4247 Therefore, on detecting this, the line is rematched, having got
4248 rid of the existing references and actual_arg_list. */
4250 check_host_association (gfc_expr
*e
)
4252 gfc_symbol
*sym
, *old_sym
;
4256 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
4258 if (e
->symtree
== NULL
|| e
->symtree
->n
.sym
== NULL
)
4261 old_sym
= e
->symtree
->n
.sym
;
4263 if (gfc_current_ns
->parent
4264 && old_sym
->ns
!= gfc_current_ns
)
4266 gfc_find_symbol (old_sym
->name
, gfc_current_ns
, 1, &sym
);
4267 if (sym
&& old_sym
!= sym
4268 && sym
->ts
.type
== old_sym
->ts
.type
4269 && sym
->attr
.flavor
== FL_PROCEDURE
4270 && sym
->attr
.contained
)
4272 temp_locus
= gfc_current_locus
;
4273 gfc_current_locus
= e
->where
;
4275 gfc_buffer_error (1);
4277 gfc_free_ref_list (e
->ref
);
4282 gfc_free_actual_arglist (e
->value
.function
.actual
);
4283 e
->value
.function
.actual
= NULL
;
4286 if (e
->shape
!= NULL
)
4288 for (n
= 0; n
< e
->rank
; n
++)
4289 mpz_clear (e
->shape
[n
]);
4291 gfc_free (e
->shape
);
4294 gfc_match_rvalue (&expr
);
4296 gfc_buffer_error (0);
4298 gcc_assert (expr
&& sym
== expr
->symtree
->n
.sym
);
4304 gfc_current_locus
= temp_locus
;
4307 /* This might have changed! */
4308 return e
->expr_type
== EXPR_FUNCTION
;
4313 gfc_resolve_character_operator (gfc_expr
*e
)
4315 gfc_expr
*op1
= e
->value
.op
.op1
;
4316 gfc_expr
*op2
= e
->value
.op
.op2
;
4317 gfc_expr
*e1
= NULL
;
4318 gfc_expr
*e2
= NULL
;
4320 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
4322 if (op1
->ts
.cl
&& op1
->ts
.cl
->length
)
4323 e1
= gfc_copy_expr (op1
->ts
.cl
->length
);
4324 else if (op1
->expr_type
== EXPR_CONSTANT
)
4325 e1
= gfc_int_expr (op1
->value
.character
.length
);
4327 if (op2
->ts
.cl
&& op2
->ts
.cl
->length
)
4328 e2
= gfc_copy_expr (op2
->ts
.cl
->length
);
4329 else if (op2
->expr_type
== EXPR_CONSTANT
)
4330 e2
= gfc_int_expr (op2
->value
.character
.length
);
4332 e
->ts
.cl
= gfc_get_charlen ();
4333 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4334 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4339 e
->ts
.cl
->length
= gfc_add (e1
, e2
);
4340 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
4341 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
4342 gfc_simplify_expr (e
->ts
.cl
->length
, 0);
4343 gfc_resolve_expr (e
->ts
.cl
->length
);
4349 /* Ensure that an character expression has a charlen and, if possible, a
4350 length expression. */
4353 fixup_charlen (gfc_expr
*e
)
4355 /* The cases fall through so that changes in expression type and the need
4356 for multiple fixes are picked up. In all circumstances, a charlen should
4357 be available for the middle end to hang a backend_decl on. */
4358 switch (e
->expr_type
)
4361 gfc_resolve_character_operator (e
);
4364 if (e
->expr_type
== EXPR_ARRAY
)
4365 gfc_resolve_character_array_constructor (e
);
4367 case EXPR_SUBSTRING
:
4368 if (!e
->ts
.cl
&& e
->ref
)
4369 gfc_resolve_substring_charlen (e
);
4374 e
->ts
.cl
= gfc_get_charlen ();
4375 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4376 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4384 /* Update an actual argument to include the passed-object for type-bound
4385 procedures at the right position. */
4387 static gfc_actual_arglist
*
4388 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
)
4390 gcc_assert (argpos
> 0);
4394 gfc_actual_arglist
* result
;
4396 result
= gfc_get_actual_arglist ();
4404 gcc_assert (argpos
> 1);
4406 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1);
4411 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4414 extract_compcall_passed_object (gfc_expr
* e
)
4418 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
4420 po
= gfc_get_expr ();
4421 po
->expr_type
= EXPR_VARIABLE
;
4422 po
->symtree
= e
->symtree
;
4423 po
->ref
= gfc_copy_ref (e
->ref
);
4425 if (gfc_resolve_expr (po
) == FAILURE
)
4432 /* Update the arglist of an EXPR_COMPCALL expression to include the
4436 update_compcall_arglist (gfc_expr
* e
)
4439 gfc_typebound_proc
* tbp
;
4441 tbp
= e
->value
.compcall
.tbp
;
4446 po
= extract_compcall_passed_object (e
);
4452 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
4462 gcc_assert (tbp
->pass_arg_num
> 0);
4463 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
4470 /* Resolve a call to a type-bound procedure, either function or subroutine,
4471 statically from the data in an EXPR_COMPCALL expression. The adapted
4472 arglist and the target-procedure symtree are returned. */
4475 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
4476 gfc_actual_arglist
** actual
)
4478 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
4479 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
4481 /* Update the actual arglist for PASS. */
4482 if (update_compcall_arglist (e
) == FAILURE
)
4485 *actual
= e
->value
.compcall
.actual
;
4486 *target
= e
->value
.compcall
.tbp
->u
.specific
;
4488 gfc_free_ref_list (e
->ref
);
4490 e
->value
.compcall
.actual
= NULL
;
4496 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4497 which of the specific bindings (if any) matches the arglist and transform
4498 the expression into a call of that binding. */
4501 resolve_typebound_generic_call (gfc_expr
* e
)
4503 gfc_typebound_proc
* genproc
;
4504 const char* genname
;
4506 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
4507 genname
= e
->value
.compcall
.name
;
4508 genproc
= e
->value
.compcall
.tbp
;
4510 if (!genproc
->is_generic
)
4513 /* Try the bindings on this type and in the inheritance hierarchy. */
4514 for (; genproc
; genproc
= genproc
->overridden
)
4518 gcc_assert (genproc
->is_generic
);
4519 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
4522 gfc_actual_arglist
* args
;
4525 gcc_assert (g
->specific
);
4527 if (g
->specific
->error
)
4530 target
= g
->specific
->u
.specific
->n
.sym
;
4532 /* Get the right arglist by handling PASS/NOPASS. */
4533 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
4534 if (!g
->specific
->nopass
)
4537 po
= extract_compcall_passed_object (e
);
4541 gcc_assert (g
->specific
->pass_arg_num
> 0);
4542 gcc_assert (!g
->specific
->error
);
4543 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
);
4545 resolve_actual_arglist (args
, target
->attr
.proc
,
4546 is_external_proc (target
) && !target
->formal
);
4548 /* Check if this arglist matches the formal. */
4549 matches
= gfc_arglist_matches_symbol (&args
, target
);
4551 /* Clean up and break out of the loop if we've found it. */
4552 gfc_free_actual_arglist (args
);
4555 e
->value
.compcall
.tbp
= g
->specific
;
4561 /* Nothing matching found! */
4562 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4563 " '%s' at %L", genname
, &e
->where
);
4571 /* Resolve a call to a type-bound subroutine. */
4574 resolve_typebound_call (gfc_code
* c
)
4576 gfc_actual_arglist
* newactual
;
4577 gfc_symtree
* target
;
4579 /* Check that's really a SUBROUTINE. */
4580 if (!c
->expr
->value
.compcall
.tbp
->subroutine
)
4582 gfc_error ("'%s' at %L should be a SUBROUTINE",
4583 c
->expr
->value
.compcall
.name
, &c
->loc
);
4587 if (resolve_typebound_generic_call (c
->expr
) == FAILURE
)
4590 /* Transform into an ordinary EXEC_CALL for now. */
4592 if (resolve_typebound_static (c
->expr
, &target
, &newactual
) == FAILURE
)
4595 c
->ext
.actual
= newactual
;
4596 c
->symtree
= target
;
4599 gcc_assert (!c
->expr
->ref
&& !c
->expr
->value
.compcall
.actual
);
4600 gfc_free_expr (c
->expr
);
4603 return resolve_call (c
);
4607 /* Resolve a component-call expression. */
4610 resolve_compcall (gfc_expr
* e
)
4612 gfc_actual_arglist
* newactual
;
4613 gfc_symtree
* target
;
4615 /* Check that's really a FUNCTION. */
4616 if (!e
->value
.compcall
.tbp
->function
)
4618 gfc_error ("'%s' at %L should be a FUNCTION",
4619 e
->value
.compcall
.name
, &e
->where
);
4623 if (resolve_typebound_generic_call (e
) == FAILURE
)
4625 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
4627 /* Take the rank from the function's symbol. */
4628 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
4629 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
4631 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
4632 arglist to the TBP's binding target. */
4634 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
4637 e
->value
.function
.actual
= newactual
;
4638 e
->value
.function
.name
= e
->value
.compcall
.name
;
4639 e
->value
.function
.isym
= NULL
;
4640 e
->value
.function
.esym
= NULL
;
4641 e
->symtree
= target
;
4642 e
->ts
= target
->n
.sym
->ts
;
4643 e
->expr_type
= EXPR_FUNCTION
;
4645 return gfc_resolve_expr (e
);
4649 /* Resolve an expression. That is, make sure that types of operands agree
4650 with their operators, intrinsic operators are converted to function calls
4651 for overloaded types and unresolved function references are resolved. */
4654 gfc_resolve_expr (gfc_expr
*e
)
4661 switch (e
->expr_type
)
4664 t
= resolve_operator (e
);
4670 if (check_host_association (e
))
4671 t
= resolve_function (e
);
4674 t
= resolve_variable (e
);
4676 expression_rank (e
);
4679 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.cl
== NULL
&& e
->ref
4680 && e
->ref
->type
!= REF_SUBSTRING
)
4681 gfc_resolve_substring_charlen (e
);
4686 t
= resolve_compcall (e
);
4689 case EXPR_SUBSTRING
:
4690 t
= resolve_ref (e
);
4700 if (resolve_ref (e
) == FAILURE
)
4703 t
= gfc_resolve_array_constructor (e
);
4704 /* Also try to expand a constructor. */
4707 expression_rank (e
);
4708 gfc_expand_constructor (e
);
4711 /* This provides the opportunity for the length of constructors with
4712 character valued function elements to propagate the string length
4713 to the expression. */
4714 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
4715 t
= gfc_resolve_character_array_constructor (e
);
4719 case EXPR_STRUCTURE
:
4720 t
= resolve_ref (e
);
4724 t
= resolve_structure_cons (e
);
4728 t
= gfc_simplify_expr (e
, 0);
4732 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4735 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.cl
)
4742 /* Resolve an expression from an iterator. They must be scalar and have
4743 INTEGER or (optionally) REAL type. */
4746 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
4747 const char *name_msgid
)
4749 if (gfc_resolve_expr (expr
) == FAILURE
)
4752 if (expr
->rank
!= 0)
4754 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
4758 if (expr
->ts
.type
!= BT_INTEGER
)
4760 if (expr
->ts
.type
== BT_REAL
)
4763 return gfc_notify_std (GFC_STD_F95_DEL
,
4764 "Deleted feature: %s at %L must be integer",
4765 _(name_msgid
), &expr
->where
);
4768 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
4775 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
4783 /* Resolve the expressions in an iterator structure. If REAL_OK is
4784 false allow only INTEGER type iterators, otherwise allow REAL types. */
4787 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
4789 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
4793 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
4795 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4800 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
4801 "Start expression in DO loop") == FAILURE
)
4804 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
4805 "End expression in DO loop") == FAILURE
)
4808 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
4809 "Step expression in DO loop") == FAILURE
)
4812 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
4814 if ((iter
->step
->ts
.type
== BT_INTEGER
4815 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
4816 || (iter
->step
->ts
.type
== BT_REAL
4817 && mpfr_sgn (iter
->step
->value
.real
) == 0))
4819 gfc_error ("Step expression in DO loop at %L cannot be zero",
4820 &iter
->step
->where
);
4825 /* Convert start, end, and step to the same type as var. */
4826 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
4827 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
4828 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4830 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
4831 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
4832 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4834 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
4835 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
4836 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
4842 /* Traversal function for find_forall_index. f == 2 signals that
4843 that variable itself is not to be checked - only the references. */
4846 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
4848 if (expr
->expr_type
!= EXPR_VARIABLE
)
4851 /* A scalar assignment */
4852 if (!expr
->ref
|| *f
== 1)
4854 if (expr
->symtree
->n
.sym
== sym
)
4866 /* Check whether the FORALL index appears in the expression or not.
4867 Returns SUCCESS if SYM is found in EXPR. */
4870 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
4872 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
4879 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4880 to be a scalar INTEGER variable. The subscripts and stride are scalar
4881 INTEGERs, and if stride is a constant it must be nonzero.
4882 Furthermore "A subscript or stride in a forall-triplet-spec shall
4883 not contain a reference to any index-name in the
4884 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4887 resolve_forall_iterators (gfc_forall_iterator
*it
)
4889 gfc_forall_iterator
*iter
, *iter2
;
4891 for (iter
= it
; iter
; iter
= iter
->next
)
4893 if (gfc_resolve_expr (iter
->var
) == SUCCESS
4894 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
4895 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4898 if (gfc_resolve_expr (iter
->start
) == SUCCESS
4899 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
4900 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4901 &iter
->start
->where
);
4902 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
4903 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4905 if (gfc_resolve_expr (iter
->end
) == SUCCESS
4906 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
4907 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4909 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
4910 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4912 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
4914 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
4915 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4916 &iter
->stride
->where
, "INTEGER");
4918 if (iter
->stride
->expr_type
== EXPR_CONSTANT
4919 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
4920 gfc_error ("FORALL stride expression at %L cannot be zero",
4921 &iter
->stride
->where
);
4923 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
4924 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
4927 for (iter
= it
; iter
; iter
= iter
->next
)
4928 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
4930 if (find_forall_index (iter2
->start
,
4931 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
4932 || find_forall_index (iter2
->end
,
4933 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
4934 || find_forall_index (iter2
->stride
,
4935 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
4936 gfc_error ("FORALL index '%s' may not appear in triplet "
4937 "specification at %L", iter
->var
->symtree
->name
,
4938 &iter2
->start
->where
);
4943 /* Given a pointer to a symbol that is a derived type, see if it's
4944 inaccessible, i.e. if it's defined in another module and the components are
4945 PRIVATE. The search is recursive if necessary. Returns zero if no
4946 inaccessible components are found, nonzero otherwise. */
4949 derived_inaccessible (gfc_symbol
*sym
)
4953 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
4956 for (c
= sym
->components
; c
; c
= c
->next
)
4958 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
4966 /* Resolve the argument of a deallocate expression. The expression must be
4967 a pointer or a full array. */
4970 resolve_deallocate_expr (gfc_expr
*e
)
4972 symbol_attribute attr
;
4973 int allocatable
, pointer
, check_intent_in
;
4976 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4977 check_intent_in
= 1;
4979 if (gfc_resolve_expr (e
) == FAILURE
)
4982 if (e
->expr_type
!= EXPR_VARIABLE
)
4985 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
4986 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
4987 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4990 check_intent_in
= 0;
4995 if (ref
->u
.ar
.type
!= AR_FULL
)
5000 allocatable
= (ref
->u
.c
.component
->as
!= NULL
5001 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
5002 pointer
= ref
->u
.c
.component
->attr
.pointer
;
5011 attr
= gfc_expr_attr (e
);
5013 if (allocatable
== 0 && attr
.pointer
== 0)
5016 gfc_error ("Expression in DEALLOCATE statement at %L must be "
5017 "ALLOCATABLE or a POINTER", &e
->where
);
5021 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
5023 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
5024 e
->symtree
->n
.sym
->name
, &e
->where
);
5032 /* Returns true if the expression e contains a reference to the symbol sym. */
5034 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5036 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
5043 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
5045 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
5049 /* Given the expression node e for an allocatable/pointer of derived type to be
5050 allocated, get the expression node to be initialized afterwards (needed for
5051 derived types with default initializers, and derived types with allocatable
5052 components that need nullification.) */
5055 expr_to_initialize (gfc_expr
*e
)
5061 result
= gfc_copy_expr (e
);
5063 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5064 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
5065 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5067 ref
->u
.ar
.type
= AR_FULL
;
5069 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5070 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
5072 result
->rank
= ref
->u
.ar
.dimen
;
5080 /* Resolve the expression in an ALLOCATE statement, doing the additional
5081 checks to see whether the expression is OK or not. The expression must
5082 have a trailing array reference that gives the size of the array. */
5085 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
5087 int i
, pointer
, allocatable
, dimension
, check_intent_in
;
5088 symbol_attribute attr
;
5089 gfc_ref
*ref
, *ref2
;
5096 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5097 check_intent_in
= 1;
5099 if (gfc_resolve_expr (e
) == FAILURE
)
5102 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
5103 sym
= code
->expr
->symtree
->n
.sym
;
5107 /* Make sure the expression is allocatable or a pointer. If it is
5108 pointer, the next-to-last reference must be a pointer. */
5112 if (e
->expr_type
!= EXPR_VARIABLE
)
5115 attr
= gfc_expr_attr (e
);
5116 pointer
= attr
.pointer
;
5117 dimension
= attr
.dimension
;
5121 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
5122 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
5123 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
5125 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
5127 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
5128 "not be allocated in the same statement at %L",
5129 sym
->name
, &e
->where
);
5133 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
5136 check_intent_in
= 0;
5141 if (ref
->next
!= NULL
)
5146 allocatable
= (ref
->u
.c
.component
->as
!= NULL
5147 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
5149 pointer
= ref
->u
.c
.component
->attr
.pointer
;
5150 dimension
= ref
->u
.c
.component
->attr
.dimension
;
5161 if (allocatable
== 0 && pointer
== 0)
5163 gfc_error ("Expression in ALLOCATE statement at %L must be "
5164 "ALLOCATABLE or a POINTER", &e
->where
);
5169 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
5171 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
5172 e
->symtree
->n
.sym
->name
, &e
->where
);
5176 /* Add default initializer for those derived types that need them. */
5177 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
5179 init_st
= gfc_get_code ();
5180 init_st
->loc
= code
->loc
;
5181 init_st
->op
= EXEC_INIT_ASSIGN
;
5182 init_st
->expr
= expr_to_initialize (e
);
5183 init_st
->expr2
= init_e
;
5184 init_st
->next
= code
->next
;
5185 code
->next
= init_st
;
5188 if (pointer
&& dimension
== 0)
5191 /* Make sure the next-to-last reference node is an array specification. */
5193 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
5195 gfc_error ("Array specification required in ALLOCATE statement "
5196 "at %L", &e
->where
);
5200 /* Make sure that the array section reference makes sense in the
5201 context of an ALLOCATE specification. */
5205 for (i
= 0; i
< ar
->dimen
; i
++)
5207 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
5210 switch (ar
->dimen_type
[i
])
5216 if (ar
->start
[i
] != NULL
5217 && ar
->end
[i
] != NULL
5218 && ar
->stride
[i
] == NULL
)
5221 /* Fall Through... */
5225 gfc_error ("Bad array specification in ALLOCATE statement at %L",
5232 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5234 sym
= a
->expr
->symtree
->n
.sym
;
5236 /* TODO - check derived type components. */
5237 if (sym
->ts
.type
== BT_DERIVED
)
5240 if ((ar
->start
[i
] != NULL
5241 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
5242 || (ar
->end
[i
] != NULL
5243 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
5245 gfc_error ("'%s' must not appear in the array specification at "
5246 "%L in the same ALLOCATE statement where it is "
5247 "itself allocated", sym
->name
, &ar
->where
);
5257 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
5259 gfc_symbol
*s
= NULL
;
5263 s
= code
->expr
->symtree
->n
.sym
;
5267 if (s
->attr
.intent
== INTENT_IN
)
5268 gfc_error ("STAT variable '%s' of %s statement at %C cannot "
5269 "be INTENT(IN)", s
->name
, fcn
);
5271 if (gfc_pure (NULL
) && gfc_impure_variable (s
))
5272 gfc_error ("Illegal STAT variable in %s statement at %C "
5273 "for a PURE procedure", fcn
);
5276 if (s
&& code
->expr
->ts
.type
!= BT_INTEGER
)
5277 gfc_error ("STAT tag in %s statement at %L must be "
5278 "of type INTEGER", fcn
, &code
->expr
->where
);
5280 if (strcmp (fcn
, "ALLOCATE") == 0)
5282 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5283 resolve_allocate_expr (a
->expr
, code
);
5287 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5288 resolve_deallocate_expr (a
->expr
);
5292 /************ SELECT CASE resolution subroutines ************/
5294 /* Callback function for our mergesort variant. Determines interval
5295 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
5296 op1 > op2. Assumes we're not dealing with the default case.
5297 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
5298 There are nine situations to check. */
5301 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
5305 if (op1
->low
== NULL
) /* op1 = (:L) */
5307 /* op2 = (:N), so overlap. */
5309 /* op2 = (M:) or (M:N), L < M */
5310 if (op2
->low
!= NULL
5311 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
5314 else if (op1
->high
== NULL
) /* op1 = (K:) */
5316 /* op2 = (M:), so overlap. */
5318 /* op2 = (:N) or (M:N), K > N */
5319 if (op2
->high
!= NULL
5320 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
5323 else /* op1 = (K:L) */
5325 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
5326 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
5328 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
5329 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
5331 else /* op2 = (M:N) */
5335 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
5338 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
5347 /* Merge-sort a double linked case list, detecting overlap in the
5348 process. LIST is the head of the double linked case list before it
5349 is sorted. Returns the head of the sorted list if we don't see any
5350 overlap, or NULL otherwise. */
5353 check_case_overlap (gfc_case
*list
)
5355 gfc_case
*p
, *q
, *e
, *tail
;
5356 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
5358 /* If the passed list was empty, return immediately. */
5365 /* Loop unconditionally. The only exit from this loop is a return
5366 statement, when we've finished sorting the case list. */
5373 /* Count the number of merges we do in this pass. */
5376 /* Loop while there exists a merge to be done. */
5381 /* Count this merge. */
5384 /* Cut the list in two pieces by stepping INSIZE places
5385 forward in the list, starting from P. */
5388 for (i
= 0; i
< insize
; i
++)
5397 /* Now we have two lists. Merge them! */
5398 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
5400 /* See from which the next case to merge comes from. */
5403 /* P is empty so the next case must come from Q. */
5408 else if (qsize
== 0 || q
== NULL
)
5417 cmp
= compare_cases (p
, q
);
5420 /* The whole case range for P is less than the
5428 /* The whole case range for Q is greater than
5429 the case range for P. */
5436 /* The cases overlap, or they are the same
5437 element in the list. Either way, we must
5438 issue an error and get the next case from P. */
5439 /* FIXME: Sort P and Q by line number. */
5440 gfc_error ("CASE label at %L overlaps with CASE "
5441 "label at %L", &p
->where
, &q
->where
);
5449 /* Add the next element to the merged list. */
5458 /* P has now stepped INSIZE places along, and so has Q. So
5459 they're the same. */
5464 /* If we have done only one merge or none at all, we've
5465 finished sorting the cases. */
5474 /* Otherwise repeat, merging lists twice the size. */
5480 /* Check to see if an expression is suitable for use in a CASE statement.
5481 Makes sure that all case expressions are scalar constants of the same
5482 type. Return FAILURE if anything is wrong. */
5485 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
5487 if (e
== NULL
) return SUCCESS
;
5489 if (e
->ts
.type
!= case_expr
->ts
.type
)
5491 gfc_error ("Expression in CASE statement at %L must be of type %s",
5492 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
5496 /* C805 (R808) For a given case-construct, each case-value shall be of
5497 the same type as case-expr. For character type, length differences
5498 are allowed, but the kind type parameters shall be the same. */
5500 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
5502 gfc_error ("Expression in CASE statement at %L must be of kind %d",
5503 &e
->where
, case_expr
->ts
.kind
);
5507 /* Convert the case value kind to that of case expression kind, if needed.
5508 FIXME: Should a warning be issued? */
5509 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
5510 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
5514 gfc_error ("Expression in CASE statement at %L must be scalar",
5523 /* Given a completely parsed select statement, we:
5525 - Validate all expressions and code within the SELECT.
5526 - Make sure that the selection expression is not of the wrong type.
5527 - Make sure that no case ranges overlap.
5528 - Eliminate unreachable cases and unreachable code resulting from
5529 removing case labels.
5531 The standard does allow unreachable cases, e.g. CASE (5:3). But
5532 they are a hassle for code generation, and to prevent that, we just
5533 cut them out here. This is not necessary for overlapping cases
5534 because they are illegal and we never even try to generate code.
5536 We have the additional caveat that a SELECT construct could have
5537 been a computed GOTO in the source code. Fortunately we can fairly
5538 easily work around that here: The case_expr for a "real" SELECT CASE
5539 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5540 we have to do is make sure that the case_expr is a scalar integer
5544 resolve_select (gfc_code
*code
)
5547 gfc_expr
*case_expr
;
5548 gfc_case
*cp
, *default_case
, *tail
, *head
;
5549 int seen_unreachable
;
5555 if (code
->expr
== NULL
)
5557 /* This was actually a computed GOTO statement. */
5558 case_expr
= code
->expr2
;
5559 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
5560 gfc_error ("Selection expression in computed GOTO statement "
5561 "at %L must be a scalar integer expression",
5564 /* Further checking is not necessary because this SELECT was built
5565 by the compiler, so it should always be OK. Just move the
5566 case_expr from expr2 to expr so that we can handle computed
5567 GOTOs as normal SELECTs from here on. */
5568 code
->expr
= code
->expr2
;
5573 case_expr
= code
->expr
;
5575 type
= case_expr
->ts
.type
;
5576 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
5578 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5579 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
5581 /* Punt. Going on here just produce more garbage error messages. */
5585 if (case_expr
->rank
!= 0)
5587 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5588 "expression", &case_expr
->where
);
5594 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5595 of the SELECT CASE expression and its CASE values. Walk the lists
5596 of case values, and if we find a mismatch, promote case_expr to
5597 the appropriate kind. */
5599 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
5601 for (body
= code
->block
; body
; body
= body
->block
)
5603 /* Walk the case label list. */
5604 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5606 /* Intercept the DEFAULT case. It does not have a kind. */
5607 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5610 /* Unreachable case ranges are discarded, so ignore. */
5611 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5612 && cp
->low
!= cp
->high
5613 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
5616 /* FIXME: Should a warning be issued? */
5618 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
5619 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
5621 if (cp
->high
!= NULL
5622 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
5623 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
5628 /* Assume there is no DEFAULT case. */
5629 default_case
= NULL
;
5634 for (body
= code
->block
; body
; body
= body
->block
)
5636 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5638 seen_unreachable
= 0;
5640 /* Walk the case label list, making sure that all case labels
5642 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5644 /* Count the number of cases in the whole construct. */
5647 /* Intercept the DEFAULT case. */
5648 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5650 if (default_case
!= NULL
)
5652 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5653 "by a second DEFAULT CASE at %L",
5654 &default_case
->where
, &cp
->where
);
5665 /* Deal with single value cases and case ranges. Errors are
5666 issued from the validation function. */
5667 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
5668 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
5674 if (type
== BT_LOGICAL
5675 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
5676 || cp
->low
!= cp
->high
))
5678 gfc_error ("Logical range in CASE statement at %L is not "
5679 "allowed", &cp
->low
->where
);
5684 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
5687 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
5688 if (value
& seen_logical
)
5690 gfc_error ("constant logical value in CASE statement "
5691 "is repeated at %L",
5696 seen_logical
|= value
;
5699 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5700 && cp
->low
!= cp
->high
5701 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
5703 if (gfc_option
.warn_surprising
)
5704 gfc_warning ("Range specification at %L can never "
5705 "be matched", &cp
->where
);
5707 cp
->unreachable
= 1;
5708 seen_unreachable
= 1;
5712 /* If the case range can be matched, it can also overlap with
5713 other cases. To make sure it does not, we put it in a
5714 double linked list here. We sort that with a merge sort
5715 later on to detect any overlapping cases. */
5719 head
->right
= head
->left
= NULL
;
5724 tail
->right
->left
= tail
;
5731 /* It there was a failure in the previous case label, give up
5732 for this case label list. Continue with the next block. */
5736 /* See if any case labels that are unreachable have been seen.
5737 If so, we eliminate them. This is a bit of a kludge because
5738 the case lists for a single case statement (label) is a
5739 single forward linked lists. */
5740 if (seen_unreachable
)
5742 /* Advance until the first case in the list is reachable. */
5743 while (body
->ext
.case_list
!= NULL
5744 && body
->ext
.case_list
->unreachable
)
5746 gfc_case
*n
= body
->ext
.case_list
;
5747 body
->ext
.case_list
= body
->ext
.case_list
->next
;
5749 gfc_free_case_list (n
);
5752 /* Strip all other unreachable cases. */
5753 if (body
->ext
.case_list
)
5755 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
5757 if (cp
->next
->unreachable
)
5759 gfc_case
*n
= cp
->next
;
5760 cp
->next
= cp
->next
->next
;
5762 gfc_free_case_list (n
);
5769 /* See if there were overlapping cases. If the check returns NULL,
5770 there was overlap. In that case we don't do anything. If head
5771 is non-NULL, we prepend the DEFAULT case. The sorted list can
5772 then used during code generation for SELECT CASE constructs with
5773 a case expression of a CHARACTER type. */
5776 head
= check_case_overlap (head
);
5778 /* Prepend the default_case if it is there. */
5779 if (head
!= NULL
&& default_case
)
5781 default_case
->left
= NULL
;
5782 default_case
->right
= head
;
5783 head
->left
= default_case
;
5787 /* Eliminate dead blocks that may be the result if we've seen
5788 unreachable case labels for a block. */
5789 for (body
= code
; body
&& body
->block
; body
= body
->block
)
5791 if (body
->block
->ext
.case_list
== NULL
)
5793 /* Cut the unreachable block from the code chain. */
5794 gfc_code
*c
= body
->block
;
5795 body
->block
= c
->block
;
5797 /* Kill the dead block, but not the blocks below it. */
5799 gfc_free_statements (c
);
5803 /* More than two cases is legal but insane for logical selects.
5804 Issue a warning for it. */
5805 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
5807 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5812 /* Resolve a transfer statement. This is making sure that:
5813 -- a derived type being transferred has only non-pointer components
5814 -- a derived type being transferred doesn't have private components, unless
5815 it's being transferred from the module where the type was defined
5816 -- we're not trying to transfer a whole assumed size array. */
5819 resolve_transfer (gfc_code
*code
)
5828 if (exp
->expr_type
!= EXPR_VARIABLE
&& exp
->expr_type
!= EXPR_FUNCTION
)
5831 sym
= exp
->symtree
->n
.sym
;
5834 /* Go to actual component transferred. */
5835 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
5836 if (ref
->type
== REF_COMPONENT
)
5837 ts
= &ref
->u
.c
.component
->ts
;
5839 if (ts
->type
== BT_DERIVED
)
5841 /* Check that transferred derived type doesn't contain POINTER
5843 if (ts
->derived
->attr
.pointer_comp
)
5845 gfc_error ("Data transfer element at %L cannot have "
5846 "POINTER components", &code
->loc
);
5850 if (ts
->derived
->attr
.alloc_comp
)
5852 gfc_error ("Data transfer element at %L cannot have "
5853 "ALLOCATABLE components", &code
->loc
);
5857 if (derived_inaccessible (ts
->derived
))
5859 gfc_error ("Data transfer element at %L cannot have "
5860 "PRIVATE components",&code
->loc
);
5865 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
5866 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
5868 gfc_error ("Data transfer element at %L cannot be a full reference to "
5869 "an assumed-size array", &code
->loc
);
5875 /*********** Toplevel code resolution subroutines ***********/
5877 /* Find the set of labels that are reachable from this block. We also
5878 record the last statement in each block so that we don't have to do
5879 a linear search to find the END DO statements of the blocks. */
5882 reachable_labels (gfc_code
*block
)
5889 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
5891 /* Collect labels in this block. */
5892 for (c
= block
; c
; c
= c
->next
)
5895 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
5897 if (!c
->next
&& cs_base
->prev
)
5898 cs_base
->prev
->tail
= c
;
5901 /* Merge with labels from parent block. */
5904 gcc_assert (cs_base
->prev
->reachable_labels
);
5905 bitmap_ior_into (cs_base
->reachable_labels
,
5906 cs_base
->prev
->reachable_labels
);
5910 /* Given a branch to a label and a namespace, if the branch is conforming.
5911 The code node describes where the branch is located. */
5914 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
5921 /* Step one: is this a valid branching target? */
5923 if (label
->defined
== ST_LABEL_UNKNOWN
)
5925 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
5930 if (label
->defined
!= ST_LABEL_TARGET
)
5932 gfc_error ("Statement at %L is not a valid branch target statement "
5933 "for the branch statement at %L", &label
->where
, &code
->loc
);
5937 /* Step two: make sure this branch is not a branch to itself ;-) */
5939 if (code
->here
== label
)
5941 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
5945 /* Step three: See if the label is in the same block as the
5946 branching statement. The hard work has been done by setting up
5947 the bitmap reachable_labels. */
5949 if (!bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
5951 /* The label is not in an enclosing block, so illegal. This was
5952 allowed in Fortran 66, so we allow it as extension. No
5953 further checks are necessary in this case. */
5954 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
5955 "as the GOTO statement at %L", &label
->where
,
5960 /* Step four: Make sure that the branching target is legal if
5961 the statement is an END {SELECT,IF}. */
5963 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5964 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
5967 if (stack
&& stack
->current
->next
->op
== EXEC_NOP
)
5969 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps to "
5970 "END of construct at %L", &code
->loc
,
5971 &stack
->current
->next
->loc
);
5972 return; /* We know this is not an END DO. */
5975 /* Step five: Make sure that we're not jumping to the end of a DO
5976 loop from within the loop. */
5978 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5979 if ((stack
->current
->op
== EXEC_DO
5980 || stack
->current
->op
== EXEC_DO_WHILE
)
5981 && stack
->tail
->here
== label
&& stack
->tail
->op
== EXEC_NOP
)
5983 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps "
5984 "to END of construct at %L", &code
->loc
,
5992 /* Check whether EXPR1 has the same shape as EXPR2. */
5995 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
5997 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5998 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
5999 gfc_try result
= FAILURE
;
6002 /* Compare the rank. */
6003 if (expr1
->rank
!= expr2
->rank
)
6006 /* Compare the size of each dimension. */
6007 for (i
=0; i
<expr1
->rank
; i
++)
6009 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
6012 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
6015 if (mpz_cmp (shape
[i
], shape2
[i
]))
6019 /* When either of the two expression is an assumed size array, we
6020 ignore the comparison of dimension sizes. */
6025 for (i
--; i
>= 0; i
--)
6027 mpz_clear (shape
[i
]);
6028 mpz_clear (shape2
[i
]);
6034 /* Check whether a WHERE assignment target or a WHERE mask expression
6035 has the same shape as the outmost WHERE mask expression. */
6038 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
6044 cblock
= code
->block
;
6046 /* Store the first WHERE mask-expr of the WHERE statement or construct.
6047 In case of nested WHERE, only the outmost one is stored. */
6048 if (mask
== NULL
) /* outmost WHERE */
6050 else /* inner WHERE */
6057 /* Check if the mask-expr has a consistent shape with the
6058 outmost WHERE mask-expr. */
6059 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
6060 gfc_error ("WHERE mask at %L has inconsistent shape",
6061 &cblock
->expr
->where
);
6064 /* the assignment statement of a WHERE statement, or the first
6065 statement in where-body-construct of a WHERE construct */
6066 cnext
= cblock
->next
;
6071 /* WHERE assignment statement */
6074 /* Check shape consistent for WHERE assignment target. */
6075 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
6076 gfc_error ("WHERE assignment target at %L has "
6077 "inconsistent shape", &cnext
->expr
->where
);
6081 case EXEC_ASSIGN_CALL
:
6082 resolve_call (cnext
);
6083 if (!cnext
->resolved_sym
->attr
.elemental
)
6084 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6085 &cnext
->ext
.actual
->expr
->where
);
6088 /* WHERE or WHERE construct is part of a where-body-construct */
6090 resolve_where (cnext
, e
);
6094 gfc_error ("Unsupported statement inside WHERE at %L",
6097 /* the next statement within the same where-body-construct */
6098 cnext
= cnext
->next
;
6100 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6101 cblock
= cblock
->block
;
6106 /* Resolve assignment in FORALL construct.
6107 NVAR is the number of FORALL index variables, and VAR_EXPR records the
6108 FORALL index variables. */
6111 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
6115 for (n
= 0; n
< nvar
; n
++)
6117 gfc_symbol
*forall_index
;
6119 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
6121 /* Check whether the assignment target is one of the FORALL index
6123 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
6124 && (code
->expr
->symtree
->n
.sym
== forall_index
))
6125 gfc_error ("Assignment to a FORALL index variable at %L",
6126 &code
->expr
->where
);
6129 /* If one of the FORALL index variables doesn't appear in the
6130 assignment variable, then there could be a many-to-one
6131 assignment. Emit a warning rather than an error because the
6132 mask could be resolving this problem. */
6133 if (find_forall_index (code
->expr
, forall_index
, 0) == FAILURE
)
6134 gfc_warning ("The FORALL with index '%s' is not used on the "
6135 "left side of the assignment at %L and so might "
6136 "cause multiple assignment to this object",
6137 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
6143 /* Resolve WHERE statement in FORALL construct. */
6146 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
6147 gfc_expr
**var_expr
)
6152 cblock
= code
->block
;
6155 /* the assignment statement of a WHERE statement, or the first
6156 statement in where-body-construct of a WHERE construct */
6157 cnext
= cblock
->next
;
6162 /* WHERE assignment statement */
6164 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
6167 /* WHERE operator assignment statement */
6168 case EXEC_ASSIGN_CALL
:
6169 resolve_call (cnext
);
6170 if (!cnext
->resolved_sym
->attr
.elemental
)
6171 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6172 &cnext
->ext
.actual
->expr
->where
);
6175 /* WHERE or WHERE construct is part of a where-body-construct */
6177 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
6181 gfc_error ("Unsupported statement inside WHERE at %L",
6184 /* the next statement within the same where-body-construct */
6185 cnext
= cnext
->next
;
6187 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6188 cblock
= cblock
->block
;
6193 /* Traverse the FORALL body to check whether the following errors exist:
6194 1. For assignment, check if a many-to-one assignment happens.
6195 2. For WHERE statement, check the WHERE body to see if there is any
6196 many-to-one assignment. */
6199 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
6203 c
= code
->block
->next
;
6209 case EXEC_POINTER_ASSIGN
:
6210 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
6213 case EXEC_ASSIGN_CALL
:
6217 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
6218 there is no need to handle it here. */
6222 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
6227 /* The next statement in the FORALL body. */
6233 /* Counts the number of iterators needed inside a forall construct, including
6234 nested forall constructs. This is used to allocate the needed memory
6235 in gfc_resolve_forall. */
6238 gfc_count_forall_iterators (gfc_code
*code
)
6240 int max_iters
, sub_iters
, current_iters
;
6241 gfc_forall_iterator
*fa
;
6243 gcc_assert(code
->op
== EXEC_FORALL
);
6247 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
6250 code
= code
->block
->next
;
6254 if (code
->op
== EXEC_FORALL
)
6256 sub_iters
= gfc_count_forall_iterators (code
);
6257 if (sub_iters
> max_iters
)
6258 max_iters
= sub_iters
;
6263 return current_iters
+ max_iters
;
6267 /* Given a FORALL construct, first resolve the FORALL iterator, then call
6268 gfc_resolve_forall_body to resolve the FORALL body. */
6271 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
6273 static gfc_expr
**var_expr
;
6274 static int total_var
= 0;
6275 static int nvar
= 0;
6277 gfc_forall_iterator
*fa
;
6282 /* Start to resolve a FORALL construct */
6283 if (forall_save
== 0)
6285 /* Count the total number of FORALL index in the nested FORALL
6286 construct in order to allocate the VAR_EXPR with proper size. */
6287 total_var
= gfc_count_forall_iterators (code
);
6289 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
6290 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
6293 /* The information about FORALL iterator, including FORALL index start, end
6294 and stride. The FORALL index can not appear in start, end or stride. */
6295 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
6297 /* Check if any outer FORALL index name is the same as the current
6299 for (i
= 0; i
< nvar
; i
++)
6301 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
6303 gfc_error ("An outer FORALL construct already has an index "
6304 "with this name %L", &fa
->var
->where
);
6308 /* Record the current FORALL index. */
6309 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
6313 /* No memory leak. */
6314 gcc_assert (nvar
<= total_var
);
6317 /* Resolve the FORALL body. */
6318 gfc_resolve_forall_body (code
, nvar
, var_expr
);
6320 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
6321 gfc_resolve_blocks (code
->block
, ns
);
6325 /* Free only the VAR_EXPRs allocated in this frame. */
6326 for (i
= nvar
; i
< tmp
; i
++)
6327 gfc_free_expr (var_expr
[i
]);
6331 /* We are in the outermost FORALL construct. */
6332 gcc_assert (forall_save
== 0);
6334 /* VAR_EXPR is not needed any more. */
6335 gfc_free (var_expr
);
6341 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
6344 static void resolve_code (gfc_code
*, gfc_namespace
*);
6347 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
6351 for (; b
; b
= b
->block
)
6353 t
= gfc_resolve_expr (b
->expr
);
6354 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
6360 if (t
== SUCCESS
&& b
->expr
!= NULL
6361 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
6362 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6369 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
== 0))
6370 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
6375 resolve_branch (b
->label
, b
);
6388 case EXEC_OMP_ATOMIC
:
6389 case EXEC_OMP_CRITICAL
:
6391 case EXEC_OMP_MASTER
:
6392 case EXEC_OMP_ORDERED
:
6393 case EXEC_OMP_PARALLEL
:
6394 case EXEC_OMP_PARALLEL_DO
:
6395 case EXEC_OMP_PARALLEL_SECTIONS
:
6396 case EXEC_OMP_PARALLEL_WORKSHARE
:
6397 case EXEC_OMP_SECTIONS
:
6398 case EXEC_OMP_SINGLE
:
6400 case EXEC_OMP_TASKWAIT
:
6401 case EXEC_OMP_WORKSHARE
:
6405 gfc_internal_error ("resolve_block(): Bad block type");
6408 resolve_code (b
->next
, ns
);
6413 /* Does everything to resolve an ordinary assignment. Returns true
6414 if this is an interface assignment. */
6416 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
6426 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
6428 lhs
= code
->ext
.actual
->expr
;
6429 rhs
= code
->ext
.actual
->next
->expr
;
6430 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
6432 gfc_error ("Subroutine '%s' called instead of assignment at "
6433 "%L must be PURE", code
->symtree
->n
.sym
->name
,
6438 /* Make a temporary rhs when there is a default initializer
6439 and rhs is the same symbol as the lhs. */
6440 if (rhs
->expr_type
== EXPR_VARIABLE
6441 && rhs
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
6442 && has_default_initializer (rhs
->symtree
->n
.sym
->ts
.derived
)
6443 && (lhs
->symtree
->n
.sym
== rhs
->symtree
->n
.sym
))
6444 code
->ext
.actual
->next
->expr
= gfc_get_parentheses (rhs
);
6453 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
6454 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
6455 &code
->loc
) == FAILURE
)
6458 /* Handle the case of a BOZ literal on the RHS. */
6459 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
6462 if (gfc_option
.warn_surprising
)
6463 gfc_warning ("BOZ literal at %L is bitwise transferred "
6464 "non-integer symbol '%s'", &code
->loc
,
6465 lhs
->symtree
->n
.sym
->name
);
6467 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
6469 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
6471 if (rc
== ARITH_UNDERFLOW
)
6472 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
6473 ". This check can be disabled with the option "
6474 "-fno-range-check", &rhs
->where
);
6475 else if (rc
== ARITH_OVERFLOW
)
6476 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6477 ". This check can be disabled with the option "
6478 "-fno-range-check", &rhs
->where
);
6479 else if (rc
== ARITH_NAN
)
6480 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6481 ". This check can be disabled with the option "
6482 "-fno-range-check", &rhs
->where
);
6488 if (lhs
->ts
.type
== BT_CHARACTER
6489 && gfc_option
.warn_character_truncation
)
6491 if (lhs
->ts
.cl
!= NULL
6492 && lhs
->ts
.cl
->length
!= NULL
6493 && lhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6494 llen
= mpz_get_si (lhs
->ts
.cl
->length
->value
.integer
);
6496 if (rhs
->expr_type
== EXPR_CONSTANT
)
6497 rlen
= rhs
->value
.character
.length
;
6499 else if (rhs
->ts
.cl
!= NULL
6500 && rhs
->ts
.cl
->length
!= NULL
6501 && rhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6502 rlen
= mpz_get_si (rhs
->ts
.cl
->length
->value
.integer
);
6504 if (rlen
&& llen
&& rlen
> llen
)
6505 gfc_warning_now ("CHARACTER expression will be truncated "
6506 "in assignment (%d/%d) at %L",
6507 llen
, rlen
, &code
->loc
);
6510 /* Ensure that a vector index expression for the lvalue is evaluated
6511 to a temporary if the lvalue symbol is referenced in it. */
6514 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
6515 if (ref
->type
== REF_ARRAY
)
6517 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6518 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
6519 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
6520 ref
->u
.ar
.start
[n
]))
6522 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
6526 if (gfc_pure (NULL
))
6528 if (gfc_impure_variable (lhs
->symtree
->n
.sym
))
6530 gfc_error ("Cannot assign to variable '%s' in PURE "
6532 lhs
->symtree
->n
.sym
->name
,
6537 if (lhs
->ts
.type
== BT_DERIVED
6538 && lhs
->expr_type
== EXPR_VARIABLE
6539 && lhs
->ts
.derived
->attr
.pointer_comp
6540 && gfc_impure_variable (rhs
->symtree
->n
.sym
))
6542 gfc_error ("The impure variable at %L is assigned to "
6543 "a derived type variable with a POINTER "
6544 "component in a PURE procedure (12.6)",
6550 gfc_check_assign (lhs
, rhs
, 1);
6554 /* Given a block of code, recursively resolve everything pointed to by this
6558 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
6560 int omp_workshare_save
;
6565 frame
.prev
= cs_base
;
6569 reachable_labels (code
);
6571 for (; code
; code
= code
->next
)
6573 frame
.current
= code
;
6574 forall_save
= forall_flag
;
6576 if (code
->op
== EXEC_FORALL
)
6579 gfc_resolve_forall (code
, ns
, forall_save
);
6582 else if (code
->block
)
6584 omp_workshare_save
= -1;
6587 case EXEC_OMP_PARALLEL_WORKSHARE
:
6588 omp_workshare_save
= omp_workshare_flag
;
6589 omp_workshare_flag
= 1;
6590 gfc_resolve_omp_parallel_blocks (code
, ns
);
6592 case EXEC_OMP_PARALLEL
:
6593 case EXEC_OMP_PARALLEL_DO
:
6594 case EXEC_OMP_PARALLEL_SECTIONS
:
6596 omp_workshare_save
= omp_workshare_flag
;
6597 omp_workshare_flag
= 0;
6598 gfc_resolve_omp_parallel_blocks (code
, ns
);
6601 gfc_resolve_omp_do_blocks (code
, ns
);
6603 case EXEC_OMP_WORKSHARE
:
6604 omp_workshare_save
= omp_workshare_flag
;
6605 omp_workshare_flag
= 1;
6608 gfc_resolve_blocks (code
->block
, ns
);
6612 if (omp_workshare_save
!= -1)
6613 omp_workshare_flag
= omp_workshare_save
;
6617 if (code
->op
!= EXEC_COMPCALL
)
6618 t
= gfc_resolve_expr (code
->expr
);
6619 forall_flag
= forall_save
;
6621 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
6636 /* Keep track of which entry we are up to. */
6637 current_entry_id
= code
->ext
.entry
->id
;
6641 resolve_where (code
, NULL
);
6645 if (code
->expr
!= NULL
)
6647 if (code
->expr
->ts
.type
!= BT_INTEGER
)
6648 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6649 "INTEGER variable", &code
->expr
->where
);
6650 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
6651 gfc_error ("Variable '%s' has not been assigned a target "
6652 "label at %L", code
->expr
->symtree
->n
.sym
->name
,
6653 &code
->expr
->where
);
6656 resolve_branch (code
->label
, code
);
6660 if (code
->expr
!= NULL
6661 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
6662 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6663 "INTEGER return specifier", &code
->expr
->where
);
6666 case EXEC_INIT_ASSIGN
:
6673 if (resolve_ordinary_assign (code
, ns
))
6678 case EXEC_LABEL_ASSIGN
:
6679 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
6680 gfc_error ("Label %d referenced at %L is never defined",
6681 code
->label
->value
, &code
->label
->where
);
6683 && (code
->expr
->expr_type
!= EXPR_VARIABLE
6684 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
6685 || code
->expr
->symtree
->n
.sym
->ts
.kind
6686 != gfc_default_integer_kind
6687 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
6688 gfc_error ("ASSIGN statement at %L requires a scalar "
6689 "default INTEGER variable", &code
->expr
->where
);
6692 case EXEC_POINTER_ASSIGN
:
6696 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
6699 case EXEC_ARITHMETIC_IF
:
6701 && code
->expr
->ts
.type
!= BT_INTEGER
6702 && code
->expr
->ts
.type
!= BT_REAL
)
6703 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6704 "expression", &code
->expr
->where
);
6706 resolve_branch (code
->label
, code
);
6707 resolve_branch (code
->label2
, code
);
6708 resolve_branch (code
->label3
, code
);
6712 if (t
== SUCCESS
&& code
->expr
!= NULL
6713 && (code
->expr
->ts
.type
!= BT_LOGICAL
6714 || code
->expr
->rank
!= 0))
6715 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6716 &code
->expr
->where
);
6721 resolve_call (code
);
6725 resolve_typebound_call (code
);
6729 /* Select is complicated. Also, a SELECT construct could be
6730 a transformed computed GOTO. */
6731 resolve_select (code
);
6735 if (code
->ext
.iterator
!= NULL
)
6737 gfc_iterator
*iter
= code
->ext
.iterator
;
6738 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
6739 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
6744 if (code
->expr
== NULL
)
6745 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6747 && (code
->expr
->rank
!= 0
6748 || code
->expr
->ts
.type
!= BT_LOGICAL
))
6749 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6750 "a scalar LOGICAL expression", &code
->expr
->where
);
6755 resolve_allocate_deallocate (code
, "ALLOCATE");
6759 case EXEC_DEALLOCATE
:
6761 resolve_allocate_deallocate (code
, "DEALLOCATE");
6766 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
6769 resolve_branch (code
->ext
.open
->err
, code
);
6773 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
6776 resolve_branch (code
->ext
.close
->err
, code
);
6779 case EXEC_BACKSPACE
:
6783 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
6786 resolve_branch (code
->ext
.filepos
->err
, code
);
6790 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6793 resolve_branch (code
->ext
.inquire
->err
, code
);
6797 gcc_assert (code
->ext
.inquire
!= NULL
);
6798 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6801 resolve_branch (code
->ext
.inquire
->err
, code
);
6805 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
6808 resolve_branch (code
->ext
.wait
->err
, code
);
6809 resolve_branch (code
->ext
.wait
->end
, code
);
6810 resolve_branch (code
->ext
.wait
->eor
, code
);
6815 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
6818 resolve_branch (code
->ext
.dt
->err
, code
);
6819 resolve_branch (code
->ext
.dt
->end
, code
);
6820 resolve_branch (code
->ext
.dt
->eor
, code
);
6824 resolve_transfer (code
);
6828 resolve_forall_iterators (code
->ext
.forall_iterator
);
6830 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
6831 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6832 "expression", &code
->expr
->where
);
6835 case EXEC_OMP_ATOMIC
:
6836 case EXEC_OMP_BARRIER
:
6837 case EXEC_OMP_CRITICAL
:
6838 case EXEC_OMP_FLUSH
:
6840 case EXEC_OMP_MASTER
:
6841 case EXEC_OMP_ORDERED
:
6842 case EXEC_OMP_SECTIONS
:
6843 case EXEC_OMP_SINGLE
:
6844 case EXEC_OMP_TASKWAIT
:
6845 case EXEC_OMP_WORKSHARE
:
6846 gfc_resolve_omp_directive (code
, ns
);
6849 case EXEC_OMP_PARALLEL
:
6850 case EXEC_OMP_PARALLEL_DO
:
6851 case EXEC_OMP_PARALLEL_SECTIONS
:
6852 case EXEC_OMP_PARALLEL_WORKSHARE
:
6854 omp_workshare_save
= omp_workshare_flag
;
6855 omp_workshare_flag
= 0;
6856 gfc_resolve_omp_directive (code
, ns
);
6857 omp_workshare_flag
= omp_workshare_save
;
6861 gfc_internal_error ("resolve_code(): Bad statement code");
6865 cs_base
= frame
.prev
;
6869 /* Resolve initial values and make sure they are compatible with
6873 resolve_values (gfc_symbol
*sym
)
6875 if (sym
->value
== NULL
)
6878 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
6881 gfc_check_assign_symbol (sym
, sym
->value
);
6885 /* Verify the binding labels for common blocks that are BIND(C). The label
6886 for a BIND(C) common block must be identical in all scoping units in which
6887 the common block is declared. Further, the binding label can not collide
6888 with any other global entity in the program. */
6891 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
6893 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
6895 gfc_gsymbol
*binding_label_gsym
;
6896 gfc_gsymbol
*comm_name_gsym
;
6898 /* See if a global symbol exists by the common block's name. It may
6899 be NULL if the common block is use-associated. */
6900 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
6901 comm_block_tree
->n
.common
->name
);
6902 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
6903 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6904 "with the global entity '%s' at %L",
6905 comm_block_tree
->n
.common
->binding_label
,
6906 comm_block_tree
->n
.common
->name
,
6907 &(comm_block_tree
->n
.common
->where
),
6908 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6909 else if (comm_name_gsym
!= NULL
6910 && strcmp (comm_name_gsym
->name
,
6911 comm_block_tree
->n
.common
->name
) == 0)
6913 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6915 if (comm_name_gsym
->binding_label
== NULL
)
6916 /* No binding label for common block stored yet; save this one. */
6917 comm_name_gsym
->binding_label
=
6918 comm_block_tree
->n
.common
->binding_label
;
6920 if (strcmp (comm_name_gsym
->binding_label
,
6921 comm_block_tree
->n
.common
->binding_label
) != 0)
6923 /* Common block names match but binding labels do not. */
6924 gfc_error ("Binding label '%s' for common block '%s' at %L "
6925 "does not match the binding label '%s' for common "
6927 comm_block_tree
->n
.common
->binding_label
,
6928 comm_block_tree
->n
.common
->name
,
6929 &(comm_block_tree
->n
.common
->where
),
6930 comm_name_gsym
->binding_label
,
6931 comm_name_gsym
->name
,
6932 &(comm_name_gsym
->where
));
6937 /* There is no binding label (NAME="") so we have nothing further to
6938 check and nothing to add as a global symbol for the label. */
6939 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
6942 binding_label_gsym
=
6943 gfc_find_gsymbol (gfc_gsym_root
,
6944 comm_block_tree
->n
.common
->binding_label
);
6945 if (binding_label_gsym
== NULL
)
6947 /* Need to make a global symbol for the binding label to prevent
6948 it from colliding with another. */
6949 binding_label_gsym
=
6950 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
6951 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
6952 binding_label_gsym
->type
= GSYM_COMMON
;
6956 /* If comm_name_gsym is NULL, the name common block is use
6957 associated and the name could be colliding. */
6958 if (binding_label_gsym
->type
!= GSYM_COMMON
)
6959 gfc_error ("Binding label '%s' for common block '%s' at %L "
6960 "collides with the global entity '%s' at %L",
6961 comm_block_tree
->n
.common
->binding_label
,
6962 comm_block_tree
->n
.common
->name
,
6963 &(comm_block_tree
->n
.common
->where
),
6964 binding_label_gsym
->name
,
6965 &(binding_label_gsym
->where
));
6966 else if (comm_name_gsym
!= NULL
6967 && (strcmp (binding_label_gsym
->name
,
6968 comm_name_gsym
->binding_label
) != 0)
6969 && (strcmp (binding_label_gsym
->sym_name
,
6970 comm_name_gsym
->name
) != 0))
6971 gfc_error ("Binding label '%s' for common block '%s' at %L "
6972 "collides with global entity '%s' at %L",
6973 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
6974 &(comm_block_tree
->n
.common
->where
),
6975 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6983 /* Verify any BIND(C) derived types in the namespace so we can report errors
6984 for them once, rather than for each variable declared of that type. */
6987 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
6989 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
6990 && derived_sym
->attr
.is_bind_c
== 1)
6991 verify_bind_c_derived_type (derived_sym
);
6997 /* Verify that any binding labels used in a given namespace do not collide
6998 with the names or binding labels of any global symbols. */
7001 gfc_verify_binding_labels (gfc_symbol
*sym
)
7005 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
7006 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
7008 gfc_gsymbol
*bind_c_sym
;
7010 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
7011 if (bind_c_sym
!= NULL
7012 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
7014 if (sym
->attr
.if_source
== IFSRC_DECL
7015 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
7016 && bind_c_sym
->type
!= GSYM_FUNCTION
)
7017 && ((sym
->attr
.contained
== 1
7018 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
7019 || (sym
->attr
.use_assoc
== 1
7020 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
7022 /* Make sure global procedures don't collide with anything. */
7023 gfc_error ("Binding label '%s' at %L collides with the global "
7024 "entity '%s' at %L", sym
->binding_label
,
7025 &(sym
->declared_at
), bind_c_sym
->name
,
7026 &(bind_c_sym
->where
));
7029 else if (sym
->attr
.contained
== 0
7030 && (sym
->attr
.if_source
== IFSRC_IFBODY
7031 && sym
->attr
.flavor
== FL_PROCEDURE
)
7032 && (bind_c_sym
->sym_name
!= NULL
7033 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
7035 /* Make sure procedures in interface bodies don't collide. */
7036 gfc_error ("Binding label '%s' in interface body at %L collides "
7037 "with the global entity '%s' at %L",
7039 &(sym
->declared_at
), bind_c_sym
->name
,
7040 &(bind_c_sym
->where
));
7043 else if (sym
->attr
.contained
== 0
7044 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
7045 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
7046 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
7047 || sym
->attr
.use_assoc
== 0)
7049 gfc_error ("Binding label '%s' at %L collides with global "
7050 "entity '%s' at %L", sym
->binding_label
,
7051 &(sym
->declared_at
), bind_c_sym
->name
,
7052 &(bind_c_sym
->where
));
7057 /* Clear the binding label to prevent checking multiple times. */
7058 sym
->binding_label
[0] = '\0';
7060 else if (bind_c_sym
== NULL
)
7062 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
7063 bind_c_sym
->where
= sym
->declared_at
;
7064 bind_c_sym
->sym_name
= sym
->name
;
7066 if (sym
->attr
.use_assoc
== 1)
7067 bind_c_sym
->mod_name
= sym
->module
;
7069 if (sym
->ns
->proc_name
!= NULL
)
7070 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
7072 if (sym
->attr
.contained
== 0)
7074 if (sym
->attr
.subroutine
)
7075 bind_c_sym
->type
= GSYM_SUBROUTINE
;
7076 else if (sym
->attr
.function
)
7077 bind_c_sym
->type
= GSYM_FUNCTION
;
7085 /* Resolve an index expression. */
7088 resolve_index_expr (gfc_expr
*e
)
7090 if (gfc_resolve_expr (e
) == FAILURE
)
7093 if (gfc_simplify_expr (e
, 0) == FAILURE
)
7096 if (gfc_specification_expr (e
) == FAILURE
)
7102 /* Resolve a charlen structure. */
7105 resolve_charlen (gfc_charlen
*cl
)
7114 specification_expr
= 1;
7116 if (resolve_index_expr (cl
->length
) == FAILURE
)
7118 specification_expr
= 0;
7122 /* "If the character length parameter value evaluates to a negative
7123 value, the length of character entities declared is zero." */
7124 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
7126 gfc_warning_now ("CHARACTER variable has zero length at %L",
7127 &cl
->length
->where
);
7128 gfc_replace_expr (cl
->length
, gfc_int_expr (0));
7135 /* Test for non-constant shape arrays. */
7138 is_non_constant_shape_array (gfc_symbol
*sym
)
7144 not_constant
= false;
7145 if (sym
->as
!= NULL
)
7147 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
7148 has not been simplified; parameter array references. Do the
7149 simplification now. */
7150 for (i
= 0; i
< sym
->as
->rank
; i
++)
7152 e
= sym
->as
->lower
[i
];
7153 if (e
&& (resolve_index_expr (e
) == FAILURE
7154 || !gfc_is_constant_expr (e
)))
7155 not_constant
= true;
7157 e
= sym
->as
->upper
[i
];
7158 if (e
&& (resolve_index_expr (e
) == FAILURE
7159 || !gfc_is_constant_expr (e
)))
7160 not_constant
= true;
7163 return not_constant
;
7166 /* Given a symbol and an initialization expression, add code to initialize
7167 the symbol to the function entry. */
7169 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
7173 gfc_namespace
*ns
= sym
->ns
;
7175 /* Search for the function namespace if this is a contained
7176 function without an explicit result. */
7177 if (sym
->attr
.function
&& sym
== sym
->result
7178 && sym
->name
!= sym
->ns
->proc_name
->name
)
7181 for (;ns
; ns
= ns
->sibling
)
7182 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
7188 gfc_free_expr (init
);
7192 /* Build an l-value expression for the result. */
7193 lval
= gfc_lval_expr_from_sym (sym
);
7195 /* Add the code at scope entry. */
7196 init_st
= gfc_get_code ();
7197 init_st
->next
= ns
->code
;
7200 /* Assign the default initializer to the l-value. */
7201 init_st
->loc
= sym
->declared_at
;
7202 init_st
->op
= EXEC_INIT_ASSIGN
;
7203 init_st
->expr
= lval
;
7204 init_st
->expr2
= init
;
7207 /* Assign the default initializer to a derived type variable or result. */
7210 apply_default_init (gfc_symbol
*sym
)
7212 gfc_expr
*init
= NULL
;
7214 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
7217 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
7218 init
= gfc_default_initializer (&sym
->ts
);
7223 build_init_assign (sym
, init
);
7226 /* Build an initializer for a local integer, real, complex, logical, or
7227 character variable, based on the command line flags finit-local-zero,
7228 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
7229 null if the symbol should not have a default initialization. */
7231 build_default_init_expr (gfc_symbol
*sym
)
7234 gfc_expr
*init_expr
;
7237 /* These symbols should never have a default initialization. */
7238 if ((sym
->attr
.dimension
&& !gfc_is_compile_time_shape (sym
->as
))
7239 || sym
->attr
.external
7241 || sym
->attr
.pointer
7242 || sym
->attr
.in_equivalence
7243 || sym
->attr
.in_common
7246 || sym
->attr
.cray_pointee
7247 || sym
->attr
.cray_pointer
)
7250 /* Now we'll try to build an initializer expression. */
7251 init_expr
= gfc_get_expr ();
7252 init_expr
->expr_type
= EXPR_CONSTANT
;
7253 init_expr
->ts
.type
= sym
->ts
.type
;
7254 init_expr
->ts
.kind
= sym
->ts
.kind
;
7255 init_expr
->where
= sym
->declared_at
;
7257 /* We will only initialize integers, reals, complex, logicals, and
7258 characters, and only if the corresponding command-line flags
7259 were set. Otherwise, we free init_expr and return null. */
7260 switch (sym
->ts
.type
)
7263 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
7264 mpz_init_set_si (init_expr
->value
.integer
,
7265 gfc_option
.flag_init_integer_value
);
7268 gfc_free_expr (init_expr
);
7274 mpfr_init (init_expr
->value
.real
);
7275 switch (gfc_option
.flag_init_real
)
7277 case GFC_INIT_REAL_NAN
:
7278 mpfr_set_nan (init_expr
->value
.real
);
7281 case GFC_INIT_REAL_INF
:
7282 mpfr_set_inf (init_expr
->value
.real
, 1);
7285 case GFC_INIT_REAL_NEG_INF
:
7286 mpfr_set_inf (init_expr
->value
.real
, -1);
7289 case GFC_INIT_REAL_ZERO
:
7290 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
7294 gfc_free_expr (init_expr
);
7301 mpfr_init (init_expr
->value
.complex.r
);
7302 mpfr_init (init_expr
->value
.complex.i
);
7303 switch (gfc_option
.flag_init_real
)
7305 case GFC_INIT_REAL_NAN
:
7306 mpfr_set_nan (init_expr
->value
.complex.r
);
7307 mpfr_set_nan (init_expr
->value
.complex.i
);
7310 case GFC_INIT_REAL_INF
:
7311 mpfr_set_inf (init_expr
->value
.complex.r
, 1);
7312 mpfr_set_inf (init_expr
->value
.complex.i
, 1);
7315 case GFC_INIT_REAL_NEG_INF
:
7316 mpfr_set_inf (init_expr
->value
.complex.r
, -1);
7317 mpfr_set_inf (init_expr
->value
.complex.i
, -1);
7320 case GFC_INIT_REAL_ZERO
:
7321 mpfr_set_ui (init_expr
->value
.complex.r
, 0.0, GFC_RND_MODE
);
7322 mpfr_set_ui (init_expr
->value
.complex.i
, 0.0, GFC_RND_MODE
);
7326 gfc_free_expr (init_expr
);
7333 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
7334 init_expr
->value
.logical
= 0;
7335 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
7336 init_expr
->value
.logical
= 1;
7339 gfc_free_expr (init_expr
);
7345 /* For characters, the length must be constant in order to
7346 create a default initializer. */
7347 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
7348 && sym
->ts
.cl
->length
7349 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
7351 char_len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
7352 init_expr
->value
.character
.length
= char_len
;
7353 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
7354 for (i
= 0; i
< char_len
; i
++)
7355 init_expr
->value
.character
.string
[i
]
7356 = (unsigned char) gfc_option
.flag_init_character_value
;
7360 gfc_free_expr (init_expr
);
7366 gfc_free_expr (init_expr
);
7372 /* Add an initialization expression to a local variable. */
7374 apply_default_init_local (gfc_symbol
*sym
)
7376 gfc_expr
*init
= NULL
;
7378 /* The symbol should be a variable or a function return value. */
7379 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
7380 || (sym
->attr
.function
&& sym
->result
!= sym
))
7383 /* Try to build the initializer expression. If we can't initialize
7384 this symbol, then init will be NULL. */
7385 init
= build_default_init_expr (sym
);
7389 /* For saved variables, we don't want to add an initializer at
7390 function entry, so we just add a static initializer. */
7391 if (sym
->attr
.save
|| sym
->ns
->save_all
)
7393 /* Don't clobber an existing initializer! */
7394 gcc_assert (sym
->value
== NULL
);
7399 build_init_assign (sym
, init
);
7402 /* Resolution of common features of flavors variable and procedure. */
7405 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
7407 /* Constraints on deferred shape variable. */
7408 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
7410 if (sym
->attr
.allocatable
)
7412 if (sym
->attr
.dimension
)
7413 gfc_error ("Allocatable array '%s' at %L must have "
7414 "a deferred shape", sym
->name
, &sym
->declared_at
);
7416 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
7417 sym
->name
, &sym
->declared_at
);
7421 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
7423 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
7424 sym
->name
, &sym
->declared_at
);
7431 if (!mp_flag
&& !sym
->attr
.allocatable
7432 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
7434 gfc_error ("Array '%s' at %L cannot have a deferred shape",
7435 sym
->name
, &sym
->declared_at
);
7443 /* Additional checks for symbols with flavor variable and derived
7444 type. To be called from resolve_fl_variable. */
7447 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
7449 gcc_assert (sym
->ts
.type
== BT_DERIVED
);
7451 /* Check to see if a derived type is blocked from being host
7452 associated by the presence of another class I symbol in the same
7453 namespace. 14.6.1.3 of the standard and the discussion on
7454 comp.lang.fortran. */
7455 if (sym
->ns
!= sym
->ts
.derived
->ns
7456 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
7459 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
7460 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
7462 gfc_error ("The type '%s' cannot be host associated at %L "
7463 "because it is blocked by an incompatible object "
7464 "of the same name declared at %L",
7465 sym
->ts
.derived
->name
, &sym
->declared_at
,
7471 /* 4th constraint in section 11.3: "If an object of a type for which
7472 component-initialization is specified (R429) appears in the
7473 specification-part of a module and does not have the ALLOCATABLE
7474 or POINTER attribute, the object shall have the SAVE attribute."
7476 The check for initializers is performed with
7477 has_default_initializer because gfc_default_initializer generates
7478 a hidden default for allocatable components. */
7479 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
7480 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7481 && !sym
->ns
->save_all
&& !sym
->attr
.save
7482 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
7483 && has_default_initializer (sym
->ts
.derived
))
7485 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7486 "default initialization of a component",
7487 sym
->name
, &sym
->declared_at
);
7491 /* Assign default initializer. */
7492 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
7493 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
7495 sym
->value
= gfc_default_initializer (&sym
->ts
);
7502 /* Resolve symbols with flavor variable. */
7505 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
7507 int no_init_flag
, automatic_flag
;
7509 const char *auto_save_msg
;
7511 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
7514 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
7517 /* Set this flag to check that variables are parameters of all entries.
7518 This check is effected by the call to gfc_resolve_expr through
7519 is_non_constant_shape_array. */
7520 specification_expr
= 1;
7522 if (sym
->ns
->proc_name
7523 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7524 || sym
->ns
->proc_name
->attr
.is_main_program
)
7525 && !sym
->attr
.use_assoc
7526 && !sym
->attr
.allocatable
7527 && !sym
->attr
.pointer
7528 && is_non_constant_shape_array (sym
))
7530 /* The shape of a main program or module array needs to be
7532 gfc_error ("The module or main program array '%s' at %L must "
7533 "have constant shape", sym
->name
, &sym
->declared_at
);
7534 specification_expr
= 0;
7538 if (sym
->ts
.type
== BT_CHARACTER
)
7540 /* Make sure that character string variables with assumed length are
7542 e
= sym
->ts
.cl
->length
;
7543 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
7545 gfc_error ("Entity with assumed character length at %L must be a "
7546 "dummy argument or a PARAMETER", &sym
->declared_at
);
7550 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
7552 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7556 if (!gfc_is_constant_expr (e
)
7557 && !(e
->expr_type
== EXPR_VARIABLE
7558 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
7559 && sym
->ns
->proc_name
7560 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7561 || sym
->ns
->proc_name
->attr
.is_main_program
)
7562 && !sym
->attr
.use_assoc
)
7564 gfc_error ("'%s' at %L must have constant character length "
7565 "in this context", sym
->name
, &sym
->declared_at
);
7570 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
7571 apply_default_init_local (sym
); /* Try to apply a default initialization. */
7573 /* Determine if the symbol may not have an initializer. */
7574 no_init_flag
= automatic_flag
= 0;
7575 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
7576 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
7578 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
7579 && is_non_constant_shape_array (sym
))
7581 no_init_flag
= automatic_flag
= 1;
7583 /* Also, they must not have the SAVE attribute.
7584 SAVE_IMPLICIT is checked below. */
7585 if (sym
->attr
.save
== SAVE_EXPLICIT
)
7587 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7592 /* Ensure that any initializer is simplified. */
7594 gfc_simplify_expr (sym
->value
, 1);
7596 /* Reject illegal initializers. */
7597 if (!sym
->mark
&& sym
->value
)
7599 if (sym
->attr
.allocatable
)
7600 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7601 sym
->name
, &sym
->declared_at
);
7602 else if (sym
->attr
.external
)
7603 gfc_error ("External '%s' at %L cannot have an initializer",
7604 sym
->name
, &sym
->declared_at
);
7605 else if (sym
->attr
.dummy
7606 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
7607 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7608 sym
->name
, &sym
->declared_at
);
7609 else if (sym
->attr
.intrinsic
)
7610 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7611 sym
->name
, &sym
->declared_at
);
7612 else if (sym
->attr
.result
)
7613 gfc_error ("Function result '%s' at %L cannot have an initializer",
7614 sym
->name
, &sym
->declared_at
);
7615 else if (automatic_flag
)
7616 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7617 sym
->name
, &sym
->declared_at
);
7624 if (sym
->ts
.type
== BT_DERIVED
)
7625 return resolve_fl_variable_derived (sym
, no_init_flag
);
7631 /* Resolve a procedure. */
7634 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
7636 gfc_formal_arglist
*arg
;
7638 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
7639 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7640 "interfaces", sym
->name
, &sym
->declared_at
);
7642 if (sym
->attr
.function
7643 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
7646 if (sym
->ts
.type
== BT_CHARACTER
)
7648 gfc_charlen
*cl
= sym
->ts
.cl
;
7650 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
7651 && resolve_charlen (cl
) == FAILURE
)
7654 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
7656 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7658 gfc_error ("Character-valued statement function '%s' at %L must "
7659 "have constant length", sym
->name
, &sym
->declared_at
);
7663 if (sym
->attr
.external
&& sym
->formal
== NULL
7664 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
7666 gfc_error ("Automatic character length function '%s' at %L must "
7667 "have an explicit interface", sym
->name
,
7674 /* Ensure that derived type for are not of a private type. Internal
7675 module procedures are excluded by 2.2.3.3 - i.e., they are not
7676 externally accessible and can access all the objects accessible in
7678 if (!(sym
->ns
->parent
7679 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
7680 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
7682 gfc_interface
*iface
;
7684 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
7687 && arg
->sym
->ts
.type
== BT_DERIVED
7688 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7689 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7690 arg
->sym
->ts
.derived
->ns
->default_access
)
7691 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
7692 "PRIVATE type and cannot be a dummy argument"
7693 " of '%s', which is PUBLIC at %L",
7694 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
7697 /* Stop this message from recurring. */
7698 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7703 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7704 PRIVATE to the containing module. */
7705 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7707 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7710 && arg
->sym
->ts
.type
== BT_DERIVED
7711 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7712 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7713 arg
->sym
->ts
.derived
->ns
->default_access
)
7714 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7715 "'%s' in PUBLIC interface '%s' at %L "
7716 "takes dummy arguments of '%s' which is "
7717 "PRIVATE", iface
->sym
->name
, sym
->name
,
7718 &iface
->sym
->declared_at
,
7719 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7721 /* Stop this message from recurring. */
7722 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7728 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7729 PRIVATE to the containing module. */
7730 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7732 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7735 && arg
->sym
->ts
.type
== BT_DERIVED
7736 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7737 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7738 arg
->sym
->ts
.derived
->ns
->default_access
)
7739 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7740 "'%s' in PUBLIC interface '%s' at %L "
7741 "takes dummy arguments of '%s' which is "
7742 "PRIVATE", iface
->sym
->name
, sym
->name
,
7743 &iface
->sym
->declared_at
,
7744 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7746 /* Stop this message from recurring. */
7747 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7754 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
7755 && !sym
->attr
.proc_pointer
)
7757 gfc_error ("Function '%s' at %L cannot have an initializer",
7758 sym
->name
, &sym
->declared_at
);
7762 /* An external symbol may not have an initializer because it is taken to be
7763 a procedure. Exception: Procedure Pointers. */
7764 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
7766 gfc_error ("External object '%s' at %L may not have an initializer",
7767 sym
->name
, &sym
->declared_at
);
7771 /* An elemental function is required to return a scalar 12.7.1 */
7772 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
7774 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7775 "result", sym
->name
, &sym
->declared_at
);
7776 /* Reset so that the error only occurs once. */
7777 sym
->attr
.elemental
= 0;
7781 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7782 char-len-param shall not be array-valued, pointer-valued, recursive
7783 or pure. ....snip... A character value of * may only be used in the
7784 following ways: (i) Dummy arg of procedure - dummy associates with
7785 actual length; (ii) To declare a named constant; or (iii) External
7786 function - but length must be declared in calling scoping unit. */
7787 if (sym
->attr
.function
7788 && sym
->ts
.type
== BT_CHARACTER
7789 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
7791 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
7792 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
7794 if (sym
->as
&& sym
->as
->rank
)
7795 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7796 "array-valued", sym
->name
, &sym
->declared_at
);
7798 if (sym
->attr
.pointer
)
7799 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7800 "pointer-valued", sym
->name
, &sym
->declared_at
);
7803 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7804 "pure", sym
->name
, &sym
->declared_at
);
7806 if (sym
->attr
.recursive
)
7807 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7808 "recursive", sym
->name
, &sym
->declared_at
);
7813 /* Appendix B.2 of the standard. Contained functions give an
7814 error anyway. Fixed-form is likely to be F77/legacy. */
7815 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
7816 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
7817 "'%s' at %L is obsolescent in fortran 95",
7818 sym
->name
, &sym
->declared_at
);
7821 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
7823 gfc_formal_arglist
*curr_arg
;
7824 int has_non_interop_arg
= 0;
7826 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
7827 sym
->common_block
) == FAILURE
)
7829 /* Clear these to prevent looking at them again if there was an
7831 sym
->attr
.is_bind_c
= 0;
7832 sym
->attr
.is_c_interop
= 0;
7833 sym
->ts
.is_c_interop
= 0;
7837 /* So far, no errors have been found. */
7838 sym
->attr
.is_c_interop
= 1;
7839 sym
->ts
.is_c_interop
= 1;
7842 curr_arg
= sym
->formal
;
7843 while (curr_arg
!= NULL
)
7845 /* Skip implicitly typed dummy args here. */
7846 if (curr_arg
->sym
->attr
.implicit_type
== 0)
7847 if (verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
7848 /* If something is found to fail, record the fact so we
7849 can mark the symbol for the procedure as not being
7850 BIND(C) to try and prevent multiple errors being
7852 has_non_interop_arg
= 1;
7854 curr_arg
= curr_arg
->next
;
7857 /* See if any of the arguments were not interoperable and if so, clear
7858 the procedure symbol to prevent duplicate error messages. */
7859 if (has_non_interop_arg
!= 0)
7861 sym
->attr
.is_c_interop
= 0;
7862 sym
->ts
.is_c_interop
= 0;
7863 sym
->attr
.is_bind_c
= 0;
7867 if (sym
->attr
.save
== SAVE_EXPLICIT
&& !sym
->attr
.proc_pointer
)
7869 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
7870 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
7874 if (sym
->attr
.intent
&& !sym
->attr
.proc_pointer
)
7876 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
7877 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
7885 /* Resolve a list of finalizer procedures. That is, after they have hopefully
7886 been defined and we now know their defined arguments, check that they fulfill
7887 the requirements of the standard for procedures used as finalizers. */
7890 gfc_resolve_finalizers (gfc_symbol
* derived
)
7892 gfc_finalizer
* list
;
7893 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
7894 gfc_try result
= SUCCESS
;
7895 bool seen_scalar
= false;
7897 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
7900 /* Walk over the list of finalizer-procedures, check them, and if any one
7901 does not fit in with the standard's definition, print an error and remove
7902 it from the list. */
7903 prev_link
= &derived
->f2k_derived
->finalizers
;
7904 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
7910 /* Skip this finalizer if we already resolved it. */
7911 if (list
->proc_tree
)
7913 prev_link
= &(list
->next
);
7917 /* Check this exists and is a SUBROUTINE. */
7918 if (!list
->proc_sym
->attr
.subroutine
)
7920 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
7921 list
->proc_sym
->name
, &list
->where
);
7925 /* We should have exactly one argument. */
7926 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
7928 gfc_error ("FINAL procedure at %L must have exactly one argument",
7932 arg
= list
->proc_sym
->formal
->sym
;
7934 /* This argument must be of our type. */
7935 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.derived
!= derived
)
7937 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
7938 &arg
->declared_at
, derived
->name
);
7942 /* It must neither be a pointer nor allocatable nor optional. */
7943 if (arg
->attr
.pointer
)
7945 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
7949 if (arg
->attr
.allocatable
)
7951 gfc_error ("Argument of FINAL procedure at %L must not be"
7952 " ALLOCATABLE", &arg
->declared_at
);
7955 if (arg
->attr
.optional
)
7957 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
7962 /* It must not be INTENT(OUT). */
7963 if (arg
->attr
.intent
== INTENT_OUT
)
7965 gfc_error ("Argument of FINAL procedure at %L must not be"
7966 " INTENT(OUT)", &arg
->declared_at
);
7970 /* Warn if the procedure is non-scalar and not assumed shape. */
7971 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
> 0
7972 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
7973 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
7974 " shape argument", &arg
->declared_at
);
7976 /* Check that it does not match in kind and rank with a FINAL procedure
7977 defined earlier. To really loop over the *earlier* declarations,
7978 we need to walk the tail of the list as new ones were pushed at the
7980 /* TODO: Handle kind parameters once they are implemented. */
7981 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
7982 for (i
= list
->next
; i
; i
= i
->next
)
7984 /* Argument list might be empty; that is an error signalled earlier,
7985 but we nevertheless continued resolving. */
7986 if (i
->proc_sym
->formal
)
7988 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
7989 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
7990 if (i_rank
== my_rank
)
7992 gfc_error ("FINAL procedure '%s' declared at %L has the same"
7993 " rank (%d) as '%s'",
7994 list
->proc_sym
->name
, &list
->where
, my_rank
,
8001 /* Is this the/a scalar finalizer procedure? */
8002 if (!arg
->as
|| arg
->as
->rank
== 0)
8005 /* Find the symtree for this procedure. */
8006 gcc_assert (!list
->proc_tree
);
8007 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
8009 prev_link
= &list
->next
;
8012 /* Remove wrong nodes immediately from the list so we don't risk any
8013 troubles in the future when they might fail later expectations. */
8017 *prev_link
= list
->next
;
8018 gfc_free_finalizer (i
);
8021 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
8022 were nodes in the list, must have been for arrays. It is surely a good
8023 idea to have a scalar version there if there's something to finalize. */
8024 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
8025 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
8026 " defined at %L, suggest also scalar one",
8027 derived
->name
, &derived
->declared_at
);
8029 /* TODO: Remove this error when finalization is finished. */
8030 gfc_error ("Finalization at %L is not yet implemented",
8031 &derived
->declared_at
);
8037 /* Check that it is ok for the typebound procedure proc to override the
8041 check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
8044 const gfc_symbol
* proc_target
;
8045 const gfc_symbol
* old_target
;
8046 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
8047 gfc_formal_arglist
* proc_formal
;
8048 gfc_formal_arglist
* old_formal
;
8050 /* This procedure should only be called for non-GENERIC proc. */
8051 gcc_assert (!proc
->typebound
->is_generic
);
8053 /* If the overwritten procedure is GENERIC, this is an error. */
8054 if (old
->typebound
->is_generic
)
8056 gfc_error ("Can't overwrite GENERIC '%s' at %L",
8057 old
->name
, &proc
->typebound
->where
);
8061 where
= proc
->typebound
->where
;
8062 proc_target
= proc
->typebound
->u
.specific
->n
.sym
;
8063 old_target
= old
->typebound
->u
.specific
->n
.sym
;
8065 /* Check that overridden binding is not NON_OVERRIDABLE. */
8066 if (old
->typebound
->non_overridable
)
8068 gfc_error ("'%s' at %L overrides a procedure binding declared"
8069 " NON_OVERRIDABLE", proc
->name
, &where
);
8073 /* If the overridden binding is PURE, the overriding must be, too. */
8074 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
8076 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
8077 proc
->name
, &where
);
8081 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
8082 is not, the overriding must not be either. */
8083 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
8085 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
8086 " ELEMENTAL", proc
->name
, &where
);
8089 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
8091 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
8092 " be ELEMENTAL, either", proc
->name
, &where
);
8096 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
8098 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
8100 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
8101 " SUBROUTINE", proc
->name
, &where
);
8105 /* If the overridden binding is a FUNCTION, the overriding must also be a
8106 FUNCTION and have the same characteristics. */
8107 if (old_target
->attr
.function
)
8109 if (!proc_target
->attr
.function
)
8111 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
8112 " FUNCTION", proc
->name
, &where
);
8116 /* FIXME: Do more comprehensive checking (including, for instance, the
8117 rank and array-shape). */
8118 gcc_assert (proc_target
->result
&& old_target
->result
);
8119 if (!gfc_compare_types (&proc_target
->result
->ts
,
8120 &old_target
->result
->ts
))
8122 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
8123 " matching result types", proc
->name
, &where
);
8128 /* If the overridden binding is PUBLIC, the overriding one must not be
8130 if (old
->typebound
->access
== ACCESS_PUBLIC
8131 && proc
->typebound
->access
== ACCESS_PRIVATE
)
8133 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
8134 " PRIVATE", proc
->name
, &where
);
8138 /* Compare the formal argument lists of both procedures. This is also abused
8139 to find the position of the passed-object dummy arguments of both
8140 bindings as at least the overridden one might not yet be resolved and we
8141 need those positions in the check below. */
8142 proc_pass_arg
= old_pass_arg
= 0;
8143 if (!proc
->typebound
->nopass
&& !proc
->typebound
->pass_arg
)
8145 if (!old
->typebound
->nopass
&& !old
->typebound
->pass_arg
)
8148 for (proc_formal
= proc_target
->formal
, old_formal
= old_target
->formal
;
8149 proc_formal
&& old_formal
;
8150 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
8152 if (proc
->typebound
->pass_arg
8153 && !strcmp (proc
->typebound
->pass_arg
, proc_formal
->sym
->name
))
8154 proc_pass_arg
= argpos
;
8155 if (old
->typebound
->pass_arg
8156 && !strcmp (old
->typebound
->pass_arg
, old_formal
->sym
->name
))
8157 old_pass_arg
= argpos
;
8159 /* Check that the names correspond. */
8160 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
8162 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
8163 " to match the corresponding argument of the overridden"
8164 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
8165 old_formal
->sym
->name
);
8169 /* Check that the types correspond if neither is the passed-object
8171 /* FIXME: Do more comprehensive testing here. */
8172 if (proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
8173 && !gfc_compare_types (&proc_formal
->sym
->ts
, &old_formal
->sym
->ts
))
8175 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
8176 " in respect to the overridden procedure",
8177 proc_formal
->sym
->name
, proc
->name
, &where
);
8183 if (proc_formal
|| old_formal
)
8185 gfc_error ("'%s' at %L must have the same number of formal arguments as"
8186 " the overridden procedure", proc
->name
, &where
);
8190 /* If the overridden binding is NOPASS, the overriding one must also be
8192 if (old
->typebound
->nopass
&& !proc
->typebound
->nopass
)
8194 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
8195 " NOPASS", proc
->name
, &where
);
8199 /* If the overridden binding is PASS(x), the overriding one must also be
8200 PASS and the passed-object dummy arguments must correspond. */
8201 if (!old
->typebound
->nopass
)
8203 if (proc
->typebound
->nopass
)
8205 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
8206 " PASS", proc
->name
, &where
);
8210 if (proc_pass_arg
!= old_pass_arg
)
8212 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
8213 " the same position as the passed-object dummy argument of"
8214 " the overridden procedure", proc
->name
, &where
);
8223 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
8226 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
8227 const char* generic_name
, locus where
)
8232 gcc_assert (t1
->specific
&& t2
->specific
);
8233 gcc_assert (!t1
->specific
->is_generic
);
8234 gcc_assert (!t2
->specific
->is_generic
);
8236 sym1
= t1
->specific
->u
.specific
->n
.sym
;
8237 sym2
= t2
->specific
->u
.specific
->n
.sym
;
8239 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
8240 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
8241 || sym1
->attr
.function
!= sym2
->attr
.function
)
8243 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
8244 " GENERIC '%s' at %L",
8245 sym1
->name
, sym2
->name
, generic_name
, &where
);
8249 /* Compare the interfaces. */
8250 if (gfc_compare_interfaces (sym1
, sym2
, 1))
8252 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
8253 sym1
->name
, sym2
->name
, generic_name
, &where
);
8261 /* Resolve a GENERIC procedure binding for a derived type. */
8264 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
8266 gfc_tbp_generic
* target
;
8267 gfc_symtree
* first_target
;
8268 gfc_symbol
* super_type
;
8269 gfc_symtree
* inherited
;
8272 gcc_assert (st
->typebound
);
8273 gcc_assert (st
->typebound
->is_generic
);
8275 where
= st
->typebound
->where
;
8276 super_type
= gfc_get_derived_super_type (derived
);
8278 /* Find the overridden binding if any. */
8279 st
->typebound
->overridden
= NULL
;
8282 gfc_symtree
* overridden
;
8283 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
, true);
8285 if (overridden
&& overridden
->typebound
)
8286 st
->typebound
->overridden
= overridden
->typebound
;
8289 /* Try to find the specific bindings for the symtrees in our target-list. */
8290 gcc_assert (st
->typebound
->u
.generic
);
8291 for (target
= st
->typebound
->u
.generic
; target
; target
= target
->next
)
8292 if (!target
->specific
)
8294 gfc_typebound_proc
* overridden_tbp
;
8296 const char* target_name
;
8298 target_name
= target
->specific_st
->name
;
8300 /* Defined for this type directly. */
8301 if (target
->specific_st
->typebound
)
8303 target
->specific
= target
->specific_st
->typebound
;
8304 goto specific_found
;
8307 /* Look for an inherited specific binding. */
8310 inherited
= gfc_find_typebound_proc (super_type
, NULL
,
8315 gcc_assert (inherited
->typebound
);
8316 target
->specific
= inherited
->typebound
;
8317 goto specific_found
;
8321 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
8322 " at %L", target_name
, st
->name
, &where
);
8325 /* Once we've found the specific binding, check it is not ambiguous with
8326 other specifics already found or inherited for the same GENERIC. */
8328 gcc_assert (target
->specific
);
8330 /* This must really be a specific binding! */
8331 if (target
->specific
->is_generic
)
8333 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
8334 " '%s' is GENERIC, too", st
->name
, &where
, target_name
);
8338 /* Check those already resolved on this type directly. */
8339 for (g
= st
->typebound
->u
.generic
; g
; g
= g
->next
)
8340 if (g
!= target
&& g
->specific
8341 && check_generic_tbp_ambiguity (target
, g
, st
->name
, where
)
8345 /* Check for ambiguity with inherited specific targets. */
8346 for (overridden_tbp
= st
->typebound
->overridden
; overridden_tbp
;
8347 overridden_tbp
= overridden_tbp
->overridden
)
8348 if (overridden_tbp
->is_generic
)
8350 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
8352 gcc_assert (g
->specific
);
8353 if (check_generic_tbp_ambiguity (target
, g
,
8354 st
->name
, where
) == FAILURE
)
8360 /* If we attempt to "overwrite" a specific binding, this is an error. */
8361 if (st
->typebound
->overridden
&& !st
->typebound
->overridden
->is_generic
)
8363 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
8364 " the same name", st
->name
, &where
);
8368 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
8369 all must have the same attributes here. */
8370 first_target
= st
->typebound
->u
.generic
->specific
->u
.specific
;
8371 st
->typebound
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
8372 st
->typebound
->function
= first_target
->n
.sym
->attr
.function
;
8378 /* Resolve the type-bound procedures for a derived type. */
8380 static gfc_symbol
* resolve_bindings_derived
;
8381 static gfc_try resolve_bindings_result
;
8384 resolve_typebound_procedure (gfc_symtree
* stree
)
8389 gfc_symbol
* super_type
;
8390 gfc_component
* comp
;
8392 /* If this is no type-bound procedure, just return. */
8393 if (!stree
->typebound
)
8396 /* If this is a GENERIC binding, use that routine. */
8397 if (stree
->typebound
->is_generic
)
8399 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
8405 /* Get the target-procedure to check it. */
8406 gcc_assert (!stree
->typebound
->is_generic
);
8407 gcc_assert (stree
->typebound
->u
.specific
);
8408 proc
= stree
->typebound
->u
.specific
->n
.sym
;
8409 where
= stree
->typebound
->where
;
8411 /* Default access should already be resolved from the parser. */
8412 gcc_assert (stree
->typebound
->access
!= ACCESS_UNKNOWN
);
8414 /* It should be a module procedure or an external procedure with explicit
8416 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
8417 || (proc
->attr
.proc
!= PROC_MODULE
8418 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
8419 || proc
->attr
.abstract
)
8421 gfc_error ("'%s' must be a module procedure or an external procedure with"
8422 " an explicit interface at %L", proc
->name
, &where
);
8425 stree
->typebound
->subroutine
= proc
->attr
.subroutine
;
8426 stree
->typebound
->function
= proc
->attr
.function
;
8428 /* Find the super-type of the current derived type. We could do this once and
8429 store in a global if speed is needed, but as long as not I believe this is
8430 more readable and clearer. */
8431 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
8433 /* If PASS, resolve and check arguments if not already resolved / loaded
8434 from a .mod file. */
8435 if (!stree
->typebound
->nopass
&& stree
->typebound
->pass_arg_num
== 0)
8437 if (stree
->typebound
->pass_arg
)
8439 gfc_formal_arglist
* i
;
8441 /* If an explicit passing argument name is given, walk the arg-list
8445 stree
->typebound
->pass_arg_num
= 1;
8446 for (i
= proc
->formal
; i
; i
= i
->next
)
8448 if (!strcmp (i
->sym
->name
, stree
->typebound
->pass_arg
))
8453 ++stree
->typebound
->pass_arg_num
;
8458 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
8460 proc
->name
, stree
->typebound
->pass_arg
, &where
,
8461 stree
->typebound
->pass_arg
);
8467 /* Otherwise, take the first one; there should in fact be at least
8469 stree
->typebound
->pass_arg_num
= 1;
8472 gfc_error ("Procedure '%s' with PASS at %L must have at"
8473 " least one argument", proc
->name
, &where
);
8476 me_arg
= proc
->formal
->sym
;
8479 /* Now check that the argument-type matches. */
8480 gcc_assert (me_arg
);
8481 if (me_arg
->ts
.type
!= BT_DERIVED
8482 || me_arg
->ts
.derived
!= resolve_bindings_derived
)
8484 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
8485 " the derived-type '%s'", me_arg
->name
, proc
->name
,
8486 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
8490 gfc_warning ("Polymorphic entities are not yet implemented,"
8491 " non-polymorphic passed-object dummy argument of '%s'"
8492 " at %L accepted", proc
->name
, &where
);
8495 /* If we are extending some type, check that we don't override a procedure
8496 flagged NON_OVERRIDABLE. */
8497 stree
->typebound
->overridden
= NULL
;
8500 gfc_symtree
* overridden
;
8501 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
8504 if (overridden
&& overridden
->typebound
)
8505 stree
->typebound
->overridden
= overridden
->typebound
;
8507 if (overridden
&& check_typebound_override (stree
, overridden
) == FAILURE
)
8511 /* See if there's a name collision with a component directly in this type. */
8512 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
8513 if (!strcmp (comp
->name
, stree
->name
))
8515 gfc_error ("Procedure '%s' at %L has the same name as a component of"
8517 stree
->name
, &where
, resolve_bindings_derived
->name
);
8521 /* Try to find a name collision with an inherited component. */
8522 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
8524 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
8525 " component of '%s'",
8526 stree
->name
, &where
, resolve_bindings_derived
->name
);
8530 stree
->typebound
->error
= 0;
8534 resolve_bindings_result
= FAILURE
;
8535 stree
->typebound
->error
= 1;
8539 resolve_typebound_procedures (gfc_symbol
* derived
)
8541 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->sym_root
)
8544 resolve_bindings_derived
= derived
;
8545 resolve_bindings_result
= SUCCESS
;
8546 gfc_traverse_symtree (derived
->f2k_derived
->sym_root
,
8547 &resolve_typebound_procedure
);
8549 return resolve_bindings_result
;
8553 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
8554 to give all identical derived types the same backend_decl. */
8556 add_dt_to_dt_list (gfc_symbol
*derived
)
8558 gfc_dt_list
*dt_list
;
8560 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
8561 if (derived
== dt_list
->derived
)
8564 if (dt_list
== NULL
)
8566 dt_list
= gfc_get_dt_list ();
8567 dt_list
->next
= gfc_derived_types
;
8568 dt_list
->derived
= derived
;
8569 gfc_derived_types
= dt_list
;
8574 /* Resolve the components of a derived type. */
8577 resolve_fl_derived (gfc_symbol
*sym
)
8579 gfc_symbol
* super_type
;
8583 super_type
= gfc_get_derived_super_type (sym
);
8585 /* Ensure the extended type gets resolved before we do. */
8586 if (super_type
&& resolve_fl_derived (super_type
) == FAILURE
)
8589 /* An ABSTRACT type must be extensible. */
8590 if (sym
->attr
.abstract
&& (sym
->attr
.is_bind_c
|| sym
->attr
.sequence
))
8592 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
8593 sym
->name
, &sym
->declared_at
);
8597 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
8599 /* Check type-spec if this is not the parent-type component. */
8600 if ((!sym
->attr
.extension
|| c
!= sym
->components
)
8601 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
8604 /* If this type is an extension, see if this component has the same name
8605 as an inherited type-bound procedure. */
8607 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true))
8609 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
8610 " inherited type-bound procedure",
8611 c
->name
, sym
->name
, &c
->loc
);
8615 if (c
->ts
.type
== BT_CHARACTER
)
8617 if (c
->ts
.cl
->length
== NULL
8618 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
8619 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
8621 gfc_error ("Character length of component '%s' needs to "
8622 "be a constant specification expression at %L",
8624 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
8629 if (c
->ts
.type
== BT_DERIVED
8630 && sym
->component_access
!= ACCESS_PRIVATE
8631 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
8632 && !c
->ts
.derived
->attr
.use_assoc
8633 && !gfc_check_access (c
->ts
.derived
->attr
.access
,
8634 c
->ts
.derived
->ns
->default_access
))
8636 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
8637 "a component of '%s', which is PUBLIC at %L",
8638 c
->name
, sym
->name
, &sym
->declared_at
);
8642 if (sym
->attr
.sequence
)
8644 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
8646 gfc_error ("Component %s of SEQUENCE type declared at %L does "
8647 "not have the SEQUENCE attribute",
8648 c
->ts
.derived
->name
, &sym
->declared_at
);
8653 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
8654 && c
->ts
.derived
->components
== NULL
8655 && !c
->ts
.derived
->attr
.zero_comp
)
8657 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
8658 "that has not been declared", c
->name
, sym
->name
,
8663 /* Ensure that all the derived type components are put on the
8664 derived type list; even in formal namespaces, where derived type
8665 pointer components might not have been declared. */
8666 if (c
->ts
.type
== BT_DERIVED
8668 && c
->ts
.derived
->components
8670 && sym
!= c
->ts
.derived
)
8671 add_dt_to_dt_list (c
->ts
.derived
);
8673 if (c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->as
== NULL
)
8676 for (i
= 0; i
< c
->as
->rank
; i
++)
8678 if (c
->as
->lower
[i
] == NULL
8679 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
8680 || !gfc_is_constant_expr (c
->as
->lower
[i
])
8681 || c
->as
->upper
[i
] == NULL
8682 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
8683 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
8685 gfc_error ("Component '%s' of '%s' at %L must have "
8686 "constant array bounds",
8687 c
->name
, sym
->name
, &c
->loc
);
8693 /* Resolve the type-bound procedures. */
8694 if (resolve_typebound_procedures (sym
) == FAILURE
)
8697 /* Resolve the finalizer procedures. */
8698 if (gfc_resolve_finalizers (sym
) == FAILURE
)
8701 /* Add derived type to the derived type list. */
8702 add_dt_to_dt_list (sym
);
8709 resolve_fl_namelist (gfc_symbol
*sym
)
8714 /* Reject PRIVATE objects in a PUBLIC namelist. */
8715 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
8717 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
8719 if (!nl
->sym
->attr
.use_assoc
8720 && !(sym
->ns
->parent
== nl
->sym
->ns
)
8721 && !(sym
->ns
->parent
8722 && sym
->ns
->parent
->parent
== nl
->sym
->ns
)
8723 && !gfc_check_access(nl
->sym
->attr
.access
,
8724 nl
->sym
->ns
->default_access
))
8726 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
8727 "cannot be member of PUBLIC namelist '%s' at %L",
8728 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8732 /* Types with private components that came here by USE-association. */
8733 if (nl
->sym
->ts
.type
== BT_DERIVED
8734 && derived_inaccessible (nl
->sym
->ts
.derived
))
8736 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
8737 "components and cannot be member of namelist '%s' at %L",
8738 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8742 /* Types with private components that are defined in the same module. */
8743 if (nl
->sym
->ts
.type
== BT_DERIVED
8744 && !(sym
->ns
->parent
== nl
->sym
->ts
.derived
->ns
)
8745 && !gfc_check_access (nl
->sym
->ts
.derived
->attr
.private_comp
8746 ? ACCESS_PRIVATE
: ACCESS_UNKNOWN
,
8747 nl
->sym
->ns
->default_access
))
8749 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
8750 "cannot be a member of PUBLIC namelist '%s' at %L",
8751 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8757 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
8759 /* Reject namelist arrays of assumed shape. */
8760 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
8761 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
8762 "must not have assumed shape in namelist "
8763 "'%s' at %L", nl
->sym
->name
, sym
->name
,
8764 &sym
->declared_at
) == FAILURE
)
8767 /* Reject namelist arrays that are not constant shape. */
8768 if (is_non_constant_shape_array (nl
->sym
))
8770 gfc_error ("NAMELIST array object '%s' must have constant "
8771 "shape in namelist '%s' at %L", nl
->sym
->name
,
8772 sym
->name
, &sym
->declared_at
);
8776 /* Namelist objects cannot have allocatable or pointer components. */
8777 if (nl
->sym
->ts
.type
!= BT_DERIVED
)
8780 if (nl
->sym
->ts
.derived
->attr
.alloc_comp
)
8782 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8783 "have ALLOCATABLE components",
8784 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8788 if (nl
->sym
->ts
.derived
->attr
.pointer_comp
)
8790 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8791 "have POINTER components",
8792 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8798 /* 14.1.2 A module or internal procedure represent local entities
8799 of the same type as a namelist member and so are not allowed. */
8800 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
8802 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
8805 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
8806 if ((nl
->sym
== sym
->ns
->proc_name
)
8808 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
8812 if (nl
->sym
&& nl
->sym
->name
)
8813 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
8814 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
8816 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
8817 "attribute in '%s' at %L", nlsym
->name
,
8828 resolve_fl_parameter (gfc_symbol
*sym
)
8830 /* A parameter array's shape needs to be constant. */
8832 && (sym
->as
->type
== AS_DEFERRED
8833 || is_non_constant_shape_array (sym
)))
8835 gfc_error ("Parameter array '%s' at %L cannot be automatic "
8836 "or of deferred shape", sym
->name
, &sym
->declared_at
);
8840 /* Make sure a parameter that has been implicitly typed still
8841 matches the implicit type, since PARAMETER statements can precede
8842 IMPLICIT statements. */
8843 if (sym
->attr
.implicit_type
8844 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
8846 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
8847 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
8851 /* Make sure the types of derived parameters are consistent. This
8852 type checking is deferred until resolution because the type may
8853 refer to a derived type from the host. */
8854 if (sym
->ts
.type
== BT_DERIVED
8855 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
8857 gfc_error ("Incompatible derived type in PARAMETER at %L",
8858 &sym
->value
->where
);
8865 /* Do anything necessary to resolve a symbol. Right now, we just
8866 assume that an otherwise unknown symbol is a variable. This sort
8867 of thing commonly happens for symbols in module. */
8870 resolve_symbol (gfc_symbol
*sym
)
8872 int check_constant
, mp_flag
;
8873 gfc_symtree
*symtree
;
8874 gfc_symtree
*this_symtree
;
8878 if (sym
->attr
.flavor
== FL_UNKNOWN
)
8881 /* If we find that a flavorless symbol is an interface in one of the
8882 parent namespaces, find its symtree in this namespace, free the
8883 symbol and set the symtree to point to the interface symbol. */
8884 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
8886 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
8887 if (symtree
&& symtree
->n
.sym
->generic
)
8889 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8893 gfc_free_symbol (sym
);
8894 symtree
->n
.sym
->refs
++;
8895 this_symtree
->n
.sym
= symtree
->n
.sym
;
8900 /* Otherwise give it a flavor according to such attributes as
8902 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
8903 sym
->attr
.flavor
= FL_VARIABLE
;
8906 sym
->attr
.flavor
= FL_PROCEDURE
;
8907 if (sym
->attr
.dimension
)
8908 sym
->attr
.function
= 1;
8912 if (sym
->attr
.procedure
&& sym
->ts
.interface
8913 && sym
->attr
.if_source
!= IFSRC_DECL
)
8915 if (sym
->ts
.interface
->attr
.procedure
)
8916 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
8917 "in a later PROCEDURE statement", sym
->ts
.interface
->name
,
8918 sym
->name
,&sym
->declared_at
);
8920 /* Get the attributes from the interface (now resolved). */
8921 if (sym
->ts
.interface
->attr
.if_source
|| sym
->ts
.interface
->attr
.intrinsic
)
8923 gfc_symbol
*ifc
= sym
->ts
.interface
;
8925 sym
->ts
.interface
= ifc
;
8926 sym
->attr
.function
= ifc
->attr
.function
;
8927 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
8928 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
8929 sym
->attr
.pointer
= ifc
->attr
.pointer
;
8930 sym
->attr
.pure
= ifc
->attr
.pure
;
8931 sym
->attr
.elemental
= ifc
->attr
.elemental
;
8932 sym
->attr
.dimension
= ifc
->attr
.dimension
;
8933 sym
->attr
.recursive
= ifc
->attr
.recursive
;
8934 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
8935 copy_formal_args (sym
, ifc
);
8936 /* Copy array spec. */
8937 sym
->as
= gfc_copy_array_spec (ifc
->as
);
8941 for (i
= 0; i
< sym
->as
->rank
; i
++)
8943 gfc_expr_replace_symbols (sym
->as
->lower
[i
], sym
);
8944 gfc_expr_replace_symbols (sym
->as
->upper
[i
], sym
);
8947 /* Copy char length. */
8950 sym
->ts
.cl
= gfc_get_charlen();
8951 sym
->ts
.cl
->resolved
= ifc
->ts
.cl
->resolved
;
8952 sym
->ts
.cl
->length
= gfc_copy_expr (ifc
->ts
.cl
->length
);
8953 gfc_expr_replace_symbols (sym
->ts
.cl
->length
, sym
);
8954 /* Add charlen to namespace. */
8957 sym
->ts
.cl
->next
= sym
->formal_ns
->cl_list
;
8958 sym
->formal_ns
->cl_list
= sym
->ts
.cl
;
8962 else if (sym
->ts
.interface
->name
[0] != '\0')
8964 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
8965 sym
->ts
.interface
->name
, sym
->name
, &sym
->declared_at
);
8970 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
8973 /* Symbols that are module procedures with results (functions) have
8974 the types and array specification copied for type checking in
8975 procedures that call them, as well as for saving to a module
8976 file. These symbols can't stand the scrutiny that their results
8978 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
8981 /* Make sure that the intrinsic is consistent with its internal
8982 representation. This needs to be done before assigning a default
8983 type to avoid spurious warnings. */
8984 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
)
8986 gfc_intrinsic_sym
* isym
;
8989 /* We already know this one is an intrinsic, so we don't call
8990 gfc_is_intrinsic for full checking but rather use gfc_find_function and
8991 gfc_find_subroutine directly to check whether it is a function or
8994 if ((isym
= gfc_find_function (sym
->name
)))
8996 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
)
8997 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
8998 " ignored", sym
->name
, &sym
->declared_at
);
9000 else if ((isym
= gfc_find_subroutine (sym
->name
)))
9002 if (sym
->ts
.type
!= BT_UNKNOWN
)
9004 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
9005 " specifier", sym
->name
, &sym
->declared_at
);
9011 gfc_error ("'%s' declared INTRINSIC at %L does not exist",
9012 sym
->name
, &sym
->declared_at
);
9016 /* Check it is actually available in the standard settings. */
9017 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
9020 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
9021 " available in the current standard settings but %s. Use"
9022 " an appropriate -std=* option or enable -fall-intrinsics"
9023 " in order to use it.",
9024 sym
->name
, &sym
->declared_at
, symstd
);
9029 /* Assign default type to symbols that need one and don't have one. */
9030 if (sym
->ts
.type
== BT_UNKNOWN
)
9032 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
9033 gfc_set_default_type (sym
, 1, NULL
);
9035 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
9037 /* The specific case of an external procedure should emit an error
9038 in the case that there is no implicit type. */
9040 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
9043 /* Result may be in another namespace. */
9044 resolve_symbol (sym
->result
);
9046 sym
->ts
= sym
->result
->ts
;
9047 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
9048 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
9049 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
9050 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
9055 /* Assumed size arrays and assumed shape arrays must be dummy
9059 && (sym
->as
->type
== AS_ASSUMED_SIZE
9060 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
9061 && sym
->attr
.dummy
== 0)
9063 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
9064 gfc_error ("Assumed size array at %L must be a dummy argument",
9067 gfc_error ("Assumed shape array at %L must be a dummy argument",
9072 /* Make sure symbols with known intent or optional are really dummy
9073 variable. Because of ENTRY statement, this has to be deferred
9074 until resolution time. */
9076 if (!sym
->attr
.dummy
9077 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
9079 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
9083 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
9085 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
9086 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
9090 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
9092 gfc_charlen
*cl
= sym
->ts
.cl
;
9093 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
9095 gfc_error ("Character dummy variable '%s' at %L with VALUE "
9096 "attribute must have constant length",
9097 sym
->name
, &sym
->declared_at
);
9101 if (sym
->ts
.is_c_interop
9102 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
9104 gfc_error ("C interoperable character dummy variable '%s' at %L "
9105 "with VALUE attribute must have length one",
9106 sym
->name
, &sym
->declared_at
);
9111 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
9112 do this for something that was implicitly typed because that is handled
9113 in gfc_set_default_type. Handle dummy arguments and procedure
9114 definitions separately. Also, anything that is use associated is not
9115 handled here but instead is handled in the module it is declared in.
9116 Finally, derived type definitions are allowed to be BIND(C) since that
9117 only implies that they're interoperable, and they are checked fully for
9118 interoperability when a variable is declared of that type. */
9119 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
9120 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
9121 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
9123 gfc_try t
= SUCCESS
;
9125 /* First, make sure the variable is declared at the
9126 module-level scope (J3/04-007, Section 15.3). */
9127 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
9128 sym
->attr
.in_common
== 0)
9130 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
9131 "is neither a COMMON block nor declared at the "
9132 "module level scope", sym
->name
, &(sym
->declared_at
));
9135 else if (sym
->common_head
!= NULL
)
9137 t
= verify_com_block_vars_c_interop (sym
->common_head
);
9141 /* If type() declaration, we need to verify that the components
9142 of the given type are all C interoperable, etc. */
9143 if (sym
->ts
.type
== BT_DERIVED
&&
9144 sym
->ts
.derived
->attr
.is_c_interop
!= 1)
9146 /* Make sure the user marked the derived type as BIND(C). If
9147 not, call the verify routine. This could print an error
9148 for the derived type more than once if multiple variables
9149 of that type are declared. */
9150 if (sym
->ts
.derived
->attr
.is_bind_c
!= 1)
9151 verify_bind_c_derived_type (sym
->ts
.derived
);
9155 /* Verify the variable itself as C interoperable if it
9156 is BIND(C). It is not possible for this to succeed if
9157 the verify_bind_c_derived_type failed, so don't have to handle
9158 any error returned by verify_bind_c_derived_type. */
9159 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
9165 /* clear the is_bind_c flag to prevent reporting errors more than
9166 once if something failed. */
9167 sym
->attr
.is_bind_c
= 0;
9172 /* If a derived type symbol has reached this point, without its
9173 type being declared, we have an error. Notice that most
9174 conditions that produce undefined derived types have already
9175 been dealt with. However, the likes of:
9176 implicit type(t) (t) ..... call foo (t) will get us here if
9177 the type is not declared in the scope of the implicit
9178 statement. Change the type to BT_UNKNOWN, both because it is so
9179 and to prevent an ICE. */
9180 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
->components
== NULL
9181 && !sym
->ts
.derived
->attr
.zero_comp
)
9183 gfc_error ("The derived type '%s' at %L is of type '%s', "
9184 "which has not been defined", sym
->name
,
9185 &sym
->declared_at
, sym
->ts
.derived
->name
);
9186 sym
->ts
.type
= BT_UNKNOWN
;
9190 /* Make sure that the derived type has been resolved and that the
9191 derived type is visible in the symbol's namespace, if it is a
9192 module function and is not PRIVATE. */
9193 if (sym
->ts
.type
== BT_DERIVED
9194 && sym
->ts
.derived
->attr
.use_assoc
9195 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
9199 if (resolve_fl_derived (sym
->ts
.derived
) == FAILURE
)
9202 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 1, &ds
);
9203 if (!ds
&& sym
->attr
.function
9204 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
9206 symtree
= gfc_new_symtree (&sym
->ns
->sym_root
,
9207 sym
->ts
.derived
->name
);
9208 symtree
->n
.sym
= sym
->ts
.derived
;
9209 sym
->ts
.derived
->refs
++;
9213 /* Unless the derived-type declaration is use associated, Fortran 95
9214 does not allow public entries of private derived types.
9215 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
9217 if (sym
->ts
.type
== BT_DERIVED
9218 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
9219 && !sym
->ts
.derived
->attr
.use_assoc
9220 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
9221 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
9222 sym
->ts
.derived
->ns
->default_access
)
9223 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
9224 "of PRIVATE derived type '%s'",
9225 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
9226 : "variable", sym
->name
, &sym
->declared_at
,
9227 sym
->ts
.derived
->name
) == FAILURE
)
9230 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
9231 default initialization is defined (5.1.2.4.4). */
9232 if (sym
->ts
.type
== BT_DERIVED
9234 && sym
->attr
.intent
== INTENT_OUT
9236 && sym
->as
->type
== AS_ASSUMED_SIZE
)
9238 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
9242 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
9243 "ASSUMED SIZE and so cannot have a default initializer",
9244 sym
->name
, &sym
->declared_at
);
9250 switch (sym
->attr
.flavor
)
9253 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
9258 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
9263 if (resolve_fl_namelist (sym
) == FAILURE
)
9268 if (resolve_fl_parameter (sym
) == FAILURE
)
9276 /* Resolve array specifier. Check as well some constraints
9277 on COMMON blocks. */
9279 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
9281 /* Set the formal_arg_flag so that check_conflict will not throw
9282 an error for host associated variables in the specification
9283 expression for an array_valued function. */
9284 if (sym
->attr
.function
&& sym
->as
)
9285 formal_arg_flag
= 1;
9287 gfc_resolve_array_spec (sym
->as
, check_constant
);
9289 formal_arg_flag
= 0;
9291 /* Resolve formal namespaces. */
9292 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
)
9293 gfc_resolve (sym
->formal_ns
);
9295 /* Check threadprivate restrictions. */
9296 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
9297 && (!sym
->attr
.in_common
9298 && sym
->module
== NULL
9299 && (sym
->ns
->proc_name
== NULL
9300 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
9301 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
9303 /* If we have come this far we can apply default-initializers, as
9304 described in 14.7.5, to those variables that have not already
9305 been assigned one. */
9306 if (sym
->ts
.type
== BT_DERIVED
9307 && sym
->attr
.referenced
9308 && sym
->ns
== gfc_current_ns
9310 && !sym
->attr
.allocatable
9311 && !sym
->attr
.alloc_comp
)
9313 symbol_attribute
*a
= &sym
->attr
;
9315 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
9316 && !a
->in_common
&& !a
->use_assoc
9317 && !(a
->function
&& sym
!= sym
->result
))
9318 || (a
->dummy
&& a
->intent
== INTENT_OUT
))
9319 apply_default_init (sym
);
9322 /* If this symbol has a type-spec, check it. */
9323 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
9324 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
9325 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
9331 /************* Resolve DATA statements *************/
9335 gfc_data_value
*vnode
;
9341 /* Advance the values structure to point to the next value in the data list. */
9344 next_data_value (void)
9347 while (mpz_cmp_ui (values
.left
, 0) == 0)
9349 if (values
.vnode
->next
== NULL
)
9352 values
.vnode
= values
.vnode
->next
;
9353 mpz_set (values
.left
, values
.vnode
->repeat
);
9361 check_data_variable (gfc_data_variable
*var
, locus
*where
)
9367 ar_type mark
= AR_UNKNOWN
;
9369 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
9373 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
9377 mpz_init_set_si (offset
, 0);
9380 if (e
->expr_type
!= EXPR_VARIABLE
)
9381 gfc_internal_error ("check_data_variable(): Bad expression");
9383 if (e
->symtree
->n
.sym
->ns
->is_block_data
9384 && !e
->symtree
->n
.sym
->attr
.in_common
)
9386 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
9387 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
9390 if (e
->ref
== NULL
&& e
->symtree
->n
.sym
->as
)
9392 gfc_error ("DATA array '%s' at %L must be specified in a previous"
9393 " declaration", e
->symtree
->n
.sym
->name
, where
);
9399 mpz_init_set_ui (size
, 1);
9406 /* Find the array section reference. */
9407 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9409 if (ref
->type
!= REF_ARRAY
)
9411 if (ref
->u
.ar
.type
== AR_ELEMENT
)
9417 /* Set marks according to the reference pattern. */
9418 switch (ref
->u
.ar
.type
)
9426 /* Get the start position of array section. */
9427 gfc_get_section_index (ar
, section_index
, &offset
);
9435 if (gfc_array_size (e
, &size
) == FAILURE
)
9437 gfc_error ("Nonconstant array section at %L in DATA statement",
9446 while (mpz_cmp_ui (size
, 0) > 0)
9448 if (next_data_value () == FAILURE
)
9450 gfc_error ("DATA statement at %L has more variables than values",
9456 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
9460 /* If we have more than one element left in the repeat count,
9461 and we have more than one element left in the target variable,
9462 then create a range assignment. */
9463 /* FIXME: Only done for full arrays for now, since array sections
9465 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
9466 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
9470 if (mpz_cmp (size
, values
.left
) >= 0)
9472 mpz_init_set (range
, values
.left
);
9473 mpz_sub (size
, size
, values
.left
);
9474 mpz_set_ui (values
.left
, 0);
9478 mpz_init_set (range
, size
);
9479 mpz_sub (values
.left
, values
.left
, size
);
9480 mpz_set_ui (size
, 0);
9483 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
9486 mpz_add (offset
, offset
, range
);
9490 /* Assign initial value to symbol. */
9493 mpz_sub_ui (values
.left
, values
.left
, 1);
9494 mpz_sub_ui (size
, size
, 1);
9496 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
9500 if (mark
== AR_FULL
)
9501 mpz_add_ui (offset
, offset
, 1);
9503 /* Modify the array section indexes and recalculate the offset
9504 for next element. */
9505 else if (mark
== AR_SECTION
)
9506 gfc_advance_section (section_index
, ar
, &offset
);
9510 if (mark
== AR_SECTION
)
9512 for (i
= 0; i
< ar
->dimen
; i
++)
9513 mpz_clear (section_index
[i
]);
9523 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
9525 /* Iterate over a list of elements in a DATA statement. */
9528 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
9531 iterator_stack frame
;
9532 gfc_expr
*e
, *start
, *end
, *step
;
9533 gfc_try retval
= SUCCESS
;
9535 mpz_init (frame
.value
);
9537 start
= gfc_copy_expr (var
->iter
.start
);
9538 end
= gfc_copy_expr (var
->iter
.end
);
9539 step
= gfc_copy_expr (var
->iter
.step
);
9541 if (gfc_simplify_expr (start
, 1) == FAILURE
9542 || start
->expr_type
!= EXPR_CONSTANT
)
9544 gfc_error ("iterator start at %L does not simplify", &start
->where
);
9548 if (gfc_simplify_expr (end
, 1) == FAILURE
9549 || end
->expr_type
!= EXPR_CONSTANT
)
9551 gfc_error ("iterator end at %L does not simplify", &end
->where
);
9555 if (gfc_simplify_expr (step
, 1) == FAILURE
9556 || step
->expr_type
!= EXPR_CONSTANT
)
9558 gfc_error ("iterator step at %L does not simplify", &step
->where
);
9563 mpz_init_set (trip
, end
->value
.integer
);
9564 mpz_sub (trip
, trip
, start
->value
.integer
);
9565 mpz_add (trip
, trip
, step
->value
.integer
);
9567 mpz_div (trip
, trip
, step
->value
.integer
);
9569 mpz_set (frame
.value
, start
->value
.integer
);
9571 frame
.prev
= iter_stack
;
9572 frame
.variable
= var
->iter
.var
->symtree
;
9573 iter_stack
= &frame
;
9575 while (mpz_cmp_ui (trip
, 0) > 0)
9577 if (traverse_data_var (var
->list
, where
) == FAILURE
)
9584 e
= gfc_copy_expr (var
->expr
);
9585 if (gfc_simplify_expr (e
, 1) == FAILURE
)
9593 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
9595 mpz_sub_ui (trip
, trip
, 1);
9600 mpz_clear (frame
.value
);
9602 gfc_free_expr (start
);
9603 gfc_free_expr (end
);
9604 gfc_free_expr (step
);
9606 iter_stack
= frame
.prev
;
9611 /* Type resolve variables in the variable list of a DATA statement. */
9614 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
9618 for (; var
; var
= var
->next
)
9620 if (var
->expr
== NULL
)
9621 t
= traverse_data_list (var
, where
);
9623 t
= check_data_variable (var
, where
);
9633 /* Resolve the expressions and iterators associated with a data statement.
9634 This is separate from the assignment checking because data lists should
9635 only be resolved once. */
9638 resolve_data_variables (gfc_data_variable
*d
)
9640 for (; d
; d
= d
->next
)
9642 if (d
->list
== NULL
)
9644 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
9649 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
9652 if (resolve_data_variables (d
->list
) == FAILURE
)
9661 /* Resolve a single DATA statement. We implement this by storing a pointer to
9662 the value list into static variables, and then recursively traversing the
9663 variables list, expanding iterators and such. */
9666 resolve_data (gfc_data
*d
)
9669 if (resolve_data_variables (d
->var
) == FAILURE
)
9672 values
.vnode
= d
->value
;
9673 if (d
->value
== NULL
)
9674 mpz_set_ui (values
.left
, 0);
9676 mpz_set (values
.left
, d
->value
->repeat
);
9678 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
9681 /* At this point, we better not have any values left. */
9683 if (next_data_value () == SUCCESS
)
9684 gfc_error ("DATA statement at %L has more values than variables",
9689 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
9690 accessed by host or use association, is a dummy argument to a pure function,
9691 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
9692 is storage associated with any such variable, shall not be used in the
9693 following contexts: (clients of this function). */
9695 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
9696 procedure. Returns zero if assignment is OK, nonzero if there is a
9699 gfc_impure_variable (gfc_symbol
*sym
)
9703 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
9706 if (sym
->ns
!= gfc_current_ns
)
9707 return !sym
->attr
.function
;
9709 proc
= sym
->ns
->proc_name
;
9710 if (sym
->attr
.dummy
&& gfc_pure (proc
)
9711 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
9713 proc
->attr
.function
))
9716 /* TODO: Sort out what can be storage associated, if anything, and include
9717 it here. In principle equivalences should be scanned but it does not
9718 seem to be possible to storage associate an impure variable this way. */
9723 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
9724 symbol of the current procedure. */
9727 gfc_pure (gfc_symbol
*sym
)
9729 symbol_attribute attr
;
9732 sym
= gfc_current_ns
->proc_name
;
9738 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
9742 /* Test whether the current procedure is elemental or not. */
9745 gfc_elemental (gfc_symbol
*sym
)
9747 symbol_attribute attr
;
9750 sym
= gfc_current_ns
->proc_name
;
9755 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
9759 /* Warn about unused labels. */
9762 warn_unused_fortran_label (gfc_st_label
*label
)
9767 warn_unused_fortran_label (label
->left
);
9769 if (label
->defined
== ST_LABEL_UNKNOWN
)
9772 switch (label
->referenced
)
9774 case ST_LABEL_UNKNOWN
:
9775 gfc_warning ("Label %d at %L defined but not used", label
->value
,
9779 case ST_LABEL_BAD_TARGET
:
9780 gfc_warning ("Label %d at %L defined but cannot be used",
9781 label
->value
, &label
->where
);
9788 warn_unused_fortran_label (label
->right
);
9792 /* Returns the sequence type of a symbol or sequence. */
9795 sequence_type (gfc_typespec ts
)
9804 if (ts
.derived
->components
== NULL
)
9805 return SEQ_NONDEFAULT
;
9807 result
= sequence_type (ts
.derived
->components
->ts
);
9808 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
9809 if (sequence_type (c
->ts
) != result
)
9815 if (ts
.kind
!= gfc_default_character_kind
)
9816 return SEQ_NONDEFAULT
;
9818 return SEQ_CHARACTER
;
9821 if (ts
.kind
!= gfc_default_integer_kind
)
9822 return SEQ_NONDEFAULT
;
9827 if (!(ts
.kind
== gfc_default_real_kind
9828 || ts
.kind
== gfc_default_double_kind
))
9829 return SEQ_NONDEFAULT
;
9834 if (ts
.kind
!= gfc_default_complex_kind
)
9835 return SEQ_NONDEFAULT
;
9840 if (ts
.kind
!= gfc_default_logical_kind
)
9841 return SEQ_NONDEFAULT
;
9846 return SEQ_NONDEFAULT
;
9851 /* Resolve derived type EQUIVALENCE object. */
9854 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
9857 gfc_component
*c
= derived
->components
;
9862 /* Shall not be an object of nonsequence derived type. */
9863 if (!derived
->attr
.sequence
)
9865 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
9866 "attribute to be an EQUIVALENCE object", sym
->name
,
9871 /* Shall not have allocatable components. */
9872 if (derived
->attr
.alloc_comp
)
9874 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
9875 "components to be an EQUIVALENCE object",sym
->name
,
9880 if (sym
->attr
.in_common
&& has_default_initializer (sym
->ts
.derived
))
9882 gfc_error ("Derived type variable '%s' at %L with default "
9883 "initialization cannot be in EQUIVALENCE with a variable "
9884 "in COMMON", sym
->name
, &e
->where
);
9888 for (; c
; c
= c
->next
)
9892 && (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
9895 /* Shall not be an object of sequence derived type containing a pointer
9896 in the structure. */
9897 if (c
->attr
.pointer
)
9899 gfc_error ("Derived type variable '%s' at %L with pointer "
9900 "component(s) cannot be an EQUIVALENCE object",
9901 sym
->name
, &e
->where
);
9909 /* Resolve equivalence object.
9910 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
9911 an allocatable array, an object of nonsequence derived type, an object of
9912 sequence derived type containing a pointer at any level of component
9913 selection, an automatic object, a function name, an entry name, a result
9914 name, a named constant, a structure component, or a subobject of any of
9915 the preceding objects. A substring shall not have length zero. A
9916 derived type shall not have components with default initialization nor
9917 shall two objects of an equivalence group be initialized.
9918 Either all or none of the objects shall have an protected attribute.
9919 The simple constraints are done in symbol.c(check_conflict) and the rest
9920 are implemented here. */
9923 resolve_equivalence (gfc_equiv
*eq
)
9926 gfc_symbol
*derived
;
9927 gfc_symbol
*first_sym
;
9930 locus
*last_where
= NULL
;
9931 seq_type eq_type
, last_eq_type
;
9932 gfc_typespec
*last_ts
;
9933 int object
, cnt_protected
;
9934 const char *value_name
;
9938 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
9940 first_sym
= eq
->expr
->symtree
->n
.sym
;
9944 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
9948 e
->ts
= e
->symtree
->n
.sym
->ts
;
9949 /* match_varspec might not know yet if it is seeing
9950 array reference or substring reference, as it doesn't
9952 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
9954 gfc_ref
*ref
= e
->ref
;
9955 sym
= e
->symtree
->n
.sym
;
9957 if (sym
->attr
.dimension
)
9959 ref
->u
.ar
.as
= sym
->as
;
9963 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
9964 if (e
->ts
.type
== BT_CHARACTER
9966 && ref
->type
== REF_ARRAY
9967 && ref
->u
.ar
.dimen
== 1
9968 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
9969 && ref
->u
.ar
.stride
[0] == NULL
)
9971 gfc_expr
*start
= ref
->u
.ar
.start
[0];
9972 gfc_expr
*end
= ref
->u
.ar
.end
[0];
9975 /* Optimize away the (:) reference. */
9976 if (start
== NULL
&& end
== NULL
)
9981 e
->ref
->next
= ref
->next
;
9986 ref
->type
= REF_SUBSTRING
;
9988 start
= gfc_int_expr (1);
9989 ref
->u
.ss
.start
= start
;
9990 if (end
== NULL
&& e
->ts
.cl
)
9991 end
= gfc_copy_expr (e
->ts
.cl
->length
);
9992 ref
->u
.ss
.end
= end
;
9993 ref
->u
.ss
.length
= e
->ts
.cl
;
10000 /* Any further ref is an error. */
10003 gcc_assert (ref
->type
== REF_ARRAY
);
10004 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
10010 if (gfc_resolve_expr (e
) == FAILURE
)
10013 sym
= e
->symtree
->n
.sym
;
10015 if (sym
->attr
.is_protected
)
10017 if (cnt_protected
> 0 && cnt_protected
!= object
)
10019 gfc_error ("Either all or none of the objects in the "
10020 "EQUIVALENCE set at %L shall have the "
10021 "PROTECTED attribute",
10026 /* Shall not equivalence common block variables in a PURE procedure. */
10027 if (sym
->ns
->proc_name
10028 && sym
->ns
->proc_name
->attr
.pure
10029 && sym
->attr
.in_common
)
10031 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
10032 "object in the pure procedure '%s'",
10033 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
10037 /* Shall not be a named constant. */
10038 if (e
->expr_type
== EXPR_CONSTANT
)
10040 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
10041 "object", sym
->name
, &e
->where
);
10045 derived
= e
->ts
.derived
;
10046 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
10049 /* Check that the types correspond correctly:
10051 A numeric sequence structure may be equivalenced to another sequence
10052 structure, an object of default integer type, default real type, double
10053 precision real type, default logical type such that components of the
10054 structure ultimately only become associated to objects of the same
10055 kind. A character sequence structure may be equivalenced to an object
10056 of default character kind or another character sequence structure.
10057 Other objects may be equivalenced only to objects of the same type and
10058 kind parameters. */
10060 /* Identical types are unconditionally OK. */
10061 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
10062 goto identical_types
;
10064 last_eq_type
= sequence_type (*last_ts
);
10065 eq_type
= sequence_type (sym
->ts
);
10067 /* Since the pair of objects is not of the same type, mixed or
10068 non-default sequences can be rejected. */
10070 msg
= "Sequence %s with mixed components in EQUIVALENCE "
10071 "statement at %L with different type objects";
10073 && last_eq_type
== SEQ_MIXED
10074 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
10076 || (eq_type
== SEQ_MIXED
10077 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
10078 &e
->where
) == FAILURE
))
10081 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
10082 "statement at %L with objects of different type";
10084 && last_eq_type
== SEQ_NONDEFAULT
10085 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
10086 last_where
) == FAILURE
)
10087 || (eq_type
== SEQ_NONDEFAULT
10088 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
10089 &e
->where
) == FAILURE
))
10092 msg
="Non-CHARACTER object '%s' in default CHARACTER "
10093 "EQUIVALENCE statement at %L";
10094 if (last_eq_type
== SEQ_CHARACTER
10095 && eq_type
!= SEQ_CHARACTER
10096 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
10097 &e
->where
) == FAILURE
)
10100 msg
="Non-NUMERIC object '%s' in default NUMERIC "
10101 "EQUIVALENCE statement at %L";
10102 if (last_eq_type
== SEQ_NUMERIC
10103 && eq_type
!= SEQ_NUMERIC
10104 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
10105 &e
->where
) == FAILURE
)
10110 last_where
= &e
->where
;
10115 /* Shall not be an automatic array. */
10116 if (e
->ref
->type
== REF_ARRAY
10117 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
10119 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
10120 "an EQUIVALENCE object", sym
->name
, &e
->where
);
10127 /* Shall not be a structure component. */
10128 if (r
->type
== REF_COMPONENT
)
10130 gfc_error ("Structure component '%s' at %L cannot be an "
10131 "EQUIVALENCE object",
10132 r
->u
.c
.component
->name
, &e
->where
);
10136 /* A substring shall not have length zero. */
10137 if (r
->type
== REF_SUBSTRING
)
10139 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
10141 gfc_error ("Substring at %L has length zero",
10142 &r
->u
.ss
.start
->where
);
10152 /* Resolve function and ENTRY types, issue diagnostics if needed. */
10155 resolve_fntype (gfc_namespace
*ns
)
10157 gfc_entry_list
*el
;
10160 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
10163 /* If there are any entries, ns->proc_name is the entry master
10164 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
10166 sym
= ns
->entries
->sym
;
10168 sym
= ns
->proc_name
;
10169 if (sym
->result
== sym
10170 && sym
->ts
.type
== BT_UNKNOWN
10171 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
10172 && !sym
->attr
.untyped
)
10174 gfc_error ("Function '%s' at %L has no IMPLICIT type",
10175 sym
->name
, &sym
->declared_at
);
10176 sym
->attr
.untyped
= 1;
10179 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
10180 && !sym
->attr
.contained
10181 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
10182 sym
->ts
.derived
->ns
->default_access
)
10183 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
10185 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC function '%s' at "
10186 "%L of PRIVATE type '%s'", sym
->name
,
10187 &sym
->declared_at
, sym
->ts
.derived
->name
);
10191 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
10193 if (el
->sym
->result
== el
->sym
10194 && el
->sym
->ts
.type
== BT_UNKNOWN
10195 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
10196 && !el
->sym
->attr
.untyped
)
10198 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
10199 el
->sym
->name
, &el
->sym
->declared_at
);
10200 el
->sym
->attr
.untyped
= 1;
10205 /* 12.3.2.1.1 Defined operators. */
10208 gfc_resolve_uops (gfc_symtree
*symtree
)
10210 gfc_interface
*itr
;
10212 gfc_formal_arglist
*formal
;
10214 if (symtree
== NULL
)
10217 gfc_resolve_uops (symtree
->left
);
10218 gfc_resolve_uops (symtree
->right
);
10220 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
10223 if (!sym
->attr
.function
)
10224 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
10225 sym
->name
, &sym
->declared_at
);
10227 if (sym
->ts
.type
== BT_CHARACTER
10228 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
10229 && !(sym
->result
&& sym
->result
->ts
.cl
10230 && sym
->result
->ts
.cl
->length
))
10231 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
10232 "character length", sym
->name
, &sym
->declared_at
);
10234 formal
= sym
->formal
;
10235 if (!formal
|| !formal
->sym
)
10237 gfc_error ("User operator procedure '%s' at %L must have at least "
10238 "one argument", sym
->name
, &sym
->declared_at
);
10242 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
10243 gfc_error ("First argument of operator interface at %L must be "
10244 "INTENT(IN)", &sym
->declared_at
);
10246 if (formal
->sym
->attr
.optional
)
10247 gfc_error ("First argument of operator interface at %L cannot be "
10248 "optional", &sym
->declared_at
);
10250 formal
= formal
->next
;
10251 if (!formal
|| !formal
->sym
)
10254 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
10255 gfc_error ("Second argument of operator interface at %L must be "
10256 "INTENT(IN)", &sym
->declared_at
);
10258 if (formal
->sym
->attr
.optional
)
10259 gfc_error ("Second argument of operator interface at %L cannot be "
10260 "optional", &sym
->declared_at
);
10263 gfc_error ("Operator interface at %L must have, at most, two "
10264 "arguments", &sym
->declared_at
);
10269 /* Examine all of the expressions associated with a program unit,
10270 assign types to all intermediate expressions, make sure that all
10271 assignments are to compatible types and figure out which names
10272 refer to which functions or subroutines. It doesn't check code
10273 block, which is handled by resolve_code. */
10276 resolve_types (gfc_namespace
*ns
)
10282 gfc_namespace
* old_ns
= gfc_current_ns
;
10284 /* Check that all IMPLICIT types are ok. */
10285 if (!ns
->seen_implicit_none
)
10288 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
10289 if (ns
->set_flag
[letter
]
10290 && resolve_typespec_used (&ns
->default_type
[letter
],
10291 &ns
->implicit_loc
[letter
],
10296 gfc_current_ns
= ns
;
10298 resolve_entries (ns
);
10300 resolve_common_vars (ns
->blank_common
.head
, false);
10301 resolve_common_blocks (ns
->common_root
);
10303 resolve_contained_functions (ns
);
10305 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
10307 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
10308 resolve_charlen (cl
);
10310 gfc_traverse_ns (ns
, resolve_symbol
);
10312 resolve_fntype (ns
);
10314 for (n
= ns
->contained
; n
; n
= n
->sibling
)
10316 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
10317 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
10318 "also be PURE", n
->proc_name
->name
,
10319 &n
->proc_name
->declared_at
);
10325 gfc_check_interfaces (ns
);
10327 gfc_traverse_ns (ns
, resolve_values
);
10333 for (d
= ns
->data
; d
; d
= d
->next
)
10337 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
10339 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
10341 if (ns
->common_root
!= NULL
)
10342 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
10344 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
10345 resolve_equivalence (eq
);
10347 /* Warn about unused labels. */
10348 if (warn_unused_label
)
10349 warn_unused_fortran_label (ns
->st_labels
);
10351 gfc_resolve_uops (ns
->uop_root
);
10353 gfc_current_ns
= old_ns
;
10357 /* Call resolve_code recursively. */
10360 resolve_codes (gfc_namespace
*ns
)
10364 for (n
= ns
->contained
; n
; n
= n
->sibling
)
10367 gfc_current_ns
= ns
;
10369 /* Set to an out of range value. */
10370 current_entry_id
= -1;
10372 bitmap_obstack_initialize (&labels_obstack
);
10373 resolve_code (ns
->code
, ns
);
10374 bitmap_obstack_release (&labels_obstack
);
10378 /* This function is called after a complete program unit has been compiled.
10379 Its purpose is to examine all of the expressions associated with a program
10380 unit, assign types to all intermediate expressions, make sure that all
10381 assignments are to compatible types and figure out which names refer to
10382 which functions or subroutines. */
10385 gfc_resolve (gfc_namespace
*ns
)
10387 gfc_namespace
*old_ns
;
10389 old_ns
= gfc_current_ns
;
10391 resolve_types (ns
);
10392 resolve_codes (ns
);
10394 gfc_current_ns
= old_ns
;