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
== FL_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 the symbol is the function that names the current (or
1180 parent) scope, then we really have a variable reference. */
1182 if (sym
->attr
.function
&& sym
->result
== sym
1183 && (sym
->ns
->proc_name
== sym
1184 || (sym
->ns
->parent
!= NULL
1185 && sym
->ns
->parent
->proc_name
== sym
)))
1188 /* If all else fails, see if we have a specific intrinsic. */
1189 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1191 gfc_intrinsic_sym
*isym
;
1193 isym
= gfc_find_function (sym
->name
);
1194 if (isym
== NULL
|| !isym
->specific
)
1196 gfc_error ("Unable to find a specific INTRINSIC procedure "
1197 "for the reference '%s' at %L", sym
->name
,
1202 sym
->attr
.intrinsic
= 1;
1203 sym
->attr
.function
= 1;
1208 /* See if the name is a module procedure in a parent unit. */
1210 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1213 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1215 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1219 if (parent_st
== NULL
)
1222 sym
= parent_st
->n
.sym
;
1223 e
->symtree
= parent_st
; /* Point to the right thing. */
1225 if (sym
->attr
.flavor
== FL_PROCEDURE
1226 || sym
->attr
.intrinsic
1227 || sym
->attr
.external
)
1233 e
->expr_type
= EXPR_VARIABLE
;
1235 if (sym
->as
!= NULL
)
1237 e
->rank
= sym
->as
->rank
;
1238 e
->ref
= gfc_get_ref ();
1239 e
->ref
->type
= REF_ARRAY
;
1240 e
->ref
->u
.ar
.type
= AR_FULL
;
1241 e
->ref
->u
.ar
.as
= sym
->as
;
1244 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1245 primary.c (match_actual_arg). If above code determines that it
1246 is a variable instead, it needs to be resolved as it was not
1247 done at the beginning of this function. */
1248 save_need_full_assumed_size
= need_full_assumed_size
;
1249 if (e
->expr_type
!= EXPR_VARIABLE
)
1250 need_full_assumed_size
= 0;
1251 if (gfc_resolve_expr (e
) != SUCCESS
)
1253 need_full_assumed_size
= save_need_full_assumed_size
;
1256 /* Check argument list functions %VAL, %LOC and %REF. There is
1257 nothing to do for %REF. */
1258 if (arg
->name
&& arg
->name
[0] == '%')
1260 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1262 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1264 gfc_error ("By-value argument at %L is not of numeric "
1271 gfc_error ("By-value argument at %L cannot be an array or "
1272 "an array section", &e
->where
);
1276 /* Intrinsics are still PROC_UNKNOWN here. However,
1277 since same file external procedures are not resolvable
1278 in gfortran, it is a good deal easier to leave them to
1280 if (ptype
!= PROC_UNKNOWN
1281 && ptype
!= PROC_DUMMY
1282 && ptype
!= PROC_EXTERNAL
1283 && ptype
!= PROC_MODULE
)
1285 gfc_error ("By-value argument at %L is not allowed "
1286 "in this context", &e
->where
);
1291 /* Statement functions have already been excluded above. */
1292 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1293 && e
->ts
.type
== BT_PROCEDURE
)
1295 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1297 gfc_error ("Passing internal procedure at %L by location "
1298 "not allowed", &e
->where
);
1309 /* Do the checks of the actual argument list that are specific to elemental
1310 procedures. If called with c == NULL, we have a function, otherwise if
1311 expr == NULL, we have a subroutine. */
1314 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1316 gfc_actual_arglist
*arg0
;
1317 gfc_actual_arglist
*arg
;
1318 gfc_symbol
*esym
= NULL
;
1319 gfc_intrinsic_sym
*isym
= NULL
;
1321 gfc_intrinsic_arg
*iformal
= NULL
;
1322 gfc_formal_arglist
*eformal
= NULL
;
1323 bool formal_optional
= false;
1324 bool set_by_optional
= false;
1328 /* Is this an elemental procedure? */
1329 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1331 if (expr
->value
.function
.esym
!= NULL
1332 && expr
->value
.function
.esym
->attr
.elemental
)
1334 arg0
= expr
->value
.function
.actual
;
1335 esym
= expr
->value
.function
.esym
;
1337 else if (expr
->value
.function
.isym
!= NULL
1338 && expr
->value
.function
.isym
->elemental
)
1340 arg0
= expr
->value
.function
.actual
;
1341 isym
= expr
->value
.function
.isym
;
1346 else if (c
&& c
->ext
.actual
!= NULL
&& c
->symtree
->n
.sym
->attr
.elemental
)
1348 arg0
= c
->ext
.actual
;
1349 esym
= c
->symtree
->n
.sym
;
1354 /* The rank of an elemental is the rank of its array argument(s). */
1355 for (arg
= arg0
; arg
; arg
= arg
->next
)
1357 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1359 rank
= arg
->expr
->rank
;
1360 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1361 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1362 set_by_optional
= true;
1364 /* Function specific; set the result rank and shape. */
1368 if (!expr
->shape
&& arg
->expr
->shape
)
1370 expr
->shape
= gfc_get_shape (rank
);
1371 for (i
= 0; i
< rank
; i
++)
1372 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1379 /* If it is an array, it shall not be supplied as an actual argument
1380 to an elemental procedure unless an array of the same rank is supplied
1381 as an actual argument corresponding to a nonoptional dummy argument of
1382 that elemental procedure(12.4.1.5). */
1383 formal_optional
= false;
1385 iformal
= isym
->formal
;
1387 eformal
= esym
->formal
;
1389 for (arg
= arg0
; arg
; arg
= arg
->next
)
1393 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1394 formal_optional
= true;
1395 eformal
= eformal
->next
;
1397 else if (isym
&& iformal
)
1399 if (iformal
->optional
)
1400 formal_optional
= true;
1401 iformal
= iformal
->next
;
1404 formal_optional
= true;
1406 if (pedantic
&& arg
->expr
!= NULL
1407 && arg
->expr
->expr_type
== EXPR_VARIABLE
1408 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1411 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1412 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1414 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1415 "MISSING, it cannot be the actual argument of an "
1416 "ELEMENTAL procedure unless there is a non-optional "
1417 "argument with the same rank (12.4.1.5)",
1418 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1423 for (arg
= arg0
; arg
; arg
= arg
->next
)
1425 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1428 /* Being elemental, the last upper bound of an assumed size array
1429 argument must be present. */
1430 if (resolve_assumed_size_actual (arg
->expr
))
1433 /* Elemental procedure's array actual arguments must conform. */
1436 if (gfc_check_conformance ("elemental procedure", arg
->expr
, e
)
1444 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1445 is an array, the intent inout/out variable needs to be also an array. */
1446 if (rank
> 0 && esym
&& expr
== NULL
)
1447 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1448 arg
= arg
->next
, eformal
= eformal
->next
)
1449 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1450 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1451 && arg
->expr
&& arg
->expr
->rank
== 0)
1453 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1454 "ELEMENTAL subroutine '%s' is a scalar, but another "
1455 "actual argument is an array", &arg
->expr
->where
,
1456 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1457 : "INOUT", eformal
->sym
->name
, esym
->name
);
1464 /* Go through each actual argument in ACTUAL and see if it can be
1465 implemented as an inlined, non-copying intrinsic. FNSYM is the
1466 function being called, or NULL if not known. */
1469 find_noncopying_intrinsics (gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
)
1471 gfc_actual_arglist
*ap
;
1474 for (ap
= actual
; ap
; ap
= ap
->next
)
1476 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1477 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
1478 ap
->expr
->inline_noncopying_intrinsic
= 1;
1482 /* This function does the checking of references to global procedures
1483 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1484 77 and 95 standards. It checks for a gsymbol for the name, making
1485 one if it does not already exist. If it already exists, then the
1486 reference being resolved must correspond to the type of gsymbol.
1487 Otherwise, the new symbol is equipped with the attributes of the
1488 reference. The corresponding code that is called in creating
1489 global entities is parse.c. */
1492 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1497 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1499 gsym
= gfc_get_gsymbol (sym
->name
);
1501 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1502 gfc_global_used (gsym
, where
);
1504 if (gsym
->type
== GSYM_UNKNOWN
)
1507 gsym
->where
= *where
;
1514 /************* Function resolution *************/
1516 /* Resolve a function call known to be generic.
1517 Section 14.1.2.4.1. */
1520 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
1524 if (sym
->attr
.generic
)
1526 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1529 expr
->value
.function
.name
= s
->name
;
1530 expr
->value
.function
.esym
= s
;
1532 if (s
->ts
.type
!= BT_UNKNOWN
)
1534 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1535 expr
->ts
= s
->result
->ts
;
1538 expr
->rank
= s
->as
->rank
;
1539 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1540 expr
->rank
= s
->result
->as
->rank
;
1542 gfc_set_sym_referenced (expr
->value
.function
.esym
);
1547 /* TODO: Need to search for elemental references in generic
1551 if (sym
->attr
.intrinsic
)
1552 return gfc_intrinsic_func_interface (expr
, 0);
1559 resolve_generic_f (gfc_expr
*expr
)
1564 sym
= expr
->symtree
->n
.sym
;
1568 m
= resolve_generic_f0 (expr
, sym
);
1571 else if (m
== MATCH_ERROR
)
1575 if (sym
->ns
->parent
== NULL
)
1577 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1581 if (!generic_sym (sym
))
1585 /* Last ditch attempt. See if the reference is to an intrinsic
1586 that possesses a matching interface. 14.1.2.4 */
1587 if (sym
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
1589 gfc_error ("There is no specific function for the generic '%s' at %L",
1590 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1594 m
= gfc_intrinsic_func_interface (expr
, 0);
1598 gfc_error ("Generic function '%s' at %L is not consistent with a "
1599 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
1606 /* Resolve a function call known to be specific. */
1609 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
1613 /* See if we have an intrinsic interface. */
1615 if (sym
->ts
.interface
!= NULL
&& sym
->ts
.interface
->attr
.intrinsic
)
1617 gfc_intrinsic_sym
*isym
;
1618 isym
= gfc_find_function (sym
->ts
.interface
->name
);
1620 /* Existence of isym should be checked already. */
1623 sym
->ts
.type
= isym
->ts
.type
;
1624 sym
->ts
.kind
= isym
->ts
.kind
;
1625 sym
->attr
.function
= 1;
1626 sym
->attr
.proc
= PROC_EXTERNAL
;
1630 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1632 if (sym
->attr
.dummy
)
1634 sym
->attr
.proc
= PROC_DUMMY
;
1638 sym
->attr
.proc
= PROC_EXTERNAL
;
1642 if (sym
->attr
.proc
== PROC_MODULE
1643 || sym
->attr
.proc
== PROC_ST_FUNCTION
1644 || sym
->attr
.proc
== PROC_INTERNAL
)
1647 if (sym
->attr
.intrinsic
)
1649 m
= gfc_intrinsic_func_interface (expr
, 1);
1653 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1654 "with an intrinsic", sym
->name
, &expr
->where
);
1662 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1665 expr
->value
.function
.name
= sym
->name
;
1666 expr
->value
.function
.esym
= sym
;
1667 if (sym
->as
!= NULL
)
1668 expr
->rank
= sym
->as
->rank
;
1675 resolve_specific_f (gfc_expr
*expr
)
1680 sym
= expr
->symtree
->n
.sym
;
1684 m
= resolve_specific_f0 (sym
, expr
);
1687 if (m
== MATCH_ERROR
)
1690 if (sym
->ns
->parent
== NULL
)
1693 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1699 gfc_error ("Unable to resolve the specific function '%s' at %L",
1700 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1706 /* Resolve a procedure call not known to be generic nor specific. */
1709 resolve_unknown_f (gfc_expr
*expr
)
1714 sym
= expr
->symtree
->n
.sym
;
1716 if (sym
->attr
.dummy
)
1718 sym
->attr
.proc
= PROC_DUMMY
;
1719 expr
->value
.function
.name
= sym
->name
;
1723 /* See if we have an intrinsic function reference. */
1725 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
1727 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1732 /* The reference is to an external name. */
1734 sym
->attr
.proc
= PROC_EXTERNAL
;
1735 expr
->value
.function
.name
= sym
->name
;
1736 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1738 if (sym
->as
!= NULL
)
1739 expr
->rank
= sym
->as
->rank
;
1741 /* Type of the expression is either the type of the symbol or the
1742 default type of the symbol. */
1745 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1747 if (sym
->ts
.type
!= BT_UNKNOWN
)
1751 ts
= gfc_get_default_type (sym
, sym
->ns
);
1753 if (ts
->type
== BT_UNKNOWN
)
1755 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1756 sym
->name
, &expr
->where
);
1767 /* Return true, if the symbol is an external procedure. */
1769 is_external_proc (gfc_symbol
*sym
)
1771 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
1772 && !(sym
->attr
.intrinsic
1773 || gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
))
1774 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1775 && !sym
->attr
.use_assoc
1783 /* Figure out if a function reference is pure or not. Also set the name
1784 of the function for a potential error message. Return nonzero if the
1785 function is PURE, zero if not. */
1787 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
1790 pure_function (gfc_expr
*e
, const char **name
)
1796 if (e
->symtree
!= NULL
1797 && e
->symtree
->n
.sym
!= NULL
1798 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1799 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
1801 if (e
->value
.function
.esym
)
1803 pure
= gfc_pure (e
->value
.function
.esym
);
1804 *name
= e
->value
.function
.esym
->name
;
1806 else if (e
->value
.function
.isym
)
1808 pure
= e
->value
.function
.isym
->pure
1809 || e
->value
.function
.isym
->elemental
;
1810 *name
= e
->value
.function
.isym
->name
;
1814 /* Implicit functions are not pure. */
1816 *name
= e
->value
.function
.name
;
1824 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
1825 int *f ATTRIBUTE_UNUSED
)
1829 /* Don't bother recursing into other statement functions
1830 since they will be checked individually for purity. */
1831 if (e
->expr_type
!= EXPR_FUNCTION
1833 || e
->symtree
->n
.sym
== sym
1834 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1837 return pure_function (e
, &name
) ? false : true;
1842 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
1844 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
1849 is_scalar_expr_ptr (gfc_expr
*expr
)
1851 gfc_try retval
= SUCCESS
;
1856 /* See if we have a gfc_ref, which means we have a substring, array
1857 reference, or a component. */
1858 if (expr
->ref
!= NULL
)
1861 while (ref
->next
!= NULL
)
1867 if (ref
->u
.ss
.length
!= NULL
1868 && ref
->u
.ss
.length
->length
!= NULL
1870 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1872 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1874 start
= (int) mpz_get_si (ref
->u
.ss
.start
->value
.integer
);
1875 end
= (int) mpz_get_si (ref
->u
.ss
.end
->value
.integer
);
1876 if (end
- start
+ 1 != 1)
1883 if (ref
->u
.ar
.type
== AR_ELEMENT
)
1885 else if (ref
->u
.ar
.type
== AR_FULL
)
1887 /* The user can give a full array if the array is of size 1. */
1888 if (ref
->u
.ar
.as
!= NULL
1889 && ref
->u
.ar
.as
->rank
== 1
1890 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
1891 && ref
->u
.ar
.as
->lower
[0] != NULL
1892 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
1893 && ref
->u
.ar
.as
->upper
[0] != NULL
1894 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
1896 /* If we have a character string, we need to check if
1897 its length is one. */
1898 if (expr
->ts
.type
== BT_CHARACTER
)
1900 if (expr
->ts
.cl
== NULL
1901 || expr
->ts
.cl
->length
== NULL
1902 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1)
1908 /* We have constant lower and upper bounds. If the
1909 difference between is 1, it can be considered a
1911 start
= (int) mpz_get_si
1912 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
1913 end
= (int) mpz_get_si
1914 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
1915 if (end
- start
+ 1 != 1)
1930 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
1932 /* Character string. Make sure it's of length 1. */
1933 if (expr
->ts
.cl
== NULL
1934 || expr
->ts
.cl
->length
== NULL
1935 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1) != 0)
1938 else if (expr
->rank
!= 0)
1945 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1946 and, in the case of c_associated, set the binding label based on
1950 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
1951 gfc_symbol
**new_sym
)
1953 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1954 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
1955 int optional_arg
= 0;
1956 gfc_try retval
= SUCCESS
;
1957 gfc_symbol
*args_sym
;
1958 gfc_typespec
*arg_ts
;
1959 gfc_ref
*parent_ref
;
1962 if (args
->expr
->expr_type
== EXPR_CONSTANT
1963 || args
->expr
->expr_type
== EXPR_OP
1964 || args
->expr
->expr_type
== EXPR_NULL
)
1966 gfc_error ("Argument to '%s' at %L is not a variable",
1967 sym
->name
, &(args
->expr
->where
));
1971 args_sym
= args
->expr
->symtree
->n
.sym
;
1973 /* The typespec for the actual arg should be that stored in the expr
1974 and not necessarily that of the expr symbol (args_sym), because
1975 the actual expression could be a part-ref of the expr symbol. */
1976 arg_ts
= &(args
->expr
->ts
);
1978 /* Get the parent reference (if any) for the expression. This happens for
1979 cases such as a%b%c. */
1980 parent_ref
= args
->expr
->ref
;
1982 if (parent_ref
!= NULL
)
1984 curr_ref
= parent_ref
->next
;
1985 while (curr_ref
!= NULL
&& curr_ref
->next
!= NULL
)
1987 parent_ref
= curr_ref
;
1988 curr_ref
= curr_ref
->next
;
1992 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
1993 is for a REF_COMPONENT, then we need to use it as the parent_ref for
1994 the name, etc. Otherwise, the current parent_ref should be correct. */
1995 if (curr_ref
!= NULL
&& curr_ref
->type
== REF_COMPONENT
)
1996 parent_ref
= curr_ref
;
1998 if (parent_ref
== args
->expr
->ref
)
2000 else if (parent_ref
!= NULL
&& parent_ref
->type
!= REF_COMPONENT
)
2001 gfc_internal_error ("Unexpected expression reference type in "
2002 "gfc_iso_c_func_interface");
2004 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2006 /* If the user gave two args then they are providing something for
2007 the optional arg (the second cptr). Therefore, set the name and
2008 binding label to the c_associated for two cptrs. Otherwise,
2009 set c_associated to expect one cptr. */
2013 sprintf (name
, "%s_2", sym
->name
);
2014 sprintf (binding_label
, "%s_2", sym
->binding_label
);
2020 sprintf (name
, "%s_1", sym
->name
);
2021 sprintf (binding_label
, "%s_1", sym
->binding_label
);
2025 /* Get a new symbol for the version of c_associated that
2027 *new_sym
= get_iso_c_sym (sym
, name
, binding_label
, optional_arg
);
2029 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2030 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2032 sprintf (name
, "%s", sym
->name
);
2033 sprintf (binding_label
, "%s", sym
->binding_label
);
2035 /* Error check the call. */
2036 if (args
->next
!= NULL
)
2038 gfc_error_now ("More actual than formal arguments in '%s' "
2039 "call at %L", name
, &(args
->expr
->where
));
2042 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2044 /* Make sure we have either the target or pointer attribute. */
2045 if (!(args_sym
->attr
.target
)
2046 && !(args_sym
->attr
.pointer
)
2047 && (parent_ref
== NULL
||
2048 !parent_ref
->u
.c
.component
->attr
.pointer
))
2050 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2051 "a TARGET or an associated pointer",
2053 sym
->name
, &(args
->expr
->where
));
2057 /* See if we have interoperable type and type param. */
2058 if (verify_c_interop (arg_ts
,
2059 (parent_ref
? parent_ref
->u
.c
.component
->name
2061 &(args
->expr
->where
)) == SUCCESS
2062 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2064 if (args_sym
->attr
.target
== 1)
2066 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2067 has the target attribute and is interoperable. */
2068 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2069 allocatable variable that has the TARGET attribute and
2070 is not an array of zero size. */
2071 if (args_sym
->attr
.allocatable
== 1)
2073 if (args_sym
->attr
.dimension
!= 0
2074 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2076 gfc_error_now ("Allocatable variable '%s' used as a "
2077 "parameter to '%s' at %L must not be "
2078 "an array of zero size",
2079 args_sym
->name
, sym
->name
,
2080 &(args
->expr
->where
));
2086 /* A non-allocatable target variable with C
2087 interoperable type and type parameters must be
2089 if (args_sym
&& args_sym
->attr
.dimension
)
2091 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2093 gfc_error ("Assumed-shape array '%s' at %L "
2094 "cannot be an argument to the "
2095 "procedure '%s' because "
2096 "it is not C interoperable",
2098 &(args
->expr
->where
), sym
->name
);
2101 else if (args_sym
->as
->type
== AS_DEFERRED
)
2103 gfc_error ("Deferred-shape array '%s' at %L "
2104 "cannot be an argument to the "
2105 "procedure '%s' because "
2106 "it is not C interoperable",
2108 &(args
->expr
->where
), sym
->name
);
2113 /* Make sure it's not a character string. Arrays of
2114 any type should be ok if the variable is of a C
2115 interoperable type. */
2116 if (arg_ts
->type
== BT_CHARACTER
)
2117 if (arg_ts
->cl
!= NULL
2118 && (arg_ts
->cl
->length
== NULL
2119 || arg_ts
->cl
->length
->expr_type
2122 (arg_ts
->cl
->length
->value
.integer
, 1)
2124 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2126 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2127 "at %L must have a length of 1",
2128 args_sym
->name
, sym
->name
,
2129 &(args
->expr
->where
));
2134 else if ((args_sym
->attr
.pointer
== 1 ||
2136 && parent_ref
->u
.c
.component
->attr
.pointer
))
2137 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2139 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2141 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2142 "associated scalar POINTER", args_sym
->name
,
2143 sym
->name
, &(args
->expr
->where
));
2149 /* The parameter is not required to be C interoperable. If it
2150 is not C interoperable, it must be a nonpolymorphic scalar
2151 with no length type parameters. It still must have either
2152 the pointer or target attribute, and it can be
2153 allocatable (but must be allocated when c_loc is called). */
2154 if (args
->expr
->rank
!= 0
2155 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2157 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2158 "scalar", args_sym
->name
, sym
->name
,
2159 &(args
->expr
->where
));
2162 else if (arg_ts
->type
== BT_CHARACTER
2163 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2165 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2166 "%L must have a length of 1",
2167 args_sym
->name
, sym
->name
,
2168 &(args
->expr
->where
));
2173 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2175 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2177 /* TODO: Update this error message to allow for procedure
2178 pointers once they are implemented. */
2179 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2181 args_sym
->name
, sym
->name
,
2182 &(args
->expr
->where
));
2185 else if (args_sym
->attr
.is_bind_c
!= 1)
2187 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2189 args_sym
->name
, sym
->name
,
2190 &(args
->expr
->where
));
2195 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2200 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2201 "iso_c_binding function: '%s'!\n", sym
->name
);
2208 /* Resolve a function call, which means resolving the arguments, then figuring
2209 out which entity the name refers to. */
2210 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2211 to INTENT(OUT) or INTENT(INOUT). */
2214 resolve_function (gfc_expr
*expr
)
2216 gfc_actual_arglist
*arg
;
2221 procedure_type p
= PROC_INTRINSIC
;
2222 bool no_formal_args
;
2226 sym
= expr
->symtree
->n
.sym
;
2228 if (sym
&& sym
->attr
.intrinsic
2229 && !gfc_find_function (sym
->name
)
2230 && gfc_find_subroutine (sym
->name
)
2231 && sym
->attr
.function
)
2233 gfc_error ("Intrinsic subroutine '%s' used as "
2234 "a function at %L", sym
->name
, &expr
->where
);
2238 if (sym
&& sym
->attr
.flavor
== FL_VARIABLE
)
2240 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2244 if (sym
&& sym
->attr
.abstract
)
2246 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2247 sym
->name
, &expr
->where
);
2251 /* If the procedure is external, check for usage. */
2252 if (sym
&& is_external_proc (sym
))
2253 resolve_global_procedure (sym
, &expr
->where
, 0);
2255 /* Switch off assumed size checking and do this again for certain kinds
2256 of procedure, once the procedure itself is resolved. */
2257 need_full_assumed_size
++;
2259 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2260 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2262 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
2263 if (resolve_actual_arglist (expr
->value
.function
.actual
,
2264 p
, no_formal_args
) == FAILURE
)
2267 /* Need to setup the call to the correct c_associated, depending on
2268 the number of cptrs to user gives to compare. */
2269 if (sym
&& sym
->attr
.is_iso_c
== 1)
2271 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
2275 /* Get the symtree for the new symbol (resolved func).
2276 the old one will be freed later, when it's no longer used. */
2277 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
2280 /* Resume assumed_size checking. */
2281 need_full_assumed_size
--;
2283 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2285 && sym
->ts
.cl
->length
== NULL
2287 && expr
->value
.function
.esym
== NULL
2288 && !sym
->attr
.contained
)
2290 /* Internal procedures are taken care of in resolve_contained_fntype. */
2291 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2292 "be used at %L since it is not a dummy argument",
2293 sym
->name
, &expr
->where
);
2297 /* See if function is already resolved. */
2299 if (expr
->value
.function
.name
!= NULL
)
2301 if (expr
->ts
.type
== BT_UNKNOWN
)
2307 /* Apply the rules of section 14.1.2. */
2309 switch (procedure_kind (sym
))
2312 t
= resolve_generic_f (expr
);
2315 case PTYPE_SPECIFIC
:
2316 t
= resolve_specific_f (expr
);
2320 t
= resolve_unknown_f (expr
);
2324 gfc_internal_error ("resolve_function(): bad function type");
2328 /* If the expression is still a function (it might have simplified),
2329 then we check to see if we are calling an elemental function. */
2331 if (expr
->expr_type
!= EXPR_FUNCTION
)
2334 temp
= need_full_assumed_size
;
2335 need_full_assumed_size
= 0;
2337 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
2340 if (omp_workshare_flag
2341 && expr
->value
.function
.esym
2342 && ! gfc_elemental (expr
->value
.function
.esym
))
2344 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2345 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2350 #define GENERIC_ID expr->value.function.isym->id
2351 else if (expr
->value
.function
.actual
!= NULL
2352 && expr
->value
.function
.isym
!= NULL
2353 && GENERIC_ID
!= GFC_ISYM_LBOUND
2354 && GENERIC_ID
!= GFC_ISYM_LEN
2355 && GENERIC_ID
!= GFC_ISYM_LOC
2356 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2358 /* Array intrinsics must also have the last upper bound of an
2359 assumed size array argument. UBOUND and SIZE have to be
2360 excluded from the check if the second argument is anything
2363 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2365 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
2366 && arg
->next
!= NULL
&& arg
->next
->expr
)
2368 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2371 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
2374 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2379 if (arg
->expr
!= NULL
2380 && arg
->expr
->rank
> 0
2381 && resolve_assumed_size_actual (arg
->expr
))
2387 need_full_assumed_size
= temp
;
2390 if (!pure_function (expr
, &name
) && name
)
2394 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2395 "FORALL %s", name
, &expr
->where
,
2396 forall_flag
== 2 ? "mask" : "block");
2399 else if (gfc_pure (NULL
))
2401 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2402 "procedure within a PURE procedure", name
, &expr
->where
);
2407 /* Functions without the RECURSIVE attribution are not allowed to
2408 * call themselves. */
2409 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
2411 gfc_symbol
*esym
, *proc
;
2412 esym
= expr
->value
.function
.esym
;
2413 proc
= gfc_current_ns
->proc_name
;
2416 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2417 "RECURSIVE", name
, &expr
->where
);
2421 if (esym
->attr
.entry
&& esym
->ns
->entries
&& proc
->ns
->entries
2422 && esym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2424 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2425 "'%s' is not declared as RECURSIVE",
2426 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
2431 /* Character lengths of use associated functions may contains references to
2432 symbols not referenced from the current program unit otherwise. Make sure
2433 those symbols are marked as referenced. */
2435 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
2436 && expr
->value
.function
.esym
->attr
.use_assoc
)
2438 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
2442 && !((expr
->value
.function
.esym
2443 && expr
->value
.function
.esym
->attr
.elemental
)
2445 (expr
->value
.function
.isym
2446 && expr
->value
.function
.isym
->elemental
)))
2447 find_noncopying_intrinsics (expr
->value
.function
.esym
,
2448 expr
->value
.function
.actual
);
2450 /* Make sure that the expression has a typespec that works. */
2451 if (expr
->ts
.type
== BT_UNKNOWN
)
2453 if (expr
->symtree
->n
.sym
->result
2454 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
)
2455 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
2462 /************* Subroutine resolution *************/
2465 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
2471 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2472 sym
->name
, &c
->loc
);
2473 else if (gfc_pure (NULL
))
2474 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
2480 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2484 if (sym
->attr
.generic
)
2486 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
2489 c
->resolved_sym
= s
;
2490 pure_subroutine (c
, s
);
2494 /* TODO: Need to search for elemental references in generic interface. */
2497 if (sym
->attr
.intrinsic
)
2498 return gfc_intrinsic_sub_interface (c
, 0);
2505 resolve_generic_s (gfc_code
*c
)
2510 sym
= c
->symtree
->n
.sym
;
2514 m
= resolve_generic_s0 (c
, sym
);
2517 else if (m
== MATCH_ERROR
)
2521 if (sym
->ns
->parent
== NULL
)
2523 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2527 if (!generic_sym (sym
))
2531 /* Last ditch attempt. See if the reference is to an intrinsic
2532 that possesses a matching interface. 14.1.2.4 */
2533 sym
= c
->symtree
->n
.sym
;
2535 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
2537 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2538 sym
->name
, &c
->loc
);
2542 m
= gfc_intrinsic_sub_interface (c
, 0);
2546 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2547 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
2553 /* Set the name and binding label of the subroutine symbol in the call
2554 expression represented by 'c' to include the type and kind of the
2555 second parameter. This function is for resolving the appropriate
2556 version of c_f_pointer() and c_f_procpointer(). For example, a
2557 call to c_f_pointer() for a default integer pointer could have a
2558 name of c_f_pointer_i4. If no second arg exists, which is an error
2559 for these two functions, it defaults to the generic symbol's name
2560 and binding label. */
2563 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
2564 char *name
, char *binding_label
)
2566 gfc_expr
*arg
= NULL
;
2570 /* The second arg of c_f_pointer and c_f_procpointer determines
2571 the type and kind for the procedure name. */
2572 arg
= c
->ext
.actual
->next
->expr
;
2576 /* Set up the name to have the given symbol's name,
2577 plus the type and kind. */
2578 /* a derived type is marked with the type letter 'u' */
2579 if (arg
->ts
.type
== BT_DERIVED
)
2582 kind
= 0; /* set the kind as 0 for now */
2586 type
= gfc_type_letter (arg
->ts
.type
);
2587 kind
= arg
->ts
.kind
;
2590 if (arg
->ts
.type
== BT_CHARACTER
)
2591 /* Kind info for character strings not needed. */
2594 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
2595 /* Set up the binding label as the given symbol's label plus
2596 the type and kind. */
2597 sprintf (binding_label
, "%s_%c%d", sym
->binding_label
, type
, kind
);
2601 /* If the second arg is missing, set the name and label as
2602 was, cause it should at least be found, and the missing
2603 arg error will be caught by compare_parameters(). */
2604 sprintf (name
, "%s", sym
->name
);
2605 sprintf (binding_label
, "%s", sym
->binding_label
);
2612 /* Resolve a generic version of the iso_c_binding procedure given
2613 (sym) to the specific one based on the type and kind of the
2614 argument(s). Currently, this function resolves c_f_pointer() and
2615 c_f_procpointer based on the type and kind of the second argument
2616 (FPTR). Other iso_c_binding procedures aren't specially handled.
2617 Upon successfully exiting, c->resolved_sym will hold the resolved
2618 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2622 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
2624 gfc_symbol
*new_sym
;
2625 /* this is fine, since we know the names won't use the max */
2626 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2627 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2628 /* default to success; will override if find error */
2629 match m
= MATCH_YES
;
2631 /* Make sure the actual arguments are in the necessary order (based on the
2632 formal args) before resolving. */
2633 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
2635 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
2636 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
2638 set_name_and_label (c
, sym
, name
, binding_label
);
2640 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
2642 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
2644 /* Make sure we got a third arg if the second arg has non-zero
2645 rank. We must also check that the type and rank are
2646 correct since we short-circuit this check in
2647 gfc_procedure_use() (called above to sort actual args). */
2648 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
2650 if(c
->ext
.actual
->next
->next
== NULL
2651 || c
->ext
.actual
->next
->next
->expr
== NULL
)
2654 gfc_error ("Missing SHAPE parameter for call to %s "
2655 "at %L", sym
->name
, &(c
->loc
));
2657 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
2659 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
2662 gfc_error ("SHAPE parameter for call to %s at %L must "
2663 "be a rank 1 INTEGER array", sym
->name
,
2670 if (m
!= MATCH_ERROR
)
2672 /* the 1 means to add the optional arg to formal list */
2673 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
2675 /* for error reporting, say it's declared where the original was */
2676 new_sym
->declared_at
= sym
->declared_at
;
2681 /* no differences for c_loc or c_funloc */
2685 /* set the resolved symbol */
2686 if (m
!= MATCH_ERROR
)
2687 c
->resolved_sym
= new_sym
;
2689 c
->resolved_sym
= sym
;
2695 /* Resolve a subroutine call known to be specific. */
2698 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2702 /* See if we have an intrinsic interface. */
2703 if (sym
->ts
.interface
!= NULL
&& !sym
->ts
.interface
->attr
.abstract
2704 && !sym
->ts
.interface
->attr
.subroutine
)
2706 gfc_intrinsic_sym
*isym
;
2708 isym
= gfc_find_function (sym
->ts
.interface
->name
);
2710 /* Existence of isym should be checked already. */
2713 sym
->ts
.type
= isym
->ts
.type
;
2714 sym
->ts
.kind
= isym
->ts
.kind
;
2715 sym
->attr
.subroutine
= 1;
2719 if(sym
->attr
.is_iso_c
)
2721 m
= gfc_iso_c_sub_interface (c
,sym
);
2725 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2727 if (sym
->attr
.dummy
)
2729 sym
->attr
.proc
= PROC_DUMMY
;
2733 sym
->attr
.proc
= PROC_EXTERNAL
;
2737 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
2740 if (sym
->attr
.intrinsic
)
2742 m
= gfc_intrinsic_sub_interface (c
, 1);
2746 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2747 "with an intrinsic", sym
->name
, &c
->loc
);
2755 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2757 c
->resolved_sym
= sym
;
2758 pure_subroutine (c
, sym
);
2765 resolve_specific_s (gfc_code
*c
)
2770 sym
= c
->symtree
->n
.sym
;
2774 m
= resolve_specific_s0 (c
, sym
);
2777 if (m
== MATCH_ERROR
)
2780 if (sym
->ns
->parent
== NULL
)
2783 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2789 sym
= c
->symtree
->n
.sym
;
2790 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2791 sym
->name
, &c
->loc
);
2797 /* Resolve a subroutine call not known to be generic nor specific. */
2800 resolve_unknown_s (gfc_code
*c
)
2804 sym
= c
->symtree
->n
.sym
;
2806 if (sym
->attr
.dummy
)
2808 sym
->attr
.proc
= PROC_DUMMY
;
2812 /* See if we have an intrinsic function reference. */
2814 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
2816 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
2821 /* The reference is to an external name. */
2824 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2826 c
->resolved_sym
= sym
;
2828 pure_subroutine (c
, sym
);
2834 /* Resolve a subroutine call. Although it was tempting to use the same code
2835 for functions, subroutines and functions are stored differently and this
2836 makes things awkward. */
2839 resolve_call (gfc_code
*c
)
2842 procedure_type ptype
= PROC_INTRINSIC
;
2844 bool no_formal_args
;
2846 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
2848 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
2850 gfc_error ("'%s' at %L has a type, which is not consistent with "
2851 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
2855 /* If external, check for usage. */
2856 if (csym
&& is_external_proc (csym
))
2857 resolve_global_procedure (csym
, &c
->loc
, 1);
2859 /* Subroutines without the RECURSIVE attribution are not allowed to
2860 * call themselves. */
2861 if (csym
&& !csym
->attr
.recursive
)
2864 proc
= gfc_current_ns
->proc_name
;
2867 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2868 "RECURSIVE", csym
->name
, &c
->loc
);
2872 if (csym
->attr
.entry
&& csym
->ns
->entries
&& proc
->ns
->entries
2873 && csym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2875 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2876 "'%s' is not declared as RECURSIVE",
2877 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
2882 /* Switch off assumed size checking and do this again for certain kinds
2883 of procedure, once the procedure itself is resolved. */
2884 need_full_assumed_size
++;
2887 ptype
= csym
->attr
.proc
;
2889 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
2890 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
2891 no_formal_args
) == FAILURE
)
2894 /* Resume assumed_size checking. */
2895 need_full_assumed_size
--;
2898 if (c
->resolved_sym
== NULL
)
2899 switch (procedure_kind (csym
))
2902 t
= resolve_generic_s (c
);
2905 case PTYPE_SPECIFIC
:
2906 t
= resolve_specific_s (c
);
2910 t
= resolve_unknown_s (c
);
2914 gfc_internal_error ("resolve_subroutine(): bad function type");
2917 /* Some checks of elemental subroutine actual arguments. */
2918 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
2921 if (t
== SUCCESS
&& !(c
->resolved_sym
&& c
->resolved_sym
->attr
.elemental
))
2922 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
2927 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2928 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2929 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2930 if their shapes do not match. If either op1->shape or op2->shape is
2931 NULL, return SUCCESS. */
2934 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
2941 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
2943 for (i
= 0; i
< op1
->rank
; i
++)
2945 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
2947 gfc_error ("Shapes for operands at %L and %L are not conformable",
2948 &op1
->where
, &op2
->where
);
2959 /* Resolve an operator expression node. This can involve replacing the
2960 operation with a user defined function call. */
2963 resolve_operator (gfc_expr
*e
)
2965 gfc_expr
*op1
, *op2
;
2967 bool dual_locus_error
;
2970 /* Resolve all subnodes-- give them types. */
2972 switch (e
->value
.op
.op
)
2975 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
2978 /* Fall through... */
2981 case INTRINSIC_UPLUS
:
2982 case INTRINSIC_UMINUS
:
2983 case INTRINSIC_PARENTHESES
:
2984 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
2989 /* Typecheck the new node. */
2991 op1
= e
->value
.op
.op1
;
2992 op2
= e
->value
.op
.op2
;
2993 dual_locus_error
= false;
2995 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
2996 || (op2
&& op2
->expr_type
== EXPR_NULL
))
2998 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3002 switch (e
->value
.op
.op
)
3004 case INTRINSIC_UPLUS
:
3005 case INTRINSIC_UMINUS
:
3006 if (op1
->ts
.type
== BT_INTEGER
3007 || op1
->ts
.type
== BT_REAL
3008 || op1
->ts
.type
== BT_COMPLEX
)
3014 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3015 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3018 case INTRINSIC_PLUS
:
3019 case INTRINSIC_MINUS
:
3020 case INTRINSIC_TIMES
:
3021 case INTRINSIC_DIVIDE
:
3022 case INTRINSIC_POWER
:
3023 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3025 gfc_type_convert_binary (e
);
3030 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3031 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3032 gfc_typename (&op2
->ts
));
3035 case INTRINSIC_CONCAT
:
3036 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3037 && op1
->ts
.kind
== op2
->ts
.kind
)
3039 e
->ts
.type
= BT_CHARACTER
;
3040 e
->ts
.kind
= op1
->ts
.kind
;
3045 _("Operands of string concatenation operator at %%L are %s/%s"),
3046 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3052 case INTRINSIC_NEQV
:
3053 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3055 e
->ts
.type
= BT_LOGICAL
;
3056 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3057 if (op1
->ts
.kind
< e
->ts
.kind
)
3058 gfc_convert_type (op1
, &e
->ts
, 2);
3059 else if (op2
->ts
.kind
< e
->ts
.kind
)
3060 gfc_convert_type (op2
, &e
->ts
, 2);
3064 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3065 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3066 gfc_typename (&op2
->ts
));
3071 if (op1
->ts
.type
== BT_LOGICAL
)
3073 e
->ts
.type
= BT_LOGICAL
;
3074 e
->ts
.kind
= op1
->ts
.kind
;
3078 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3079 gfc_typename (&op1
->ts
));
3083 case INTRINSIC_GT_OS
:
3085 case INTRINSIC_GE_OS
:
3087 case INTRINSIC_LT_OS
:
3089 case INTRINSIC_LE_OS
:
3090 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3092 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3096 /* Fall through... */
3099 case INTRINSIC_EQ_OS
:
3101 case INTRINSIC_NE_OS
:
3102 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3103 && op1
->ts
.kind
== op2
->ts
.kind
)
3105 e
->ts
.type
= BT_LOGICAL
;
3106 e
->ts
.kind
= gfc_default_logical_kind
;
3110 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3112 gfc_type_convert_binary (e
);
3114 e
->ts
.type
= BT_LOGICAL
;
3115 e
->ts
.kind
= gfc_default_logical_kind
;
3119 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3121 _("Logicals at %%L must be compared with %s instead of %s"),
3122 (e
->value
.op
.op
== INTRINSIC_EQ
3123 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3124 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3127 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3128 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3129 gfc_typename (&op2
->ts
));
3133 case INTRINSIC_USER
:
3134 if (e
->value
.op
.uop
->op
== NULL
)
3135 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3136 else if (op2
== NULL
)
3137 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3138 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3140 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3141 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3142 gfc_typename (&op2
->ts
));
3146 case INTRINSIC_PARENTHESES
:
3148 if (e
->ts
.type
== BT_CHARACTER
)
3149 e
->ts
.cl
= op1
->ts
.cl
;
3153 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3156 /* Deal with arrayness of an operand through an operator. */
3160 switch (e
->value
.op
.op
)
3162 case INTRINSIC_PLUS
:
3163 case INTRINSIC_MINUS
:
3164 case INTRINSIC_TIMES
:
3165 case INTRINSIC_DIVIDE
:
3166 case INTRINSIC_POWER
:
3167 case INTRINSIC_CONCAT
:
3171 case INTRINSIC_NEQV
:
3173 case INTRINSIC_EQ_OS
:
3175 case INTRINSIC_NE_OS
:
3177 case INTRINSIC_GT_OS
:
3179 case INTRINSIC_GE_OS
:
3181 case INTRINSIC_LT_OS
:
3183 case INTRINSIC_LE_OS
:
3185 if (op1
->rank
== 0 && op2
->rank
== 0)
3188 if (op1
->rank
== 0 && op2
->rank
!= 0)
3190 e
->rank
= op2
->rank
;
3192 if (e
->shape
== NULL
)
3193 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3196 if (op1
->rank
!= 0 && op2
->rank
== 0)
3198 e
->rank
= op1
->rank
;
3200 if (e
->shape
== NULL
)
3201 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3204 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3206 if (op1
->rank
== op2
->rank
)
3208 e
->rank
= op1
->rank
;
3209 if (e
->shape
== NULL
)
3211 t
= compare_shapes(op1
, op2
);
3215 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3220 /* Allow higher level expressions to work. */
3223 /* Try user-defined operators, and otherwise throw an error. */
3224 dual_locus_error
= true;
3226 _("Inconsistent ranks for operator at %%L and %%L"));
3233 case INTRINSIC_PARENTHESES
:
3235 case INTRINSIC_UPLUS
:
3236 case INTRINSIC_UMINUS
:
3237 /* Simply copy arrayness attribute */
3238 e
->rank
= op1
->rank
;
3240 if (e
->shape
== NULL
)
3241 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3249 /* Attempt to simplify the expression. */
3252 t
= gfc_simplify_expr (e
, 0);
3253 /* Some calls do not succeed in simplification and return FAILURE
3254 even though there is no error; e.g. variable references to
3255 PARAMETER arrays. */
3256 if (!gfc_is_constant_expr (e
))
3263 if (gfc_extend_expr (e
) == SUCCESS
)
3266 if (dual_locus_error
)
3267 gfc_error (msg
, &op1
->where
, &op2
->where
);
3269 gfc_error (msg
, &e
->where
);
3275 /************** Array resolution subroutines **************/
3278 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3281 /* Compare two integer expressions. */
3284 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3288 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3289 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3292 /* If either of the types isn't INTEGER, we must have
3293 raised an error earlier. */
3295 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3298 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3308 /* Compare an integer expression with an integer. */
3311 compare_bound_int (gfc_expr
*a
, int b
)
3315 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3318 if (a
->ts
.type
!= BT_INTEGER
)
3319 gfc_internal_error ("compare_bound_int(): Bad expression");
3321 i
= mpz_cmp_si (a
->value
.integer
, b
);
3331 /* Compare an integer expression with a mpz_t. */
3334 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3338 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3341 if (a
->ts
.type
!= BT_INTEGER
)
3342 gfc_internal_error ("compare_bound_int(): Bad expression");
3344 i
= mpz_cmp (a
->value
.integer
, b
);
3354 /* Compute the last value of a sequence given by a triplet.
3355 Return 0 if it wasn't able to compute the last value, or if the
3356 sequence if empty, and 1 otherwise. */
3359 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3360 gfc_expr
*stride
, mpz_t last
)
3364 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3365 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3366 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3369 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3370 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3373 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
3375 if (compare_bound (start
, end
) == CMP_GT
)
3377 mpz_set (last
, end
->value
.integer
);
3381 if (compare_bound_int (stride
, 0) == CMP_GT
)
3383 /* Stride is positive */
3384 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3389 /* Stride is negative */
3390 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3395 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3396 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3397 mpz_sub (last
, end
->value
.integer
, rem
);
3404 /* Compare a single dimension of an array reference to the array
3408 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3412 /* Given start, end and stride values, calculate the minimum and
3413 maximum referenced indexes. */
3415 switch (ar
->dimen_type
[i
])
3421 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3423 gfc_warning ("Array reference at %L is out of bounds "
3424 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3425 mpz_get_si (ar
->start
[i
]->value
.integer
),
3426 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3429 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3431 gfc_warning ("Array reference at %L is out of bounds "
3432 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3433 mpz_get_si (ar
->start
[i
]->value
.integer
),
3434 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3442 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3443 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3445 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3447 /* Check for zero stride, which is not allowed. */
3448 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3450 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3454 /* if start == len || (stride > 0 && start < len)
3455 || (stride < 0 && start > len),
3456 then the array section contains at least one element. In this
3457 case, there is an out-of-bounds access if
3458 (start < lower || start > upper). */
3459 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3460 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3461 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3462 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3463 && comp_start_end
== CMP_GT
))
3465 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3467 gfc_warning ("Lower array reference at %L is out of bounds "
3468 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3469 mpz_get_si (AR_START
->value
.integer
),
3470 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3473 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3475 gfc_warning ("Lower array reference at %L is out of bounds "
3476 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3477 mpz_get_si (AR_START
->value
.integer
),
3478 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3483 /* If we can compute the highest index of the array section,
3484 then it also has to be between lower and upper. */
3485 mpz_init (last_value
);
3486 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
3489 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
3491 gfc_warning ("Upper array reference at %L is out of bounds "
3492 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3493 mpz_get_si (last_value
),
3494 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3495 mpz_clear (last_value
);
3498 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
3500 gfc_warning ("Upper array reference at %L is out of bounds "
3501 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3502 mpz_get_si (last_value
),
3503 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3504 mpz_clear (last_value
);
3508 mpz_clear (last_value
);
3516 gfc_internal_error ("check_dimension(): Bad array reference");
3523 /* Compare an array reference with an array specification. */
3526 compare_spec_to_ref (gfc_array_ref
*ar
)
3533 /* TODO: Full array sections are only allowed as actual parameters. */
3534 if (as
->type
== AS_ASSUMED_SIZE
3535 && (/*ar->type == AR_FULL
3536 ||*/ (ar
->type
== AR_SECTION
3537 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
3539 gfc_error ("Rightmost upper bound of assumed size array section "
3540 "not specified at %L", &ar
->where
);
3544 if (ar
->type
== AR_FULL
)
3547 if (as
->rank
!= ar
->dimen
)
3549 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3550 &ar
->where
, ar
->dimen
, as
->rank
);
3554 for (i
= 0; i
< as
->rank
; i
++)
3555 if (check_dimension (i
, ar
, as
) == FAILURE
)
3562 /* Resolve one part of an array index. */
3565 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
3572 if (gfc_resolve_expr (index
) == FAILURE
)
3575 if (check_scalar
&& index
->rank
!= 0)
3577 gfc_error ("Array index at %L must be scalar", &index
->where
);
3581 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
3583 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3584 &index
->where
, gfc_basic_typename (index
->ts
.type
));
3588 if (index
->ts
.type
== BT_REAL
)
3589 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
3590 &index
->where
) == FAILURE
)
3593 if (index
->ts
.kind
!= gfc_index_integer_kind
3594 || index
->ts
.type
!= BT_INTEGER
)
3597 ts
.type
= BT_INTEGER
;
3598 ts
.kind
= gfc_index_integer_kind
;
3600 gfc_convert_type_warn (index
, &ts
, 2, 0);
3606 /* Resolve a dim argument to an intrinsic function. */
3609 gfc_resolve_dim_arg (gfc_expr
*dim
)
3614 if (gfc_resolve_expr (dim
) == FAILURE
)
3619 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
3624 if (dim
->ts
.type
!= BT_INTEGER
)
3626 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
3630 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
3634 ts
.type
= BT_INTEGER
;
3635 ts
.kind
= gfc_index_integer_kind
;
3637 gfc_convert_type_warn (dim
, &ts
, 2, 0);
3643 /* Given an expression that contains array references, update those array
3644 references to point to the right array specifications. While this is
3645 filled in during matching, this information is difficult to save and load
3646 in a module, so we take care of it here.
3648 The idea here is that the original array reference comes from the
3649 base symbol. We traverse the list of reference structures, setting
3650 the stored reference to references. Component references can
3651 provide an additional array specification. */
3654 find_array_spec (gfc_expr
*e
)
3658 gfc_symbol
*derived
;
3661 as
= e
->symtree
->n
.sym
->as
;
3664 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3669 gfc_internal_error ("find_array_spec(): Missing spec");
3676 if (derived
== NULL
)
3677 derived
= e
->symtree
->n
.sym
->ts
.derived
;
3679 c
= derived
->components
;
3681 for (; c
; c
= c
->next
)
3682 if (c
== ref
->u
.c
.component
)
3684 /* Track the sequence of component references. */
3685 if (c
->ts
.type
== BT_DERIVED
)
3686 derived
= c
->ts
.derived
;
3691 gfc_internal_error ("find_array_spec(): Component not found");
3693 if (c
->attr
.dimension
)
3696 gfc_internal_error ("find_array_spec(): unused as(1)");
3707 gfc_internal_error ("find_array_spec(): unused as(2)");
3711 /* Resolve an array reference. */
3714 resolve_array_ref (gfc_array_ref
*ar
)
3716 int i
, check_scalar
;
3719 for (i
= 0; i
< ar
->dimen
; i
++)
3721 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
3723 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
3725 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
3727 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
3732 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
3736 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3740 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
3741 if (e
->expr_type
== EXPR_VARIABLE
3742 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
3743 ar
->start
[i
] = gfc_get_parentheses (e
);
3747 gfc_error ("Array index at %L is an array of rank %d",
3748 &ar
->c_where
[i
], e
->rank
);
3753 /* If the reference type is unknown, figure out what kind it is. */
3755 if (ar
->type
== AR_UNKNOWN
)
3757 ar
->type
= AR_ELEMENT
;
3758 for (i
= 0; i
< ar
->dimen
; i
++)
3759 if (ar
->dimen_type
[i
] == DIMEN_RANGE
3760 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3762 ar
->type
= AR_SECTION
;
3767 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
3775 resolve_substring (gfc_ref
*ref
)
3777 if (ref
->u
.ss
.start
!= NULL
)
3779 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
3782 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
3784 gfc_error ("Substring start index at %L must be of type INTEGER",
3785 &ref
->u
.ss
.start
->where
);
3789 if (ref
->u
.ss
.start
->rank
!= 0)
3791 gfc_error ("Substring start index at %L must be scalar",
3792 &ref
->u
.ss
.start
->where
);
3796 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
3797 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3798 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3800 gfc_error ("Substring start index at %L is less than one",
3801 &ref
->u
.ss
.start
->where
);
3806 if (ref
->u
.ss
.end
!= NULL
)
3808 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
3811 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
3813 gfc_error ("Substring end index at %L must be of type INTEGER",
3814 &ref
->u
.ss
.end
->where
);
3818 if (ref
->u
.ss
.end
->rank
!= 0)
3820 gfc_error ("Substring end index at %L must be scalar",
3821 &ref
->u
.ss
.end
->where
);
3825 if (ref
->u
.ss
.length
!= NULL
3826 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
3827 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3828 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3830 gfc_error ("Substring end index at %L exceeds the string length",
3831 &ref
->u
.ss
.start
->where
);
3840 /* This function supplies missing substring charlens. */
3843 gfc_resolve_substring_charlen (gfc_expr
*e
)
3846 gfc_expr
*start
, *end
;
3848 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
3849 if (char_ref
->type
== REF_SUBSTRING
)
3855 gcc_assert (char_ref
->next
== NULL
);
3859 if (e
->ts
.cl
->length
)
3860 gfc_free_expr (e
->ts
.cl
->length
);
3861 else if (e
->expr_type
== EXPR_VARIABLE
3862 && e
->symtree
->n
.sym
->attr
.dummy
)
3866 e
->ts
.type
= BT_CHARACTER
;
3867 e
->ts
.kind
= gfc_default_character_kind
;
3871 e
->ts
.cl
= gfc_get_charlen ();
3872 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
3873 gfc_current_ns
->cl_list
= e
->ts
.cl
;
3876 if (char_ref
->u
.ss
.start
)
3877 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
3879 start
= gfc_int_expr (1);
3881 if (char_ref
->u
.ss
.end
)
3882 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
3883 else if (e
->expr_type
== EXPR_VARIABLE
)
3884 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.cl
->length
);
3891 /* Length = (end - start +1). */
3892 e
->ts
.cl
->length
= gfc_subtract (end
, start
);
3893 e
->ts
.cl
->length
= gfc_add (e
->ts
.cl
->length
, gfc_int_expr (1));
3895 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
3896 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
3898 /* Make sure that the length is simplified. */
3899 gfc_simplify_expr (e
->ts
.cl
->length
, 1);
3900 gfc_resolve_expr (e
->ts
.cl
->length
);
3904 /* Resolve subtype references. */
3907 resolve_ref (gfc_expr
*expr
)
3909 int current_part_dimension
, n_components
, seen_part_dimension
;
3912 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3913 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
3915 find_array_spec (expr
);
3919 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3923 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
3931 resolve_substring (ref
);
3935 /* Check constraints on part references. */
3937 current_part_dimension
= 0;
3938 seen_part_dimension
= 0;
3941 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3946 switch (ref
->u
.ar
.type
)
3950 current_part_dimension
= 1;
3954 current_part_dimension
= 0;
3958 gfc_internal_error ("resolve_ref(): Bad array reference");
3964 if (current_part_dimension
|| seen_part_dimension
)
3966 if (ref
->u
.c
.component
->attr
.pointer
)
3968 gfc_error ("Component to the right of a part reference "
3969 "with nonzero rank must not have the POINTER "
3970 "attribute at %L", &expr
->where
);
3973 else if (ref
->u
.c
.component
->attr
.allocatable
)
3975 gfc_error ("Component to the right of a part reference "
3976 "with nonzero rank must not have the ALLOCATABLE "
3977 "attribute at %L", &expr
->where
);
3989 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
3990 || ref
->next
== NULL
)
3991 && current_part_dimension
3992 && seen_part_dimension
)
3994 gfc_error ("Two or more part references with nonzero rank must "
3995 "not be specified at %L", &expr
->where
);
3999 if (ref
->type
== REF_COMPONENT
)
4001 if (current_part_dimension
)
4002 seen_part_dimension
= 1;
4004 /* reset to make sure */
4005 current_part_dimension
= 0;
4013 /* Given an expression, determine its shape. This is easier than it sounds.
4014 Leaves the shape array NULL if it is not possible to determine the shape. */
4017 expression_shape (gfc_expr
*e
)
4019 mpz_t array
[GFC_MAX_DIMENSIONS
];
4022 if (e
->rank
== 0 || e
->shape
!= NULL
)
4025 for (i
= 0; i
< e
->rank
; i
++)
4026 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
4029 e
->shape
= gfc_get_shape (e
->rank
);
4031 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4036 for (i
--; i
>= 0; i
--)
4037 mpz_clear (array
[i
]);
4041 /* Given a variable expression node, compute the rank of the expression by
4042 examining the base symbol and any reference structures it may have. */
4045 expression_rank (gfc_expr
*e
)
4050 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4051 could lead to serious confusion... */
4052 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4056 if (e
->expr_type
== EXPR_ARRAY
)
4058 /* Constructors can have a rank different from one via RESHAPE(). */
4060 if (e
->symtree
== NULL
)
4066 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4067 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4073 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4075 if (ref
->type
!= REF_ARRAY
)
4078 if (ref
->u
.ar
.type
== AR_FULL
)
4080 rank
= ref
->u
.ar
.as
->rank
;
4084 if (ref
->u
.ar
.type
== AR_SECTION
)
4086 /* Figure out the rank of the section. */
4088 gfc_internal_error ("expression_rank(): Two array specs");
4090 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4091 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4092 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4102 expression_shape (e
);
4106 /* Resolve a variable expression. */
4109 resolve_variable (gfc_expr
*e
)
4116 if (e
->symtree
== NULL
)
4119 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
4122 sym
= e
->symtree
->n
.sym
;
4123 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
4125 e
->ts
.type
= BT_PROCEDURE
;
4129 if (sym
->ts
.type
!= BT_UNKNOWN
)
4130 gfc_variable_attr (e
, &e
->ts
);
4133 /* Must be a simple variable reference. */
4134 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
4139 if (check_assumed_size_reference (sym
, e
))
4142 /* Deal with forward references to entries during resolve_code, to
4143 satisfy, at least partially, 12.5.2.5. */
4144 if (gfc_current_ns
->entries
4145 && current_entry_id
== sym
->entry_id
4148 && cs_base
->current
->op
!= EXEC_ENTRY
)
4150 gfc_entry_list
*entry
;
4151 gfc_formal_arglist
*formal
;
4155 /* If the symbol is a dummy... */
4156 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4158 entry
= gfc_current_ns
->entries
;
4161 /* ...test if the symbol is a parameter of previous entries. */
4162 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4163 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4165 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4169 /* If it has not been seen as a dummy, this is an error. */
4172 if (specification_expr
)
4173 gfc_error ("Variable '%s', used in a specification expression"
4174 ", is referenced at %L before the ENTRY statement "
4175 "in which it is a parameter",
4176 sym
->name
, &cs_base
->current
->loc
);
4178 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4179 "statement in which it is a parameter",
4180 sym
->name
, &cs_base
->current
->loc
);
4185 /* Now do the same check on the specification expressions. */
4186 specification_expr
= 1;
4187 if (sym
->ts
.type
== BT_CHARACTER
4188 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
4192 for (n
= 0; n
< sym
->as
->rank
; n
++)
4194 specification_expr
= 1;
4195 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
4197 specification_expr
= 1;
4198 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
4201 specification_expr
= 0;
4204 /* Update the symbol's entry level. */
4205 sym
->entry_id
= current_entry_id
+ 1;
4212 /* Checks to see that the correct symbol has been host associated.
4213 The only situation where this arises is that in which a twice
4214 contained function is parsed after the host association is made.
4215 Therefore, on detecting this, the line is rematched, having got
4216 rid of the existing references and actual_arg_list. */
4218 check_host_association (gfc_expr
*e
)
4220 gfc_symbol
*sym
, *old_sym
;
4224 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
4226 if (e
->symtree
== NULL
|| e
->symtree
->n
.sym
== NULL
)
4229 old_sym
= e
->symtree
->n
.sym
;
4231 if (old_sym
->attr
.use_assoc
)
4234 if (gfc_current_ns
->parent
4235 && old_sym
->ns
!= gfc_current_ns
)
4237 gfc_find_symbol (old_sym
->name
, gfc_current_ns
, 1, &sym
);
4238 if (sym
&& old_sym
!= sym
4239 && sym
->attr
.flavor
== FL_PROCEDURE
4240 && sym
->attr
.contained
)
4242 temp_locus
= gfc_current_locus
;
4243 gfc_current_locus
= e
->where
;
4245 gfc_buffer_error (1);
4247 gfc_free_ref_list (e
->ref
);
4252 gfc_free_actual_arglist (e
->value
.function
.actual
);
4253 e
->value
.function
.actual
= NULL
;
4256 if (e
->shape
!= NULL
)
4258 for (n
= 0; n
< e
->rank
; n
++)
4259 mpz_clear (e
->shape
[n
]);
4261 gfc_free (e
->shape
);
4264 gfc_match_rvalue (&expr
);
4266 gfc_buffer_error (0);
4268 gcc_assert (expr
&& sym
== expr
->symtree
->n
.sym
);
4274 gfc_current_locus
= temp_locus
;
4277 /* This might have changed! */
4278 return e
->expr_type
== EXPR_FUNCTION
;
4283 gfc_resolve_character_operator (gfc_expr
*e
)
4285 gfc_expr
*op1
= e
->value
.op
.op1
;
4286 gfc_expr
*op2
= e
->value
.op
.op2
;
4287 gfc_expr
*e1
= NULL
;
4288 gfc_expr
*e2
= NULL
;
4290 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
4292 if (op1
->ts
.cl
&& op1
->ts
.cl
->length
)
4293 e1
= gfc_copy_expr (op1
->ts
.cl
->length
);
4294 else if (op1
->expr_type
== EXPR_CONSTANT
)
4295 e1
= gfc_int_expr (op1
->value
.character
.length
);
4297 if (op2
->ts
.cl
&& op2
->ts
.cl
->length
)
4298 e2
= gfc_copy_expr (op2
->ts
.cl
->length
);
4299 else if (op2
->expr_type
== EXPR_CONSTANT
)
4300 e2
= gfc_int_expr (op2
->value
.character
.length
);
4302 e
->ts
.cl
= gfc_get_charlen ();
4303 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4304 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4309 e
->ts
.cl
->length
= gfc_add (e1
, e2
);
4310 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
4311 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
4312 gfc_simplify_expr (e
->ts
.cl
->length
, 0);
4313 gfc_resolve_expr (e
->ts
.cl
->length
);
4319 /* Ensure that an character expression has a charlen and, if possible, a
4320 length expression. */
4323 fixup_charlen (gfc_expr
*e
)
4325 /* The cases fall through so that changes in expression type and the need
4326 for multiple fixes are picked up. In all circumstances, a charlen should
4327 be available for the middle end to hang a backend_decl on. */
4328 switch (e
->expr_type
)
4331 gfc_resolve_character_operator (e
);
4334 if (e
->expr_type
== EXPR_ARRAY
)
4335 gfc_resolve_character_array_constructor (e
);
4337 case EXPR_SUBSTRING
:
4338 if (!e
->ts
.cl
&& e
->ref
)
4339 gfc_resolve_substring_charlen (e
);
4344 e
->ts
.cl
= gfc_get_charlen ();
4345 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4346 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4354 /* Update an actual argument to include the passed-object for type-bound
4355 procedures at the right position. */
4357 static gfc_actual_arglist
*
4358 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
)
4362 gfc_actual_arglist
* result
;
4364 result
= gfc_get_actual_arglist ();
4372 gcc_assert (argpos
> 1);
4374 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1);
4379 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4382 extract_compcall_passed_object (gfc_expr
* e
)
4386 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
4388 po
= gfc_get_expr ();
4389 po
->expr_type
= EXPR_VARIABLE
;
4390 po
->symtree
= e
->symtree
;
4391 po
->ref
= gfc_copy_ref (e
->ref
);
4393 if (gfc_resolve_expr (po
) == FAILURE
)
4400 /* Update the arglist of an EXPR_COMPCALL expression to include the
4404 update_compcall_arglist (gfc_expr
* e
)
4407 gfc_typebound_proc
* tbp
;
4409 tbp
= e
->value
.compcall
.tbp
;
4411 po
= extract_compcall_passed_object (e
);
4417 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
4427 gcc_assert (tbp
->pass_arg_num
> 0);
4428 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
4435 /* Resolve a call to a type-bound procedure, either function or subroutine,
4436 statically from the data in an EXPR_COMPCALL expression. The adapted
4437 arglist and the target-procedure symtree are returned. */
4440 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
4441 gfc_actual_arglist
** actual
)
4443 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
4444 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
4446 /* Update the actual arglist for PASS. */
4447 if (update_compcall_arglist (e
) == FAILURE
)
4450 *actual
= e
->value
.compcall
.actual
;
4451 *target
= e
->value
.compcall
.tbp
->u
.specific
;
4453 gfc_free_ref_list (e
->ref
);
4455 e
->value
.compcall
.actual
= NULL
;
4461 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4462 which of the specific bindings (if any) matches the arglist and transform
4463 the expression into a call of that binding. */
4466 resolve_typebound_generic_call (gfc_expr
* e
)
4468 gfc_typebound_proc
* genproc
;
4469 const char* genname
;
4471 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
4472 genname
= e
->value
.compcall
.name
;
4473 genproc
= e
->value
.compcall
.tbp
;
4475 if (!genproc
->is_generic
)
4478 /* Try the bindings on this type and in the inheritance hierarchy. */
4479 for (; genproc
; genproc
= genproc
->overridden
)
4483 gcc_assert (genproc
->is_generic
);
4484 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
4487 gfc_actual_arglist
* args
;
4490 gcc_assert (g
->specific
);
4491 target
= g
->specific
->u
.specific
->n
.sym
;
4493 /* Get the right arglist by handling PASS/NOPASS. */
4494 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
4495 if (!g
->specific
->nopass
)
4498 po
= extract_compcall_passed_object (e
);
4502 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
);
4505 /* Check if this arglist matches the formal. */
4506 matches
= gfc_compare_actual_formal (&args
, target
->formal
, 1,
4507 target
->attr
.elemental
, NULL
);
4509 /* Clean up and break out of the loop if we've found it. */
4510 gfc_free_actual_arglist (args
);
4513 e
->value
.compcall
.tbp
= g
->specific
;
4519 /* Nothing matching found! */
4520 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4521 " '%s' at %L", genname
, &e
->where
);
4529 /* Resolve a call to a type-bound subroutine. */
4532 resolve_typebound_call (gfc_code
* c
)
4534 gfc_actual_arglist
* newactual
;
4535 gfc_symtree
* target
;
4537 /* Check that's really a SUBROUTINE. */
4538 if (!c
->expr
->value
.compcall
.tbp
->subroutine
)
4540 gfc_error ("'%s' at %L should be a SUBROUTINE",
4541 c
->expr
->value
.compcall
.name
, &c
->loc
);
4545 if (resolve_typebound_generic_call (c
->expr
) == FAILURE
)
4548 /* Transform into an ordinary EXEC_CALL for now. */
4550 if (resolve_typebound_static (c
->expr
, &target
, &newactual
) == FAILURE
)
4553 c
->ext
.actual
= newactual
;
4554 c
->symtree
= target
;
4557 gcc_assert (!c
->expr
->ref
&& !c
->expr
->value
.compcall
.actual
);
4558 gfc_free_expr (c
->expr
);
4561 return resolve_call (c
);
4565 /* Resolve a component-call expression. */
4568 resolve_compcall (gfc_expr
* e
)
4570 gfc_actual_arglist
* newactual
;
4571 gfc_symtree
* target
;
4573 /* Check that's really a FUNCTION. */
4574 if (!e
->value
.compcall
.tbp
->function
)
4576 gfc_error ("'%s' at %L should be a FUNCTION",
4577 e
->value
.compcall
.name
, &e
->where
);
4581 if (resolve_typebound_generic_call (e
) == FAILURE
)
4583 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
4585 /* Take the rank from the function's symbol. */
4586 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
4587 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
4589 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
4590 arglist to the TBP's binding target. */
4592 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
4595 e
->value
.function
.actual
= newactual
;
4596 e
->value
.function
.name
= e
->value
.compcall
.name
;
4597 e
->value
.function
.isym
= NULL
;
4598 e
->value
.function
.esym
= NULL
;
4599 e
->symtree
= target
;
4600 e
->expr_type
= EXPR_FUNCTION
;
4602 return gfc_resolve_expr (e
);
4606 /* Resolve an expression. That is, make sure that types of operands agree
4607 with their operators, intrinsic operators are converted to function calls
4608 for overloaded types and unresolved function references are resolved. */
4611 gfc_resolve_expr (gfc_expr
*e
)
4618 switch (e
->expr_type
)
4621 t
= resolve_operator (e
);
4627 if (check_host_association (e
))
4628 t
= resolve_function (e
);
4631 t
= resolve_variable (e
);
4633 expression_rank (e
);
4636 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.cl
== NULL
&& e
->ref
4637 && e
->ref
->type
!= REF_SUBSTRING
)
4638 gfc_resolve_substring_charlen (e
);
4643 t
= resolve_compcall (e
);
4646 case EXPR_SUBSTRING
:
4647 t
= resolve_ref (e
);
4657 if (resolve_ref (e
) == FAILURE
)
4660 t
= gfc_resolve_array_constructor (e
);
4661 /* Also try to expand a constructor. */
4664 expression_rank (e
);
4665 gfc_expand_constructor (e
);
4668 /* This provides the opportunity for the length of constructors with
4669 character valued function elements to propagate the string length
4670 to the expression. */
4671 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
4672 t
= gfc_resolve_character_array_constructor (e
);
4676 case EXPR_STRUCTURE
:
4677 t
= resolve_ref (e
);
4681 t
= resolve_structure_cons (e
);
4685 t
= gfc_simplify_expr (e
, 0);
4689 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4692 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.cl
)
4699 /* Resolve an expression from an iterator. They must be scalar and have
4700 INTEGER or (optionally) REAL type. */
4703 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
4704 const char *name_msgid
)
4706 if (gfc_resolve_expr (expr
) == FAILURE
)
4709 if (expr
->rank
!= 0)
4711 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
4715 if (expr
->ts
.type
!= BT_INTEGER
)
4717 if (expr
->ts
.type
== BT_REAL
)
4720 return gfc_notify_std (GFC_STD_F95_DEL
,
4721 "Deleted feature: %s at %L must be integer",
4722 _(name_msgid
), &expr
->where
);
4725 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
4732 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
4740 /* Resolve the expressions in an iterator structure. If REAL_OK is
4741 false allow only INTEGER type iterators, otherwise allow REAL types. */
4744 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
4746 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
4750 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
4752 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4757 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
4758 "Start expression in DO loop") == FAILURE
)
4761 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
4762 "End expression in DO loop") == FAILURE
)
4765 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
4766 "Step expression in DO loop") == FAILURE
)
4769 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
4771 if ((iter
->step
->ts
.type
== BT_INTEGER
4772 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
4773 || (iter
->step
->ts
.type
== BT_REAL
4774 && mpfr_sgn (iter
->step
->value
.real
) == 0))
4776 gfc_error ("Step expression in DO loop at %L cannot be zero",
4777 &iter
->step
->where
);
4782 /* Convert start, end, and step to the same type as var. */
4783 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
4784 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
4785 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4787 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
4788 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
4789 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4791 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
4792 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
4793 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
4799 /* Traversal function for find_forall_index. f == 2 signals that
4800 that variable itself is not to be checked - only the references. */
4803 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
4805 if (expr
->expr_type
!= EXPR_VARIABLE
)
4808 /* A scalar assignment */
4809 if (!expr
->ref
|| *f
== 1)
4811 if (expr
->symtree
->n
.sym
== sym
)
4823 /* Check whether the FORALL index appears in the expression or not.
4824 Returns SUCCESS if SYM is found in EXPR. */
4827 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
4829 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
4836 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4837 to be a scalar INTEGER variable. The subscripts and stride are scalar
4838 INTEGERs, and if stride is a constant it must be nonzero.
4839 Furthermore "A subscript or stride in a forall-triplet-spec shall
4840 not contain a reference to any index-name in the
4841 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4844 resolve_forall_iterators (gfc_forall_iterator
*it
)
4846 gfc_forall_iterator
*iter
, *iter2
;
4848 for (iter
= it
; iter
; iter
= iter
->next
)
4850 if (gfc_resolve_expr (iter
->var
) == SUCCESS
4851 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
4852 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4855 if (gfc_resolve_expr (iter
->start
) == SUCCESS
4856 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
4857 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4858 &iter
->start
->where
);
4859 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
4860 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4862 if (gfc_resolve_expr (iter
->end
) == SUCCESS
4863 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
4864 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4866 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
4867 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4869 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
4871 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
4872 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4873 &iter
->stride
->where
, "INTEGER");
4875 if (iter
->stride
->expr_type
== EXPR_CONSTANT
4876 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
4877 gfc_error ("FORALL stride expression at %L cannot be zero",
4878 &iter
->stride
->where
);
4880 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
4881 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
4884 for (iter
= it
; iter
; iter
= iter
->next
)
4885 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
4887 if (find_forall_index (iter2
->start
,
4888 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
4889 || find_forall_index (iter2
->end
,
4890 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
4891 || find_forall_index (iter2
->stride
,
4892 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
4893 gfc_error ("FORALL index '%s' may not appear in triplet "
4894 "specification at %L", iter
->var
->symtree
->name
,
4895 &iter2
->start
->where
);
4900 /* Given a pointer to a symbol that is a derived type, see if it's
4901 inaccessible, i.e. if it's defined in another module and the components are
4902 PRIVATE. The search is recursive if necessary. Returns zero if no
4903 inaccessible components are found, nonzero otherwise. */
4906 derived_inaccessible (gfc_symbol
*sym
)
4910 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
4913 for (c
= sym
->components
; c
; c
= c
->next
)
4915 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
4923 /* Resolve the argument of a deallocate expression. The expression must be
4924 a pointer or a full array. */
4927 resolve_deallocate_expr (gfc_expr
*e
)
4929 symbol_attribute attr
;
4930 int allocatable
, pointer
, check_intent_in
;
4933 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4934 check_intent_in
= 1;
4936 if (gfc_resolve_expr (e
) == FAILURE
)
4939 if (e
->expr_type
!= EXPR_VARIABLE
)
4942 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
4943 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
4944 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4947 check_intent_in
= 0;
4952 if (ref
->u
.ar
.type
!= AR_FULL
)
4957 allocatable
= (ref
->u
.c
.component
->as
!= NULL
4958 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
4959 pointer
= ref
->u
.c
.component
->attr
.pointer
;
4968 attr
= gfc_expr_attr (e
);
4970 if (allocatable
== 0 && attr
.pointer
== 0)
4973 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4974 "ALLOCATABLE or a POINTER", &e
->where
);
4978 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
4980 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4981 e
->symtree
->n
.sym
->name
, &e
->where
);
4989 /* Returns true if the expression e contains a reference to the symbol sym. */
4991 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
4993 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
5000 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
5002 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
5006 /* Given the expression node e for an allocatable/pointer of derived type to be
5007 allocated, get the expression node to be initialized afterwards (needed for
5008 derived types with default initializers, and derived types with allocatable
5009 components that need nullification.) */
5012 expr_to_initialize (gfc_expr
*e
)
5018 result
= gfc_copy_expr (e
);
5020 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5021 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
5022 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5024 ref
->u
.ar
.type
= AR_FULL
;
5026 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5027 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
5029 result
->rank
= ref
->u
.ar
.dimen
;
5037 /* Resolve the expression in an ALLOCATE statement, doing the additional
5038 checks to see whether the expression is OK or not. The expression must
5039 have a trailing array reference that gives the size of the array. */
5042 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
5044 int i
, pointer
, allocatable
, dimension
, check_intent_in
;
5045 symbol_attribute attr
;
5046 gfc_ref
*ref
, *ref2
;
5053 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5054 check_intent_in
= 1;
5056 if (gfc_resolve_expr (e
) == FAILURE
)
5059 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
5060 sym
= code
->expr
->symtree
->n
.sym
;
5064 /* Make sure the expression is allocatable or a pointer. If it is
5065 pointer, the next-to-last reference must be a pointer. */
5069 if (e
->expr_type
!= EXPR_VARIABLE
)
5072 attr
= gfc_expr_attr (e
);
5073 pointer
= attr
.pointer
;
5074 dimension
= attr
.dimension
;
5078 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
5079 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
5080 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
5082 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
5084 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
5085 "not be allocated in the same statement at %L",
5086 sym
->name
, &e
->where
);
5090 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
5093 check_intent_in
= 0;
5098 if (ref
->next
!= NULL
)
5103 allocatable
= (ref
->u
.c
.component
->as
!= NULL
5104 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
5106 pointer
= ref
->u
.c
.component
->attr
.pointer
;
5107 dimension
= ref
->u
.c
.component
->attr
.dimension
;
5118 if (allocatable
== 0 && pointer
== 0)
5120 gfc_error ("Expression in ALLOCATE statement at %L must be "
5121 "ALLOCATABLE or a POINTER", &e
->where
);
5126 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
5128 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
5129 e
->symtree
->n
.sym
->name
, &e
->where
);
5133 /* Add default initializer for those derived types that need them. */
5134 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
5136 init_st
= gfc_get_code ();
5137 init_st
->loc
= code
->loc
;
5138 init_st
->op
= EXEC_INIT_ASSIGN
;
5139 init_st
->expr
= expr_to_initialize (e
);
5140 init_st
->expr2
= init_e
;
5141 init_st
->next
= code
->next
;
5142 code
->next
= init_st
;
5145 if (pointer
&& dimension
== 0)
5148 /* Make sure the next-to-last reference node is an array specification. */
5150 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
5152 gfc_error ("Array specification required in ALLOCATE statement "
5153 "at %L", &e
->where
);
5157 /* Make sure that the array section reference makes sense in the
5158 context of an ALLOCATE specification. */
5162 for (i
= 0; i
< ar
->dimen
; i
++)
5164 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
5167 switch (ar
->dimen_type
[i
])
5173 if (ar
->start
[i
] != NULL
5174 && ar
->end
[i
] != NULL
5175 && ar
->stride
[i
] == NULL
)
5178 /* Fall Through... */
5182 gfc_error ("Bad array specification in ALLOCATE statement at %L",
5189 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5191 sym
= a
->expr
->symtree
->n
.sym
;
5193 /* TODO - check derived type components. */
5194 if (sym
->ts
.type
== BT_DERIVED
)
5197 if ((ar
->start
[i
] != NULL
5198 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
5199 || (ar
->end
[i
] != NULL
5200 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
5202 gfc_error ("'%s' must not appear in the array specification at "
5203 "%L in the same ALLOCATE statement where it is "
5204 "itself allocated", sym
->name
, &ar
->where
);
5214 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
5216 gfc_symbol
*s
= NULL
;
5220 s
= code
->expr
->symtree
->n
.sym
;
5224 if (s
->attr
.intent
== INTENT_IN
)
5225 gfc_error ("STAT variable '%s' of %s statement at %C cannot "
5226 "be INTENT(IN)", s
->name
, fcn
);
5228 if (gfc_pure (NULL
) && gfc_impure_variable (s
))
5229 gfc_error ("Illegal STAT variable in %s statement at %C "
5230 "for a PURE procedure", fcn
);
5233 if (s
&& code
->expr
->ts
.type
!= BT_INTEGER
)
5234 gfc_error ("STAT tag in %s statement at %L must be "
5235 "of type INTEGER", fcn
, &code
->expr
->where
);
5237 if (strcmp (fcn
, "ALLOCATE") == 0)
5239 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5240 resolve_allocate_expr (a
->expr
, code
);
5244 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5245 resolve_deallocate_expr (a
->expr
);
5249 /************ SELECT CASE resolution subroutines ************/
5251 /* Callback function for our mergesort variant. Determines interval
5252 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
5253 op1 > op2. Assumes we're not dealing with the default case.
5254 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
5255 There are nine situations to check. */
5258 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
5262 if (op1
->low
== NULL
) /* op1 = (:L) */
5264 /* op2 = (:N), so overlap. */
5266 /* op2 = (M:) or (M:N), L < M */
5267 if (op2
->low
!= NULL
5268 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
5271 else if (op1
->high
== NULL
) /* op1 = (K:) */
5273 /* op2 = (M:), so overlap. */
5275 /* op2 = (:N) or (M:N), K > N */
5276 if (op2
->high
!= NULL
5277 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
5280 else /* op1 = (K:L) */
5282 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
5283 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
5285 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
5286 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
5288 else /* op2 = (M:N) */
5292 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
5295 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
5304 /* Merge-sort a double linked case list, detecting overlap in the
5305 process. LIST is the head of the double linked case list before it
5306 is sorted. Returns the head of the sorted list if we don't see any
5307 overlap, or NULL otherwise. */
5310 check_case_overlap (gfc_case
*list
)
5312 gfc_case
*p
, *q
, *e
, *tail
;
5313 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
5315 /* If the passed list was empty, return immediately. */
5322 /* Loop unconditionally. The only exit from this loop is a return
5323 statement, when we've finished sorting the case list. */
5330 /* Count the number of merges we do in this pass. */
5333 /* Loop while there exists a merge to be done. */
5338 /* Count this merge. */
5341 /* Cut the list in two pieces by stepping INSIZE places
5342 forward in the list, starting from P. */
5345 for (i
= 0; i
< insize
; i
++)
5354 /* Now we have two lists. Merge them! */
5355 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
5357 /* See from which the next case to merge comes from. */
5360 /* P is empty so the next case must come from Q. */
5365 else if (qsize
== 0 || q
== NULL
)
5374 cmp
= compare_cases (p
, q
);
5377 /* The whole case range for P is less than the
5385 /* The whole case range for Q is greater than
5386 the case range for P. */
5393 /* The cases overlap, or they are the same
5394 element in the list. Either way, we must
5395 issue an error and get the next case from P. */
5396 /* FIXME: Sort P and Q by line number. */
5397 gfc_error ("CASE label at %L overlaps with CASE "
5398 "label at %L", &p
->where
, &q
->where
);
5406 /* Add the next element to the merged list. */
5415 /* P has now stepped INSIZE places along, and so has Q. So
5416 they're the same. */
5421 /* If we have done only one merge or none at all, we've
5422 finished sorting the cases. */
5431 /* Otherwise repeat, merging lists twice the size. */
5437 /* Check to see if an expression is suitable for use in a CASE statement.
5438 Makes sure that all case expressions are scalar constants of the same
5439 type. Return FAILURE if anything is wrong. */
5442 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
5444 if (e
== NULL
) return SUCCESS
;
5446 if (e
->ts
.type
!= case_expr
->ts
.type
)
5448 gfc_error ("Expression in CASE statement at %L must be of type %s",
5449 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
5453 /* C805 (R808) For a given case-construct, each case-value shall be of
5454 the same type as case-expr. For character type, length differences
5455 are allowed, but the kind type parameters shall be the same. */
5457 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
5459 gfc_error ("Expression in CASE statement at %L must be of kind %d",
5460 &e
->where
, case_expr
->ts
.kind
);
5464 /* Convert the case value kind to that of case expression kind, if needed.
5465 FIXME: Should a warning be issued? */
5466 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
5467 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
5471 gfc_error ("Expression in CASE statement at %L must be scalar",
5480 /* Given a completely parsed select statement, we:
5482 - Validate all expressions and code within the SELECT.
5483 - Make sure that the selection expression is not of the wrong type.
5484 - Make sure that no case ranges overlap.
5485 - Eliminate unreachable cases and unreachable code resulting from
5486 removing case labels.
5488 The standard does allow unreachable cases, e.g. CASE (5:3). But
5489 they are a hassle for code generation, and to prevent that, we just
5490 cut them out here. This is not necessary for overlapping cases
5491 because they are illegal and we never even try to generate code.
5493 We have the additional caveat that a SELECT construct could have
5494 been a computed GOTO in the source code. Fortunately we can fairly
5495 easily work around that here: The case_expr for a "real" SELECT CASE
5496 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5497 we have to do is make sure that the case_expr is a scalar integer
5501 resolve_select (gfc_code
*code
)
5504 gfc_expr
*case_expr
;
5505 gfc_case
*cp
, *default_case
, *tail
, *head
;
5506 int seen_unreachable
;
5512 if (code
->expr
== NULL
)
5514 /* This was actually a computed GOTO statement. */
5515 case_expr
= code
->expr2
;
5516 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
5517 gfc_error ("Selection expression in computed GOTO statement "
5518 "at %L must be a scalar integer expression",
5521 /* Further checking is not necessary because this SELECT was built
5522 by the compiler, so it should always be OK. Just move the
5523 case_expr from expr2 to expr so that we can handle computed
5524 GOTOs as normal SELECTs from here on. */
5525 code
->expr
= code
->expr2
;
5530 case_expr
= code
->expr
;
5532 type
= case_expr
->ts
.type
;
5533 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
5535 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5536 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
5538 /* Punt. Going on here just produce more garbage error messages. */
5542 if (case_expr
->rank
!= 0)
5544 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5545 "expression", &case_expr
->where
);
5551 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5552 of the SELECT CASE expression and its CASE values. Walk the lists
5553 of case values, and if we find a mismatch, promote case_expr to
5554 the appropriate kind. */
5556 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
5558 for (body
= code
->block
; body
; body
= body
->block
)
5560 /* Walk the case label list. */
5561 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5563 /* Intercept the DEFAULT case. It does not have a kind. */
5564 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5567 /* Unreachable case ranges are discarded, so ignore. */
5568 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5569 && cp
->low
!= cp
->high
5570 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
5573 /* FIXME: Should a warning be issued? */
5575 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
5576 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
5578 if (cp
->high
!= NULL
5579 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
5580 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
5585 /* Assume there is no DEFAULT case. */
5586 default_case
= NULL
;
5591 for (body
= code
->block
; body
; body
= body
->block
)
5593 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5595 seen_unreachable
= 0;
5597 /* Walk the case label list, making sure that all case labels
5599 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5601 /* Count the number of cases in the whole construct. */
5604 /* Intercept the DEFAULT case. */
5605 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5607 if (default_case
!= NULL
)
5609 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5610 "by a second DEFAULT CASE at %L",
5611 &default_case
->where
, &cp
->where
);
5622 /* Deal with single value cases and case ranges. Errors are
5623 issued from the validation function. */
5624 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
5625 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
5631 if (type
== BT_LOGICAL
5632 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
5633 || cp
->low
!= cp
->high
))
5635 gfc_error ("Logical range in CASE statement at %L is not "
5636 "allowed", &cp
->low
->where
);
5641 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
5644 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
5645 if (value
& seen_logical
)
5647 gfc_error ("constant logical value in CASE statement "
5648 "is repeated at %L",
5653 seen_logical
|= value
;
5656 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5657 && cp
->low
!= cp
->high
5658 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
5660 if (gfc_option
.warn_surprising
)
5661 gfc_warning ("Range specification at %L can never "
5662 "be matched", &cp
->where
);
5664 cp
->unreachable
= 1;
5665 seen_unreachable
= 1;
5669 /* If the case range can be matched, it can also overlap with
5670 other cases. To make sure it does not, we put it in a
5671 double linked list here. We sort that with a merge sort
5672 later on to detect any overlapping cases. */
5676 head
->right
= head
->left
= NULL
;
5681 tail
->right
->left
= tail
;
5688 /* It there was a failure in the previous case label, give up
5689 for this case label list. Continue with the next block. */
5693 /* See if any case labels that are unreachable have been seen.
5694 If so, we eliminate them. This is a bit of a kludge because
5695 the case lists for a single case statement (label) is a
5696 single forward linked lists. */
5697 if (seen_unreachable
)
5699 /* Advance until the first case in the list is reachable. */
5700 while (body
->ext
.case_list
!= NULL
5701 && body
->ext
.case_list
->unreachable
)
5703 gfc_case
*n
= body
->ext
.case_list
;
5704 body
->ext
.case_list
= body
->ext
.case_list
->next
;
5706 gfc_free_case_list (n
);
5709 /* Strip all other unreachable cases. */
5710 if (body
->ext
.case_list
)
5712 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
5714 if (cp
->next
->unreachable
)
5716 gfc_case
*n
= cp
->next
;
5717 cp
->next
= cp
->next
->next
;
5719 gfc_free_case_list (n
);
5726 /* See if there were overlapping cases. If the check returns NULL,
5727 there was overlap. In that case we don't do anything. If head
5728 is non-NULL, we prepend the DEFAULT case. The sorted list can
5729 then used during code generation for SELECT CASE constructs with
5730 a case expression of a CHARACTER type. */
5733 head
= check_case_overlap (head
);
5735 /* Prepend the default_case if it is there. */
5736 if (head
!= NULL
&& default_case
)
5738 default_case
->left
= NULL
;
5739 default_case
->right
= head
;
5740 head
->left
= default_case
;
5744 /* Eliminate dead blocks that may be the result if we've seen
5745 unreachable case labels for a block. */
5746 for (body
= code
; body
&& body
->block
; body
= body
->block
)
5748 if (body
->block
->ext
.case_list
== NULL
)
5750 /* Cut the unreachable block from the code chain. */
5751 gfc_code
*c
= body
->block
;
5752 body
->block
= c
->block
;
5754 /* Kill the dead block, but not the blocks below it. */
5756 gfc_free_statements (c
);
5760 /* More than two cases is legal but insane for logical selects.
5761 Issue a warning for it. */
5762 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
5764 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5769 /* Resolve a transfer statement. This is making sure that:
5770 -- a derived type being transferred has only non-pointer components
5771 -- a derived type being transferred doesn't have private components, unless
5772 it's being transferred from the module where the type was defined
5773 -- we're not trying to transfer a whole assumed size array. */
5776 resolve_transfer (gfc_code
*code
)
5785 if (exp
->expr_type
!= EXPR_VARIABLE
&& exp
->expr_type
!= EXPR_FUNCTION
)
5788 sym
= exp
->symtree
->n
.sym
;
5791 /* Go to actual component transferred. */
5792 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
5793 if (ref
->type
== REF_COMPONENT
)
5794 ts
= &ref
->u
.c
.component
->ts
;
5796 if (ts
->type
== BT_DERIVED
)
5798 /* Check that transferred derived type doesn't contain POINTER
5800 if (ts
->derived
->attr
.pointer_comp
)
5802 gfc_error ("Data transfer element at %L cannot have "
5803 "POINTER components", &code
->loc
);
5807 if (ts
->derived
->attr
.alloc_comp
)
5809 gfc_error ("Data transfer element at %L cannot have "
5810 "ALLOCATABLE components", &code
->loc
);
5814 if (derived_inaccessible (ts
->derived
))
5816 gfc_error ("Data transfer element at %L cannot have "
5817 "PRIVATE components",&code
->loc
);
5822 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
5823 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
5825 gfc_error ("Data transfer element at %L cannot be a full reference to "
5826 "an assumed-size array", &code
->loc
);
5832 /*********** Toplevel code resolution subroutines ***********/
5834 /* Find the set of labels that are reachable from this block. We also
5835 record the last statement in each block so that we don't have to do
5836 a linear search to find the END DO statements of the blocks. */
5839 reachable_labels (gfc_code
*block
)
5846 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
5848 /* Collect labels in this block. */
5849 for (c
= block
; c
; c
= c
->next
)
5852 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
5854 if (!c
->next
&& cs_base
->prev
)
5855 cs_base
->prev
->tail
= c
;
5858 /* Merge with labels from parent block. */
5861 gcc_assert (cs_base
->prev
->reachable_labels
);
5862 bitmap_ior_into (cs_base
->reachable_labels
,
5863 cs_base
->prev
->reachable_labels
);
5867 /* Given a branch to a label and a namespace, if the branch is conforming.
5868 The code node describes where the branch is located. */
5871 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
5878 /* Step one: is this a valid branching target? */
5880 if (label
->defined
== ST_LABEL_UNKNOWN
)
5882 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
5887 if (label
->defined
!= ST_LABEL_TARGET
)
5889 gfc_error ("Statement at %L is not a valid branch target statement "
5890 "for the branch statement at %L", &label
->where
, &code
->loc
);
5894 /* Step two: make sure this branch is not a branch to itself ;-) */
5896 if (code
->here
== label
)
5898 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
5902 /* Step three: See if the label is in the same block as the
5903 branching statement. The hard work has been done by setting up
5904 the bitmap reachable_labels. */
5906 if (!bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
5908 /* The label is not in an enclosing block, so illegal. This was
5909 allowed in Fortran 66, so we allow it as extension. No
5910 further checks are necessary in this case. */
5911 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
5912 "as the GOTO statement at %L", &label
->where
,
5917 /* Step four: Make sure that the branching target is legal if
5918 the statement is an END {SELECT,IF}. */
5920 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5921 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
5924 if (stack
&& stack
->current
->next
->op
== EXEC_NOP
)
5926 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps to "
5927 "END of construct at %L", &code
->loc
,
5928 &stack
->current
->next
->loc
);
5929 return; /* We know this is not an END DO. */
5932 /* Step five: Make sure that we're not jumping to the end of a DO
5933 loop from within the loop. */
5935 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5936 if ((stack
->current
->op
== EXEC_DO
5937 || stack
->current
->op
== EXEC_DO_WHILE
)
5938 && stack
->tail
->here
== label
&& stack
->tail
->op
== EXEC_NOP
)
5940 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps "
5941 "to END of construct at %L", &code
->loc
,
5949 /* Check whether EXPR1 has the same shape as EXPR2. */
5952 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
5954 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5955 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
5956 gfc_try result
= FAILURE
;
5959 /* Compare the rank. */
5960 if (expr1
->rank
!= expr2
->rank
)
5963 /* Compare the size of each dimension. */
5964 for (i
=0; i
<expr1
->rank
; i
++)
5966 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
5969 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
5972 if (mpz_cmp (shape
[i
], shape2
[i
]))
5976 /* When either of the two expression is an assumed size array, we
5977 ignore the comparison of dimension sizes. */
5982 for (i
--; i
>= 0; i
--)
5984 mpz_clear (shape
[i
]);
5985 mpz_clear (shape2
[i
]);
5991 /* Check whether a WHERE assignment target or a WHERE mask expression
5992 has the same shape as the outmost WHERE mask expression. */
5995 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
6001 cblock
= code
->block
;
6003 /* Store the first WHERE mask-expr of the WHERE statement or construct.
6004 In case of nested WHERE, only the outmost one is stored. */
6005 if (mask
== NULL
) /* outmost WHERE */
6007 else /* inner WHERE */
6014 /* Check if the mask-expr has a consistent shape with the
6015 outmost WHERE mask-expr. */
6016 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
6017 gfc_error ("WHERE mask at %L has inconsistent shape",
6018 &cblock
->expr
->where
);
6021 /* the assignment statement of a WHERE statement, or the first
6022 statement in where-body-construct of a WHERE construct */
6023 cnext
= cblock
->next
;
6028 /* WHERE assignment statement */
6031 /* Check shape consistent for WHERE assignment target. */
6032 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
6033 gfc_error ("WHERE assignment target at %L has "
6034 "inconsistent shape", &cnext
->expr
->where
);
6038 case EXEC_ASSIGN_CALL
:
6039 resolve_call (cnext
);
6040 if (!cnext
->resolved_sym
->attr
.elemental
)
6041 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6042 &cnext
->ext
.actual
->expr
->where
);
6045 /* WHERE or WHERE construct is part of a where-body-construct */
6047 resolve_where (cnext
, e
);
6051 gfc_error ("Unsupported statement inside WHERE at %L",
6054 /* the next statement within the same where-body-construct */
6055 cnext
= cnext
->next
;
6057 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6058 cblock
= cblock
->block
;
6063 /* Resolve assignment in FORALL construct.
6064 NVAR is the number of FORALL index variables, and VAR_EXPR records the
6065 FORALL index variables. */
6068 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
6072 for (n
= 0; n
< nvar
; n
++)
6074 gfc_symbol
*forall_index
;
6076 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
6078 /* Check whether the assignment target is one of the FORALL index
6080 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
6081 && (code
->expr
->symtree
->n
.sym
== forall_index
))
6082 gfc_error ("Assignment to a FORALL index variable at %L",
6083 &code
->expr
->where
);
6086 /* If one of the FORALL index variables doesn't appear in the
6087 assignment target, then there will be a many-to-one
6089 if (find_forall_index (code
->expr
, forall_index
, 0) == FAILURE
)
6090 gfc_error ("The FORALL with index '%s' cause more than one "
6091 "assignment to this object at %L",
6092 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
6098 /* Resolve WHERE statement in FORALL construct. */
6101 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
6102 gfc_expr
**var_expr
)
6107 cblock
= code
->block
;
6110 /* the assignment statement of a WHERE statement, or the first
6111 statement in where-body-construct of a WHERE construct */
6112 cnext
= cblock
->next
;
6117 /* WHERE assignment statement */
6119 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
6122 /* WHERE operator assignment statement */
6123 case EXEC_ASSIGN_CALL
:
6124 resolve_call (cnext
);
6125 if (!cnext
->resolved_sym
->attr
.elemental
)
6126 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6127 &cnext
->ext
.actual
->expr
->where
);
6130 /* WHERE or WHERE construct is part of a where-body-construct */
6132 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
6136 gfc_error ("Unsupported statement inside WHERE at %L",
6139 /* the next statement within the same where-body-construct */
6140 cnext
= cnext
->next
;
6142 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6143 cblock
= cblock
->block
;
6148 /* Traverse the FORALL body to check whether the following errors exist:
6149 1. For assignment, check if a many-to-one assignment happens.
6150 2. For WHERE statement, check the WHERE body to see if there is any
6151 many-to-one assignment. */
6154 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
6158 c
= code
->block
->next
;
6164 case EXEC_POINTER_ASSIGN
:
6165 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
6168 case EXEC_ASSIGN_CALL
:
6172 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
6173 there is no need to handle it here. */
6177 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
6182 /* The next statement in the FORALL body. */
6188 /* Given a FORALL construct, first resolve the FORALL iterator, then call
6189 gfc_resolve_forall_body to resolve the FORALL body. */
6192 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
6194 static gfc_expr
**var_expr
;
6195 static int total_var
= 0;
6196 static int nvar
= 0;
6197 gfc_forall_iterator
*fa
;
6201 /* Start to resolve a FORALL construct */
6202 if (forall_save
== 0)
6204 /* Count the total number of FORALL index in the nested FORALL
6205 construct in order to allocate the VAR_EXPR with proper size. */
6207 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
6209 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
6211 next
= next
->block
->next
;
6214 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
6215 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
6218 /* The information about FORALL iterator, including FORALL index start, end
6219 and stride. The FORALL index can not appear in start, end or stride. */
6220 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
6222 /* Check if any outer FORALL index name is the same as the current
6224 for (i
= 0; i
< nvar
; i
++)
6226 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
6228 gfc_error ("An outer FORALL construct already has an index "
6229 "with this name %L", &fa
->var
->where
);
6233 /* Record the current FORALL index. */
6234 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
6239 /* Resolve the FORALL body. */
6240 gfc_resolve_forall_body (code
, nvar
, var_expr
);
6242 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
6243 gfc_resolve_blocks (code
->block
, ns
);
6245 /* Free VAR_EXPR after the whole FORALL construct resolved. */
6246 for (i
= 0; i
< total_var
; i
++)
6247 gfc_free_expr (var_expr
[i
]);
6249 /* Reset the counters. */
6255 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
6258 static void resolve_code (gfc_code
*, gfc_namespace
*);
6261 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
6265 for (; b
; b
= b
->block
)
6267 t
= gfc_resolve_expr (b
->expr
);
6268 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
6274 if (t
== SUCCESS
&& b
->expr
!= NULL
6275 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
6276 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6283 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
== 0))
6284 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
6289 resolve_branch (b
->label
, b
);
6302 case EXEC_OMP_ATOMIC
:
6303 case EXEC_OMP_CRITICAL
:
6305 case EXEC_OMP_MASTER
:
6306 case EXEC_OMP_ORDERED
:
6307 case EXEC_OMP_PARALLEL
:
6308 case EXEC_OMP_PARALLEL_DO
:
6309 case EXEC_OMP_PARALLEL_SECTIONS
:
6310 case EXEC_OMP_PARALLEL_WORKSHARE
:
6311 case EXEC_OMP_SECTIONS
:
6312 case EXEC_OMP_SINGLE
:
6314 case EXEC_OMP_TASKWAIT
:
6315 case EXEC_OMP_WORKSHARE
:
6319 gfc_internal_error ("resolve_block(): Bad block type");
6322 resolve_code (b
->next
, ns
);
6327 /* Does everything to resolve an ordinary assignment. Returns true
6328 if this is an interface assignment. */
6330 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
6340 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
6342 lhs
= code
->ext
.actual
->expr
;
6343 rhs
= code
->ext
.actual
->next
->expr
;
6344 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
6346 gfc_error ("Subroutine '%s' called instead of assignment at "
6347 "%L must be PURE", code
->symtree
->n
.sym
->name
,
6352 /* Make a temporary rhs when there is a default initializer
6353 and rhs is the same symbol as the lhs. */
6354 if (rhs
->expr_type
== EXPR_VARIABLE
6355 && rhs
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
6356 && has_default_initializer (rhs
->symtree
->n
.sym
->ts
.derived
)
6357 && (lhs
->symtree
->n
.sym
== rhs
->symtree
->n
.sym
))
6358 code
->ext
.actual
->next
->expr
= gfc_get_parentheses (rhs
);
6367 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
6368 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
6369 &code
->loc
) == FAILURE
)
6372 /* Handle the case of a BOZ literal on the RHS. */
6373 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
6376 if (gfc_option
.warn_surprising
)
6377 gfc_warning ("BOZ literal at %L is bitwise transferred "
6378 "non-integer symbol '%s'", &code
->loc
,
6379 lhs
->symtree
->n
.sym
->name
);
6381 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
6383 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
6385 if (rc
== ARITH_UNDERFLOW
)
6386 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
6387 ". This check can be disabled with the option "
6388 "-fno-range-check", &rhs
->where
);
6389 else if (rc
== ARITH_OVERFLOW
)
6390 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6391 ". This check can be disabled with the option "
6392 "-fno-range-check", &rhs
->where
);
6393 else if (rc
== ARITH_NAN
)
6394 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6395 ". This check can be disabled with the option "
6396 "-fno-range-check", &rhs
->where
);
6402 if (lhs
->ts
.type
== BT_CHARACTER
6403 && gfc_option
.warn_character_truncation
)
6405 if (lhs
->ts
.cl
!= NULL
6406 && lhs
->ts
.cl
->length
!= NULL
6407 && lhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6408 llen
= mpz_get_si (lhs
->ts
.cl
->length
->value
.integer
);
6410 if (rhs
->expr_type
== EXPR_CONSTANT
)
6411 rlen
= rhs
->value
.character
.length
;
6413 else if (rhs
->ts
.cl
!= NULL
6414 && rhs
->ts
.cl
->length
!= NULL
6415 && rhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6416 rlen
= mpz_get_si (rhs
->ts
.cl
->length
->value
.integer
);
6418 if (rlen
&& llen
&& rlen
> llen
)
6419 gfc_warning_now ("CHARACTER expression will be truncated "
6420 "in assignment (%d/%d) at %L",
6421 llen
, rlen
, &code
->loc
);
6424 /* Ensure that a vector index expression for the lvalue is evaluated
6425 to a temporary if the lvalue symbol is referenced in it. */
6428 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
6429 if (ref
->type
== REF_ARRAY
)
6431 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6432 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
6433 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
6434 ref
->u
.ar
.start
[n
]))
6436 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
6440 if (gfc_pure (NULL
))
6442 if (gfc_impure_variable (lhs
->symtree
->n
.sym
))
6444 gfc_error ("Cannot assign to variable '%s' in PURE "
6446 lhs
->symtree
->n
.sym
->name
,
6451 if (lhs
->ts
.type
== BT_DERIVED
6452 && lhs
->expr_type
== EXPR_VARIABLE
6453 && lhs
->ts
.derived
->attr
.pointer_comp
6454 && gfc_impure_variable (rhs
->symtree
->n
.sym
))
6456 gfc_error ("The impure variable at %L is assigned to "
6457 "a derived type variable with a POINTER "
6458 "component in a PURE procedure (12.6)",
6464 gfc_check_assign (lhs
, rhs
, 1);
6468 /* Given a block of code, recursively resolve everything pointed to by this
6472 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
6474 int omp_workshare_save
;
6479 frame
.prev
= cs_base
;
6483 reachable_labels (code
);
6485 for (; code
; code
= code
->next
)
6487 frame
.current
= code
;
6488 forall_save
= forall_flag
;
6490 if (code
->op
== EXEC_FORALL
)
6493 gfc_resolve_forall (code
, ns
, forall_save
);
6496 else if (code
->block
)
6498 omp_workshare_save
= -1;
6501 case EXEC_OMP_PARALLEL_WORKSHARE
:
6502 omp_workshare_save
= omp_workshare_flag
;
6503 omp_workshare_flag
= 1;
6504 gfc_resolve_omp_parallel_blocks (code
, ns
);
6506 case EXEC_OMP_PARALLEL
:
6507 case EXEC_OMP_PARALLEL_DO
:
6508 case EXEC_OMP_PARALLEL_SECTIONS
:
6510 omp_workshare_save
= omp_workshare_flag
;
6511 omp_workshare_flag
= 0;
6512 gfc_resolve_omp_parallel_blocks (code
, ns
);
6515 gfc_resolve_omp_do_blocks (code
, ns
);
6517 case EXEC_OMP_WORKSHARE
:
6518 omp_workshare_save
= omp_workshare_flag
;
6519 omp_workshare_flag
= 1;
6522 gfc_resolve_blocks (code
->block
, ns
);
6526 if (omp_workshare_save
!= -1)
6527 omp_workshare_flag
= omp_workshare_save
;
6531 if (code
->op
!= EXEC_COMPCALL
)
6532 t
= gfc_resolve_expr (code
->expr
);
6533 forall_flag
= forall_save
;
6535 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
6550 /* Keep track of which entry we are up to. */
6551 current_entry_id
= code
->ext
.entry
->id
;
6555 resolve_where (code
, NULL
);
6559 if (code
->expr
!= NULL
)
6561 if (code
->expr
->ts
.type
!= BT_INTEGER
)
6562 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6563 "INTEGER variable", &code
->expr
->where
);
6564 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
6565 gfc_error ("Variable '%s' has not been assigned a target "
6566 "label at %L", code
->expr
->symtree
->n
.sym
->name
,
6567 &code
->expr
->where
);
6570 resolve_branch (code
->label
, code
);
6574 if (code
->expr
!= NULL
6575 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
6576 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6577 "INTEGER return specifier", &code
->expr
->where
);
6580 case EXEC_INIT_ASSIGN
:
6587 if (resolve_ordinary_assign (code
, ns
))
6592 case EXEC_LABEL_ASSIGN
:
6593 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
6594 gfc_error ("Label %d referenced at %L is never defined",
6595 code
->label
->value
, &code
->label
->where
);
6597 && (code
->expr
->expr_type
!= EXPR_VARIABLE
6598 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
6599 || code
->expr
->symtree
->n
.sym
->ts
.kind
6600 != gfc_default_integer_kind
6601 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
6602 gfc_error ("ASSIGN statement at %L requires a scalar "
6603 "default INTEGER variable", &code
->expr
->where
);
6606 case EXEC_POINTER_ASSIGN
:
6610 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
6613 case EXEC_ARITHMETIC_IF
:
6615 && code
->expr
->ts
.type
!= BT_INTEGER
6616 && code
->expr
->ts
.type
!= BT_REAL
)
6617 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6618 "expression", &code
->expr
->where
);
6620 resolve_branch (code
->label
, code
);
6621 resolve_branch (code
->label2
, code
);
6622 resolve_branch (code
->label3
, code
);
6626 if (t
== SUCCESS
&& code
->expr
!= NULL
6627 && (code
->expr
->ts
.type
!= BT_LOGICAL
6628 || code
->expr
->rank
!= 0))
6629 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6630 &code
->expr
->where
);
6635 resolve_call (code
);
6639 resolve_typebound_call (code
);
6643 /* Select is complicated. Also, a SELECT construct could be
6644 a transformed computed GOTO. */
6645 resolve_select (code
);
6649 if (code
->ext
.iterator
!= NULL
)
6651 gfc_iterator
*iter
= code
->ext
.iterator
;
6652 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
6653 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
6658 if (code
->expr
== NULL
)
6659 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6661 && (code
->expr
->rank
!= 0
6662 || code
->expr
->ts
.type
!= BT_LOGICAL
))
6663 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6664 "a scalar LOGICAL expression", &code
->expr
->where
);
6669 resolve_allocate_deallocate (code
, "ALLOCATE");
6673 case EXEC_DEALLOCATE
:
6675 resolve_allocate_deallocate (code
, "DEALLOCATE");
6680 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
6683 resolve_branch (code
->ext
.open
->err
, code
);
6687 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
6690 resolve_branch (code
->ext
.close
->err
, code
);
6693 case EXEC_BACKSPACE
:
6697 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
6700 resolve_branch (code
->ext
.filepos
->err
, code
);
6704 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6707 resolve_branch (code
->ext
.inquire
->err
, code
);
6711 gcc_assert (code
->ext
.inquire
!= NULL
);
6712 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6715 resolve_branch (code
->ext
.inquire
->err
, code
);
6719 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
6722 resolve_branch (code
->ext
.wait
->err
, code
);
6723 resolve_branch (code
->ext
.wait
->end
, code
);
6724 resolve_branch (code
->ext
.wait
->eor
, code
);
6729 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
6732 resolve_branch (code
->ext
.dt
->err
, code
);
6733 resolve_branch (code
->ext
.dt
->end
, code
);
6734 resolve_branch (code
->ext
.dt
->eor
, code
);
6738 resolve_transfer (code
);
6742 resolve_forall_iterators (code
->ext
.forall_iterator
);
6744 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
6745 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6746 "expression", &code
->expr
->where
);
6749 case EXEC_OMP_ATOMIC
:
6750 case EXEC_OMP_BARRIER
:
6751 case EXEC_OMP_CRITICAL
:
6752 case EXEC_OMP_FLUSH
:
6754 case EXEC_OMP_MASTER
:
6755 case EXEC_OMP_ORDERED
:
6756 case EXEC_OMP_SECTIONS
:
6757 case EXEC_OMP_SINGLE
:
6758 case EXEC_OMP_TASKWAIT
:
6759 case EXEC_OMP_WORKSHARE
:
6760 gfc_resolve_omp_directive (code
, ns
);
6763 case EXEC_OMP_PARALLEL
:
6764 case EXEC_OMP_PARALLEL_DO
:
6765 case EXEC_OMP_PARALLEL_SECTIONS
:
6766 case EXEC_OMP_PARALLEL_WORKSHARE
:
6768 omp_workshare_save
= omp_workshare_flag
;
6769 omp_workshare_flag
= 0;
6770 gfc_resolve_omp_directive (code
, ns
);
6771 omp_workshare_flag
= omp_workshare_save
;
6775 gfc_internal_error ("resolve_code(): Bad statement code");
6779 cs_base
= frame
.prev
;
6783 /* Resolve initial values and make sure they are compatible with
6787 resolve_values (gfc_symbol
*sym
)
6789 if (sym
->value
== NULL
)
6792 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
6795 gfc_check_assign_symbol (sym
, sym
->value
);
6799 /* Verify the binding labels for common blocks that are BIND(C). The label
6800 for a BIND(C) common block must be identical in all scoping units in which
6801 the common block is declared. Further, the binding label can not collide
6802 with any other global entity in the program. */
6805 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
6807 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
6809 gfc_gsymbol
*binding_label_gsym
;
6810 gfc_gsymbol
*comm_name_gsym
;
6812 /* See if a global symbol exists by the common block's name. It may
6813 be NULL if the common block is use-associated. */
6814 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
6815 comm_block_tree
->n
.common
->name
);
6816 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
6817 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6818 "with the global entity '%s' at %L",
6819 comm_block_tree
->n
.common
->binding_label
,
6820 comm_block_tree
->n
.common
->name
,
6821 &(comm_block_tree
->n
.common
->where
),
6822 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6823 else if (comm_name_gsym
!= NULL
6824 && strcmp (comm_name_gsym
->name
,
6825 comm_block_tree
->n
.common
->name
) == 0)
6827 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6829 if (comm_name_gsym
->binding_label
== NULL
)
6830 /* No binding label for common block stored yet; save this one. */
6831 comm_name_gsym
->binding_label
=
6832 comm_block_tree
->n
.common
->binding_label
;
6834 if (strcmp (comm_name_gsym
->binding_label
,
6835 comm_block_tree
->n
.common
->binding_label
) != 0)
6837 /* Common block names match but binding labels do not. */
6838 gfc_error ("Binding label '%s' for common block '%s' at %L "
6839 "does not match the binding label '%s' for common "
6841 comm_block_tree
->n
.common
->binding_label
,
6842 comm_block_tree
->n
.common
->name
,
6843 &(comm_block_tree
->n
.common
->where
),
6844 comm_name_gsym
->binding_label
,
6845 comm_name_gsym
->name
,
6846 &(comm_name_gsym
->where
));
6851 /* There is no binding label (NAME="") so we have nothing further to
6852 check and nothing to add as a global symbol for the label. */
6853 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
6856 binding_label_gsym
=
6857 gfc_find_gsymbol (gfc_gsym_root
,
6858 comm_block_tree
->n
.common
->binding_label
);
6859 if (binding_label_gsym
== NULL
)
6861 /* Need to make a global symbol for the binding label to prevent
6862 it from colliding with another. */
6863 binding_label_gsym
=
6864 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
6865 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
6866 binding_label_gsym
->type
= GSYM_COMMON
;
6870 /* If comm_name_gsym is NULL, the name common block is use
6871 associated and the name could be colliding. */
6872 if (binding_label_gsym
->type
!= GSYM_COMMON
)
6873 gfc_error ("Binding label '%s' for common block '%s' at %L "
6874 "collides with the global entity '%s' at %L",
6875 comm_block_tree
->n
.common
->binding_label
,
6876 comm_block_tree
->n
.common
->name
,
6877 &(comm_block_tree
->n
.common
->where
),
6878 binding_label_gsym
->name
,
6879 &(binding_label_gsym
->where
));
6880 else if (comm_name_gsym
!= NULL
6881 && (strcmp (binding_label_gsym
->name
,
6882 comm_name_gsym
->binding_label
) != 0)
6883 && (strcmp (binding_label_gsym
->sym_name
,
6884 comm_name_gsym
->name
) != 0))
6885 gfc_error ("Binding label '%s' for common block '%s' at %L "
6886 "collides with global entity '%s' at %L",
6887 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
6888 &(comm_block_tree
->n
.common
->where
),
6889 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6897 /* Verify any BIND(C) derived types in the namespace so we can report errors
6898 for them once, rather than for each variable declared of that type. */
6901 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
6903 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
6904 && derived_sym
->attr
.is_bind_c
== 1)
6905 verify_bind_c_derived_type (derived_sym
);
6911 /* Verify that any binding labels used in a given namespace do not collide
6912 with the names or binding labels of any global symbols. */
6915 gfc_verify_binding_labels (gfc_symbol
*sym
)
6919 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
6920 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
6922 gfc_gsymbol
*bind_c_sym
;
6924 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
6925 if (bind_c_sym
!= NULL
6926 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
6928 if (sym
->attr
.if_source
== IFSRC_DECL
6929 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
6930 && bind_c_sym
->type
!= GSYM_FUNCTION
)
6931 && ((sym
->attr
.contained
== 1
6932 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
6933 || (sym
->attr
.use_assoc
== 1
6934 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
6936 /* Make sure global procedures don't collide with anything. */
6937 gfc_error ("Binding label '%s' at %L collides with the global "
6938 "entity '%s' at %L", sym
->binding_label
,
6939 &(sym
->declared_at
), bind_c_sym
->name
,
6940 &(bind_c_sym
->where
));
6943 else if (sym
->attr
.contained
== 0
6944 && (sym
->attr
.if_source
== IFSRC_IFBODY
6945 && sym
->attr
.flavor
== FL_PROCEDURE
)
6946 && (bind_c_sym
->sym_name
!= NULL
6947 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
6949 /* Make sure procedures in interface bodies don't collide. */
6950 gfc_error ("Binding label '%s' in interface body at %L collides "
6951 "with the global entity '%s' at %L",
6953 &(sym
->declared_at
), bind_c_sym
->name
,
6954 &(bind_c_sym
->where
));
6957 else if (sym
->attr
.contained
== 0
6958 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
6959 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
6960 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
6961 || sym
->attr
.use_assoc
== 0)
6963 gfc_error ("Binding label '%s' at %L collides with global "
6964 "entity '%s' at %L", sym
->binding_label
,
6965 &(sym
->declared_at
), bind_c_sym
->name
,
6966 &(bind_c_sym
->where
));
6971 /* Clear the binding label to prevent checking multiple times. */
6972 sym
->binding_label
[0] = '\0';
6974 else if (bind_c_sym
== NULL
)
6976 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
6977 bind_c_sym
->where
= sym
->declared_at
;
6978 bind_c_sym
->sym_name
= sym
->name
;
6980 if (sym
->attr
.use_assoc
== 1)
6981 bind_c_sym
->mod_name
= sym
->module
;
6983 if (sym
->ns
->proc_name
!= NULL
)
6984 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
6986 if (sym
->attr
.contained
== 0)
6988 if (sym
->attr
.subroutine
)
6989 bind_c_sym
->type
= GSYM_SUBROUTINE
;
6990 else if (sym
->attr
.function
)
6991 bind_c_sym
->type
= GSYM_FUNCTION
;
6999 /* Resolve an index expression. */
7002 resolve_index_expr (gfc_expr
*e
)
7004 if (gfc_resolve_expr (e
) == FAILURE
)
7007 if (gfc_simplify_expr (e
, 0) == FAILURE
)
7010 if (gfc_specification_expr (e
) == FAILURE
)
7016 /* Resolve a charlen structure. */
7019 resolve_charlen (gfc_charlen
*cl
)
7028 specification_expr
= 1;
7030 if (resolve_index_expr (cl
->length
) == FAILURE
)
7032 specification_expr
= 0;
7036 /* "If the character length parameter value evaluates to a negative
7037 value, the length of character entities declared is zero." */
7038 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
7040 gfc_warning_now ("CHARACTER variable has zero length at %L",
7041 &cl
->length
->where
);
7042 gfc_replace_expr (cl
->length
, gfc_int_expr (0));
7049 /* Test for non-constant shape arrays. */
7052 is_non_constant_shape_array (gfc_symbol
*sym
)
7058 not_constant
= false;
7059 if (sym
->as
!= NULL
)
7061 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
7062 has not been simplified; parameter array references. Do the
7063 simplification now. */
7064 for (i
= 0; i
< sym
->as
->rank
; i
++)
7066 e
= sym
->as
->lower
[i
];
7067 if (e
&& (resolve_index_expr (e
) == FAILURE
7068 || !gfc_is_constant_expr (e
)))
7069 not_constant
= true;
7071 e
= sym
->as
->upper
[i
];
7072 if (e
&& (resolve_index_expr (e
) == FAILURE
7073 || !gfc_is_constant_expr (e
)))
7074 not_constant
= true;
7077 return not_constant
;
7080 /* Given a symbol and an initialization expression, add code to initialize
7081 the symbol to the function entry. */
7083 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
7087 gfc_namespace
*ns
= sym
->ns
;
7089 /* Search for the function namespace if this is a contained
7090 function without an explicit result. */
7091 if (sym
->attr
.function
&& sym
== sym
->result
7092 && sym
->name
!= sym
->ns
->proc_name
->name
)
7095 for (;ns
; ns
= ns
->sibling
)
7096 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
7102 gfc_free_expr (init
);
7106 /* Build an l-value expression for the result. */
7107 lval
= gfc_lval_expr_from_sym (sym
);
7109 /* Add the code at scope entry. */
7110 init_st
= gfc_get_code ();
7111 init_st
->next
= ns
->code
;
7114 /* Assign the default initializer to the l-value. */
7115 init_st
->loc
= sym
->declared_at
;
7116 init_st
->op
= EXEC_INIT_ASSIGN
;
7117 init_st
->expr
= lval
;
7118 init_st
->expr2
= init
;
7121 /* Assign the default initializer to a derived type variable or result. */
7124 apply_default_init (gfc_symbol
*sym
)
7126 gfc_expr
*init
= NULL
;
7128 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
7131 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
7132 init
= gfc_default_initializer (&sym
->ts
);
7137 build_init_assign (sym
, init
);
7140 /* Build an initializer for a local integer, real, complex, logical, or
7141 character variable, based on the command line flags finit-local-zero,
7142 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
7143 null if the symbol should not have a default initialization. */
7145 build_default_init_expr (gfc_symbol
*sym
)
7148 gfc_expr
*init_expr
;
7151 /* These symbols should never have a default initialization. */
7152 if ((sym
->attr
.dimension
&& !gfc_is_compile_time_shape (sym
->as
))
7153 || sym
->attr
.external
7155 || sym
->attr
.pointer
7156 || sym
->attr
.in_equivalence
7157 || sym
->attr
.in_common
7160 || sym
->attr
.cray_pointee
7161 || sym
->attr
.cray_pointer
)
7164 /* Now we'll try to build an initializer expression. */
7165 init_expr
= gfc_get_expr ();
7166 init_expr
->expr_type
= EXPR_CONSTANT
;
7167 init_expr
->ts
.type
= sym
->ts
.type
;
7168 init_expr
->ts
.kind
= sym
->ts
.kind
;
7169 init_expr
->where
= sym
->declared_at
;
7171 /* We will only initialize integers, reals, complex, logicals, and
7172 characters, and only if the corresponding command-line flags
7173 were set. Otherwise, we free init_expr and return null. */
7174 switch (sym
->ts
.type
)
7177 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
7178 mpz_init_set_si (init_expr
->value
.integer
,
7179 gfc_option
.flag_init_integer_value
);
7182 gfc_free_expr (init_expr
);
7188 mpfr_init (init_expr
->value
.real
);
7189 switch (gfc_option
.flag_init_real
)
7191 case GFC_INIT_REAL_NAN
:
7192 mpfr_set_nan (init_expr
->value
.real
);
7195 case GFC_INIT_REAL_INF
:
7196 mpfr_set_inf (init_expr
->value
.real
, 1);
7199 case GFC_INIT_REAL_NEG_INF
:
7200 mpfr_set_inf (init_expr
->value
.real
, -1);
7203 case GFC_INIT_REAL_ZERO
:
7204 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
7208 gfc_free_expr (init_expr
);
7215 mpfr_init (init_expr
->value
.complex.r
);
7216 mpfr_init (init_expr
->value
.complex.i
);
7217 switch (gfc_option
.flag_init_real
)
7219 case GFC_INIT_REAL_NAN
:
7220 mpfr_set_nan (init_expr
->value
.complex.r
);
7221 mpfr_set_nan (init_expr
->value
.complex.i
);
7224 case GFC_INIT_REAL_INF
:
7225 mpfr_set_inf (init_expr
->value
.complex.r
, 1);
7226 mpfr_set_inf (init_expr
->value
.complex.i
, 1);
7229 case GFC_INIT_REAL_NEG_INF
:
7230 mpfr_set_inf (init_expr
->value
.complex.r
, -1);
7231 mpfr_set_inf (init_expr
->value
.complex.i
, -1);
7234 case GFC_INIT_REAL_ZERO
:
7235 mpfr_set_ui (init_expr
->value
.complex.r
, 0.0, GFC_RND_MODE
);
7236 mpfr_set_ui (init_expr
->value
.complex.i
, 0.0, GFC_RND_MODE
);
7240 gfc_free_expr (init_expr
);
7247 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
7248 init_expr
->value
.logical
= 0;
7249 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
7250 init_expr
->value
.logical
= 1;
7253 gfc_free_expr (init_expr
);
7259 /* For characters, the length must be constant in order to
7260 create a default initializer. */
7261 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
7262 && sym
->ts
.cl
->length
7263 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
7265 char_len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
7266 init_expr
->value
.character
.length
= char_len
;
7267 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
7268 for (i
= 0; i
< char_len
; i
++)
7269 init_expr
->value
.character
.string
[i
]
7270 = (unsigned char) gfc_option
.flag_init_character_value
;
7274 gfc_free_expr (init_expr
);
7280 gfc_free_expr (init_expr
);
7286 /* Add an initialization expression to a local variable. */
7288 apply_default_init_local (gfc_symbol
*sym
)
7290 gfc_expr
*init
= NULL
;
7292 /* The symbol should be a variable or a function return value. */
7293 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
7294 || (sym
->attr
.function
&& sym
->result
!= sym
))
7297 /* Try to build the initializer expression. If we can't initialize
7298 this symbol, then init will be NULL. */
7299 init
= build_default_init_expr (sym
);
7303 /* For saved variables, we don't want to add an initializer at
7304 function entry, so we just add a static initializer. */
7305 if (sym
->attr
.save
|| sym
->ns
->save_all
)
7307 /* Don't clobber an existing initializer! */
7308 gcc_assert (sym
->value
== NULL
);
7313 build_init_assign (sym
, init
);
7316 /* Resolution of common features of flavors variable and procedure. */
7319 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
7321 /* Constraints on deferred shape variable. */
7322 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
7324 if (sym
->attr
.allocatable
)
7326 if (sym
->attr
.dimension
)
7327 gfc_error ("Allocatable array '%s' at %L must have "
7328 "a deferred shape", sym
->name
, &sym
->declared_at
);
7330 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
7331 sym
->name
, &sym
->declared_at
);
7335 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
7337 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
7338 sym
->name
, &sym
->declared_at
);
7345 if (!mp_flag
&& !sym
->attr
.allocatable
7346 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
7348 gfc_error ("Array '%s' at %L cannot have a deferred shape",
7349 sym
->name
, &sym
->declared_at
);
7357 /* Additional checks for symbols with flavor variable and derived
7358 type. To be called from resolve_fl_variable. */
7361 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
7363 gcc_assert (sym
->ts
.type
== BT_DERIVED
);
7365 /* Check to see if a derived type is blocked from being host
7366 associated by the presence of another class I symbol in the same
7367 namespace. 14.6.1.3 of the standard and the discussion on
7368 comp.lang.fortran. */
7369 if (sym
->ns
!= sym
->ts
.derived
->ns
7370 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
7373 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
7374 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
7376 gfc_error ("The type '%s' cannot be host associated at %L "
7377 "because it is blocked by an incompatible object "
7378 "of the same name declared at %L",
7379 sym
->ts
.derived
->name
, &sym
->declared_at
,
7385 /* 4th constraint in section 11.3: "If an object of a type for which
7386 component-initialization is specified (R429) appears in the
7387 specification-part of a module and does not have the ALLOCATABLE
7388 or POINTER attribute, the object shall have the SAVE attribute."
7390 The check for initializers is performed with
7391 has_default_initializer because gfc_default_initializer generates
7392 a hidden default for allocatable components. */
7393 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
7394 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7395 && !sym
->ns
->save_all
&& !sym
->attr
.save
7396 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
7397 && has_default_initializer (sym
->ts
.derived
))
7399 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7400 "default initialization of a component",
7401 sym
->name
, &sym
->declared_at
);
7405 /* Assign default initializer. */
7406 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
7407 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
7409 sym
->value
= gfc_default_initializer (&sym
->ts
);
7416 /* Resolve symbols with flavor variable. */
7419 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
7421 int no_init_flag
, automatic_flag
;
7423 const char *auto_save_msg
;
7425 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
7428 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
7431 /* Set this flag to check that variables are parameters of all entries.
7432 This check is effected by the call to gfc_resolve_expr through
7433 is_non_constant_shape_array. */
7434 specification_expr
= 1;
7436 if (sym
->ns
->proc_name
7437 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7438 || sym
->ns
->proc_name
->attr
.is_main_program
)
7439 && !sym
->attr
.use_assoc
7440 && !sym
->attr
.allocatable
7441 && !sym
->attr
.pointer
7442 && is_non_constant_shape_array (sym
))
7444 /* The shape of a main program or module array needs to be
7446 gfc_error ("The module or main program array '%s' at %L must "
7447 "have constant shape", sym
->name
, &sym
->declared_at
);
7448 specification_expr
= 0;
7452 if (sym
->ts
.type
== BT_CHARACTER
)
7454 /* Make sure that character string variables with assumed length are
7456 e
= sym
->ts
.cl
->length
;
7457 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
7459 gfc_error ("Entity with assumed character length at %L must be a "
7460 "dummy argument or a PARAMETER", &sym
->declared_at
);
7464 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
7466 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7470 if (!gfc_is_constant_expr (e
)
7471 && !(e
->expr_type
== EXPR_VARIABLE
7472 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
7473 && sym
->ns
->proc_name
7474 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7475 || sym
->ns
->proc_name
->attr
.is_main_program
)
7476 && !sym
->attr
.use_assoc
)
7478 gfc_error ("'%s' at %L must have constant character length "
7479 "in this context", sym
->name
, &sym
->declared_at
);
7484 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
7485 apply_default_init_local (sym
); /* Try to apply a default initialization. */
7487 /* Determine if the symbol may not have an initializer. */
7488 no_init_flag
= automatic_flag
= 0;
7489 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
7490 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
7492 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
7493 && is_non_constant_shape_array (sym
))
7495 no_init_flag
= automatic_flag
= 1;
7497 /* Also, they must not have the SAVE attribute.
7498 SAVE_IMPLICIT is checked below. */
7499 if (sym
->attr
.save
== SAVE_EXPLICIT
)
7501 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7506 /* Reject illegal initializers. */
7507 if (!sym
->mark
&& sym
->value
)
7509 if (sym
->attr
.allocatable
)
7510 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7511 sym
->name
, &sym
->declared_at
);
7512 else if (sym
->attr
.external
)
7513 gfc_error ("External '%s' at %L cannot have an initializer",
7514 sym
->name
, &sym
->declared_at
);
7515 else if (sym
->attr
.dummy
7516 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
7517 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7518 sym
->name
, &sym
->declared_at
);
7519 else if (sym
->attr
.intrinsic
)
7520 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7521 sym
->name
, &sym
->declared_at
);
7522 else if (sym
->attr
.result
)
7523 gfc_error ("Function result '%s' at %L cannot have an initializer",
7524 sym
->name
, &sym
->declared_at
);
7525 else if (automatic_flag
)
7526 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7527 sym
->name
, &sym
->declared_at
);
7534 if (sym
->ts
.type
== BT_DERIVED
)
7535 return resolve_fl_variable_derived (sym
, no_init_flag
);
7541 /* Resolve a procedure. */
7544 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
7546 gfc_formal_arglist
*arg
;
7548 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
7549 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7550 "interfaces", sym
->name
, &sym
->declared_at
);
7552 if (sym
->attr
.function
7553 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
7556 if (sym
->ts
.type
== BT_CHARACTER
)
7558 gfc_charlen
*cl
= sym
->ts
.cl
;
7560 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
7561 && resolve_charlen (cl
) == FAILURE
)
7564 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
7566 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7568 gfc_error ("Character-valued statement function '%s' at %L must "
7569 "have constant length", sym
->name
, &sym
->declared_at
);
7573 if (sym
->attr
.external
&& sym
->formal
== NULL
7574 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
7576 gfc_error ("Automatic character length function '%s' at %L must "
7577 "have an explicit interface", sym
->name
,
7584 /* Ensure that derived type for are not of a private type. Internal
7585 module procedures are excluded by 2.2.3.3 - i.e., they are not
7586 externally accessible and can access all the objects accessible in
7588 if (!(sym
->ns
->parent
7589 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
7590 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
7592 gfc_interface
*iface
;
7594 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
7597 && arg
->sym
->ts
.type
== BT_DERIVED
7598 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7599 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7600 arg
->sym
->ts
.derived
->ns
->default_access
)
7601 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
7602 "PRIVATE type and cannot be a dummy argument"
7603 " of '%s', which is PUBLIC at %L",
7604 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
7607 /* Stop this message from recurring. */
7608 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7613 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7614 PRIVATE to the containing module. */
7615 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7617 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7620 && arg
->sym
->ts
.type
== BT_DERIVED
7621 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7622 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7623 arg
->sym
->ts
.derived
->ns
->default_access
)
7624 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7625 "'%s' in PUBLIC interface '%s' at %L "
7626 "takes dummy arguments of '%s' which is "
7627 "PRIVATE", iface
->sym
->name
, sym
->name
,
7628 &iface
->sym
->declared_at
,
7629 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7631 /* Stop this message from recurring. */
7632 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7638 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7639 PRIVATE to the containing module. */
7640 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7642 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7645 && arg
->sym
->ts
.type
== BT_DERIVED
7646 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7647 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7648 arg
->sym
->ts
.derived
->ns
->default_access
)
7649 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7650 "'%s' in PUBLIC interface '%s' at %L "
7651 "takes dummy arguments of '%s' which is "
7652 "PRIVATE", iface
->sym
->name
, sym
->name
,
7653 &iface
->sym
->declared_at
,
7654 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7656 /* Stop this message from recurring. */
7657 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7664 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
7665 && !sym
->attr
.proc_pointer
)
7667 gfc_error ("Function '%s' at %L cannot have an initializer",
7668 sym
->name
, &sym
->declared_at
);
7672 /* An external symbol may not have an initializer because it is taken to be
7673 a procedure. Exception: Procedure Pointers. */
7674 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
7676 gfc_error ("External object '%s' at %L may not have an initializer",
7677 sym
->name
, &sym
->declared_at
);
7681 /* An elemental function is required to return a scalar 12.7.1 */
7682 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
7684 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7685 "result", sym
->name
, &sym
->declared_at
);
7686 /* Reset so that the error only occurs once. */
7687 sym
->attr
.elemental
= 0;
7691 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7692 char-len-param shall not be array-valued, pointer-valued, recursive
7693 or pure. ....snip... A character value of * may only be used in the
7694 following ways: (i) Dummy arg of procedure - dummy associates with
7695 actual length; (ii) To declare a named constant; or (iii) External
7696 function - but length must be declared in calling scoping unit. */
7697 if (sym
->attr
.function
7698 && sym
->ts
.type
== BT_CHARACTER
7699 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
7701 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
7702 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
7704 if (sym
->as
&& sym
->as
->rank
)
7705 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7706 "array-valued", sym
->name
, &sym
->declared_at
);
7708 if (sym
->attr
.pointer
)
7709 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7710 "pointer-valued", sym
->name
, &sym
->declared_at
);
7713 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7714 "pure", sym
->name
, &sym
->declared_at
);
7716 if (sym
->attr
.recursive
)
7717 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7718 "recursive", sym
->name
, &sym
->declared_at
);
7723 /* Appendix B.2 of the standard. Contained functions give an
7724 error anyway. Fixed-form is likely to be F77/legacy. */
7725 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
7726 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
7727 "'%s' at %L is obsolescent in fortran 95",
7728 sym
->name
, &sym
->declared_at
);
7731 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
7733 gfc_formal_arglist
*curr_arg
;
7734 int has_non_interop_arg
= 0;
7736 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
7737 sym
->common_block
) == FAILURE
)
7739 /* Clear these to prevent looking at them again if there was an
7741 sym
->attr
.is_bind_c
= 0;
7742 sym
->attr
.is_c_interop
= 0;
7743 sym
->ts
.is_c_interop
= 0;
7747 /* So far, no errors have been found. */
7748 sym
->attr
.is_c_interop
= 1;
7749 sym
->ts
.is_c_interop
= 1;
7752 curr_arg
= sym
->formal
;
7753 while (curr_arg
!= NULL
)
7755 /* Skip implicitly typed dummy args here. */
7756 if (curr_arg
->sym
->attr
.implicit_type
== 0)
7757 if (verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
7758 /* If something is found to fail, record the fact so we
7759 can mark the symbol for the procedure as not being
7760 BIND(C) to try and prevent multiple errors being
7762 has_non_interop_arg
= 1;
7764 curr_arg
= curr_arg
->next
;
7767 /* See if any of the arguments were not interoperable and if so, clear
7768 the procedure symbol to prevent duplicate error messages. */
7769 if (has_non_interop_arg
!= 0)
7771 sym
->attr
.is_c_interop
= 0;
7772 sym
->ts
.is_c_interop
= 0;
7773 sym
->attr
.is_bind_c
= 0;
7777 if (sym
->attr
.save
== SAVE_EXPLICIT
&& !sym
->attr
.proc_pointer
)
7779 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
7780 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
7784 if (sym
->attr
.intent
&& !sym
->attr
.proc_pointer
)
7786 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
7787 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
7795 /* Resolve a list of finalizer procedures. That is, after they have hopefully
7796 been defined and we now know their defined arguments, check that they fulfill
7797 the requirements of the standard for procedures used as finalizers. */
7800 gfc_resolve_finalizers (gfc_symbol
* derived
)
7802 gfc_finalizer
* list
;
7803 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
7804 gfc_try result
= SUCCESS
;
7805 bool seen_scalar
= false;
7807 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
7810 /* Walk over the list of finalizer-procedures, check them, and if any one
7811 does not fit in with the standard's definition, print an error and remove
7812 it from the list. */
7813 prev_link
= &derived
->f2k_derived
->finalizers
;
7814 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
7820 /* Skip this finalizer if we already resolved it. */
7821 if (list
->proc_tree
)
7823 prev_link
= &(list
->next
);
7827 /* Check this exists and is a SUBROUTINE. */
7828 if (!list
->proc_sym
->attr
.subroutine
)
7830 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
7831 list
->proc_sym
->name
, &list
->where
);
7835 /* We should have exactly one argument. */
7836 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
7838 gfc_error ("FINAL procedure at %L must have exactly one argument",
7842 arg
= list
->proc_sym
->formal
->sym
;
7844 /* This argument must be of our type. */
7845 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.derived
!= derived
)
7847 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
7848 &arg
->declared_at
, derived
->name
);
7852 /* It must neither be a pointer nor allocatable nor optional. */
7853 if (arg
->attr
.pointer
)
7855 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
7859 if (arg
->attr
.allocatable
)
7861 gfc_error ("Argument of FINAL procedure at %L must not be"
7862 " ALLOCATABLE", &arg
->declared_at
);
7865 if (arg
->attr
.optional
)
7867 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
7872 /* It must not be INTENT(OUT). */
7873 if (arg
->attr
.intent
== INTENT_OUT
)
7875 gfc_error ("Argument of FINAL procedure at %L must not be"
7876 " INTENT(OUT)", &arg
->declared_at
);
7880 /* Warn if the procedure is non-scalar and not assumed shape. */
7881 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
> 0
7882 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
7883 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
7884 " shape argument", &arg
->declared_at
);
7886 /* Check that it does not match in kind and rank with a FINAL procedure
7887 defined earlier. To really loop over the *earlier* declarations,
7888 we need to walk the tail of the list as new ones were pushed at the
7890 /* TODO: Handle kind parameters once they are implemented. */
7891 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
7892 for (i
= list
->next
; i
; i
= i
->next
)
7894 /* Argument list might be empty; that is an error signalled earlier,
7895 but we nevertheless continued resolving. */
7896 if (i
->proc_sym
->formal
)
7898 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
7899 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
7900 if (i_rank
== my_rank
)
7902 gfc_error ("FINAL procedure '%s' declared at %L has the same"
7903 " rank (%d) as '%s'",
7904 list
->proc_sym
->name
, &list
->where
, my_rank
,
7911 /* Is this the/a scalar finalizer procedure? */
7912 if (!arg
->as
|| arg
->as
->rank
== 0)
7915 /* Find the symtree for this procedure. */
7916 gcc_assert (!list
->proc_tree
);
7917 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
7919 prev_link
= &list
->next
;
7922 /* Remove wrong nodes immediately from the list so we don't risk any
7923 troubles in the future when they might fail later expectations. */
7927 *prev_link
= list
->next
;
7928 gfc_free_finalizer (i
);
7931 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
7932 were nodes in the list, must have been for arrays. It is surely a good
7933 idea to have a scalar version there if there's something to finalize. */
7934 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
7935 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
7936 " defined at %L, suggest also scalar one",
7937 derived
->name
, &derived
->declared_at
);
7939 /* TODO: Remove this error when finalization is finished. */
7940 gfc_error ("Finalization at %L is not yet implemented",
7941 &derived
->declared_at
);
7947 /* Check that it is ok for the typebound procedure proc to override the
7951 check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
7954 const gfc_symbol
* proc_target
;
7955 const gfc_symbol
* old_target
;
7956 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
7957 gfc_formal_arglist
* proc_formal
;
7958 gfc_formal_arglist
* old_formal
;
7960 /* This procedure should only be called for non-GENERIC proc. */
7961 gcc_assert (!proc
->typebound
->is_generic
);
7963 /* If the overwritten procedure is GENERIC, this is an error. */
7964 if (old
->typebound
->is_generic
)
7966 gfc_error ("Can't overwrite GENERIC '%s' at %L",
7967 old
->name
, &proc
->typebound
->where
);
7971 where
= proc
->typebound
->where
;
7972 proc_target
= proc
->typebound
->u
.specific
->n
.sym
;
7973 old_target
= old
->typebound
->u
.specific
->n
.sym
;
7975 /* Check that overridden binding is not NON_OVERRIDABLE. */
7976 if (old
->typebound
->non_overridable
)
7978 gfc_error ("'%s' at %L overrides a procedure binding declared"
7979 " NON_OVERRIDABLE", proc
->name
, &where
);
7983 /* If the overridden binding is PURE, the overriding must be, too. */
7984 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
7986 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
7987 proc
->name
, &where
);
7991 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
7992 is not, the overriding must not be either. */
7993 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
7995 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
7996 " ELEMENTAL", proc
->name
, &where
);
7999 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
8001 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
8002 " be ELEMENTAL, either", proc
->name
, &where
);
8006 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
8008 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
8010 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
8011 " SUBROUTINE", proc
->name
, &where
);
8015 /* If the overridden binding is a FUNCTION, the overriding must also be a
8016 FUNCTION and have the same characteristics. */
8017 if (old_target
->attr
.function
)
8019 if (!proc_target
->attr
.function
)
8021 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
8022 " FUNCTION", proc
->name
, &where
);
8026 /* FIXME: Do more comprehensive checking (including, for instance, the
8027 rank and array-shape). */
8028 gcc_assert (proc_target
->result
&& old_target
->result
);
8029 if (!gfc_compare_types (&proc_target
->result
->ts
,
8030 &old_target
->result
->ts
))
8032 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
8033 " matching result types", proc
->name
, &where
);
8038 /* If the overridden binding is PUBLIC, the overriding one must not be
8040 if (old
->typebound
->access
== ACCESS_PUBLIC
8041 && proc
->typebound
->access
== ACCESS_PRIVATE
)
8043 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
8044 " PRIVATE", proc
->name
, &where
);
8048 /* Compare the formal argument lists of both procedures. This is also abused
8049 to find the position of the passed-object dummy arguments of both
8050 bindings as at least the overridden one might not yet be resolved and we
8051 need those positions in the check below. */
8052 proc_pass_arg
= old_pass_arg
= 0;
8053 if (!proc
->typebound
->nopass
&& !proc
->typebound
->pass_arg
)
8055 if (!old
->typebound
->nopass
&& !old
->typebound
->pass_arg
)
8058 for (proc_formal
= proc_target
->formal
, old_formal
= old_target
->formal
;
8059 proc_formal
&& old_formal
;
8060 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
8062 if (proc
->typebound
->pass_arg
8063 && !strcmp (proc
->typebound
->pass_arg
, proc_formal
->sym
->name
))
8064 proc_pass_arg
= argpos
;
8065 if (old
->typebound
->pass_arg
8066 && !strcmp (old
->typebound
->pass_arg
, old_formal
->sym
->name
))
8067 old_pass_arg
= argpos
;
8069 /* Check that the names correspond. */
8070 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
8072 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
8073 " to match the corresponding argument of the overridden"
8074 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
8075 old_formal
->sym
->name
);
8079 /* Check that the types correspond if neither is the passed-object
8081 /* FIXME: Do more comprehensive testing here. */
8082 if (proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
8083 && !gfc_compare_types (&proc_formal
->sym
->ts
, &old_formal
->sym
->ts
))
8085 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
8086 " in respect to the overridden procedure",
8087 proc_formal
->sym
->name
, proc
->name
, &where
);
8093 if (proc_formal
|| old_formal
)
8095 gfc_error ("'%s' at %L must have the same number of formal arguments as"
8096 " the overridden procedure", proc
->name
, &where
);
8100 /* If the overridden binding is NOPASS, the overriding one must also be
8102 if (old
->typebound
->nopass
&& !proc
->typebound
->nopass
)
8104 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
8105 " NOPASS", proc
->name
, &where
);
8109 /* If the overridden binding is PASS(x), the overriding one must also be
8110 PASS and the passed-object dummy arguments must correspond. */
8111 if (!old
->typebound
->nopass
)
8113 if (proc
->typebound
->nopass
)
8115 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
8116 " PASS", proc
->name
, &where
);
8120 if (proc_pass_arg
!= old_pass_arg
)
8122 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
8123 " the same position as the passed-object dummy argument of"
8124 " the overridden procedure", proc
->name
, &where
);
8133 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
8136 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
8137 const char* generic_name
, locus where
)
8142 gcc_assert (t1
->specific
&& t2
->specific
);
8143 gcc_assert (!t1
->specific
->is_generic
);
8144 gcc_assert (!t2
->specific
->is_generic
);
8146 sym1
= t1
->specific
->u
.specific
->n
.sym
;
8147 sym2
= t2
->specific
->u
.specific
->n
.sym
;
8149 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
8150 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
8151 || sym1
->attr
.function
!= sym2
->attr
.function
)
8153 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
8154 " GENERIC '%s' at %L",
8155 sym1
->name
, sym2
->name
, generic_name
, &where
);
8159 /* Compare the interfaces. */
8160 if (gfc_compare_interfaces (sym1
, sym2
, 1))
8162 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
8163 sym1
->name
, sym2
->name
, generic_name
, &where
);
8171 /* Resolve a GENERIC procedure binding for a derived type. */
8174 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
8176 gfc_tbp_generic
* target
;
8177 gfc_symtree
* first_target
;
8178 gfc_symbol
* super_type
;
8179 gfc_symtree
* inherited
;
8182 gcc_assert (st
->typebound
);
8183 gcc_assert (st
->typebound
->is_generic
);
8185 where
= st
->typebound
->where
;
8186 super_type
= gfc_get_derived_super_type (derived
);
8188 /* Find the overridden binding if any. */
8189 st
->typebound
->overridden
= NULL
;
8192 gfc_symtree
* overridden
;
8193 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
, true);
8195 if (overridden
&& overridden
->typebound
)
8196 st
->typebound
->overridden
= overridden
->typebound
;
8199 /* Try to find the specific bindings for the symtrees in our target-list. */
8200 gcc_assert (st
->typebound
->u
.generic
);
8201 for (target
= st
->typebound
->u
.generic
; target
; target
= target
->next
)
8202 if (!target
->specific
)
8204 gfc_typebound_proc
* overridden_tbp
;
8206 const char* target_name
;
8208 target_name
= target
->specific_st
->name
;
8210 /* Defined for this type directly. */
8211 if (target
->specific_st
->typebound
)
8213 target
->specific
= target
->specific_st
->typebound
;
8214 goto specific_found
;
8217 /* Look for an inherited specific binding. */
8220 inherited
= gfc_find_typebound_proc (super_type
, NULL
,
8225 gcc_assert (inherited
->typebound
);
8226 target
->specific
= inherited
->typebound
;
8227 goto specific_found
;
8231 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
8232 " at %L", target_name
, st
->name
, &where
);
8235 /* Once we've found the specific binding, check it is not ambiguous with
8236 other specifics already found or inherited for the same GENERIC. */
8238 gcc_assert (target
->specific
);
8240 /* This must really be a specific binding! */
8241 if (target
->specific
->is_generic
)
8243 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
8244 " '%s' is GENERIC, too", st
->name
, &where
, target_name
);
8248 /* Check those already resolved on this type directly. */
8249 for (g
= st
->typebound
->u
.generic
; g
; g
= g
->next
)
8250 if (g
!= target
&& g
->specific
8251 && check_generic_tbp_ambiguity (target
, g
, st
->name
, where
)
8255 /* Check for ambiguity with inherited specific targets. */
8256 for (overridden_tbp
= st
->typebound
->overridden
; overridden_tbp
;
8257 overridden_tbp
= overridden_tbp
->overridden
)
8258 if (overridden_tbp
->is_generic
)
8260 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
8262 gcc_assert (g
->specific
);
8263 if (check_generic_tbp_ambiguity (target
, g
,
8264 st
->name
, where
) == FAILURE
)
8270 /* If we attempt to "overwrite" a specific binding, this is an error. */
8271 if (st
->typebound
->overridden
&& !st
->typebound
->overridden
->is_generic
)
8273 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
8274 " the same name", st
->name
, &where
);
8278 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
8279 all must have the same attributes here. */
8280 first_target
= st
->typebound
->u
.generic
->specific
->u
.specific
;
8281 st
->typebound
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
8282 st
->typebound
->function
= first_target
->n
.sym
->attr
.function
;
8288 /* Resolve the type-bound procedures for a derived type. */
8290 static gfc_symbol
* resolve_bindings_derived
;
8291 static gfc_try resolve_bindings_result
;
8294 resolve_typebound_procedure (gfc_symtree
* stree
)
8299 gfc_symbol
* super_type
;
8300 gfc_component
* comp
;
8302 /* If this is no type-bound procedure, just return. */
8303 if (!stree
->typebound
)
8306 /* If this is a GENERIC binding, use that routine. */
8307 if (stree
->typebound
->is_generic
)
8309 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
8315 /* Get the target-procedure to check it. */
8316 gcc_assert (!stree
->typebound
->is_generic
);
8317 gcc_assert (stree
->typebound
->u
.specific
);
8318 proc
= stree
->typebound
->u
.specific
->n
.sym
;
8319 where
= stree
->typebound
->where
;
8321 /* Default access should already be resolved from the parser. */
8322 gcc_assert (stree
->typebound
->access
!= ACCESS_UNKNOWN
);
8324 /* It should be a module procedure or an external procedure with explicit
8326 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
8327 || (proc
->attr
.proc
!= PROC_MODULE
8328 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
8329 || proc
->attr
.abstract
)
8331 gfc_error ("'%s' must be a module procedure or an external procedure with"
8332 " an explicit interface at %L", proc
->name
, &where
);
8335 stree
->typebound
->subroutine
= proc
->attr
.subroutine
;
8336 stree
->typebound
->function
= proc
->attr
.function
;
8338 /* Find the super-type of the current derived type. We could do this once and
8339 store in a global if speed is needed, but as long as not I believe this is
8340 more readable and clearer. */
8341 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
8343 /* If PASS, resolve and check arguments if not already resolved / loaded
8344 from a .mod file. */
8345 if (!stree
->typebound
->nopass
&& stree
->typebound
->pass_arg_num
== 0)
8347 if (stree
->typebound
->pass_arg
)
8349 gfc_formal_arglist
* i
;
8351 /* If an explicit passing argument name is given, walk the arg-list
8355 stree
->typebound
->pass_arg_num
= 1;
8356 for (i
= proc
->formal
; i
; i
= i
->next
)
8358 if (!strcmp (i
->sym
->name
, stree
->typebound
->pass_arg
))
8363 ++stree
->typebound
->pass_arg_num
;
8368 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
8370 proc
->name
, stree
->typebound
->pass_arg
, &where
,
8371 stree
->typebound
->pass_arg
);
8377 /* Otherwise, take the first one; there should in fact be at least
8379 stree
->typebound
->pass_arg_num
= 1;
8382 gfc_error ("Procedure '%s' with PASS at %L must have at"
8383 " least one argument", proc
->name
, &where
);
8386 me_arg
= proc
->formal
->sym
;
8389 /* Now check that the argument-type matches. */
8390 gcc_assert (me_arg
);
8391 if (me_arg
->ts
.type
!= BT_DERIVED
8392 || me_arg
->ts
.derived
!= resolve_bindings_derived
)
8394 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
8395 " the derived-type '%s'", me_arg
->name
, proc
->name
,
8396 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
8400 gfc_warning ("Polymorphic entities are not yet implemented,"
8401 " non-polymorphic passed-object dummy argument of '%s'"
8402 " at %L accepted", proc
->name
, &where
);
8405 /* If we are extending some type, check that we don't override a procedure
8406 flagged NON_OVERRIDABLE. */
8407 stree
->typebound
->overridden
= NULL
;
8410 gfc_symtree
* overridden
;
8411 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
8414 if (overridden
&& overridden
->typebound
)
8415 stree
->typebound
->overridden
= overridden
->typebound
;
8417 if (overridden
&& check_typebound_override (stree
, overridden
) == FAILURE
)
8421 /* See if there's a name collision with a component directly in this type. */
8422 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
8423 if (!strcmp (comp
->name
, stree
->name
))
8425 gfc_error ("Procedure '%s' at %L has the same name as a component of"
8427 stree
->name
, &where
, resolve_bindings_derived
->name
);
8431 /* Try to find a name collision with an inherited component. */
8432 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
8434 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
8435 " component of '%s'",
8436 stree
->name
, &where
, resolve_bindings_derived
->name
);
8443 resolve_bindings_result
= FAILURE
;
8447 resolve_typebound_procedures (gfc_symbol
* derived
)
8449 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->sym_root
)
8452 resolve_bindings_derived
= derived
;
8453 resolve_bindings_result
= SUCCESS
;
8454 gfc_traverse_symtree (derived
->f2k_derived
->sym_root
,
8455 &resolve_typebound_procedure
);
8457 return resolve_bindings_result
;
8461 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
8462 to give all identical derived types the same backend_decl. */
8464 add_dt_to_dt_list (gfc_symbol
*derived
)
8466 gfc_dt_list
*dt_list
;
8468 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
8469 if (derived
== dt_list
->derived
)
8472 if (dt_list
== NULL
)
8474 dt_list
= gfc_get_dt_list ();
8475 dt_list
->next
= gfc_derived_types
;
8476 dt_list
->derived
= derived
;
8477 gfc_derived_types
= dt_list
;
8482 /* Resolve the components of a derived type. */
8485 resolve_fl_derived (gfc_symbol
*sym
)
8487 gfc_symbol
* super_type
;
8491 super_type
= gfc_get_derived_super_type (sym
);
8493 /* Ensure the extended type gets resolved before we do. */
8494 if (super_type
&& resolve_fl_derived (super_type
) == FAILURE
)
8497 /* An ABSTRACT type must be extensible. */
8498 if (sym
->attr
.abstract
&& (sym
->attr
.is_bind_c
|| sym
->attr
.sequence
))
8500 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
8501 sym
->name
, &sym
->declared_at
);
8505 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
8507 /* Check type-spec if this is not the parent-type component. */
8508 if ((!sym
->attr
.extension
|| c
!= sym
->components
)
8509 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
8512 /* If this type is an extension, see if this component has the same name
8513 as an inherited type-bound procedure. */
8515 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true))
8517 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
8518 " inherited type-bound procedure",
8519 c
->name
, sym
->name
, &c
->loc
);
8523 if (c
->ts
.type
== BT_CHARACTER
)
8525 if (c
->ts
.cl
->length
== NULL
8526 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
8527 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
8529 gfc_error ("Character length of component '%s' needs to "
8530 "be a constant specification expression at %L",
8532 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
8537 if (c
->ts
.type
== BT_DERIVED
8538 && sym
->component_access
!= ACCESS_PRIVATE
8539 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
8540 && !c
->ts
.derived
->attr
.use_assoc
8541 && !gfc_check_access (c
->ts
.derived
->attr
.access
,
8542 c
->ts
.derived
->ns
->default_access
))
8544 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
8545 "a component of '%s', which is PUBLIC at %L",
8546 c
->name
, sym
->name
, &sym
->declared_at
);
8550 if (sym
->attr
.sequence
)
8552 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
8554 gfc_error ("Component %s of SEQUENCE type declared at %L does "
8555 "not have the SEQUENCE attribute",
8556 c
->ts
.derived
->name
, &sym
->declared_at
);
8561 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
8562 && c
->ts
.derived
->components
== NULL
8563 && !c
->ts
.derived
->attr
.zero_comp
)
8565 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
8566 "that has not been declared", c
->name
, sym
->name
,
8571 /* Ensure that all the derived type components are put on the
8572 derived type list; even in formal namespaces, where derived type
8573 pointer components might not have been declared. */
8574 if (c
->ts
.type
== BT_DERIVED
8576 && c
->ts
.derived
->components
8578 && sym
!= c
->ts
.derived
)
8579 add_dt_to_dt_list (c
->ts
.derived
);
8581 if (c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->as
== NULL
)
8584 for (i
= 0; i
< c
->as
->rank
; i
++)
8586 if (c
->as
->lower
[i
] == NULL
8587 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
8588 || !gfc_is_constant_expr (c
->as
->lower
[i
])
8589 || c
->as
->upper
[i
] == NULL
8590 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
8591 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
8593 gfc_error ("Component '%s' of '%s' at %L must have "
8594 "constant array bounds",
8595 c
->name
, sym
->name
, &c
->loc
);
8601 /* Resolve the type-bound procedures. */
8602 if (resolve_typebound_procedures (sym
) == FAILURE
)
8605 /* Resolve the finalizer procedures. */
8606 if (gfc_resolve_finalizers (sym
) == FAILURE
)
8609 /* Add derived type to the derived type list. */
8610 add_dt_to_dt_list (sym
);
8617 resolve_fl_namelist (gfc_symbol
*sym
)
8622 /* Reject PRIVATE objects in a PUBLIC namelist. */
8623 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
8625 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
8627 if (!nl
->sym
->attr
.use_assoc
8628 && !(sym
->ns
->parent
== nl
->sym
->ns
)
8629 && !(sym
->ns
->parent
8630 && sym
->ns
->parent
->parent
== nl
->sym
->ns
)
8631 && !gfc_check_access(nl
->sym
->attr
.access
,
8632 nl
->sym
->ns
->default_access
))
8634 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
8635 "cannot be member of PUBLIC namelist '%s' at %L",
8636 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8640 /* Types with private components that came here by USE-association. */
8641 if (nl
->sym
->ts
.type
== BT_DERIVED
8642 && derived_inaccessible (nl
->sym
->ts
.derived
))
8644 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
8645 "components and cannot be member of namelist '%s' at %L",
8646 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8650 /* Types with private components that are defined in the same module. */
8651 if (nl
->sym
->ts
.type
== BT_DERIVED
8652 && !(sym
->ns
->parent
== nl
->sym
->ts
.derived
->ns
)
8653 && !gfc_check_access (nl
->sym
->ts
.derived
->attr
.private_comp
8654 ? ACCESS_PRIVATE
: ACCESS_UNKNOWN
,
8655 nl
->sym
->ns
->default_access
))
8657 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
8658 "cannot be a member of PUBLIC namelist '%s' at %L",
8659 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8665 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
8667 /* Reject namelist arrays of assumed shape. */
8668 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
8669 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
8670 "must not have assumed shape in namelist "
8671 "'%s' at %L", nl
->sym
->name
, sym
->name
,
8672 &sym
->declared_at
) == FAILURE
)
8675 /* Reject namelist arrays that are not constant shape. */
8676 if (is_non_constant_shape_array (nl
->sym
))
8678 gfc_error ("NAMELIST array object '%s' must have constant "
8679 "shape in namelist '%s' at %L", nl
->sym
->name
,
8680 sym
->name
, &sym
->declared_at
);
8684 /* Namelist objects cannot have allocatable or pointer components. */
8685 if (nl
->sym
->ts
.type
!= BT_DERIVED
)
8688 if (nl
->sym
->ts
.derived
->attr
.alloc_comp
)
8690 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8691 "have ALLOCATABLE components",
8692 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8696 if (nl
->sym
->ts
.derived
->attr
.pointer_comp
)
8698 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8699 "have POINTER components",
8700 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8706 /* 14.1.2 A module or internal procedure represent local entities
8707 of the same type as a namelist member and so are not allowed. */
8708 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
8710 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
8713 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
8714 if ((nl
->sym
== sym
->ns
->proc_name
)
8716 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
8720 if (nl
->sym
&& nl
->sym
->name
)
8721 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
8722 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
8724 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
8725 "attribute in '%s' at %L", nlsym
->name
,
8736 resolve_fl_parameter (gfc_symbol
*sym
)
8738 /* A parameter array's shape needs to be constant. */
8740 && (sym
->as
->type
== AS_DEFERRED
8741 || is_non_constant_shape_array (sym
)))
8743 gfc_error ("Parameter array '%s' at %L cannot be automatic "
8744 "or of deferred shape", sym
->name
, &sym
->declared_at
);
8748 /* Make sure a parameter that has been implicitly typed still
8749 matches the implicit type, since PARAMETER statements can precede
8750 IMPLICIT statements. */
8751 if (sym
->attr
.implicit_type
8752 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
8754 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
8755 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
8759 /* Make sure the types of derived parameters are consistent. This
8760 type checking is deferred until resolution because the type may
8761 refer to a derived type from the host. */
8762 if (sym
->ts
.type
== BT_DERIVED
8763 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
8765 gfc_error ("Incompatible derived type in PARAMETER at %L",
8766 &sym
->value
->where
);
8773 /* Do anything necessary to resolve a symbol. Right now, we just
8774 assume that an otherwise unknown symbol is a variable. This sort
8775 of thing commonly happens for symbols in module. */
8778 resolve_symbol (gfc_symbol
*sym
)
8780 int check_constant
, mp_flag
;
8781 gfc_symtree
*symtree
;
8782 gfc_symtree
*this_symtree
;
8786 if (sym
->attr
.flavor
== FL_UNKNOWN
)
8789 /* If we find that a flavorless symbol is an interface in one of the
8790 parent namespaces, find its symtree in this namespace, free the
8791 symbol and set the symtree to point to the interface symbol. */
8792 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
8794 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
8795 if (symtree
&& symtree
->n
.sym
->generic
)
8797 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8801 gfc_free_symbol (sym
);
8802 symtree
->n
.sym
->refs
++;
8803 this_symtree
->n
.sym
= symtree
->n
.sym
;
8808 /* Otherwise give it a flavor according to such attributes as
8810 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
8811 sym
->attr
.flavor
= FL_VARIABLE
;
8814 sym
->attr
.flavor
= FL_PROCEDURE
;
8815 if (sym
->attr
.dimension
)
8816 sym
->attr
.function
= 1;
8820 if (sym
->attr
.procedure
&& sym
->ts
.interface
8821 && sym
->attr
.if_source
!= IFSRC_DECL
)
8823 if (sym
->ts
.interface
->attr
.procedure
)
8824 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
8825 "in a later PROCEDURE statement", sym
->ts
.interface
->name
,
8826 sym
->name
,&sym
->declared_at
);
8828 /* Get the attributes from the interface (now resolved). */
8829 if (sym
->ts
.interface
->attr
.if_source
|| sym
->ts
.interface
->attr
.intrinsic
)
8831 gfc_symbol
*ifc
= sym
->ts
.interface
;
8833 sym
->ts
.interface
= ifc
;
8834 sym
->attr
.function
= ifc
->attr
.function
;
8835 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
8836 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
8837 sym
->attr
.pointer
= ifc
->attr
.pointer
;
8838 sym
->attr
.pure
= ifc
->attr
.pure
;
8839 sym
->attr
.elemental
= ifc
->attr
.elemental
;
8840 sym
->attr
.dimension
= ifc
->attr
.dimension
;
8841 sym
->attr
.recursive
= ifc
->attr
.recursive
;
8842 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
8843 sym
->as
= gfc_copy_array_spec (ifc
->as
);
8844 copy_formal_args (sym
, ifc
);
8846 else if (sym
->ts
.interface
->name
[0] != '\0')
8848 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
8849 sym
->ts
.interface
->name
, sym
->name
, &sym
->declared_at
);
8854 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
8857 /* Symbols that are module procedures with results (functions) have
8858 the types and array specification copied for type checking in
8859 procedures that call them, as well as for saving to a module
8860 file. These symbols can't stand the scrutiny that their results
8862 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
8865 /* Make sure that the intrinsic is consistent with its internal
8866 representation. This needs to be done before assigning a default
8867 type to avoid spurious warnings. */
8868 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
)
8870 gfc_intrinsic_sym
* isym
;
8873 /* We already know this one is an intrinsic, so we don't call
8874 gfc_is_intrinsic for full checking but rather use gfc_find_function and
8875 gfc_find_subroutine directly to check whether it is a function or
8878 if ((isym
= gfc_find_function (sym
->name
)))
8880 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
)
8881 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
8882 " ignored", sym
->name
, &sym
->declared_at
);
8884 else if ((isym
= gfc_find_subroutine (sym
->name
)))
8886 if (sym
->ts
.type
!= BT_UNKNOWN
)
8888 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
8889 " specifier", sym
->name
, &sym
->declared_at
);
8895 gfc_error ("'%s' declared INTRINSIC at %L does not exist",
8896 sym
->name
, &sym
->declared_at
);
8900 /* Check it is actually available in the standard settings. */
8901 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
8904 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
8905 " available in the current standard settings but %s. Use"
8906 " an appropriate -std=* option or enable -fall-intrinsics"
8907 " in order to use it.",
8908 sym
->name
, &sym
->declared_at
, symstd
);
8913 /* Assign default type to symbols that need one and don't have one. */
8914 if (sym
->ts
.type
== BT_UNKNOWN
)
8916 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
8917 gfc_set_default_type (sym
, 1, NULL
);
8919 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
8921 /* The specific case of an external procedure should emit an error
8922 in the case that there is no implicit type. */
8924 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
8927 /* Result may be in another namespace. */
8928 resolve_symbol (sym
->result
);
8930 sym
->ts
= sym
->result
->ts
;
8931 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
8932 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
8933 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
8934 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
8939 /* Assumed size arrays and assumed shape arrays must be dummy
8943 && (sym
->as
->type
== AS_ASSUMED_SIZE
8944 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
8945 && sym
->attr
.dummy
== 0)
8947 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
8948 gfc_error ("Assumed size array at %L must be a dummy argument",
8951 gfc_error ("Assumed shape array at %L must be a dummy argument",
8956 /* Make sure symbols with known intent or optional are really dummy
8957 variable. Because of ENTRY statement, this has to be deferred
8958 until resolution time. */
8960 if (!sym
->attr
.dummy
8961 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
8963 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
8967 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
8969 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
8970 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
8974 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
8976 gfc_charlen
*cl
= sym
->ts
.cl
;
8977 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
8979 gfc_error ("Character dummy variable '%s' at %L with VALUE "
8980 "attribute must have constant length",
8981 sym
->name
, &sym
->declared_at
);
8985 if (sym
->ts
.is_c_interop
8986 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
8988 gfc_error ("C interoperable character dummy variable '%s' at %L "
8989 "with VALUE attribute must have length one",
8990 sym
->name
, &sym
->declared_at
);
8995 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
8996 do this for something that was implicitly typed because that is handled
8997 in gfc_set_default_type. Handle dummy arguments and procedure
8998 definitions separately. Also, anything that is use associated is not
8999 handled here but instead is handled in the module it is declared in.
9000 Finally, derived type definitions are allowed to be BIND(C) since that
9001 only implies that they're interoperable, and they are checked fully for
9002 interoperability when a variable is declared of that type. */
9003 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
9004 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
9005 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
9007 gfc_try t
= SUCCESS
;
9009 /* First, make sure the variable is declared at the
9010 module-level scope (J3/04-007, Section 15.3). */
9011 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
9012 sym
->attr
.in_common
== 0)
9014 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
9015 "is neither a COMMON block nor declared at the "
9016 "module level scope", sym
->name
, &(sym
->declared_at
));
9019 else if (sym
->common_head
!= NULL
)
9021 t
= verify_com_block_vars_c_interop (sym
->common_head
);
9025 /* If type() declaration, we need to verify that the components
9026 of the given type are all C interoperable, etc. */
9027 if (sym
->ts
.type
== BT_DERIVED
&&
9028 sym
->ts
.derived
->attr
.is_c_interop
!= 1)
9030 /* Make sure the user marked the derived type as BIND(C). If
9031 not, call the verify routine. This could print an error
9032 for the derived type more than once if multiple variables
9033 of that type are declared. */
9034 if (sym
->ts
.derived
->attr
.is_bind_c
!= 1)
9035 verify_bind_c_derived_type (sym
->ts
.derived
);
9039 /* Verify the variable itself as C interoperable if it
9040 is BIND(C). It is not possible for this to succeed if
9041 the verify_bind_c_derived_type failed, so don't have to handle
9042 any error returned by verify_bind_c_derived_type. */
9043 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
9049 /* clear the is_bind_c flag to prevent reporting errors more than
9050 once if something failed. */
9051 sym
->attr
.is_bind_c
= 0;
9056 /* If a derived type symbol has reached this point, without its
9057 type being declared, we have an error. Notice that most
9058 conditions that produce undefined derived types have already
9059 been dealt with. However, the likes of:
9060 implicit type(t) (t) ..... call foo (t) will get us here if
9061 the type is not declared in the scope of the implicit
9062 statement. Change the type to BT_UNKNOWN, both because it is so
9063 and to prevent an ICE. */
9064 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
->components
== NULL
9065 && !sym
->ts
.derived
->attr
.zero_comp
)
9067 gfc_error ("The derived type '%s' at %L is of type '%s', "
9068 "which has not been defined", sym
->name
,
9069 &sym
->declared_at
, sym
->ts
.derived
->name
);
9070 sym
->ts
.type
= BT_UNKNOWN
;
9074 /* Make sure that the derived type has been resolved and that the
9075 derived type is visible in the symbol's namespace, if it is a
9076 module function and is not PRIVATE. */
9077 if (sym
->ts
.type
== BT_DERIVED
9078 && sym
->ts
.derived
->attr
.use_assoc
9079 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
9083 if (resolve_fl_derived (sym
->ts
.derived
) == FAILURE
)
9086 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 1, &ds
);
9087 if (!ds
&& sym
->attr
.function
9088 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
9090 symtree
= gfc_new_symtree (&sym
->ns
->sym_root
,
9091 sym
->ts
.derived
->name
);
9092 symtree
->n
.sym
= sym
->ts
.derived
;
9093 sym
->ts
.derived
->refs
++;
9097 /* Unless the derived-type declaration is use associated, Fortran 95
9098 does not allow public entries of private derived types.
9099 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
9101 if (sym
->ts
.type
== BT_DERIVED
9102 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
9103 && !sym
->ts
.derived
->attr
.use_assoc
9104 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
9105 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
9106 sym
->ts
.derived
->ns
->default_access
)
9107 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
9108 "of PRIVATE derived type '%s'",
9109 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
9110 : "variable", sym
->name
, &sym
->declared_at
,
9111 sym
->ts
.derived
->name
) == FAILURE
)
9114 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
9115 default initialization is defined (5.1.2.4.4). */
9116 if (sym
->ts
.type
== BT_DERIVED
9118 && sym
->attr
.intent
== INTENT_OUT
9120 && sym
->as
->type
== AS_ASSUMED_SIZE
)
9122 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
9126 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
9127 "ASSUMED SIZE and so cannot have a default initializer",
9128 sym
->name
, &sym
->declared_at
);
9134 switch (sym
->attr
.flavor
)
9137 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
9142 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
9147 if (resolve_fl_namelist (sym
) == FAILURE
)
9152 if (resolve_fl_parameter (sym
) == FAILURE
)
9160 /* Resolve array specifier. Check as well some constraints
9161 on COMMON blocks. */
9163 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
9165 /* Set the formal_arg_flag so that check_conflict will not throw
9166 an error for host associated variables in the specification
9167 expression for an array_valued function. */
9168 if (sym
->attr
.function
&& sym
->as
)
9169 formal_arg_flag
= 1;
9171 gfc_resolve_array_spec (sym
->as
, check_constant
);
9173 formal_arg_flag
= 0;
9175 /* Resolve formal namespaces. */
9176 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
)
9177 gfc_resolve (sym
->formal_ns
);
9179 /* Check threadprivate restrictions. */
9180 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
9181 && (!sym
->attr
.in_common
9182 && sym
->module
== NULL
9183 && (sym
->ns
->proc_name
== NULL
9184 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
9185 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
9187 /* If we have come this far we can apply default-initializers, as
9188 described in 14.7.5, to those variables that have not already
9189 been assigned one. */
9190 if (sym
->ts
.type
== BT_DERIVED
9191 && sym
->attr
.referenced
9192 && sym
->ns
== gfc_current_ns
9194 && !sym
->attr
.allocatable
9195 && !sym
->attr
.alloc_comp
)
9197 symbol_attribute
*a
= &sym
->attr
;
9199 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
9200 && !a
->in_common
&& !a
->use_assoc
9201 && !(a
->function
&& sym
!= sym
->result
))
9202 || (a
->dummy
&& a
->intent
== INTENT_OUT
))
9203 apply_default_init (sym
);
9206 /* If this symbol has a type-spec, check it. */
9207 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
9208 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
9209 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
9215 /************* Resolve DATA statements *************/
9219 gfc_data_value
*vnode
;
9225 /* Advance the values structure to point to the next value in the data list. */
9228 next_data_value (void)
9231 while (mpz_cmp_ui (values
.left
, 0) == 0)
9233 if (values
.vnode
->next
== NULL
)
9236 values
.vnode
= values
.vnode
->next
;
9237 mpz_set (values
.left
, values
.vnode
->repeat
);
9245 check_data_variable (gfc_data_variable
*var
, locus
*where
)
9251 ar_type mark
= AR_UNKNOWN
;
9253 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
9257 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
9261 mpz_init_set_si (offset
, 0);
9264 if (e
->expr_type
!= EXPR_VARIABLE
)
9265 gfc_internal_error ("check_data_variable(): Bad expression");
9267 if (e
->symtree
->n
.sym
->ns
->is_block_data
9268 && !e
->symtree
->n
.sym
->attr
.in_common
)
9270 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
9271 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
9274 if (e
->ref
== NULL
&& e
->symtree
->n
.sym
->as
)
9276 gfc_error ("DATA array '%s' at %L must be specified in a previous"
9277 " declaration", e
->symtree
->n
.sym
->name
, where
);
9283 mpz_init_set_ui (size
, 1);
9290 /* Find the array section reference. */
9291 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9293 if (ref
->type
!= REF_ARRAY
)
9295 if (ref
->u
.ar
.type
== AR_ELEMENT
)
9301 /* Set marks according to the reference pattern. */
9302 switch (ref
->u
.ar
.type
)
9310 /* Get the start position of array section. */
9311 gfc_get_section_index (ar
, section_index
, &offset
);
9319 if (gfc_array_size (e
, &size
) == FAILURE
)
9321 gfc_error ("Nonconstant array section at %L in DATA statement",
9330 while (mpz_cmp_ui (size
, 0) > 0)
9332 if (next_data_value () == FAILURE
)
9334 gfc_error ("DATA statement at %L has more variables than values",
9340 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
9344 /* If we have more than one element left in the repeat count,
9345 and we have more than one element left in the target variable,
9346 then create a range assignment. */
9347 /* FIXME: Only done for full arrays for now, since array sections
9349 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
9350 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
9354 if (mpz_cmp (size
, values
.left
) >= 0)
9356 mpz_init_set (range
, values
.left
);
9357 mpz_sub (size
, size
, values
.left
);
9358 mpz_set_ui (values
.left
, 0);
9362 mpz_init_set (range
, size
);
9363 mpz_sub (values
.left
, values
.left
, size
);
9364 mpz_set_ui (size
, 0);
9367 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
9370 mpz_add (offset
, offset
, range
);
9374 /* Assign initial value to symbol. */
9377 mpz_sub_ui (values
.left
, values
.left
, 1);
9378 mpz_sub_ui (size
, size
, 1);
9380 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
9384 if (mark
== AR_FULL
)
9385 mpz_add_ui (offset
, offset
, 1);
9387 /* Modify the array section indexes and recalculate the offset
9388 for next element. */
9389 else if (mark
== AR_SECTION
)
9390 gfc_advance_section (section_index
, ar
, &offset
);
9394 if (mark
== AR_SECTION
)
9396 for (i
= 0; i
< ar
->dimen
; i
++)
9397 mpz_clear (section_index
[i
]);
9407 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
9409 /* Iterate over a list of elements in a DATA statement. */
9412 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
9415 iterator_stack frame
;
9416 gfc_expr
*e
, *start
, *end
, *step
;
9417 gfc_try retval
= SUCCESS
;
9419 mpz_init (frame
.value
);
9421 start
= gfc_copy_expr (var
->iter
.start
);
9422 end
= gfc_copy_expr (var
->iter
.end
);
9423 step
= gfc_copy_expr (var
->iter
.step
);
9425 if (gfc_simplify_expr (start
, 1) == FAILURE
9426 || start
->expr_type
!= EXPR_CONSTANT
)
9428 gfc_error ("iterator start at %L does not simplify", &start
->where
);
9432 if (gfc_simplify_expr (end
, 1) == FAILURE
9433 || end
->expr_type
!= EXPR_CONSTANT
)
9435 gfc_error ("iterator end at %L does not simplify", &end
->where
);
9439 if (gfc_simplify_expr (step
, 1) == FAILURE
9440 || step
->expr_type
!= EXPR_CONSTANT
)
9442 gfc_error ("iterator step at %L does not simplify", &step
->where
);
9447 mpz_init_set (trip
, end
->value
.integer
);
9448 mpz_sub (trip
, trip
, start
->value
.integer
);
9449 mpz_add (trip
, trip
, step
->value
.integer
);
9451 mpz_div (trip
, trip
, step
->value
.integer
);
9453 mpz_set (frame
.value
, start
->value
.integer
);
9455 frame
.prev
= iter_stack
;
9456 frame
.variable
= var
->iter
.var
->symtree
;
9457 iter_stack
= &frame
;
9459 while (mpz_cmp_ui (trip
, 0) > 0)
9461 if (traverse_data_var (var
->list
, where
) == FAILURE
)
9468 e
= gfc_copy_expr (var
->expr
);
9469 if (gfc_simplify_expr (e
, 1) == FAILURE
)
9477 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
9479 mpz_sub_ui (trip
, trip
, 1);
9484 mpz_clear (frame
.value
);
9486 gfc_free_expr (start
);
9487 gfc_free_expr (end
);
9488 gfc_free_expr (step
);
9490 iter_stack
= frame
.prev
;
9495 /* Type resolve variables in the variable list of a DATA statement. */
9498 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
9502 for (; var
; var
= var
->next
)
9504 if (var
->expr
== NULL
)
9505 t
= traverse_data_list (var
, where
);
9507 t
= check_data_variable (var
, where
);
9517 /* Resolve the expressions and iterators associated with a data statement.
9518 This is separate from the assignment checking because data lists should
9519 only be resolved once. */
9522 resolve_data_variables (gfc_data_variable
*d
)
9524 for (; d
; d
= d
->next
)
9526 if (d
->list
== NULL
)
9528 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
9533 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
9536 if (resolve_data_variables (d
->list
) == FAILURE
)
9545 /* Resolve a single DATA statement. We implement this by storing a pointer to
9546 the value list into static variables, and then recursively traversing the
9547 variables list, expanding iterators and such. */
9550 resolve_data (gfc_data
*d
)
9553 if (resolve_data_variables (d
->var
) == FAILURE
)
9556 values
.vnode
= d
->value
;
9557 if (d
->value
== NULL
)
9558 mpz_set_ui (values
.left
, 0);
9560 mpz_set (values
.left
, d
->value
->repeat
);
9562 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
9565 /* At this point, we better not have any values left. */
9567 if (next_data_value () == SUCCESS
)
9568 gfc_error ("DATA statement at %L has more values than variables",
9573 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
9574 accessed by host or use association, is a dummy argument to a pure function,
9575 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
9576 is storage associated with any such variable, shall not be used in the
9577 following contexts: (clients of this function). */
9579 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
9580 procedure. Returns zero if assignment is OK, nonzero if there is a
9583 gfc_impure_variable (gfc_symbol
*sym
)
9587 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
9590 if (sym
->ns
!= gfc_current_ns
)
9591 return !sym
->attr
.function
;
9593 proc
= sym
->ns
->proc_name
;
9594 if (sym
->attr
.dummy
&& gfc_pure (proc
)
9595 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
9597 proc
->attr
.function
))
9600 /* TODO: Sort out what can be storage associated, if anything, and include
9601 it here. In principle equivalences should be scanned but it does not
9602 seem to be possible to storage associate an impure variable this way. */
9607 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
9608 symbol of the current procedure. */
9611 gfc_pure (gfc_symbol
*sym
)
9613 symbol_attribute attr
;
9616 sym
= gfc_current_ns
->proc_name
;
9622 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
9626 /* Test whether the current procedure is elemental or not. */
9629 gfc_elemental (gfc_symbol
*sym
)
9631 symbol_attribute attr
;
9634 sym
= gfc_current_ns
->proc_name
;
9639 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
9643 /* Warn about unused labels. */
9646 warn_unused_fortran_label (gfc_st_label
*label
)
9651 warn_unused_fortran_label (label
->left
);
9653 if (label
->defined
== ST_LABEL_UNKNOWN
)
9656 switch (label
->referenced
)
9658 case ST_LABEL_UNKNOWN
:
9659 gfc_warning ("Label %d at %L defined but not used", label
->value
,
9663 case ST_LABEL_BAD_TARGET
:
9664 gfc_warning ("Label %d at %L defined but cannot be used",
9665 label
->value
, &label
->where
);
9672 warn_unused_fortran_label (label
->right
);
9676 /* Returns the sequence type of a symbol or sequence. */
9679 sequence_type (gfc_typespec ts
)
9688 if (ts
.derived
->components
== NULL
)
9689 return SEQ_NONDEFAULT
;
9691 result
= sequence_type (ts
.derived
->components
->ts
);
9692 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
9693 if (sequence_type (c
->ts
) != result
)
9699 if (ts
.kind
!= gfc_default_character_kind
)
9700 return SEQ_NONDEFAULT
;
9702 return SEQ_CHARACTER
;
9705 if (ts
.kind
!= gfc_default_integer_kind
)
9706 return SEQ_NONDEFAULT
;
9711 if (!(ts
.kind
== gfc_default_real_kind
9712 || ts
.kind
== gfc_default_double_kind
))
9713 return SEQ_NONDEFAULT
;
9718 if (ts
.kind
!= gfc_default_complex_kind
)
9719 return SEQ_NONDEFAULT
;
9724 if (ts
.kind
!= gfc_default_logical_kind
)
9725 return SEQ_NONDEFAULT
;
9730 return SEQ_NONDEFAULT
;
9735 /* Resolve derived type EQUIVALENCE object. */
9738 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
9741 gfc_component
*c
= derived
->components
;
9746 /* Shall not be an object of nonsequence derived type. */
9747 if (!derived
->attr
.sequence
)
9749 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
9750 "attribute to be an EQUIVALENCE object", sym
->name
,
9755 /* Shall not have allocatable components. */
9756 if (derived
->attr
.alloc_comp
)
9758 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
9759 "components to be an EQUIVALENCE object",sym
->name
,
9764 if (sym
->attr
.in_common
&& has_default_initializer (sym
->ts
.derived
))
9766 gfc_error ("Derived type variable '%s' at %L with default "
9767 "initialization cannot be in EQUIVALENCE with a variable "
9768 "in COMMON", sym
->name
, &e
->where
);
9772 for (; c
; c
= c
->next
)
9776 && (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
9779 /* Shall not be an object of sequence derived type containing a pointer
9780 in the structure. */
9781 if (c
->attr
.pointer
)
9783 gfc_error ("Derived type variable '%s' at %L with pointer "
9784 "component(s) cannot be an EQUIVALENCE object",
9785 sym
->name
, &e
->where
);
9793 /* Resolve equivalence object.
9794 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
9795 an allocatable array, an object of nonsequence derived type, an object of
9796 sequence derived type containing a pointer at any level of component
9797 selection, an automatic object, a function name, an entry name, a result
9798 name, a named constant, a structure component, or a subobject of any of
9799 the preceding objects. A substring shall not have length zero. A
9800 derived type shall not have components with default initialization nor
9801 shall two objects of an equivalence group be initialized.
9802 Either all or none of the objects shall have an protected attribute.
9803 The simple constraints are done in symbol.c(check_conflict) and the rest
9804 are implemented here. */
9807 resolve_equivalence (gfc_equiv
*eq
)
9810 gfc_symbol
*derived
;
9811 gfc_symbol
*first_sym
;
9814 locus
*last_where
= NULL
;
9815 seq_type eq_type
, last_eq_type
;
9816 gfc_typespec
*last_ts
;
9817 int object
, cnt_protected
;
9818 const char *value_name
;
9822 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
9824 first_sym
= eq
->expr
->symtree
->n
.sym
;
9828 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
9832 e
->ts
= e
->symtree
->n
.sym
->ts
;
9833 /* match_varspec might not know yet if it is seeing
9834 array reference or substring reference, as it doesn't
9836 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
9838 gfc_ref
*ref
= e
->ref
;
9839 sym
= e
->symtree
->n
.sym
;
9841 if (sym
->attr
.dimension
)
9843 ref
->u
.ar
.as
= sym
->as
;
9847 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
9848 if (e
->ts
.type
== BT_CHARACTER
9850 && ref
->type
== REF_ARRAY
9851 && ref
->u
.ar
.dimen
== 1
9852 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
9853 && ref
->u
.ar
.stride
[0] == NULL
)
9855 gfc_expr
*start
= ref
->u
.ar
.start
[0];
9856 gfc_expr
*end
= ref
->u
.ar
.end
[0];
9859 /* Optimize away the (:) reference. */
9860 if (start
== NULL
&& end
== NULL
)
9865 e
->ref
->next
= ref
->next
;
9870 ref
->type
= REF_SUBSTRING
;
9872 start
= gfc_int_expr (1);
9873 ref
->u
.ss
.start
= start
;
9874 if (end
== NULL
&& e
->ts
.cl
)
9875 end
= gfc_copy_expr (e
->ts
.cl
->length
);
9876 ref
->u
.ss
.end
= end
;
9877 ref
->u
.ss
.length
= e
->ts
.cl
;
9884 /* Any further ref is an error. */
9887 gcc_assert (ref
->type
== REF_ARRAY
);
9888 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
9894 if (gfc_resolve_expr (e
) == FAILURE
)
9897 sym
= e
->symtree
->n
.sym
;
9899 if (sym
->attr
.is_protected
)
9901 if (cnt_protected
> 0 && cnt_protected
!= object
)
9903 gfc_error ("Either all or none of the objects in the "
9904 "EQUIVALENCE set at %L shall have the "
9905 "PROTECTED attribute",
9910 /* Shall not equivalence common block variables in a PURE procedure. */
9911 if (sym
->ns
->proc_name
9912 && sym
->ns
->proc_name
->attr
.pure
9913 && sym
->attr
.in_common
)
9915 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
9916 "object in the pure procedure '%s'",
9917 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
9921 /* Shall not be a named constant. */
9922 if (e
->expr_type
== EXPR_CONSTANT
)
9924 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
9925 "object", sym
->name
, &e
->where
);
9929 derived
= e
->ts
.derived
;
9930 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
9933 /* Check that the types correspond correctly:
9935 A numeric sequence structure may be equivalenced to another sequence
9936 structure, an object of default integer type, default real type, double
9937 precision real type, default logical type such that components of the
9938 structure ultimately only become associated to objects of the same
9939 kind. A character sequence structure may be equivalenced to an object
9940 of default character kind or another character sequence structure.
9941 Other objects may be equivalenced only to objects of the same type and
9944 /* Identical types are unconditionally OK. */
9945 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
9946 goto identical_types
;
9948 last_eq_type
= sequence_type (*last_ts
);
9949 eq_type
= sequence_type (sym
->ts
);
9951 /* Since the pair of objects is not of the same type, mixed or
9952 non-default sequences can be rejected. */
9954 msg
= "Sequence %s with mixed components in EQUIVALENCE "
9955 "statement at %L with different type objects";
9957 && last_eq_type
== SEQ_MIXED
9958 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
9960 || (eq_type
== SEQ_MIXED
9961 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
9962 &e
->where
) == FAILURE
))
9965 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
9966 "statement at %L with objects of different type";
9968 && last_eq_type
== SEQ_NONDEFAULT
9969 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
9970 last_where
) == FAILURE
)
9971 || (eq_type
== SEQ_NONDEFAULT
9972 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
9973 &e
->where
) == FAILURE
))
9976 msg
="Non-CHARACTER object '%s' in default CHARACTER "
9977 "EQUIVALENCE statement at %L";
9978 if (last_eq_type
== SEQ_CHARACTER
9979 && eq_type
!= SEQ_CHARACTER
9980 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
9981 &e
->where
) == FAILURE
)
9984 msg
="Non-NUMERIC object '%s' in default NUMERIC "
9985 "EQUIVALENCE statement at %L";
9986 if (last_eq_type
== SEQ_NUMERIC
9987 && eq_type
!= SEQ_NUMERIC
9988 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
9989 &e
->where
) == FAILURE
)
9994 last_where
= &e
->where
;
9999 /* Shall not be an automatic array. */
10000 if (e
->ref
->type
== REF_ARRAY
10001 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
10003 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
10004 "an EQUIVALENCE object", sym
->name
, &e
->where
);
10011 /* Shall not be a structure component. */
10012 if (r
->type
== REF_COMPONENT
)
10014 gfc_error ("Structure component '%s' at %L cannot be an "
10015 "EQUIVALENCE object",
10016 r
->u
.c
.component
->name
, &e
->where
);
10020 /* A substring shall not have length zero. */
10021 if (r
->type
== REF_SUBSTRING
)
10023 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
10025 gfc_error ("Substring at %L has length zero",
10026 &r
->u
.ss
.start
->where
);
10036 /* Resolve function and ENTRY types, issue diagnostics if needed. */
10039 resolve_fntype (gfc_namespace
*ns
)
10041 gfc_entry_list
*el
;
10044 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
10047 /* If there are any entries, ns->proc_name is the entry master
10048 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
10050 sym
= ns
->entries
->sym
;
10052 sym
= ns
->proc_name
;
10053 if (sym
->result
== sym
10054 && sym
->ts
.type
== BT_UNKNOWN
10055 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
10056 && !sym
->attr
.untyped
)
10058 gfc_error ("Function '%s' at %L has no IMPLICIT type",
10059 sym
->name
, &sym
->declared_at
);
10060 sym
->attr
.untyped
= 1;
10063 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
10064 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
10065 sym
->ts
.derived
->ns
->default_access
)
10066 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
10068 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
10069 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
10073 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
10075 if (el
->sym
->result
== el
->sym
10076 && el
->sym
->ts
.type
== BT_UNKNOWN
10077 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
10078 && !el
->sym
->attr
.untyped
)
10080 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
10081 el
->sym
->name
, &el
->sym
->declared_at
);
10082 el
->sym
->attr
.untyped
= 1;
10087 /* 12.3.2.1.1 Defined operators. */
10090 gfc_resolve_uops (gfc_symtree
*symtree
)
10092 gfc_interface
*itr
;
10094 gfc_formal_arglist
*formal
;
10096 if (symtree
== NULL
)
10099 gfc_resolve_uops (symtree
->left
);
10100 gfc_resolve_uops (symtree
->right
);
10102 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
10105 if (!sym
->attr
.function
)
10106 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
10107 sym
->name
, &sym
->declared_at
);
10109 if (sym
->ts
.type
== BT_CHARACTER
10110 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
10111 && !(sym
->result
&& sym
->result
->ts
.cl
10112 && sym
->result
->ts
.cl
->length
))
10113 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
10114 "character length", sym
->name
, &sym
->declared_at
);
10116 formal
= sym
->formal
;
10117 if (!formal
|| !formal
->sym
)
10119 gfc_error ("User operator procedure '%s' at %L must have at least "
10120 "one argument", sym
->name
, &sym
->declared_at
);
10124 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
10125 gfc_error ("First argument of operator interface at %L must be "
10126 "INTENT(IN)", &sym
->declared_at
);
10128 if (formal
->sym
->attr
.optional
)
10129 gfc_error ("First argument of operator interface at %L cannot be "
10130 "optional", &sym
->declared_at
);
10132 formal
= formal
->next
;
10133 if (!formal
|| !formal
->sym
)
10136 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
10137 gfc_error ("Second argument of operator interface at %L must be "
10138 "INTENT(IN)", &sym
->declared_at
);
10140 if (formal
->sym
->attr
.optional
)
10141 gfc_error ("Second argument of operator interface at %L cannot be "
10142 "optional", &sym
->declared_at
);
10145 gfc_error ("Operator interface at %L must have, at most, two "
10146 "arguments", &sym
->declared_at
);
10151 /* Examine all of the expressions associated with a program unit,
10152 assign types to all intermediate expressions, make sure that all
10153 assignments are to compatible types and figure out which names
10154 refer to which functions or subroutines. It doesn't check code
10155 block, which is handled by resolve_code. */
10158 resolve_types (gfc_namespace
*ns
)
10164 gfc_namespace
* old_ns
= gfc_current_ns
;
10166 /* Check that all IMPLICIT types are ok. */
10167 if (!ns
->seen_implicit_none
)
10170 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
10171 if (ns
->set_flag
[letter
]
10172 && resolve_typespec_used (&ns
->default_type
[letter
],
10173 &ns
->implicit_loc
[letter
],
10178 gfc_current_ns
= ns
;
10180 resolve_entries (ns
);
10182 resolve_common_vars (ns
->blank_common
.head
, false);
10183 resolve_common_blocks (ns
->common_root
);
10185 resolve_contained_functions (ns
);
10187 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
10189 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
10190 resolve_charlen (cl
);
10192 gfc_traverse_ns (ns
, resolve_symbol
);
10194 resolve_fntype (ns
);
10196 for (n
= ns
->contained
; n
; n
= n
->sibling
)
10198 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
10199 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
10200 "also be PURE", n
->proc_name
->name
,
10201 &n
->proc_name
->declared_at
);
10207 gfc_check_interfaces (ns
);
10209 gfc_traverse_ns (ns
, resolve_values
);
10215 for (d
= ns
->data
; d
; d
= d
->next
)
10219 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
10221 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
10223 if (ns
->common_root
!= NULL
)
10224 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
10226 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
10227 resolve_equivalence (eq
);
10229 /* Warn about unused labels. */
10230 if (warn_unused_label
)
10231 warn_unused_fortran_label (ns
->st_labels
);
10233 gfc_resolve_uops (ns
->uop_root
);
10235 gfc_current_ns
= old_ns
;
10239 /* Call resolve_code recursively. */
10242 resolve_codes (gfc_namespace
*ns
)
10246 for (n
= ns
->contained
; n
; n
= n
->sibling
)
10249 gfc_current_ns
= ns
;
10251 /* Set to an out of range value. */
10252 current_entry_id
= -1;
10254 bitmap_obstack_initialize (&labels_obstack
);
10255 resolve_code (ns
->code
, ns
);
10256 bitmap_obstack_release (&labels_obstack
);
10260 /* This function is called after a complete program unit has been compiled.
10261 Its purpose is to examine all of the expressions associated with a program
10262 unit, assign types to all intermediate expressions, make sure that all
10263 assignments are to compatible types and figure out which names refer to
10264 which functions or subroutines. */
10267 gfc_resolve (gfc_namespace
*ns
)
10269 gfc_namespace
*old_ns
;
10271 old_ns
= gfc_current_ns
;
10273 resolve_types (ns
);
10274 resolve_codes (ns
);
10276 gfc_current_ns
= old_ns
;