1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
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"
32 /* Types used in equivalence statements. */
36 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and resolve_code(). */
43 typedef struct code_stack
45 struct gfc_code
*head
, *current
, *tail
;
46 struct code_stack
*prev
;
48 /* This bitmap keeps track of the targets valid for a branch from
50 bitmap reachable_labels
;
54 static code_stack
*cs_base
= NULL
;
57 /* Nonzero if we're inside a FORALL block. */
59 static int forall_flag
;
61 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
63 static int omp_workshare_flag
;
65 /* Nonzero if we are processing a formal arglist. The corresponding function
66 resets the flag each time that it is read. */
67 static int formal_arg_flag
= 0;
69 /* True if we are resolving a specification expression. */
70 static int specification_expr
= 0;
72 /* The id of the last entry seen. */
73 static int current_entry_id
;
75 /* We use bitmaps to determine if a branch target is valid. */
76 static bitmap_obstack labels_obstack
;
79 gfc_is_formal_arg (void)
81 return formal_arg_flag
;
84 /* Resolve types of formal argument lists. These have to be done early so that
85 the formal argument lists of module procedures can be copied to the
86 containing module before the individual procedures are resolved
87 individually. We also resolve argument lists of procedures in interface
88 blocks because they are self-contained scoping units.
90 Since a dummy argument cannot be a non-dummy procedure, the only
91 resort left for untyped names are the IMPLICIT types. */
94 resolve_formal_arglist (gfc_symbol
*proc
)
96 gfc_formal_arglist
*f
;
100 if (proc
->result
!= NULL
)
105 if (gfc_elemental (proc
)
106 || sym
->attr
.pointer
|| sym
->attr
.allocatable
107 || (sym
->as
&& sym
->as
->rank
> 0))
108 proc
->attr
.always_explicit
= 1;
112 for (f
= proc
->formal
; f
; f
= f
->next
)
118 /* Alternate return placeholder. */
119 if (gfc_elemental (proc
))
120 gfc_error ("Alternate return specifier in elemental subroutine "
121 "'%s' at %L is not allowed", proc
->name
,
123 if (proc
->attr
.function
)
124 gfc_error ("Alternate return specifier in function "
125 "'%s' at %L is not allowed", proc
->name
,
130 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
131 resolve_formal_arglist (sym
);
133 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
135 if (gfc_pure (proc
) && !gfc_pure (sym
))
137 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
138 "also be PURE", sym
->name
, &sym
->declared_at
);
142 if (gfc_elemental (proc
))
144 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
145 "procedure", &sym
->declared_at
);
149 if (sym
->attr
.function
150 && sym
->ts
.type
== BT_UNKNOWN
151 && sym
->attr
.intrinsic
)
153 gfc_intrinsic_sym
*isym
;
154 isym
= gfc_find_function (sym
->name
);
155 if (isym
== NULL
|| !isym
->specific
)
157 gfc_error ("Unable to find a specific INTRINSIC procedure "
158 "for the reference '%s' at %L", sym
->name
,
167 if (sym
->ts
.type
== BT_UNKNOWN
)
169 if (!sym
->attr
.function
|| sym
->result
== sym
)
170 gfc_set_default_type (sym
, 1, sym
->ns
);
173 gfc_resolve_array_spec (sym
->as
, 0);
175 /* We can't tell if an array with dimension (:) is assumed or deferred
176 shape until we know if it has the pointer or allocatable attributes.
178 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
179 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
181 sym
->as
->type
= AS_ASSUMED_SHAPE
;
182 for (i
= 0; i
< sym
->as
->rank
; i
++)
183 sym
->as
->lower
[i
] = gfc_int_expr (1);
186 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
187 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
188 || sym
->attr
.optional
)
189 proc
->attr
.always_explicit
= 1;
191 /* If the flavor is unknown at this point, it has to be a variable.
192 A procedure specification would have already set the type. */
194 if (sym
->attr
.flavor
== FL_UNKNOWN
)
195 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
197 if (gfc_pure (proc
) && !sym
->attr
.pointer
198 && sym
->attr
.flavor
!= FL_PROCEDURE
)
200 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
201 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
202 "INTENT(IN)", sym
->name
, proc
->name
,
205 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
206 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
207 "have its INTENT specified", sym
->name
, proc
->name
,
211 if (gfc_elemental (proc
))
215 gfc_error ("Argument '%s' of elemental procedure at %L must "
216 "be scalar", sym
->name
, &sym
->declared_at
);
220 if (sym
->attr
.pointer
)
222 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
223 "have the POINTER attribute", sym
->name
,
229 /* Each dummy shall be specified to be scalar. */
230 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
234 gfc_error ("Argument '%s' of statement function at %L must "
235 "be scalar", sym
->name
, &sym
->declared_at
);
239 if (sym
->ts
.type
== BT_CHARACTER
)
241 gfc_charlen
*cl
= sym
->ts
.cl
;
242 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
244 gfc_error ("Character-valued argument '%s' of statement "
245 "function at %L must have constant length",
246 sym
->name
, &sym
->declared_at
);
256 /* Work function called when searching for symbols that have argument lists
257 associated with them. */
260 find_arglists (gfc_symbol
*sym
)
262 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
265 resolve_formal_arglist (sym
);
269 /* Given a namespace, resolve all formal argument lists within the namespace.
273 resolve_formal_arglists (gfc_namespace
*ns
)
278 gfc_traverse_ns (ns
, find_arglists
);
283 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
287 /* If this namespace is not a function, ignore it. */
288 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
))
291 /* Try to find out of what the return type is. */
292 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
294 t
= gfc_set_default_type (sym
->result
, 0, ns
);
296 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
298 if (sym
->result
== sym
)
299 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
300 sym
->name
, &sym
->declared_at
);
302 gfc_error ("Result '%s' of contained function '%s' at %L has "
303 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
304 &sym
->result
->declared_at
);
305 sym
->result
->attr
.untyped
= 1;
309 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
310 type, lists the only ways a character length value of * can be used:
311 dummy arguments of procedures, named constants, and function results
312 in external functions. Internal function results are not on that list;
313 ergo, not permitted. */
315 if (sym
->result
->ts
.type
== BT_CHARACTER
)
317 gfc_charlen
*cl
= sym
->result
->ts
.cl
;
318 if (!cl
|| !cl
->length
)
319 gfc_error ("Character-valued internal function '%s' at %L must "
320 "not be assumed length", sym
->name
, &sym
->declared_at
);
325 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
326 introduce duplicates. */
329 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
331 gfc_formal_arglist
*f
, *new_arglist
;
334 for (; new_args
!= NULL
; new_args
= new_args
->next
)
336 new_sym
= new_args
->sym
;
337 /* See if this arg is already in the formal argument list. */
338 for (f
= proc
->formal
; f
; f
= f
->next
)
340 if (new_sym
== f
->sym
)
347 /* Add a new argument. Argument order is not important. */
348 new_arglist
= gfc_get_formal_arglist ();
349 new_arglist
->sym
= new_sym
;
350 new_arglist
->next
= proc
->formal
;
351 proc
->formal
= new_arglist
;
356 /* Flag the arguments that are not present in all entries. */
359 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
361 gfc_formal_arglist
*f
, *head
;
364 for (f
= proc
->formal
; f
; f
= f
->next
)
369 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
371 if (new_args
->sym
== f
->sym
)
378 f
->sym
->attr
.not_always_present
= 1;
383 /* Resolve alternate entry points. If a symbol has multiple entry points we
384 create a new master symbol for the main routine, and turn the existing
385 symbol into an entry point. */
388 resolve_entries (gfc_namespace
*ns
)
390 gfc_namespace
*old_ns
;
394 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
395 static int master_count
= 0;
397 if (ns
->proc_name
== NULL
)
400 /* No need to do anything if this procedure doesn't have alternate entry
405 /* We may already have resolved alternate entry points. */
406 if (ns
->proc_name
->attr
.entry_master
)
409 /* If this isn't a procedure something has gone horribly wrong. */
410 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
412 /* Remember the current namespace. */
413 old_ns
= gfc_current_ns
;
417 /* Add the main entry point to the list of entry points. */
418 el
= gfc_get_entry_list ();
419 el
->sym
= ns
->proc_name
;
421 el
->next
= ns
->entries
;
423 ns
->proc_name
->attr
.entry
= 1;
425 /* If it is a module function, it needs to be in the right namespace
426 so that gfc_get_fake_result_decl can gather up the results. The
427 need for this arose in get_proc_name, where these beasts were
428 left in their own namespace, to keep prior references linked to
429 the entry declaration.*/
430 if (ns
->proc_name
->attr
.function
431 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
434 /* Do the same for entries where the master is not a module
435 procedure. These are retained in the module namespace because
436 of the module procedure declaration. */
437 for (el
= el
->next
; el
; el
= el
->next
)
438 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
439 && el
->sym
->attr
.mod_proc
)
443 /* Add an entry statement for it. */
450 /* Create a new symbol for the master function. */
451 /* Give the internal function a unique name (within this file).
452 Also include the function name so the user has some hope of figuring
453 out what is going on. */
454 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
455 master_count
++, ns
->proc_name
->name
);
456 gfc_get_ha_symbol (name
, &proc
);
457 gcc_assert (proc
!= NULL
);
459 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
460 if (ns
->proc_name
->attr
.subroutine
)
461 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
465 gfc_typespec
*ts
, *fts
;
466 gfc_array_spec
*as
, *fas
;
467 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
469 fas
= ns
->entries
->sym
->as
;
470 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
471 fts
= &ns
->entries
->sym
->result
->ts
;
472 if (fts
->type
== BT_UNKNOWN
)
473 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
474 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
476 ts
= &el
->sym
->result
->ts
;
478 as
= as
? as
: el
->sym
->result
->as
;
479 if (ts
->type
== BT_UNKNOWN
)
480 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
482 if (! gfc_compare_types (ts
, fts
)
483 || (el
->sym
->result
->attr
.dimension
484 != ns
->entries
->sym
->result
->attr
.dimension
)
485 || (el
->sym
->result
->attr
.pointer
486 != ns
->entries
->sym
->result
->attr
.pointer
))
489 else if (as
&& fas
&& gfc_compare_array_spec (as
, fas
) == 0)
490 gfc_error ("Procedure %s at %L has entries with mismatched "
491 "array specifications", ns
->entries
->sym
->name
,
492 &ns
->entries
->sym
->declared_at
);
497 sym
= ns
->entries
->sym
->result
;
498 /* All result types the same. */
500 if (sym
->attr
.dimension
)
501 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
502 if (sym
->attr
.pointer
)
503 gfc_add_pointer (&proc
->attr
, NULL
);
507 /* Otherwise the result will be passed through a union by
509 proc
->attr
.mixed_entry_master
= 1;
510 for (el
= ns
->entries
; el
; el
= el
->next
)
512 sym
= el
->sym
->result
;
513 if (sym
->attr
.dimension
)
515 if (el
== ns
->entries
)
516 gfc_error ("FUNCTION result %s can't be an array in "
517 "FUNCTION %s at %L", sym
->name
,
518 ns
->entries
->sym
->name
, &sym
->declared_at
);
520 gfc_error ("ENTRY result %s can't be an array in "
521 "FUNCTION %s at %L", sym
->name
,
522 ns
->entries
->sym
->name
, &sym
->declared_at
);
524 else if (sym
->attr
.pointer
)
526 if (el
== ns
->entries
)
527 gfc_error ("FUNCTION result %s can't be a POINTER in "
528 "FUNCTION %s at %L", sym
->name
,
529 ns
->entries
->sym
->name
, &sym
->declared_at
);
531 gfc_error ("ENTRY result %s can't be a POINTER in "
532 "FUNCTION %s at %L", sym
->name
,
533 ns
->entries
->sym
->name
, &sym
->declared_at
);
538 if (ts
->type
== BT_UNKNOWN
)
539 ts
= gfc_get_default_type (sym
, NULL
);
543 if (ts
->kind
== gfc_default_integer_kind
)
547 if (ts
->kind
== gfc_default_real_kind
548 || ts
->kind
== gfc_default_double_kind
)
552 if (ts
->kind
== gfc_default_complex_kind
)
556 if (ts
->kind
== gfc_default_logical_kind
)
560 /* We will issue error elsewhere. */
568 if (el
== ns
->entries
)
569 gfc_error ("FUNCTION result %s can't be of type %s "
570 "in FUNCTION %s at %L", sym
->name
,
571 gfc_typename (ts
), ns
->entries
->sym
->name
,
574 gfc_error ("ENTRY result %s can't be of type %s "
575 "in FUNCTION %s at %L", sym
->name
,
576 gfc_typename (ts
), ns
->entries
->sym
->name
,
583 proc
->attr
.access
= ACCESS_PRIVATE
;
584 proc
->attr
.entry_master
= 1;
586 /* Merge all the entry point arguments. */
587 for (el
= ns
->entries
; el
; el
= el
->next
)
588 merge_argument_lists (proc
, el
->sym
->formal
);
590 /* Check the master formal arguments for any that are not
591 present in all entry points. */
592 for (el
= ns
->entries
; el
; el
= el
->next
)
593 check_argument_lists (proc
, el
->sym
->formal
);
595 /* Use the master function for the function body. */
596 ns
->proc_name
= proc
;
598 /* Finalize the new symbols. */
599 gfc_commit_symbols ();
601 /* Restore the original namespace. */
602 gfc_current_ns
= old_ns
;
607 has_default_initializer (gfc_symbol
*der
)
611 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
612 for (c
= der
->components
; c
; c
= c
->next
)
613 if ((c
->ts
.type
!= BT_DERIVED
&& c
->initializer
)
614 || (c
->ts
.type
== BT_DERIVED
615 && (!c
->pointer
&& has_default_initializer (c
->ts
.derived
))))
622 /* Resolve common blocks. */
624 resolve_common_blocks (gfc_symtree
*common_root
)
626 gfc_symbol
*sym
, *csym
;
628 if (common_root
== NULL
)
631 if (common_root
->left
)
632 resolve_common_blocks (common_root
->left
);
633 if (common_root
->right
)
634 resolve_common_blocks (common_root
->right
);
636 for (csym
= common_root
->n
.common
->head
; csym
; csym
= csym
->common_next
)
638 if (csym
->ts
.type
!= BT_DERIVED
)
641 if (!(csym
->ts
.derived
->attr
.sequence
642 || csym
->ts
.derived
->attr
.is_bind_c
))
643 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
644 "has neither the SEQUENCE nor the BIND(C) "
645 "attribute", csym
->name
, &csym
->declared_at
);
646 if (csym
->ts
.derived
->attr
.alloc_comp
)
647 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
648 "has an ultimate component that is "
649 "allocatable", csym
->name
, &csym
->declared_at
);
650 if (has_default_initializer (csym
->ts
.derived
))
651 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
652 "may not have default initializer", csym
->name
,
656 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
660 if (sym
->attr
.flavor
== FL_PARAMETER
)
661 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
662 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
664 if (sym
->attr
.intrinsic
)
665 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
666 sym
->name
, &common_root
->n
.common
->where
);
667 else if (sym
->attr
.result
668 ||(sym
->attr
.function
&& gfc_current_ns
->proc_name
== sym
))
669 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
670 "that is also a function result", sym
->name
,
671 &common_root
->n
.common
->where
);
672 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
673 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
674 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
675 "that is also a global procedure", sym
->name
,
676 &common_root
->n
.common
->where
);
680 /* Resolve contained function types. Because contained functions can call one
681 another, they have to be worked out before any of the contained procedures
684 The good news is that if a function doesn't already have a type, the only
685 way it can get one is through an IMPLICIT type or a RESULT variable, because
686 by definition contained functions are contained namespace they're contained
687 in, not in a sibling or parent namespace. */
690 resolve_contained_functions (gfc_namespace
*ns
)
692 gfc_namespace
*child
;
695 resolve_formal_arglists (ns
);
697 for (child
= ns
->contained
; child
; child
= child
->sibling
)
699 /* Resolve alternate entry points first. */
700 resolve_entries (child
);
702 /* Then check function return types. */
703 resolve_contained_fntype (child
->proc_name
, child
);
704 for (el
= child
->entries
; el
; el
= el
->next
)
705 resolve_contained_fntype (el
->sym
, child
);
710 /* Resolve all of the elements of a structure constructor and make sure that
711 the types are correct. */
714 resolve_structure_cons (gfc_expr
*expr
)
716 gfc_constructor
*cons
;
722 cons
= expr
->value
.constructor
;
723 /* A constructor may have references if it is the result of substituting a
724 parameter variable. In this case we just pull out the component we
727 comp
= expr
->ref
->u
.c
.sym
->components
;
729 comp
= expr
->ts
.derived
->components
;
731 /* See if the user is trying to invoke a structure constructor for one of
732 the iso_c_binding derived types. */
733 if (expr
->ts
.derived
&& expr
->ts
.derived
->ts
.is_iso_c
&& cons
734 && cons
->expr
!= NULL
)
736 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
737 expr
->ts
.derived
->name
, &(expr
->where
));
741 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
746 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
752 if (cons
->expr
->expr_type
!= EXPR_NULL
753 && comp
->as
&& comp
->as
->rank
!= cons
->expr
->rank
754 && (comp
->allocatable
|| cons
->expr
->rank
))
756 gfc_error ("The rank of the element in the derived type "
757 "constructor at %L does not match that of the "
758 "component (%d/%d)", &cons
->expr
->where
,
759 cons
->expr
->rank
, comp
->as
? comp
->as
->rank
: 0);
763 /* If we don't have the right type, try to convert it. */
765 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
768 if (comp
->pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
769 gfc_error ("The element in the derived type constructor at %L, "
770 "for pointer component '%s', is %s but should be %s",
771 &cons
->expr
->where
, comp
->name
,
772 gfc_basic_typename (cons
->expr
->ts
.type
),
773 gfc_basic_typename (comp
->ts
.type
));
775 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
778 if (!comp
->pointer
|| cons
->expr
->expr_type
== EXPR_NULL
)
781 a
= gfc_expr_attr (cons
->expr
);
783 if (!a
.pointer
&& !a
.target
)
786 gfc_error ("The element in the derived type constructor at %L, "
787 "for pointer component '%s' should be a POINTER or "
788 "a TARGET", &cons
->expr
->where
, comp
->name
);
796 /****************** Expression name resolution ******************/
798 /* Returns 0 if a symbol was not declared with a type or
799 attribute declaration statement, nonzero otherwise. */
802 was_declared (gfc_symbol
*sym
)
808 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
811 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
812 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
813 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
820 /* Determine if a symbol is generic or not. */
823 generic_sym (gfc_symbol
*sym
)
827 if (sym
->attr
.generic
||
828 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
831 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
834 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
841 return generic_sym (s
);
848 /* Determine if a symbol is specific or not. */
851 specific_sym (gfc_symbol
*sym
)
855 if (sym
->attr
.if_source
== IFSRC_IFBODY
856 || sym
->attr
.proc
== PROC_MODULE
857 || sym
->attr
.proc
== PROC_INTERNAL
858 || sym
->attr
.proc
== PROC_ST_FUNCTION
859 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
860 || sym
->attr
.external
)
863 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
866 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
868 return (s
== NULL
) ? 0 : specific_sym (s
);
872 /* Figure out if the procedure is specific, generic or unknown. */
875 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
879 procedure_kind (gfc_symbol
*sym
)
881 if (generic_sym (sym
))
882 return PTYPE_GENERIC
;
884 if (specific_sym (sym
))
885 return PTYPE_SPECIFIC
;
887 return PTYPE_UNKNOWN
;
890 /* Check references to assumed size arrays. The flag need_full_assumed_size
891 is nonzero when matching actual arguments. */
893 static int need_full_assumed_size
= 0;
896 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
902 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
905 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
906 if (ref
->type
== REF_ARRAY
)
907 for (dim
= 0; dim
< ref
->u
.ar
.as
->rank
; dim
++)
908 last
= (ref
->u
.ar
.end
[dim
] == NULL
)
909 && (ref
->u
.ar
.type
== DIMEN_ELEMENT
);
913 gfc_error ("The upper bound in the last dimension must "
914 "appear in the reference to the assumed size "
915 "array '%s' at %L", sym
->name
, &e
->where
);
922 /* Look for bad assumed size array references in argument expressions
923 of elemental and array valued intrinsic procedures. Since this is
924 called from procedure resolution functions, it only recurses at
928 resolve_assumed_size_actual (gfc_expr
*e
)
933 switch (e
->expr_type
)
936 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
941 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
942 || resolve_assumed_size_actual (e
->value
.op
.op2
))
953 /* Resolve an actual argument list. Most of the time, this is just
954 resolving the expressions in the list.
955 The exception is that we sometimes have to decide whether arguments
956 that look like procedure arguments are really simple variable
960 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
)
963 gfc_symtree
*parent_st
;
966 for (; arg
; arg
= arg
->next
)
971 /* Check the label is a valid branching target. */
974 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
976 gfc_error ("Label %d referenced at %L is never defined",
977 arg
->label
->value
, &arg
->label
->where
);
984 if (e
->expr_type
== FL_VARIABLE
&& e
->symtree
->ambiguous
)
986 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
991 if (e
->ts
.type
!= BT_PROCEDURE
)
993 if (gfc_resolve_expr (e
) != SUCCESS
)
998 /* See if the expression node should really be a variable reference. */
1000 sym
= e
->symtree
->n
.sym
;
1002 if (sym
->attr
.flavor
== FL_PROCEDURE
1003 || sym
->attr
.intrinsic
1004 || sym
->attr
.external
)
1008 /* If a procedure is not already determined to be something else
1009 check if it is intrinsic. */
1010 if (!sym
->attr
.intrinsic
1011 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1012 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1013 && gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
1014 sym
->attr
.intrinsic
= 1;
1016 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1018 gfc_error ("Statement function '%s' at %L is not allowed as an "
1019 "actual argument", sym
->name
, &e
->where
);
1022 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1023 sym
->attr
.subroutine
);
1024 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1026 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1027 "actual argument", sym
->name
, &e
->where
);
1030 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1031 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1033 gfc_error ("Internal procedure '%s' is not allowed as an "
1034 "actual argument at %L", sym
->name
, &e
->where
);
1037 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1039 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1040 "allowed as an actual argument at %L", sym
->name
,
1044 /* Check if a generic interface has a specific procedure
1045 with the same name before emitting an error. */
1046 if (sym
->attr
.generic
)
1049 for (p
= sym
->generic
; p
; p
= p
->next
)
1050 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1052 e
->symtree
= gfc_find_symtree
1053 (p
->sym
->ns
->sym_root
, sym
->name
);
1058 if (p
== NULL
|| e
->symtree
== NULL
)
1059 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
1060 "allowed as an actual argument at %L", sym
->name
,
1064 /* If the symbol is the function that names the current (or
1065 parent) scope, then we really have a variable reference. */
1067 if (sym
->attr
.function
&& sym
->result
== sym
1068 && (sym
->ns
->proc_name
== sym
1069 || (sym
->ns
->parent
!= NULL
1070 && sym
->ns
->parent
->proc_name
== sym
)))
1073 /* If all else fails, see if we have a specific intrinsic. */
1074 if (sym
->attr
.function
1075 && sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1077 gfc_intrinsic_sym
*isym
;
1078 isym
= gfc_find_function (sym
->name
);
1079 if (isym
== NULL
|| !isym
->specific
)
1081 gfc_error ("Unable to find a specific INTRINSIC procedure "
1082 "for the reference '%s' at %L", sym
->name
,
1090 /* See if the name is a module procedure in a parent unit. */
1092 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1095 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1097 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1101 if (parent_st
== NULL
)
1104 sym
= parent_st
->n
.sym
;
1105 e
->symtree
= parent_st
; /* Point to the right thing. */
1107 if (sym
->attr
.flavor
== FL_PROCEDURE
1108 || sym
->attr
.intrinsic
1109 || sym
->attr
.external
)
1115 e
->expr_type
= EXPR_VARIABLE
;
1117 if (sym
->as
!= NULL
)
1119 e
->rank
= sym
->as
->rank
;
1120 e
->ref
= gfc_get_ref ();
1121 e
->ref
->type
= REF_ARRAY
;
1122 e
->ref
->u
.ar
.type
= AR_FULL
;
1123 e
->ref
->u
.ar
.as
= sym
->as
;
1126 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1127 primary.c (match_actual_arg). If above code determines that it
1128 is a variable instead, it needs to be resolved as it was not
1129 done at the beginning of this function. */
1130 if (gfc_resolve_expr (e
) != SUCCESS
)
1134 /* Check argument list functions %VAL, %LOC and %REF. There is
1135 nothing to do for %REF. */
1136 if (arg
->name
&& arg
->name
[0] == '%')
1138 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1140 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1142 gfc_error ("By-value argument at %L is not of numeric "
1149 gfc_error ("By-value argument at %L cannot be an array or "
1150 "an array section", &e
->where
);
1154 /* Intrinsics are still PROC_UNKNOWN here. However,
1155 since same file external procedures are not resolvable
1156 in gfortran, it is a good deal easier to leave them to
1158 if (ptype
!= PROC_UNKNOWN
1159 && ptype
!= PROC_DUMMY
1160 && ptype
!= PROC_EXTERNAL
1161 && ptype
!= PROC_MODULE
)
1163 gfc_error ("By-value argument at %L is not allowed "
1164 "in this context", &e
->where
);
1169 /* Statement functions have already been excluded above. */
1170 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1171 && e
->ts
.type
== BT_PROCEDURE
)
1173 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1175 gfc_error ("Passing internal procedure at %L by location "
1176 "not allowed", &e
->where
);
1187 /* Do the checks of the actual argument list that are specific to elemental
1188 procedures. If called with c == NULL, we have a function, otherwise if
1189 expr == NULL, we have a subroutine. */
1192 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1194 gfc_actual_arglist
*arg0
;
1195 gfc_actual_arglist
*arg
;
1196 gfc_symbol
*esym
= NULL
;
1197 gfc_intrinsic_sym
*isym
= NULL
;
1199 gfc_intrinsic_arg
*iformal
= NULL
;
1200 gfc_formal_arglist
*eformal
= NULL
;
1201 bool formal_optional
= false;
1202 bool set_by_optional
= false;
1206 /* Is this an elemental procedure? */
1207 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1209 if (expr
->value
.function
.esym
!= NULL
1210 && expr
->value
.function
.esym
->attr
.elemental
)
1212 arg0
= expr
->value
.function
.actual
;
1213 esym
= expr
->value
.function
.esym
;
1215 else if (expr
->value
.function
.isym
!= NULL
1216 && expr
->value
.function
.isym
->elemental
)
1218 arg0
= expr
->value
.function
.actual
;
1219 isym
= expr
->value
.function
.isym
;
1224 else if (c
&& c
->ext
.actual
!= NULL
&& c
->symtree
->n
.sym
->attr
.elemental
)
1226 arg0
= c
->ext
.actual
;
1227 esym
= c
->symtree
->n
.sym
;
1232 /* The rank of an elemental is the rank of its array argument(s). */
1233 for (arg
= arg0
; arg
; arg
= arg
->next
)
1235 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1237 rank
= arg
->expr
->rank
;
1238 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1239 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1240 set_by_optional
= true;
1242 /* Function specific; set the result rank and shape. */
1246 if (!expr
->shape
&& arg
->expr
->shape
)
1248 expr
->shape
= gfc_get_shape (rank
);
1249 for (i
= 0; i
< rank
; i
++)
1250 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1257 /* If it is an array, it shall not be supplied as an actual argument
1258 to an elemental procedure unless an array of the same rank is supplied
1259 as an actual argument corresponding to a nonoptional dummy argument of
1260 that elemental procedure(12.4.1.5). */
1261 formal_optional
= false;
1263 iformal
= isym
->formal
;
1265 eformal
= esym
->formal
;
1267 for (arg
= arg0
; arg
; arg
= arg
->next
)
1271 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1272 formal_optional
= true;
1273 eformal
= eformal
->next
;
1275 else if (isym
&& iformal
)
1277 if (iformal
->optional
)
1278 formal_optional
= true;
1279 iformal
= iformal
->next
;
1282 formal_optional
= true;
1284 if (pedantic
&& arg
->expr
!= NULL
1285 && arg
->expr
->expr_type
== EXPR_VARIABLE
1286 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1289 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1290 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1292 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1293 "MISSING, it cannot be the actual argument of an "
1294 "ELEMENTAL procedure unless there is a non-optional "
1295 "argument with the same rank (12.4.1.5)",
1296 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1301 for (arg
= arg0
; arg
; arg
= arg
->next
)
1303 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1306 /* Being elemental, the last upper bound of an assumed size array
1307 argument must be present. */
1308 if (resolve_assumed_size_actual (arg
->expr
))
1311 /* Elemental procedure's array actual arguments must conform. */
1314 if (gfc_check_conformance ("elemental procedure", arg
->expr
, e
)
1322 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1323 is an array, the intent inout/out variable needs to be also an array. */
1324 if (rank
> 0 && esym
&& expr
== NULL
)
1325 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1326 arg
= arg
->next
, eformal
= eformal
->next
)
1327 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1328 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1329 && arg
->expr
&& arg
->expr
->rank
== 0)
1331 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1332 "ELEMENTAL subroutine '%s' is a scalar, but another "
1333 "actual argument is an array", &arg
->expr
->where
,
1334 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1335 : "INOUT", eformal
->sym
->name
, esym
->name
);
1342 /* Go through each actual argument in ACTUAL and see if it can be
1343 implemented as an inlined, non-copying intrinsic. FNSYM is the
1344 function being called, or NULL if not known. */
1347 find_noncopying_intrinsics (gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
)
1349 gfc_actual_arglist
*ap
;
1352 for (ap
= actual
; ap
; ap
= ap
->next
)
1354 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1355 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
1356 ap
->expr
->inline_noncopying_intrinsic
= 1;
1360 /* This function does the checking of references to global procedures
1361 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1362 77 and 95 standards. It checks for a gsymbol for the name, making
1363 one if it does not already exist. If it already exists, then the
1364 reference being resolved must correspond to the type of gsymbol.
1365 Otherwise, the new symbol is equipped with the attributes of the
1366 reference. The corresponding code that is called in creating
1367 global entities is parse.c. */
1370 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1375 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1377 gsym
= gfc_get_gsymbol (sym
->name
);
1379 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1380 gfc_global_used (gsym
, where
);
1382 if (gsym
->type
== GSYM_UNKNOWN
)
1385 gsym
->where
= *where
;
1392 /************* Function resolution *************/
1394 /* Resolve a function call known to be generic.
1395 Section 14.1.2.4.1. */
1398 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
1402 if (sym
->attr
.generic
)
1404 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1407 expr
->value
.function
.name
= s
->name
;
1408 expr
->value
.function
.esym
= s
;
1410 if (s
->ts
.type
!= BT_UNKNOWN
)
1412 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1413 expr
->ts
= s
->result
->ts
;
1416 expr
->rank
= s
->as
->rank
;
1417 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1418 expr
->rank
= s
->result
->as
->rank
;
1423 /* TODO: Need to search for elemental references in generic
1427 if (sym
->attr
.intrinsic
)
1428 return gfc_intrinsic_func_interface (expr
, 0);
1435 resolve_generic_f (gfc_expr
*expr
)
1440 sym
= expr
->symtree
->n
.sym
;
1444 m
= resolve_generic_f0 (expr
, sym
);
1447 else if (m
== MATCH_ERROR
)
1451 if (sym
->ns
->parent
== NULL
)
1453 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1457 if (!generic_sym (sym
))
1461 /* Last ditch attempt. See if the reference is to an intrinsic
1462 that possesses a matching interface. 14.1.2.4 */
1463 if (sym
&& !gfc_intrinsic_name (sym
->name
, 0))
1465 gfc_error ("There is no specific function for the generic '%s' at %L",
1466 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1470 m
= gfc_intrinsic_func_interface (expr
, 0);
1474 gfc_error ("Generic function '%s' at %L is not consistent with a "
1475 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
1482 /* Resolve a function call known to be specific. */
1485 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
1489 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1491 if (sym
->attr
.dummy
)
1493 sym
->attr
.proc
= PROC_DUMMY
;
1497 sym
->attr
.proc
= PROC_EXTERNAL
;
1501 if (sym
->attr
.proc
== PROC_MODULE
1502 || sym
->attr
.proc
== PROC_ST_FUNCTION
1503 || sym
->attr
.proc
== PROC_INTERNAL
)
1506 if (sym
->attr
.intrinsic
)
1508 m
= gfc_intrinsic_func_interface (expr
, 1);
1512 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1513 "with an intrinsic", sym
->name
, &expr
->where
);
1521 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1524 expr
->value
.function
.name
= sym
->name
;
1525 expr
->value
.function
.esym
= sym
;
1526 if (sym
->as
!= NULL
)
1527 expr
->rank
= sym
->as
->rank
;
1534 resolve_specific_f (gfc_expr
*expr
)
1539 sym
= expr
->symtree
->n
.sym
;
1543 m
= resolve_specific_f0 (sym
, expr
);
1546 if (m
== MATCH_ERROR
)
1549 if (sym
->ns
->parent
== NULL
)
1552 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1558 gfc_error ("Unable to resolve the specific function '%s' at %L",
1559 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1565 /* Resolve a procedure call not known to be generic nor specific. */
1568 resolve_unknown_f (gfc_expr
*expr
)
1573 sym
= expr
->symtree
->n
.sym
;
1575 if (sym
->attr
.dummy
)
1577 sym
->attr
.proc
= PROC_DUMMY
;
1578 expr
->value
.function
.name
= sym
->name
;
1582 /* See if we have an intrinsic function reference. */
1584 if (gfc_intrinsic_name (sym
->name
, 0))
1586 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1591 /* The reference is to an external name. */
1593 sym
->attr
.proc
= PROC_EXTERNAL
;
1594 expr
->value
.function
.name
= sym
->name
;
1595 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1597 if (sym
->as
!= NULL
)
1598 expr
->rank
= sym
->as
->rank
;
1600 /* Type of the expression is either the type of the symbol or the
1601 default type of the symbol. */
1604 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1606 if (sym
->ts
.type
!= BT_UNKNOWN
)
1610 ts
= gfc_get_default_type (sym
, sym
->ns
);
1612 if (ts
->type
== BT_UNKNOWN
)
1614 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1615 sym
->name
, &expr
->where
);
1626 /* Return true, if the symbol is an external procedure. */
1628 is_external_proc (gfc_symbol
*sym
)
1630 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
1631 && !(sym
->attr
.intrinsic
1632 || gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
1633 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1634 && !sym
->attr
.use_assoc
1642 /* Figure out if a function reference is pure or not. Also set the name
1643 of the function for a potential error message. Return nonzero if the
1644 function is PURE, zero if not. */
1647 pure_function (gfc_expr
*e
, const char **name
)
1653 if (e
->symtree
!= NULL
1654 && e
->symtree
->n
.sym
!= NULL
1655 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1658 if (e
->value
.function
.esym
)
1660 pure
= gfc_pure (e
->value
.function
.esym
);
1661 *name
= e
->value
.function
.esym
->name
;
1663 else if (e
->value
.function
.isym
)
1665 pure
= e
->value
.function
.isym
->pure
1666 || e
->value
.function
.isym
->elemental
;
1667 *name
= e
->value
.function
.isym
->name
;
1671 /* Implicit functions are not pure. */
1673 *name
= e
->value
.function
.name
;
1681 is_scalar_expr_ptr (gfc_expr
*expr
)
1683 try retval
= SUCCESS
;
1688 /* See if we have a gfc_ref, which means we have a substring, array
1689 reference, or a component. */
1690 if (expr
->ref
!= NULL
)
1693 while (ref
->next
!= NULL
)
1699 if (ref
->u
.ss
.length
!= NULL
1700 && ref
->u
.ss
.length
->length
!= NULL
1702 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1704 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1706 start
= (int) mpz_get_si (ref
->u
.ss
.start
->value
.integer
);
1707 end
= (int) mpz_get_si (ref
->u
.ss
.end
->value
.integer
);
1708 if (end
- start
+ 1 != 1)
1715 if (ref
->u
.ar
.type
== AR_ELEMENT
)
1717 else if (ref
->u
.ar
.type
== AR_FULL
)
1719 /* The user can give a full array if the array is of size 1. */
1720 if (ref
->u
.ar
.as
!= NULL
1721 && ref
->u
.ar
.as
->rank
== 1
1722 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
1723 && ref
->u
.ar
.as
->lower
[0] != NULL
1724 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
1725 && ref
->u
.ar
.as
->upper
[0] != NULL
1726 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
1728 /* If we have a character string, we need to check if
1729 its length is one. */
1730 if (expr
->ts
.type
== BT_CHARACTER
)
1732 if (expr
->ts
.cl
== NULL
1733 || expr
->ts
.cl
->length
== NULL
1734 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1)
1740 /* We have constant lower and upper bounds. If the
1741 difference between is 1, it can be considered a
1743 start
= (int) mpz_get_si
1744 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
1745 end
= (int) mpz_get_si
1746 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
1747 if (end
- start
+ 1 != 1)
1762 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
1764 /* Character string. Make sure it's of length 1. */
1765 if (expr
->ts
.cl
== NULL
1766 || expr
->ts
.cl
->length
== NULL
1767 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1) != 0)
1770 else if (expr
->rank
!= 0)
1777 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1778 and, in the case of c_associated, set the binding label based on
1782 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
1783 gfc_symbol
**new_sym
)
1785 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1786 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
1787 int optional_arg
= 0;
1788 try retval
= SUCCESS
;
1789 gfc_symbol
*args_sym
;
1790 gfc_typespec
*arg_ts
;
1791 gfc_ref
*parent_ref
;
1794 if (args
->expr
->expr_type
== EXPR_CONSTANT
1795 || args
->expr
->expr_type
== EXPR_OP
1796 || args
->expr
->expr_type
== EXPR_NULL
)
1798 gfc_error ("Argument to '%s' at %L is not a variable",
1799 sym
->name
, &(args
->expr
->where
));
1803 args_sym
= args
->expr
->symtree
->n
.sym
;
1805 /* The typespec for the actual arg should be that stored in the expr
1806 and not necessarily that of the expr symbol (args_sym), because
1807 the actual expression could be a part-ref of the expr symbol. */
1808 arg_ts
= &(args
->expr
->ts
);
1810 /* Get the parent reference (if any) for the expression. This happens for
1811 cases such as a%b%c. */
1812 parent_ref
= args
->expr
->ref
;
1814 if (parent_ref
!= NULL
)
1816 curr_ref
= parent_ref
->next
;
1817 while (curr_ref
!= NULL
&& curr_ref
->next
!= NULL
)
1819 parent_ref
= curr_ref
;
1820 curr_ref
= curr_ref
->next
;
1824 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
1825 is for a REF_COMPONENT, then we need to use it as the parent_ref for
1826 the name, etc. Otherwise, the current parent_ref should be correct. */
1827 if (curr_ref
!= NULL
&& curr_ref
->type
== REF_COMPONENT
)
1828 parent_ref
= curr_ref
;
1830 if (parent_ref
== args
->expr
->ref
)
1832 else if (parent_ref
!= NULL
&& parent_ref
->type
!= REF_COMPONENT
)
1833 gfc_internal_error ("Unexpected expression reference type in "
1834 "gfc_iso_c_func_interface");
1836 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
1838 /* If the user gave two args then they are providing something for
1839 the optional arg (the second cptr). Therefore, set the name and
1840 binding label to the c_associated for two cptrs. Otherwise,
1841 set c_associated to expect one cptr. */
1845 sprintf (name
, "%s_2", sym
->name
);
1846 sprintf (binding_label
, "%s_2", sym
->binding_label
);
1852 sprintf (name
, "%s_1", sym
->name
);
1853 sprintf (binding_label
, "%s_1", sym
->binding_label
);
1857 /* Get a new symbol for the version of c_associated that
1859 *new_sym
= get_iso_c_sym (sym
, name
, binding_label
, optional_arg
);
1861 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
1862 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
1864 sprintf (name
, "%s", sym
->name
);
1865 sprintf (binding_label
, "%s", sym
->binding_label
);
1867 /* Error check the call. */
1868 if (args
->next
!= NULL
)
1870 gfc_error_now ("More actual than formal arguments in '%s' "
1871 "call at %L", name
, &(args
->expr
->where
));
1874 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
1876 /* Make sure we have either the target or pointer attribute. */
1877 if (!(args_sym
->attr
.target
)
1878 && !(args_sym
->attr
.pointer
)
1879 && (parent_ref
== NULL
||
1880 !parent_ref
->u
.c
.component
->pointer
))
1882 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1883 "a TARGET or an associated pointer",
1885 sym
->name
, &(args
->expr
->where
));
1889 /* See if we have interoperable type and type param. */
1890 if (verify_c_interop (arg_ts
,
1891 (parent_ref
? parent_ref
->u
.c
.component
->name
1893 &(args
->expr
->where
)) == SUCCESS
1894 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
1896 if (args_sym
->attr
.target
== 1)
1898 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1899 has the target attribute and is interoperable. */
1900 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1901 allocatable variable that has the TARGET attribute and
1902 is not an array of zero size. */
1903 if (args_sym
->attr
.allocatable
== 1)
1905 if (args_sym
->attr
.dimension
!= 0
1906 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
1908 gfc_error_now ("Allocatable variable '%s' used as a "
1909 "parameter to '%s' at %L must not be "
1910 "an array of zero size",
1911 args_sym
->name
, sym
->name
,
1912 &(args
->expr
->where
));
1918 /* A non-allocatable target variable with C
1919 interoperable type and type parameters must be
1921 if (args_sym
&& args_sym
->attr
.dimension
)
1923 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
1925 gfc_error ("Assumed-shape array '%s' at %L "
1926 "cannot be an argument to the "
1927 "procedure '%s' because "
1928 "it is not C interoperable",
1930 &(args
->expr
->where
), sym
->name
);
1933 else if (args_sym
->as
->type
== AS_DEFERRED
)
1935 gfc_error ("Deferred-shape array '%s' at %L "
1936 "cannot be an argument to the "
1937 "procedure '%s' because "
1938 "it is not C interoperable",
1940 &(args
->expr
->where
), sym
->name
);
1945 /* Make sure it's not a character string. Arrays of
1946 any type should be ok if the variable is of a C
1947 interoperable type. */
1948 if (arg_ts
->type
== BT_CHARACTER
)
1949 if (arg_ts
->cl
!= NULL
1950 && (arg_ts
->cl
->length
== NULL
1951 || arg_ts
->cl
->length
->expr_type
1954 (arg_ts
->cl
->length
->value
.integer
, 1)
1956 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
1958 gfc_error_now ("CHARACTER argument '%s' to '%s' "
1959 "at %L must have a length of 1",
1960 args_sym
->name
, sym
->name
,
1961 &(args
->expr
->where
));
1966 else if ((args_sym
->attr
.pointer
== 1 ||
1968 && parent_ref
->u
.c
.component
->pointer
))
1969 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
1971 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1973 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1974 "associated scalar POINTER", args_sym
->name
,
1975 sym
->name
, &(args
->expr
->where
));
1981 /* The parameter is not required to be C interoperable. If it
1982 is not C interoperable, it must be a nonpolymorphic scalar
1983 with no length type parameters. It still must have either
1984 the pointer or target attribute, and it can be
1985 allocatable (but must be allocated when c_loc is called). */
1986 if (args
->expr
->rank
!= 0
1987 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
1989 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1990 "scalar", args_sym
->name
, sym
->name
,
1991 &(args
->expr
->where
));
1994 else if (arg_ts
->type
== BT_CHARACTER
1995 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
1997 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1998 "%L must have a length of 1",
1999 args_sym
->name
, sym
->name
,
2000 &(args
->expr
->where
));
2005 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2007 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2009 /* TODO: Update this error message to allow for procedure
2010 pointers once they are implemented. */
2011 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2013 args_sym
->name
, sym
->name
,
2014 &(args
->expr
->where
));
2017 else if (args_sym
->attr
.is_bind_c
!= 1)
2019 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2021 args_sym
->name
, sym
->name
,
2022 &(args
->expr
->where
));
2027 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2032 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2033 "iso_c_binding function: '%s'!\n", sym
->name
);
2040 /* Resolve a function call, which means resolving the arguments, then figuring
2041 out which entity the name refers to. */
2042 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2043 to INTENT(OUT) or INTENT(INOUT). */
2046 resolve_function (gfc_expr
*expr
)
2048 gfc_actual_arglist
*arg
;
2053 procedure_type p
= PROC_INTRINSIC
;
2057 sym
= expr
->symtree
->n
.sym
;
2059 if (sym
&& sym
->attr
.flavor
== FL_VARIABLE
)
2061 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2065 if (sym
&& sym
->attr
.abstract
)
2067 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2068 sym
->name
, &expr
->where
);
2072 /* If the procedure is external, check for usage. */
2073 if (sym
&& is_external_proc (sym
))
2074 resolve_global_procedure (sym
, &expr
->where
, 0);
2076 /* Switch off assumed size checking and do this again for certain kinds
2077 of procedure, once the procedure itself is resolved. */
2078 need_full_assumed_size
++;
2080 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2081 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2083 if (resolve_actual_arglist (expr
->value
.function
.actual
, p
) == FAILURE
)
2086 /* Need to setup the call to the correct c_associated, depending on
2087 the number of cptrs to user gives to compare. */
2088 if (sym
&& sym
->attr
.is_iso_c
== 1)
2090 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
2094 /* Get the symtree for the new symbol (resolved func).
2095 the old one will be freed later, when it's no longer used. */
2096 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
2099 /* Resume assumed_size checking. */
2100 need_full_assumed_size
--;
2102 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2104 && sym
->ts
.cl
->length
== NULL
2106 && expr
->value
.function
.esym
== NULL
2107 && !sym
->attr
.contained
)
2109 /* Internal procedures are taken care of in resolve_contained_fntype. */
2110 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2111 "be used at %L since it is not a dummy argument",
2112 sym
->name
, &expr
->where
);
2116 /* See if function is already resolved. */
2118 if (expr
->value
.function
.name
!= NULL
)
2120 if (expr
->ts
.type
== BT_UNKNOWN
)
2126 /* Apply the rules of section 14.1.2. */
2128 switch (procedure_kind (sym
))
2131 t
= resolve_generic_f (expr
);
2134 case PTYPE_SPECIFIC
:
2135 t
= resolve_specific_f (expr
);
2139 t
= resolve_unknown_f (expr
);
2143 gfc_internal_error ("resolve_function(): bad function type");
2147 /* If the expression is still a function (it might have simplified),
2148 then we check to see if we are calling an elemental function. */
2150 if (expr
->expr_type
!= EXPR_FUNCTION
)
2153 temp
= need_full_assumed_size
;
2154 need_full_assumed_size
= 0;
2156 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
2159 if (omp_workshare_flag
2160 && expr
->value
.function
.esym
2161 && ! gfc_elemental (expr
->value
.function
.esym
))
2163 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2164 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2169 #define GENERIC_ID expr->value.function.isym->id
2170 else if (expr
->value
.function
.actual
!= NULL
2171 && expr
->value
.function
.isym
!= NULL
2172 && GENERIC_ID
!= GFC_ISYM_LBOUND
2173 && GENERIC_ID
!= GFC_ISYM_LEN
2174 && GENERIC_ID
!= GFC_ISYM_LOC
2175 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2177 /* Array intrinsics must also have the last upper bound of an
2178 assumed size array argument. UBOUND and SIZE have to be
2179 excluded from the check if the second argument is anything
2182 inquiry
= GENERIC_ID
== GFC_ISYM_UBOUND
2183 || GENERIC_ID
== GFC_ISYM_SIZE
;
2185 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2187 if (inquiry
&& arg
->next
!= NULL
&& arg
->next
->expr
)
2189 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2192 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2197 if (arg
->expr
!= NULL
2198 && arg
->expr
->rank
> 0
2199 && resolve_assumed_size_actual (arg
->expr
))
2205 need_full_assumed_size
= temp
;
2208 if (!pure_function (expr
, &name
) && name
)
2212 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2213 "FORALL %s", name
, &expr
->where
,
2214 forall_flag
== 2 ? "mask" : "block");
2217 else if (gfc_pure (NULL
))
2219 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2220 "procedure within a PURE procedure", name
, &expr
->where
);
2225 /* Functions without the RECURSIVE attribution are not allowed to
2226 * call themselves. */
2227 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
2229 gfc_symbol
*esym
, *proc
;
2230 esym
= expr
->value
.function
.esym
;
2231 proc
= gfc_current_ns
->proc_name
;
2234 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2235 "RECURSIVE", name
, &expr
->where
);
2239 if (esym
->attr
.entry
&& esym
->ns
->entries
&& proc
->ns
->entries
2240 && esym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2242 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2243 "'%s' is not declared as RECURSIVE",
2244 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
2249 /* Character lengths of use associated functions may contains references to
2250 symbols not referenced from the current program unit otherwise. Make sure
2251 those symbols are marked as referenced. */
2253 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
2254 && expr
->value
.function
.esym
->attr
.use_assoc
)
2256 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
2260 find_noncopying_intrinsics (expr
->value
.function
.esym
,
2261 expr
->value
.function
.actual
);
2263 /* Make sure that the expression has a typespec that works. */
2264 if (expr
->ts
.type
== BT_UNKNOWN
)
2266 if (expr
->symtree
->n
.sym
->result
2267 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
)
2268 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
2275 /************* Subroutine resolution *************/
2278 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
2284 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2285 sym
->name
, &c
->loc
);
2286 else if (gfc_pure (NULL
))
2287 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
2293 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2297 if (sym
->attr
.generic
)
2299 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
2302 c
->resolved_sym
= s
;
2303 pure_subroutine (c
, s
);
2307 /* TODO: Need to search for elemental references in generic interface. */
2310 if (sym
->attr
.intrinsic
)
2311 return gfc_intrinsic_sub_interface (c
, 0);
2318 resolve_generic_s (gfc_code
*c
)
2323 sym
= c
->symtree
->n
.sym
;
2327 m
= resolve_generic_s0 (c
, sym
);
2330 else if (m
== MATCH_ERROR
)
2334 if (sym
->ns
->parent
== NULL
)
2336 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2340 if (!generic_sym (sym
))
2344 /* Last ditch attempt. See if the reference is to an intrinsic
2345 that possesses a matching interface. 14.1.2.4 */
2346 sym
= c
->symtree
->n
.sym
;
2348 if (!gfc_intrinsic_name (sym
->name
, 1))
2350 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2351 sym
->name
, &c
->loc
);
2355 m
= gfc_intrinsic_sub_interface (c
, 0);
2359 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2360 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
2366 /* Set the name and binding label of the subroutine symbol in the call
2367 expression represented by 'c' to include the type and kind of the
2368 second parameter. This function is for resolving the appropriate
2369 version of c_f_pointer() and c_f_procpointer(). For example, a
2370 call to c_f_pointer() for a default integer pointer could have a
2371 name of c_f_pointer_i4. If no second arg exists, which is an error
2372 for these two functions, it defaults to the generic symbol's name
2373 and binding label. */
2376 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
2377 char *name
, char *binding_label
)
2379 gfc_expr
*arg
= NULL
;
2383 /* The second arg of c_f_pointer and c_f_procpointer determines
2384 the type and kind for the procedure name. */
2385 arg
= c
->ext
.actual
->next
->expr
;
2389 /* Set up the name to have the given symbol's name,
2390 plus the type and kind. */
2391 /* a derived type is marked with the type letter 'u' */
2392 if (arg
->ts
.type
== BT_DERIVED
)
2395 kind
= 0; /* set the kind as 0 for now */
2399 type
= gfc_type_letter (arg
->ts
.type
);
2400 kind
= arg
->ts
.kind
;
2403 if (arg
->ts
.type
== BT_CHARACTER
)
2404 /* Kind info for character strings not needed. */
2407 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
2408 /* Set up the binding label as the given symbol's label plus
2409 the type and kind. */
2410 sprintf (binding_label
, "%s_%c%d", sym
->binding_label
, type
, kind
);
2414 /* If the second arg is missing, set the name and label as
2415 was, cause it should at least be found, and the missing
2416 arg error will be caught by compare_parameters(). */
2417 sprintf (name
, "%s", sym
->name
);
2418 sprintf (binding_label
, "%s", sym
->binding_label
);
2425 /* Resolve a generic version of the iso_c_binding procedure given
2426 (sym) to the specific one based on the type and kind of the
2427 argument(s). Currently, this function resolves c_f_pointer() and
2428 c_f_procpointer based on the type and kind of the second argument
2429 (FPTR). Other iso_c_binding procedures aren't specially handled.
2430 Upon successfully exiting, c->resolved_sym will hold the resolved
2431 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2435 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
2437 gfc_symbol
*new_sym
;
2438 /* this is fine, since we know the names won't use the max */
2439 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2440 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2441 /* default to success; will override if find error */
2442 match m
= MATCH_YES
;
2444 /* Make sure the actual arguments are in the necessary order (based on the
2445 formal args) before resolving. */
2446 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
2448 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
2449 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
2451 set_name_and_label (c
, sym
, name
, binding_label
);
2453 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
2455 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
2457 /* Make sure we got a third arg if the second arg has non-zero
2458 rank. We must also check that the type and rank are
2459 correct since we short-circuit this check in
2460 gfc_procedure_use() (called above to sort actual args). */
2461 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
2463 if(c
->ext
.actual
->next
->next
== NULL
2464 || c
->ext
.actual
->next
->next
->expr
== NULL
)
2467 gfc_error ("Missing SHAPE parameter for call to %s "
2468 "at %L", sym
->name
, &(c
->loc
));
2470 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
2472 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
2475 gfc_error ("SHAPE parameter for call to %s at %L must "
2476 "be a rank 1 INTEGER array", sym
->name
,
2483 if (m
!= MATCH_ERROR
)
2485 /* the 1 means to add the optional arg to formal list */
2486 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
2488 /* for error reporting, say it's declared where the original was */
2489 new_sym
->declared_at
= sym
->declared_at
;
2494 /* no differences for c_loc or c_funloc */
2498 /* set the resolved symbol */
2499 if (m
!= MATCH_ERROR
)
2500 c
->resolved_sym
= new_sym
;
2502 c
->resolved_sym
= sym
;
2508 /* Resolve a subroutine call known to be specific. */
2511 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2515 if(sym
->attr
.is_iso_c
)
2517 m
= gfc_iso_c_sub_interface (c
,sym
);
2521 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2523 if (sym
->attr
.dummy
)
2525 sym
->attr
.proc
= PROC_DUMMY
;
2529 sym
->attr
.proc
= PROC_EXTERNAL
;
2533 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
2536 if (sym
->attr
.intrinsic
)
2538 m
= gfc_intrinsic_sub_interface (c
, 1);
2542 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2543 "with an intrinsic", sym
->name
, &c
->loc
);
2551 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2553 c
->resolved_sym
= sym
;
2554 pure_subroutine (c
, sym
);
2561 resolve_specific_s (gfc_code
*c
)
2566 sym
= c
->symtree
->n
.sym
;
2570 m
= resolve_specific_s0 (c
, sym
);
2573 if (m
== MATCH_ERROR
)
2576 if (sym
->ns
->parent
== NULL
)
2579 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2585 sym
= c
->symtree
->n
.sym
;
2586 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2587 sym
->name
, &c
->loc
);
2593 /* Resolve a subroutine call not known to be generic nor specific. */
2596 resolve_unknown_s (gfc_code
*c
)
2600 sym
= c
->symtree
->n
.sym
;
2602 if (sym
->attr
.dummy
)
2604 sym
->attr
.proc
= PROC_DUMMY
;
2608 /* See if we have an intrinsic function reference. */
2610 if (gfc_intrinsic_name (sym
->name
, 1))
2612 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
2617 /* The reference is to an external name. */
2620 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2622 c
->resolved_sym
= sym
;
2624 pure_subroutine (c
, sym
);
2630 /* Resolve a subroutine call. Although it was tempting to use the same code
2631 for functions, subroutines and functions are stored differently and this
2632 makes things awkward. */
2635 resolve_call (gfc_code
*c
)
2638 procedure_type ptype
= PROC_INTRINSIC
;
2640 if (c
->symtree
&& c
->symtree
->n
.sym
2641 && c
->symtree
->n
.sym
->ts
.type
!= BT_UNKNOWN
)
2643 gfc_error ("'%s' at %L has a type, which is not consistent with "
2644 "the CALL at %L", c
->symtree
->n
.sym
->name
,
2645 &c
->symtree
->n
.sym
->declared_at
, &c
->loc
);
2649 /* If external, check for usage. */
2650 if (c
->symtree
&& is_external_proc (c
->symtree
->n
.sym
))
2651 resolve_global_procedure (c
->symtree
->n
.sym
, &c
->loc
, 1);
2653 /* Subroutines without the RECURSIVE attribution are not allowed to
2654 * call themselves. */
2655 if (c
->symtree
&& c
->symtree
->n
.sym
&& !c
->symtree
->n
.sym
->attr
.recursive
)
2657 gfc_symbol
*csym
, *proc
;
2658 csym
= c
->symtree
->n
.sym
;
2659 proc
= gfc_current_ns
->proc_name
;
2662 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2663 "RECURSIVE", csym
->name
, &c
->loc
);
2667 if (csym
->attr
.entry
&& csym
->ns
->entries
&& proc
->ns
->entries
2668 && csym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2670 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2671 "'%s' is not declared as RECURSIVE",
2672 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
2677 /* Switch off assumed size checking and do this again for certain kinds
2678 of procedure, once the procedure itself is resolved. */
2679 need_full_assumed_size
++;
2681 if (c
->symtree
&& c
->symtree
->n
.sym
)
2682 ptype
= c
->symtree
->n
.sym
->attr
.proc
;
2684 if (resolve_actual_arglist (c
->ext
.actual
, ptype
) == FAILURE
)
2687 /* Resume assumed_size checking. */
2688 need_full_assumed_size
--;
2691 if (c
->resolved_sym
== NULL
)
2692 switch (procedure_kind (c
->symtree
->n
.sym
))
2695 t
= resolve_generic_s (c
);
2698 case PTYPE_SPECIFIC
:
2699 t
= resolve_specific_s (c
);
2703 t
= resolve_unknown_s (c
);
2707 gfc_internal_error ("resolve_subroutine(): bad function type");
2710 /* Some checks of elemental subroutine actual arguments. */
2711 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
2715 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
2720 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2721 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2722 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2723 if their shapes do not match. If either op1->shape or op2->shape is
2724 NULL, return SUCCESS. */
2727 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
2734 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
2736 for (i
= 0; i
< op1
->rank
; i
++)
2738 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
2740 gfc_error ("Shapes for operands at %L and %L are not conformable",
2741 &op1
->where
, &op2
->where
);
2752 /* Resolve an operator expression node. This can involve replacing the
2753 operation with a user defined function call. */
2756 resolve_operator (gfc_expr
*e
)
2758 gfc_expr
*op1
, *op2
;
2760 bool dual_locus_error
;
2763 /* Resolve all subnodes-- give them types. */
2765 switch (e
->value
.op
.operator)
2768 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
2771 /* Fall through... */
2774 case INTRINSIC_UPLUS
:
2775 case INTRINSIC_UMINUS
:
2776 case INTRINSIC_PARENTHESES
:
2777 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
2782 /* Typecheck the new node. */
2784 op1
= e
->value
.op
.op1
;
2785 op2
= e
->value
.op
.op2
;
2786 dual_locus_error
= false;
2788 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
2789 || (op2
&& op2
->expr_type
== EXPR_NULL
))
2791 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
2795 switch (e
->value
.op
.operator)
2797 case INTRINSIC_UPLUS
:
2798 case INTRINSIC_UMINUS
:
2799 if (op1
->ts
.type
== BT_INTEGER
2800 || op1
->ts
.type
== BT_REAL
2801 || op1
->ts
.type
== BT_COMPLEX
)
2807 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
2808 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
2811 case INTRINSIC_PLUS
:
2812 case INTRINSIC_MINUS
:
2813 case INTRINSIC_TIMES
:
2814 case INTRINSIC_DIVIDE
:
2815 case INTRINSIC_POWER
:
2816 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2818 gfc_type_convert_binary (e
);
2823 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2824 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2825 gfc_typename (&op2
->ts
));
2828 case INTRINSIC_CONCAT
:
2829 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2831 e
->ts
.type
= BT_CHARACTER
;
2832 e
->ts
.kind
= op1
->ts
.kind
;
2837 _("Operands of string concatenation operator at %%L are %s/%s"),
2838 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
2844 case INTRINSIC_NEQV
:
2845 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2847 e
->ts
.type
= BT_LOGICAL
;
2848 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
2849 if (op1
->ts
.kind
< e
->ts
.kind
)
2850 gfc_convert_type (op1
, &e
->ts
, 2);
2851 else if (op2
->ts
.kind
< e
->ts
.kind
)
2852 gfc_convert_type (op2
, &e
->ts
, 2);
2856 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
2857 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2858 gfc_typename (&op2
->ts
));
2863 if (op1
->ts
.type
== BT_LOGICAL
)
2865 e
->ts
.type
= BT_LOGICAL
;
2866 e
->ts
.kind
= op1
->ts
.kind
;
2870 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
2871 gfc_typename (&op1
->ts
));
2875 case INTRINSIC_GT_OS
:
2877 case INTRINSIC_GE_OS
:
2879 case INTRINSIC_LT_OS
:
2881 case INTRINSIC_LE_OS
:
2882 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
2884 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
2888 /* Fall through... */
2891 case INTRINSIC_EQ_OS
:
2893 case INTRINSIC_NE_OS
:
2894 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2896 e
->ts
.type
= BT_LOGICAL
;
2897 e
->ts
.kind
= gfc_default_logical_kind
;
2901 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2903 gfc_type_convert_binary (e
);
2905 e
->ts
.type
= BT_LOGICAL
;
2906 e
->ts
.kind
= gfc_default_logical_kind
;
2910 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2912 _("Logicals at %%L must be compared with %s instead of %s"),
2913 (e
->value
.op
.operator == INTRINSIC_EQ
2914 || e
->value
.op
.operator == INTRINSIC_EQ_OS
)
2915 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.operator));
2918 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2919 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2920 gfc_typename (&op2
->ts
));
2924 case INTRINSIC_USER
:
2925 if (e
->value
.op
.uop
->operator == NULL
)
2926 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
2927 else if (op2
== NULL
)
2928 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
2929 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
2931 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
2932 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
2933 gfc_typename (&op2
->ts
));
2937 case INTRINSIC_PARENTHESES
:
2939 if (e
->ts
.type
== BT_CHARACTER
)
2940 e
->ts
.cl
= op1
->ts
.cl
;
2944 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2947 /* Deal with arrayness of an operand through an operator. */
2951 switch (e
->value
.op
.operator)
2953 case INTRINSIC_PLUS
:
2954 case INTRINSIC_MINUS
:
2955 case INTRINSIC_TIMES
:
2956 case INTRINSIC_DIVIDE
:
2957 case INTRINSIC_POWER
:
2958 case INTRINSIC_CONCAT
:
2962 case INTRINSIC_NEQV
:
2964 case INTRINSIC_EQ_OS
:
2966 case INTRINSIC_NE_OS
:
2968 case INTRINSIC_GT_OS
:
2970 case INTRINSIC_GE_OS
:
2972 case INTRINSIC_LT_OS
:
2974 case INTRINSIC_LE_OS
:
2976 if (op1
->rank
== 0 && op2
->rank
== 0)
2979 if (op1
->rank
== 0 && op2
->rank
!= 0)
2981 e
->rank
= op2
->rank
;
2983 if (e
->shape
== NULL
)
2984 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
2987 if (op1
->rank
!= 0 && op2
->rank
== 0)
2989 e
->rank
= op1
->rank
;
2991 if (e
->shape
== NULL
)
2992 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2995 if (op1
->rank
!= 0 && op2
->rank
!= 0)
2997 if (op1
->rank
== op2
->rank
)
2999 e
->rank
= op1
->rank
;
3000 if (e
->shape
== NULL
)
3002 t
= compare_shapes(op1
, op2
);
3006 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3011 /* Allow higher level expressions to work. */
3014 /* Try user-defined operators, and otherwise throw an error. */
3015 dual_locus_error
= true;
3017 _("Inconsistent ranks for operator at %%L and %%L"));
3024 case INTRINSIC_PARENTHESES
:
3026 case INTRINSIC_UPLUS
:
3027 case INTRINSIC_UMINUS
:
3028 /* Simply copy arrayness attribute */
3029 e
->rank
= op1
->rank
;
3031 if (e
->shape
== NULL
)
3032 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3040 /* Attempt to simplify the expression. */
3043 t
= gfc_simplify_expr (e
, 0);
3044 /* Some calls do not succeed in simplification and return FAILURE
3045 even though there is no error; eg. variable references to
3046 PARAMETER arrays. */
3047 if (!gfc_is_constant_expr (e
))
3054 if (gfc_extend_expr (e
) == SUCCESS
)
3057 if (dual_locus_error
)
3058 gfc_error (msg
, &op1
->where
, &op2
->where
);
3060 gfc_error (msg
, &e
->where
);
3066 /************** Array resolution subroutines **************/
3069 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3072 /* Compare two integer expressions. */
3075 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3079 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3080 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3083 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3084 gfc_internal_error ("compare_bound(): Bad expression");
3086 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3096 /* Compare an integer expression with an integer. */
3099 compare_bound_int (gfc_expr
*a
, int b
)
3103 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3106 if (a
->ts
.type
!= BT_INTEGER
)
3107 gfc_internal_error ("compare_bound_int(): Bad expression");
3109 i
= mpz_cmp_si (a
->value
.integer
, b
);
3119 /* Compare an integer expression with a mpz_t. */
3122 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3126 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3129 if (a
->ts
.type
!= BT_INTEGER
)
3130 gfc_internal_error ("compare_bound_int(): Bad expression");
3132 i
= mpz_cmp (a
->value
.integer
, b
);
3142 /* Compute the last value of a sequence given by a triplet.
3143 Return 0 if it wasn't able to compute the last value, or if the
3144 sequence if empty, and 1 otherwise. */
3147 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3148 gfc_expr
*stride
, mpz_t last
)
3152 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3153 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3154 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3157 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3158 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3161 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
3163 if (compare_bound (start
, end
) == CMP_GT
)
3165 mpz_set (last
, end
->value
.integer
);
3169 if (compare_bound_int (stride
, 0) == CMP_GT
)
3171 /* Stride is positive */
3172 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3177 /* Stride is negative */
3178 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3183 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3184 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3185 mpz_sub (last
, end
->value
.integer
, rem
);
3192 /* Compare a single dimension of an array reference to the array
3196 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3200 /* Given start, end and stride values, calculate the minimum and
3201 maximum referenced indexes. */
3203 switch (ar
->dimen_type
[i
])
3209 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3211 gfc_warning ("Array reference at %L is out of bounds "
3212 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3213 mpz_get_si (ar
->start
[i
]->value
.integer
),
3214 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3217 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3219 gfc_warning ("Array reference at %L is out of bounds "
3220 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3221 mpz_get_si (ar
->start
[i
]->value
.integer
),
3222 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3230 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3231 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3233 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3235 /* Check for zero stride, which is not allowed. */
3236 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3238 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3242 /* if start == len || (stride > 0 && start < len)
3243 || (stride < 0 && start > len),
3244 then the array section contains at least one element. In this
3245 case, there is an out-of-bounds access if
3246 (start < lower || start > upper). */
3247 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3248 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3249 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3250 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3251 && comp_start_end
== CMP_GT
))
3253 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3255 gfc_warning ("Lower array reference at %L is out of bounds "
3256 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3257 mpz_get_si (AR_START
->value
.integer
),
3258 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3261 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3263 gfc_warning ("Lower array reference at %L is out of bounds "
3264 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3265 mpz_get_si (AR_START
->value
.integer
),
3266 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3271 /* If we can compute the highest index of the array section,
3272 then it also has to be between lower and upper. */
3273 mpz_init (last_value
);
3274 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
3277 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
3279 gfc_warning ("Upper array reference at %L is out of bounds "
3280 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3281 mpz_get_si (last_value
),
3282 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3283 mpz_clear (last_value
);
3286 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
3288 gfc_warning ("Upper array reference at %L is out of bounds "
3289 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3290 mpz_get_si (last_value
),
3291 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3292 mpz_clear (last_value
);
3296 mpz_clear (last_value
);
3304 gfc_internal_error ("check_dimension(): Bad array reference");
3311 /* Compare an array reference with an array specification. */
3314 compare_spec_to_ref (gfc_array_ref
*ar
)
3321 /* TODO: Full array sections are only allowed as actual parameters. */
3322 if (as
->type
== AS_ASSUMED_SIZE
3323 && (/*ar->type == AR_FULL
3324 ||*/ (ar
->type
== AR_SECTION
3325 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
3327 gfc_error ("Rightmost upper bound of assumed size array section "
3328 "not specified at %L", &ar
->where
);
3332 if (ar
->type
== AR_FULL
)
3335 if (as
->rank
!= ar
->dimen
)
3337 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3338 &ar
->where
, ar
->dimen
, as
->rank
);
3342 for (i
= 0; i
< as
->rank
; i
++)
3343 if (check_dimension (i
, ar
, as
) == FAILURE
)
3350 /* Resolve one part of an array index. */
3353 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
3360 if (gfc_resolve_expr (index
) == FAILURE
)
3363 if (check_scalar
&& index
->rank
!= 0)
3365 gfc_error ("Array index at %L must be scalar", &index
->where
);
3369 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
3371 gfc_error ("Array index at %L must be of INTEGER type",
3376 if (index
->ts
.type
== BT_REAL
)
3377 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
3378 &index
->where
) == FAILURE
)
3381 if (index
->ts
.kind
!= gfc_index_integer_kind
3382 || index
->ts
.type
!= BT_INTEGER
)
3385 ts
.type
= BT_INTEGER
;
3386 ts
.kind
= gfc_index_integer_kind
;
3388 gfc_convert_type_warn (index
, &ts
, 2, 0);
3394 /* Resolve a dim argument to an intrinsic function. */
3397 gfc_resolve_dim_arg (gfc_expr
*dim
)
3402 if (gfc_resolve_expr (dim
) == FAILURE
)
3407 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
3411 if (dim
->ts
.type
!= BT_INTEGER
)
3413 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
3416 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
3420 ts
.type
= BT_INTEGER
;
3421 ts
.kind
= gfc_index_integer_kind
;
3423 gfc_convert_type_warn (dim
, &ts
, 2, 0);
3429 /* Given an expression that contains array references, update those array
3430 references to point to the right array specifications. While this is
3431 filled in during matching, this information is difficult to save and load
3432 in a module, so we take care of it here.
3434 The idea here is that the original array reference comes from the
3435 base symbol. We traverse the list of reference structures, setting
3436 the stored reference to references. Component references can
3437 provide an additional array specification. */
3440 find_array_spec (gfc_expr
*e
)
3444 gfc_symbol
*derived
;
3447 as
= e
->symtree
->n
.sym
->as
;
3450 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3455 gfc_internal_error ("find_array_spec(): Missing spec");
3462 if (derived
== NULL
)
3463 derived
= e
->symtree
->n
.sym
->ts
.derived
;
3465 c
= derived
->components
;
3467 for (; c
; c
= c
->next
)
3468 if (c
== ref
->u
.c
.component
)
3470 /* Track the sequence of component references. */
3471 if (c
->ts
.type
== BT_DERIVED
)
3472 derived
= c
->ts
.derived
;
3477 gfc_internal_error ("find_array_spec(): Component not found");
3482 gfc_internal_error ("find_array_spec(): unused as(1)");
3493 gfc_internal_error ("find_array_spec(): unused as(2)");
3497 /* Resolve an array reference. */
3500 resolve_array_ref (gfc_array_ref
*ar
)
3502 int i
, check_scalar
;
3505 for (i
= 0; i
< ar
->dimen
; i
++)
3507 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
3509 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
3511 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
3513 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
3518 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
3522 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3526 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
3527 if (e
->expr_type
== EXPR_VARIABLE
3528 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
3529 ar
->start
[i
] = gfc_get_parentheses (e
);
3533 gfc_error ("Array index at %L is an array of rank %d",
3534 &ar
->c_where
[i
], e
->rank
);
3539 /* If the reference type is unknown, figure out what kind it is. */
3541 if (ar
->type
== AR_UNKNOWN
)
3543 ar
->type
= AR_ELEMENT
;
3544 for (i
= 0; i
< ar
->dimen
; i
++)
3545 if (ar
->dimen_type
[i
] == DIMEN_RANGE
3546 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3548 ar
->type
= AR_SECTION
;
3553 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
3561 resolve_substring (gfc_ref
*ref
)
3563 if (ref
->u
.ss
.start
!= NULL
)
3565 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
3568 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
3570 gfc_error ("Substring start index at %L must be of type INTEGER",
3571 &ref
->u
.ss
.start
->where
);
3575 if (ref
->u
.ss
.start
->rank
!= 0)
3577 gfc_error ("Substring start index at %L must be scalar",
3578 &ref
->u
.ss
.start
->where
);
3582 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
3583 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3584 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3586 gfc_error ("Substring start index at %L is less than one",
3587 &ref
->u
.ss
.start
->where
);
3592 if (ref
->u
.ss
.end
!= NULL
)
3594 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
3597 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
3599 gfc_error ("Substring end index at %L must be of type INTEGER",
3600 &ref
->u
.ss
.end
->where
);
3604 if (ref
->u
.ss
.end
->rank
!= 0)
3606 gfc_error ("Substring end index at %L must be scalar",
3607 &ref
->u
.ss
.end
->where
);
3611 if (ref
->u
.ss
.length
!= NULL
3612 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
3613 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3614 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3616 gfc_error ("Substring end index at %L exceeds the string length",
3617 &ref
->u
.ss
.start
->where
);
3626 /* This function supplies missing substring charlens. */
3629 gfc_resolve_substring_charlen (gfc_expr
*e
)
3632 gfc_expr
*start
, *end
;
3634 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
3635 if (char_ref
->type
== REF_SUBSTRING
)
3641 gcc_assert (char_ref
->next
== NULL
);
3645 if (e
->ts
.cl
->length
)
3646 gfc_free_expr (e
->ts
.cl
->length
);
3647 else if (e
->expr_type
== EXPR_VARIABLE
3648 && e
->symtree
->n
.sym
->attr
.dummy
)
3652 e
->ts
.type
= BT_CHARACTER
;
3653 e
->ts
.kind
= gfc_default_character_kind
;
3657 e
->ts
.cl
= gfc_get_charlen ();
3658 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
3659 gfc_current_ns
->cl_list
= e
->ts
.cl
;
3662 if (char_ref
->u
.ss
.start
)
3663 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
3665 start
= gfc_int_expr (1);
3667 if (char_ref
->u
.ss
.end
)
3668 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
3669 else if (e
->expr_type
== EXPR_VARIABLE
)
3670 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.cl
->length
);
3677 /* Length = (end - start +1). */
3678 e
->ts
.cl
->length
= gfc_subtract (end
, start
);
3679 e
->ts
.cl
->length
= gfc_add (e
->ts
.cl
->length
, gfc_int_expr (1));
3681 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
3682 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
3684 /* Make sure that the length is simplified. */
3685 gfc_simplify_expr (e
->ts
.cl
->length
, 1);
3686 gfc_resolve_expr (e
->ts
.cl
->length
);
3690 /* Resolve subtype references. */
3693 resolve_ref (gfc_expr
*expr
)
3695 int current_part_dimension
, n_components
, seen_part_dimension
;
3698 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3699 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
3701 find_array_spec (expr
);
3705 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3709 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
3717 resolve_substring (ref
);
3721 /* Check constraints on part references. */
3723 current_part_dimension
= 0;
3724 seen_part_dimension
= 0;
3727 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3732 switch (ref
->u
.ar
.type
)
3736 current_part_dimension
= 1;
3740 current_part_dimension
= 0;
3744 gfc_internal_error ("resolve_ref(): Bad array reference");
3750 if (current_part_dimension
|| seen_part_dimension
)
3752 if (ref
->u
.c
.component
->pointer
)
3754 gfc_error ("Component to the right of a part reference "
3755 "with nonzero rank must not have the POINTER "
3756 "attribute at %L", &expr
->where
);
3759 else if (ref
->u
.c
.component
->allocatable
)
3761 gfc_error ("Component to the right of a part reference "
3762 "with nonzero rank must not have the ALLOCATABLE "
3763 "attribute at %L", &expr
->where
);
3775 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
3776 || ref
->next
== NULL
)
3777 && current_part_dimension
3778 && seen_part_dimension
)
3780 gfc_error ("Two or more part references with nonzero rank must "
3781 "not be specified at %L", &expr
->where
);
3785 if (ref
->type
== REF_COMPONENT
)
3787 if (current_part_dimension
)
3788 seen_part_dimension
= 1;
3790 /* reset to make sure */
3791 current_part_dimension
= 0;
3799 /* Given an expression, determine its shape. This is easier than it sounds.
3800 Leaves the shape array NULL if it is not possible to determine the shape. */
3803 expression_shape (gfc_expr
*e
)
3805 mpz_t array
[GFC_MAX_DIMENSIONS
];
3808 if (e
->rank
== 0 || e
->shape
!= NULL
)
3811 for (i
= 0; i
< e
->rank
; i
++)
3812 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
3815 e
->shape
= gfc_get_shape (e
->rank
);
3817 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
3822 for (i
--; i
>= 0; i
--)
3823 mpz_clear (array
[i
]);
3827 /* Given a variable expression node, compute the rank of the expression by
3828 examining the base symbol and any reference structures it may have. */
3831 expression_rank (gfc_expr
*e
)
3838 if (e
->expr_type
== EXPR_ARRAY
)
3840 /* Constructors can have a rank different from one via RESHAPE(). */
3842 if (e
->symtree
== NULL
)
3848 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
3849 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
3855 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3857 if (ref
->type
!= REF_ARRAY
)
3860 if (ref
->u
.ar
.type
== AR_FULL
)
3862 rank
= ref
->u
.ar
.as
->rank
;
3866 if (ref
->u
.ar
.type
== AR_SECTION
)
3868 /* Figure out the rank of the section. */
3870 gfc_internal_error ("expression_rank(): Two array specs");
3872 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3873 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
3874 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
3884 expression_shape (e
);
3888 /* Resolve a variable expression. */
3891 resolve_variable (gfc_expr
*e
)
3898 if (e
->symtree
== NULL
)
3901 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
3904 sym
= e
->symtree
->n
.sym
;
3905 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
3907 e
->ts
.type
= BT_PROCEDURE
;
3911 if (sym
->ts
.type
!= BT_UNKNOWN
)
3912 gfc_variable_attr (e
, &e
->ts
);
3915 /* Must be a simple variable reference. */
3916 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
3921 if (check_assumed_size_reference (sym
, e
))
3924 /* Deal with forward references to entries during resolve_code, to
3925 satisfy, at least partially, 12.5.2.5. */
3926 if (gfc_current_ns
->entries
3927 && current_entry_id
== sym
->entry_id
3930 && cs_base
->current
->op
!= EXEC_ENTRY
)
3932 gfc_entry_list
*entry
;
3933 gfc_formal_arglist
*formal
;
3937 /* If the symbol is a dummy... */
3938 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
3940 entry
= gfc_current_ns
->entries
;
3943 /* ...test if the symbol is a parameter of previous entries. */
3944 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
3945 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
3947 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
3951 /* If it has not been seen as a dummy, this is an error. */
3954 if (specification_expr
)
3955 gfc_error ("Variable '%s', used in a specification expression"
3956 ", is referenced at %L before the ENTRY statement "
3957 "in which it is a parameter",
3958 sym
->name
, &cs_base
->current
->loc
);
3960 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3961 "statement in which it is a parameter",
3962 sym
->name
, &cs_base
->current
->loc
);
3967 /* Now do the same check on the specification expressions. */
3968 specification_expr
= 1;
3969 if (sym
->ts
.type
== BT_CHARACTER
3970 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
3974 for (n
= 0; n
< sym
->as
->rank
; n
++)
3976 specification_expr
= 1;
3977 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
3979 specification_expr
= 1;
3980 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
3983 specification_expr
= 0;
3986 /* Update the symbol's entry level. */
3987 sym
->entry_id
= current_entry_id
+ 1;
3994 /* Checks to see that the correct symbol has been host associated.
3995 The only situation where this arises is that in which a twice
3996 contained function is parsed after the host association is made.
3997 Therefore, on detecting this, the line is rematched, having got
3998 rid of the existing references and actual_arg_list. */
4000 check_host_association (gfc_expr
*e
)
4002 gfc_symbol
*sym
, *old_sym
;
4006 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
4008 if (e
->symtree
== NULL
|| e
->symtree
->n
.sym
== NULL
)
4011 old_sym
= e
->symtree
->n
.sym
;
4013 if (old_sym
->attr
.use_assoc
)
4016 if (gfc_current_ns
->parent
4017 && old_sym
->ns
!= gfc_current_ns
)
4019 gfc_find_symbol (old_sym
->name
, gfc_current_ns
, 1, &sym
);
4020 if (sym
&& old_sym
!= sym
4021 && sym
->attr
.flavor
== FL_PROCEDURE
4022 && sym
->attr
.contained
)
4024 temp_locus
= gfc_current_locus
;
4025 gfc_current_locus
= e
->where
;
4027 gfc_buffer_error (1);
4029 gfc_free_ref_list (e
->ref
);
4034 gfc_free_actual_arglist (e
->value
.function
.actual
);
4035 e
->value
.function
.actual
= NULL
;
4038 if (e
->shape
!= NULL
)
4040 for (n
= 0; n
< e
->rank
; n
++)
4041 mpz_clear (e
->shape
[n
]);
4043 gfc_free (e
->shape
);
4046 gfc_match_rvalue (&expr
);
4048 gfc_buffer_error (0);
4050 gcc_assert (expr
&& sym
== expr
->symtree
->n
.sym
);
4056 gfc_current_locus
= temp_locus
;
4059 /* This might have changed! */
4060 return e
->expr_type
== EXPR_FUNCTION
;
4065 gfc_resolve_character_operator (gfc_expr
*e
)
4067 gfc_expr
*op1
= e
->value
.op
.op1
;
4068 gfc_expr
*op2
= e
->value
.op
.op2
;
4069 gfc_expr
*e1
= NULL
;
4070 gfc_expr
*e2
= NULL
;
4072 gcc_assert (e
->value
.op
.operator == INTRINSIC_CONCAT
);
4074 if (op1
->ts
.cl
&& op1
->ts
.cl
->length
)
4075 e1
= gfc_copy_expr (op1
->ts
.cl
->length
);
4076 else if (op1
->expr_type
== EXPR_CONSTANT
)
4077 e1
= gfc_int_expr (op1
->value
.character
.length
);
4079 if (op2
->ts
.cl
&& op2
->ts
.cl
->length
)
4080 e2
= gfc_copy_expr (op2
->ts
.cl
->length
);
4081 else if (op2
->expr_type
== EXPR_CONSTANT
)
4082 e2
= gfc_int_expr (op2
->value
.character
.length
);
4084 e
->ts
.cl
= gfc_get_charlen ();
4085 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4086 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4091 e
->ts
.cl
->length
= gfc_add (e1
, e2
);
4092 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
4093 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
4094 gfc_simplify_expr (e
->ts
.cl
->length
, 0);
4095 gfc_resolve_expr (e
->ts
.cl
->length
);
4101 /* Ensure that an character expression has a charlen and, if possible, a
4102 length expression. */
4105 fixup_charlen (gfc_expr
*e
)
4107 /* The cases fall through so that changes in expression type and the need
4108 for multiple fixes are picked up. In all circumstances, a charlen should
4109 be available for the middle end to hang a backend_decl on. */
4110 switch (e
->expr_type
)
4113 gfc_resolve_character_operator (e
);
4116 if (e
->expr_type
== EXPR_ARRAY
)
4117 gfc_resolve_character_array_constructor (e
);
4119 case EXPR_SUBSTRING
:
4120 if (!e
->ts
.cl
&& e
->ref
)
4121 gfc_resolve_substring_charlen (e
);
4126 e
->ts
.cl
= gfc_get_charlen ();
4127 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4128 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4136 /* Resolve an expression. That is, make sure that types of operands agree
4137 with their operators, intrinsic operators are converted to function calls
4138 for overloaded types and unresolved function references are resolved. */
4141 gfc_resolve_expr (gfc_expr
*e
)
4148 switch (e
->expr_type
)
4151 t
= resolve_operator (e
);
4157 if (check_host_association (e
))
4158 t
= resolve_function (e
);
4161 t
= resolve_variable (e
);
4163 expression_rank (e
);
4166 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.cl
== NULL
&& e
->ref
4167 && e
->ref
->type
!= REF_SUBSTRING
)
4168 gfc_resolve_substring_charlen (e
);
4172 case EXPR_SUBSTRING
:
4173 t
= resolve_ref (e
);
4183 if (resolve_ref (e
) == FAILURE
)
4186 t
= gfc_resolve_array_constructor (e
);
4187 /* Also try to expand a constructor. */
4190 expression_rank (e
);
4191 gfc_expand_constructor (e
);
4194 /* This provides the opportunity for the length of constructors with
4195 character valued function elements to propagate the string length
4196 to the expression. */
4197 if (e
->ts
.type
== BT_CHARACTER
)
4198 gfc_resolve_character_array_constructor (e
);
4202 case EXPR_STRUCTURE
:
4203 t
= resolve_ref (e
);
4207 t
= resolve_structure_cons (e
);
4211 t
= gfc_simplify_expr (e
, 0);
4215 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4218 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.cl
)
4225 /* Resolve an expression from an iterator. They must be scalar and have
4226 INTEGER or (optionally) REAL type. */
4229 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
4230 const char *name_msgid
)
4232 if (gfc_resolve_expr (expr
) == FAILURE
)
4235 if (expr
->rank
!= 0)
4237 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
4241 if (expr
->ts
.type
!= BT_INTEGER
)
4243 if (expr
->ts
.type
== BT_REAL
)
4246 return gfc_notify_std (GFC_STD_F95_DEL
,
4247 "Deleted feature: %s at %L must be integer",
4248 _(name_msgid
), &expr
->where
);
4251 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
4258 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
4266 /* Resolve the expressions in an iterator structure. If REAL_OK is
4267 false allow only INTEGER type iterators, otherwise allow REAL types. */
4270 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
4272 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
4276 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
4278 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4283 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
4284 "Start expression in DO loop") == FAILURE
)
4287 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
4288 "End expression in DO loop") == FAILURE
)
4291 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
4292 "Step expression in DO loop") == FAILURE
)
4295 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
4297 if ((iter
->step
->ts
.type
== BT_INTEGER
4298 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
4299 || (iter
->step
->ts
.type
== BT_REAL
4300 && mpfr_sgn (iter
->step
->value
.real
) == 0))
4302 gfc_error ("Step expression in DO loop at %L cannot be zero",
4303 &iter
->step
->where
);
4308 /* Convert start, end, and step to the same type as var. */
4309 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
4310 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
4311 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4313 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
4314 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
4315 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4317 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
4318 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
4319 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
4325 /* Check whether the FORALL index appears in the expression or not.
4326 Returns SUCCESS if SYM is found in EXPR. */
4329 find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
4333 gfc_actual_arglist
*args
;
4339 switch (expr
->expr_type
)
4342 gcc_assert (expr
->symtree
->n
.sym
);
4344 /* A scalar assignment */
4347 if (expr
->symtree
->n
.sym
== symbol
)
4353 /* the expr is array ref, substring or struct component. */
4360 /* Check if the symbol appears in the array subscript. */
4362 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4365 if (find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
4369 if (find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
4373 if (find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
4379 if (expr
->symtree
->n
.sym
== symbol
)
4382 /* Check if the symbol appears in the substring section. */
4383 if (find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4385 if (find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4393 gfc_error("expression reference type error at %L", &expr
->where
);
4399 /* If the expression is a function call, then check if the symbol
4400 appears in the actual arglist of the function. */
4402 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4404 if (find_forall_index(args
->expr
,symbol
) == SUCCESS
)
4409 /* It seems not to happen. */
4410 case EXPR_SUBSTRING
:
4414 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
4415 if (find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4417 if (find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4422 /* It seems not to happen. */
4423 case EXPR_STRUCTURE
:
4425 gfc_error ("Unsupported statement while finding forall index in "
4430 /* Find the FORALL index in the first operand. */
4431 if (expr
->value
.op
.op1
)
4433 if (find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
4437 /* Find the FORALL index in the second operand. */
4438 if (expr
->value
.op
.op2
)
4440 if (find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
4453 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4454 to be a scalar INTEGER variable. The subscripts and stride are scalar
4455 INTEGERs, and if stride is a constant it must be nonzero.
4456 Furthermore "A subscript or stride in a forall-triplet-spec shall
4457 not contain a reference to any index-name in the
4458 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4461 resolve_forall_iterators (gfc_forall_iterator
*it
)
4463 gfc_forall_iterator
*iter
, *iter2
;
4465 for (iter
= it
; iter
; iter
= iter
->next
)
4467 if (gfc_resolve_expr (iter
->var
) == SUCCESS
4468 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
4469 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4472 if (gfc_resolve_expr (iter
->start
) == SUCCESS
4473 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
4474 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4475 &iter
->start
->where
);
4476 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
4477 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4479 if (gfc_resolve_expr (iter
->end
) == SUCCESS
4480 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
4481 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4483 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
4484 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4486 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
4488 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
4489 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4490 &iter
->stride
->where
, "INTEGER");
4492 if (iter
->stride
->expr_type
== EXPR_CONSTANT
4493 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
4494 gfc_error ("FORALL stride expression at %L cannot be zero",
4495 &iter
->stride
->where
);
4497 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
4498 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
4501 for (iter
= it
; iter
; iter
= iter
->next
)
4502 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
4504 if (find_forall_index (iter2
->start
,
4505 iter
->var
->symtree
->n
.sym
) == SUCCESS
4506 || find_forall_index (iter2
->end
,
4507 iter
->var
->symtree
->n
.sym
) == SUCCESS
4508 || find_forall_index (iter2
->stride
,
4509 iter
->var
->symtree
->n
.sym
) == SUCCESS
)
4510 gfc_error ("FORALL index '%s' may not appear in triplet "
4511 "specification at %L", iter
->var
->symtree
->name
,
4512 &iter2
->start
->where
);
4517 /* Given a pointer to a symbol that is a derived type, see if it's
4518 inaccessible, i.e. if it's defined in another module and the components are
4519 PRIVATE. The search is recursive if necessary. Returns zero if no
4520 inaccessible components are found, nonzero otherwise. */
4523 derived_inaccessible (gfc_symbol
*sym
)
4527 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
4530 for (c
= sym
->components
; c
; c
= c
->next
)
4532 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
4540 /* Resolve the argument of a deallocate expression. The expression must be
4541 a pointer or a full array. */
4544 resolve_deallocate_expr (gfc_expr
*e
)
4546 symbol_attribute attr
;
4547 int allocatable
, pointer
, check_intent_in
;
4550 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4551 check_intent_in
= 1;
4553 if (gfc_resolve_expr (e
) == FAILURE
)
4556 if (e
->expr_type
!= EXPR_VARIABLE
)
4559 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
4560 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
4561 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4564 check_intent_in
= 0;
4569 if (ref
->u
.ar
.type
!= AR_FULL
)
4574 allocatable
= (ref
->u
.c
.component
->as
!= NULL
4575 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
4576 pointer
= ref
->u
.c
.component
->pointer
;
4585 attr
= gfc_expr_attr (e
);
4587 if (allocatable
== 0 && attr
.pointer
== 0)
4590 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4591 "ALLOCATABLE or a POINTER", &e
->where
);
4595 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
4597 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4598 e
->symtree
->n
.sym
->name
, &e
->where
);
4606 /* Returns true if the expression e contains a reference the symbol sym. */
4608 find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
4610 gfc_actual_arglist
*arg
;
4618 switch (e
->expr_type
)
4621 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
4622 rv
= rv
|| find_sym_in_expr (sym
, arg
->expr
);
4625 /* If the variable is not the same as the dependent, 'sym', and
4626 it is not marked as being declared and it is in the same
4627 namespace as 'sym', add it to the local declarations. */
4629 if (sym
== e
->symtree
->n
.sym
)
4634 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op1
);
4635 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op2
);
4644 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4649 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4651 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.start
[i
]);
4652 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.end
[i
]);
4653 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.stride
[i
]);
4658 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.start
);
4659 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.end
);
4663 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4664 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
4667 || find_sym_in_expr (sym
,
4668 ref
->u
.c
.component
->ts
.cl
->length
);
4670 if (ref
->u
.c
.component
->as
)
4671 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
4674 || find_sym_in_expr (sym
,
4675 ref
->u
.c
.component
->as
->lower
[i
]);
4677 || find_sym_in_expr (sym
,
4678 ref
->u
.c
.component
->as
->upper
[i
]);
4688 /* Given the expression node e for an allocatable/pointer of derived type to be
4689 allocated, get the expression node to be initialized afterwards (needed for
4690 derived types with default initializers, and derived types with allocatable
4691 components that need nullification.) */
4694 expr_to_initialize (gfc_expr
*e
)
4700 result
= gfc_copy_expr (e
);
4702 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4703 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
4704 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
4706 ref
->u
.ar
.type
= AR_FULL
;
4708 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4709 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
4711 result
->rank
= ref
->u
.ar
.dimen
;
4719 /* Resolve the expression in an ALLOCATE statement, doing the additional
4720 checks to see whether the expression is OK or not. The expression must
4721 have a trailing array reference that gives the size of the array. */
4724 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
4726 int i
, pointer
, allocatable
, dimension
, check_intent_in
;
4727 symbol_attribute attr
;
4728 gfc_ref
*ref
, *ref2
;
4735 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4736 check_intent_in
= 1;
4738 if (gfc_resolve_expr (e
) == FAILURE
)
4741 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
4742 sym
= code
->expr
->symtree
->n
.sym
;
4746 /* Make sure the expression is allocatable or a pointer. If it is
4747 pointer, the next-to-last reference must be a pointer. */
4751 if (e
->expr_type
!= EXPR_VARIABLE
)
4754 attr
= gfc_expr_attr (e
);
4755 pointer
= attr
.pointer
;
4756 dimension
= attr
.dimension
;
4760 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
4761 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
4762 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
4764 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
4766 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4767 "not be allocated in the same statement at %L",
4768 sym
->name
, &e
->where
);
4772 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
4775 check_intent_in
= 0;
4780 if (ref
->next
!= NULL
)
4785 allocatable
= (ref
->u
.c
.component
->as
!= NULL
4786 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
4788 pointer
= ref
->u
.c
.component
->pointer
;
4789 dimension
= ref
->u
.c
.component
->dimension
;
4800 if (allocatable
== 0 && pointer
== 0)
4802 gfc_error ("Expression in ALLOCATE statement at %L must be "
4803 "ALLOCATABLE or a POINTER", &e
->where
);
4808 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
4810 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4811 e
->symtree
->n
.sym
->name
, &e
->where
);
4815 /* Add default initializer for those derived types that need them. */
4816 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
4818 init_st
= gfc_get_code ();
4819 init_st
->loc
= code
->loc
;
4820 init_st
->op
= EXEC_INIT_ASSIGN
;
4821 init_st
->expr
= expr_to_initialize (e
);
4822 init_st
->expr2
= init_e
;
4823 init_st
->next
= code
->next
;
4824 code
->next
= init_st
;
4827 if (pointer
&& dimension
== 0)
4830 /* Make sure the next-to-last reference node is an array specification. */
4832 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
4834 gfc_error ("Array specification required in ALLOCATE statement "
4835 "at %L", &e
->where
);
4839 /* Make sure that the array section reference makes sense in the
4840 context of an ALLOCATE specification. */
4844 for (i
= 0; i
< ar
->dimen
; i
++)
4846 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
4849 switch (ar
->dimen_type
[i
])
4855 if (ar
->start
[i
] != NULL
4856 && ar
->end
[i
] != NULL
4857 && ar
->stride
[i
] == NULL
)
4860 /* Fall Through... */
4864 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4871 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
4873 sym
= a
->expr
->symtree
->n
.sym
;
4875 /* TODO - check derived type components. */
4876 if (sym
->ts
.type
== BT_DERIVED
)
4879 if ((ar
->start
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->start
[i
]))
4880 || (ar
->end
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->end
[i
])))
4882 gfc_error ("'%s' must not appear an the array specification at "
4883 "%L in the same ALLOCATE statement where it is "
4884 "itself allocated", sym
->name
, &ar
->where
);
4894 /************ SELECT CASE resolution subroutines ************/
4896 /* Callback function for our mergesort variant. Determines interval
4897 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4898 op1 > op2. Assumes we're not dealing with the default case.
4899 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4900 There are nine situations to check. */
4903 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
4907 if (op1
->low
== NULL
) /* op1 = (:L) */
4909 /* op2 = (:N), so overlap. */
4911 /* op2 = (M:) or (M:N), L < M */
4912 if (op2
->low
!= NULL
4913 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
4916 else if (op1
->high
== NULL
) /* op1 = (K:) */
4918 /* op2 = (M:), so overlap. */
4920 /* op2 = (:N) or (M:N), K > N */
4921 if (op2
->high
!= NULL
4922 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
4925 else /* op1 = (K:L) */
4927 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
4928 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
4929 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
4930 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
4931 else /* op2 = (M:N) */
4935 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
4938 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
4947 /* Merge-sort a double linked case list, detecting overlap in the
4948 process. LIST is the head of the double linked case list before it
4949 is sorted. Returns the head of the sorted list if we don't see any
4950 overlap, or NULL otherwise. */
4953 check_case_overlap (gfc_case
*list
)
4955 gfc_case
*p
, *q
, *e
, *tail
;
4956 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
4958 /* If the passed list was empty, return immediately. */
4965 /* Loop unconditionally. The only exit from this loop is a return
4966 statement, when we've finished sorting the case list. */
4973 /* Count the number of merges we do in this pass. */
4976 /* Loop while there exists a merge to be done. */
4981 /* Count this merge. */
4984 /* Cut the list in two pieces by stepping INSIZE places
4985 forward in the list, starting from P. */
4988 for (i
= 0; i
< insize
; i
++)
4997 /* Now we have two lists. Merge them! */
4998 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
5000 /* See from which the next case to merge comes from. */
5003 /* P is empty so the next case must come from Q. */
5008 else if (qsize
== 0 || q
== NULL
)
5017 cmp
= compare_cases (p
, q
);
5020 /* The whole case range for P is less than the
5028 /* The whole case range for Q is greater than
5029 the case range for P. */
5036 /* The cases overlap, or they are the same
5037 element in the list. Either way, we must
5038 issue an error and get the next case from P. */
5039 /* FIXME: Sort P and Q by line number. */
5040 gfc_error ("CASE label at %L overlaps with CASE "
5041 "label at %L", &p
->where
, &q
->where
);
5049 /* Add the next element to the merged list. */
5058 /* P has now stepped INSIZE places along, and so has Q. So
5059 they're the same. */
5064 /* If we have done only one merge or none at all, we've
5065 finished sorting the cases. */
5074 /* Otherwise repeat, merging lists twice the size. */
5080 /* Check to see if an expression is suitable for use in a CASE statement.
5081 Makes sure that all case expressions are scalar constants of the same
5082 type. Return FAILURE if anything is wrong. */
5085 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
5087 if (e
== NULL
) return SUCCESS
;
5089 if (e
->ts
.type
!= case_expr
->ts
.type
)
5091 gfc_error ("Expression in CASE statement at %L must be of type %s",
5092 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
5096 /* C805 (R808) For a given case-construct, each case-value shall be of
5097 the same type as case-expr. For character type, length differences
5098 are allowed, but the kind type parameters shall be the same. */
5100 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
5102 gfc_error("Expression in CASE statement at %L must be kind %d",
5103 &e
->where
, case_expr
->ts
.kind
);
5107 /* Convert the case value kind to that of case expression kind, if needed.
5108 FIXME: Should a warning be issued? */
5109 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
5110 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
5114 gfc_error ("Expression in CASE statement at %L must be scalar",
5123 /* Given a completely parsed select statement, we:
5125 - Validate all expressions and code within the SELECT.
5126 - Make sure that the selection expression is not of the wrong type.
5127 - Make sure that no case ranges overlap.
5128 - Eliminate unreachable cases and unreachable code resulting from
5129 removing case labels.
5131 The standard does allow unreachable cases, e.g. CASE (5:3). But
5132 they are a hassle for code generation, and to prevent that, we just
5133 cut them out here. This is not necessary for overlapping cases
5134 because they are illegal and we never even try to generate code.
5136 We have the additional caveat that a SELECT construct could have
5137 been a computed GOTO in the source code. Fortunately we can fairly
5138 easily work around that here: The case_expr for a "real" SELECT CASE
5139 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5140 we have to do is make sure that the case_expr is a scalar integer
5144 resolve_select (gfc_code
*code
)
5147 gfc_expr
*case_expr
;
5148 gfc_case
*cp
, *default_case
, *tail
, *head
;
5149 int seen_unreachable
;
5155 if (code
->expr
== NULL
)
5157 /* This was actually a computed GOTO statement. */
5158 case_expr
= code
->expr2
;
5159 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
5160 gfc_error ("Selection expression in computed GOTO statement "
5161 "at %L must be a scalar integer expression",
5164 /* Further checking is not necessary because this SELECT was built
5165 by the compiler, so it should always be OK. Just move the
5166 case_expr from expr2 to expr so that we can handle computed
5167 GOTOs as normal SELECTs from here on. */
5168 code
->expr
= code
->expr2
;
5173 case_expr
= code
->expr
;
5175 type
= case_expr
->ts
.type
;
5176 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
5178 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5179 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
5181 /* Punt. Going on here just produce more garbage error messages. */
5185 if (case_expr
->rank
!= 0)
5187 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5188 "expression", &case_expr
->where
);
5194 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5195 of the SELECT CASE expression and its CASE values. Walk the lists
5196 of case values, and if we find a mismatch, promote case_expr to
5197 the appropriate kind. */
5199 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
5201 for (body
= code
->block
; body
; body
= body
->block
)
5203 /* Walk the case label list. */
5204 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5206 /* Intercept the DEFAULT case. It does not have a kind. */
5207 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5210 /* Unreachable case ranges are discarded, so ignore. */
5211 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5212 && cp
->low
!= cp
->high
5213 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
5216 /* FIXME: Should a warning be issued? */
5218 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
5219 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
5221 if (cp
->high
!= NULL
5222 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
5223 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
5228 /* Assume there is no DEFAULT case. */
5229 default_case
= NULL
;
5234 for (body
= code
->block
; body
; body
= body
->block
)
5236 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5238 seen_unreachable
= 0;
5240 /* Walk the case label list, making sure that all case labels
5242 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5244 /* Count the number of cases in the whole construct. */
5247 /* Intercept the DEFAULT case. */
5248 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5250 if (default_case
!= NULL
)
5252 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5253 "by a second DEFAULT CASE at %L",
5254 &default_case
->where
, &cp
->where
);
5265 /* Deal with single value cases and case ranges. Errors are
5266 issued from the validation function. */
5267 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
5268 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
5274 if (type
== BT_LOGICAL
5275 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
5276 || cp
->low
!= cp
->high
))
5278 gfc_error ("Logical range in CASE statement at %L is not "
5279 "allowed", &cp
->low
->where
);
5284 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
5287 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
5288 if (value
& seen_logical
)
5290 gfc_error ("constant logical value in CASE statement "
5291 "is repeated at %L",
5296 seen_logical
|= value
;
5299 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5300 && cp
->low
!= cp
->high
5301 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
5303 if (gfc_option
.warn_surprising
)
5304 gfc_warning ("Range specification at %L can never "
5305 "be matched", &cp
->where
);
5307 cp
->unreachable
= 1;
5308 seen_unreachable
= 1;
5312 /* If the case range can be matched, it can also overlap with
5313 other cases. To make sure it does not, we put it in a
5314 double linked list here. We sort that with a merge sort
5315 later on to detect any overlapping cases. */
5319 head
->right
= head
->left
= NULL
;
5324 tail
->right
->left
= tail
;
5331 /* It there was a failure in the previous case label, give up
5332 for this case label list. Continue with the next block. */
5336 /* See if any case labels that are unreachable have been seen.
5337 If so, we eliminate them. This is a bit of a kludge because
5338 the case lists for a single case statement (label) is a
5339 single forward linked lists. */
5340 if (seen_unreachable
)
5342 /* Advance until the first case in the list is reachable. */
5343 while (body
->ext
.case_list
!= NULL
5344 && body
->ext
.case_list
->unreachable
)
5346 gfc_case
*n
= body
->ext
.case_list
;
5347 body
->ext
.case_list
= body
->ext
.case_list
->next
;
5349 gfc_free_case_list (n
);
5352 /* Strip all other unreachable cases. */
5353 if (body
->ext
.case_list
)
5355 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
5357 if (cp
->next
->unreachable
)
5359 gfc_case
*n
= cp
->next
;
5360 cp
->next
= cp
->next
->next
;
5362 gfc_free_case_list (n
);
5369 /* See if there were overlapping cases. If the check returns NULL,
5370 there was overlap. In that case we don't do anything. If head
5371 is non-NULL, we prepend the DEFAULT case. The sorted list can
5372 then used during code generation for SELECT CASE constructs with
5373 a case expression of a CHARACTER type. */
5376 head
= check_case_overlap (head
);
5378 /* Prepend the default_case if it is there. */
5379 if (head
!= NULL
&& default_case
)
5381 default_case
->left
= NULL
;
5382 default_case
->right
= head
;
5383 head
->left
= default_case
;
5387 /* Eliminate dead blocks that may be the result if we've seen
5388 unreachable case labels for a block. */
5389 for (body
= code
; body
&& body
->block
; body
= body
->block
)
5391 if (body
->block
->ext
.case_list
== NULL
)
5393 /* Cut the unreachable block from the code chain. */
5394 gfc_code
*c
= body
->block
;
5395 body
->block
= c
->block
;
5397 /* Kill the dead block, but not the blocks below it. */
5399 gfc_free_statements (c
);
5403 /* More than two cases is legal but insane for logical selects.
5404 Issue a warning for it. */
5405 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
5407 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5412 /* Resolve a transfer statement. This is making sure that:
5413 -- a derived type being transferred has only non-pointer components
5414 -- a derived type being transferred doesn't have private components, unless
5415 it's being transferred from the module where the type was defined
5416 -- we're not trying to transfer a whole assumed size array. */
5419 resolve_transfer (gfc_code
*code
)
5428 if (exp
->expr_type
!= EXPR_VARIABLE
&& exp
->expr_type
!= EXPR_FUNCTION
)
5431 sym
= exp
->symtree
->n
.sym
;
5434 /* Go to actual component transferred. */
5435 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
5436 if (ref
->type
== REF_COMPONENT
)
5437 ts
= &ref
->u
.c
.component
->ts
;
5439 if (ts
->type
== BT_DERIVED
)
5441 /* Check that transferred derived type doesn't contain POINTER
5443 if (ts
->derived
->attr
.pointer_comp
)
5445 gfc_error ("Data transfer element at %L cannot have "
5446 "POINTER components", &code
->loc
);
5450 if (ts
->derived
->attr
.alloc_comp
)
5452 gfc_error ("Data transfer element at %L cannot have "
5453 "ALLOCATABLE components", &code
->loc
);
5457 if (derived_inaccessible (ts
->derived
))
5459 gfc_error ("Data transfer element at %L cannot have "
5460 "PRIVATE components",&code
->loc
);
5465 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
5466 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
5468 gfc_error ("Data transfer element at %L cannot be a full reference to "
5469 "an assumed-size array", &code
->loc
);
5475 /*********** Toplevel code resolution subroutines ***********/
5477 /* Find the set of labels that are reachable from this block. We also
5478 record the last statement in each block so that we don't have to do
5479 a linear search to find the END DO statements of the blocks. */
5482 reachable_labels (gfc_code
*block
)
5489 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
5491 /* Collect labels in this block. */
5492 for (c
= block
; c
; c
= c
->next
)
5495 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
5497 if (!c
->next
&& cs_base
->prev
)
5498 cs_base
->prev
->tail
= c
;
5501 /* Merge with labels from parent block. */
5504 gcc_assert (cs_base
->prev
->reachable_labels
);
5505 bitmap_ior_into (cs_base
->reachable_labels
,
5506 cs_base
->prev
->reachable_labels
);
5510 /* Given a branch to a label and a namespace, if the branch is conforming.
5511 The code node describes where the branch is located. */
5514 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
5521 /* Step one: is this a valid branching target? */
5523 if (label
->defined
== ST_LABEL_UNKNOWN
)
5525 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
5530 if (label
->defined
!= ST_LABEL_TARGET
)
5532 gfc_error ("Statement at %L is not a valid branch target statement "
5533 "for the branch statement at %L", &label
->where
, &code
->loc
);
5537 /* Step two: make sure this branch is not a branch to itself ;-) */
5539 if (code
->here
== label
)
5541 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
5545 /* Step three: See if the label is in the same block as the
5546 branching statement. The hard work has been done by setting up
5547 the bitmap reachable_labels. */
5549 if (!bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
5551 /* The label is not in an enclosing block, so illegal. This was
5552 allowed in Fortran 66, so we allow it as extension. No
5553 further checks are necessary in this case. */
5554 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
5555 "as the GOTO statement at %L", &label
->where
,
5560 /* Step four: Make sure that the branching target is legal if
5561 the statement is an END {SELECT,IF}. */
5563 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5564 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
5567 if (stack
&& stack
->current
->next
->op
== EXEC_NOP
)
5569 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps to "
5570 "END of construct at %L", &code
->loc
,
5571 &stack
->current
->next
->loc
);
5572 return; /* We know this is not an END DO. */
5575 /* Step five: Make sure that we're not jumping to the end of a DO
5576 loop from within the loop. */
5578 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5579 if ((stack
->current
->op
== EXEC_DO
5580 || stack
->current
->op
== EXEC_DO_WHILE
)
5581 && stack
->tail
->here
== label
&& stack
->tail
->op
== EXEC_NOP
)
5583 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps "
5584 "to END of construct at %L", &code
->loc
,
5592 /* Check whether EXPR1 has the same shape as EXPR2. */
5595 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
5597 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5598 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
5599 try result
= FAILURE
;
5602 /* Compare the rank. */
5603 if (expr1
->rank
!= expr2
->rank
)
5606 /* Compare the size of each dimension. */
5607 for (i
=0; i
<expr1
->rank
; i
++)
5609 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
5612 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
5615 if (mpz_cmp (shape
[i
], shape2
[i
]))
5619 /* When either of the two expression is an assumed size array, we
5620 ignore the comparison of dimension sizes. */
5625 for (i
--; i
>= 0; i
--)
5627 mpz_clear (shape
[i
]);
5628 mpz_clear (shape2
[i
]);
5634 /* Check whether a WHERE assignment target or a WHERE mask expression
5635 has the same shape as the outmost WHERE mask expression. */
5638 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
5644 cblock
= code
->block
;
5646 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5647 In case of nested WHERE, only the outmost one is stored. */
5648 if (mask
== NULL
) /* outmost WHERE */
5650 else /* inner WHERE */
5657 /* Check if the mask-expr has a consistent shape with the
5658 outmost WHERE mask-expr. */
5659 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
5660 gfc_error ("WHERE mask at %L has inconsistent shape",
5661 &cblock
->expr
->where
);
5664 /* the assignment statement of a WHERE statement, or the first
5665 statement in where-body-construct of a WHERE construct */
5666 cnext
= cblock
->next
;
5671 /* WHERE assignment statement */
5674 /* Check shape consistent for WHERE assignment target. */
5675 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
5676 gfc_error ("WHERE assignment target at %L has "
5677 "inconsistent shape", &cnext
->expr
->where
);
5681 case EXEC_ASSIGN_CALL
:
5682 resolve_call (cnext
);
5685 /* WHERE or WHERE construct is part of a where-body-construct */
5687 resolve_where (cnext
, e
);
5691 gfc_error ("Unsupported statement inside WHERE at %L",
5694 /* the next statement within the same where-body-construct */
5695 cnext
= cnext
->next
;
5697 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5698 cblock
= cblock
->block
;
5703 /* Resolve assignment in FORALL construct.
5704 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5705 FORALL index variables. */
5708 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
5712 for (n
= 0; n
< nvar
; n
++)
5714 gfc_symbol
*forall_index
;
5716 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
5718 /* Check whether the assignment target is one of the FORALL index
5720 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
5721 && (code
->expr
->symtree
->n
.sym
== forall_index
))
5722 gfc_error ("Assignment to a FORALL index variable at %L",
5723 &code
->expr
->where
);
5726 /* If one of the FORALL index variables doesn't appear in the
5727 assignment target, then there will be a many-to-one
5729 if (find_forall_index (code
->expr
, forall_index
) == FAILURE
)
5730 gfc_error ("The FORALL with index '%s' cause more than one "
5731 "assignment to this object at %L",
5732 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
5738 /* Resolve WHERE statement in FORALL construct. */
5741 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
5742 gfc_expr
**var_expr
)
5747 cblock
= code
->block
;
5750 /* the assignment statement of a WHERE statement, or the first
5751 statement in where-body-construct of a WHERE construct */
5752 cnext
= cblock
->next
;
5757 /* WHERE assignment statement */
5759 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
5762 /* WHERE operator assignment statement */
5763 case EXEC_ASSIGN_CALL
:
5764 resolve_call (cnext
);
5767 /* WHERE or WHERE construct is part of a where-body-construct */
5769 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
5773 gfc_error ("Unsupported statement inside WHERE at %L",
5776 /* the next statement within the same where-body-construct */
5777 cnext
= cnext
->next
;
5779 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5780 cblock
= cblock
->block
;
5785 /* Traverse the FORALL body to check whether the following errors exist:
5786 1. For assignment, check if a many-to-one assignment happens.
5787 2. For WHERE statement, check the WHERE body to see if there is any
5788 many-to-one assignment. */
5791 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
5795 c
= code
->block
->next
;
5801 case EXEC_POINTER_ASSIGN
:
5802 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
5805 case EXEC_ASSIGN_CALL
:
5809 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5810 there is no need to handle it here. */
5814 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
5819 /* The next statement in the FORALL body. */
5825 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5826 gfc_resolve_forall_body to resolve the FORALL body. */
5829 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
5831 static gfc_expr
**var_expr
;
5832 static int total_var
= 0;
5833 static int nvar
= 0;
5834 gfc_forall_iterator
*fa
;
5838 /* Start to resolve a FORALL construct */
5839 if (forall_save
== 0)
5841 /* Count the total number of FORALL index in the nested FORALL
5842 construct in order to allocate the VAR_EXPR with proper size. */
5844 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
5846 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5848 next
= next
->block
->next
;
5851 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5852 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
5855 /* The information about FORALL iterator, including FORALL index start, end
5856 and stride. The FORALL index can not appear in start, end or stride. */
5857 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5859 /* Check if any outer FORALL index name is the same as the current
5861 for (i
= 0; i
< nvar
; i
++)
5863 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
5865 gfc_error ("An outer FORALL construct already has an index "
5866 "with this name %L", &fa
->var
->where
);
5870 /* Record the current FORALL index. */
5871 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
5876 /* Resolve the FORALL body. */
5877 gfc_resolve_forall_body (code
, nvar
, var_expr
);
5879 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5880 gfc_resolve_blocks (code
->block
, ns
);
5882 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5883 for (i
= 0; i
< total_var
; i
++)
5884 gfc_free_expr (var_expr
[i
]);
5886 /* Reset the counters. */
5892 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5895 static void resolve_code (gfc_code
*, gfc_namespace
*);
5898 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
5902 for (; b
; b
= b
->block
)
5904 t
= gfc_resolve_expr (b
->expr
);
5905 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
5911 if (t
== SUCCESS
&& b
->expr
!= NULL
5912 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
5913 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5920 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
== 0))
5921 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5926 resolve_branch (b
->label
, b
);
5938 case EXEC_OMP_ATOMIC
:
5939 case EXEC_OMP_CRITICAL
:
5941 case EXEC_OMP_MASTER
:
5942 case EXEC_OMP_ORDERED
:
5943 case EXEC_OMP_PARALLEL
:
5944 case EXEC_OMP_PARALLEL_DO
:
5945 case EXEC_OMP_PARALLEL_SECTIONS
:
5946 case EXEC_OMP_PARALLEL_WORKSHARE
:
5947 case EXEC_OMP_SECTIONS
:
5948 case EXEC_OMP_SINGLE
:
5949 case EXEC_OMP_WORKSHARE
:
5953 gfc_internal_error ("resolve_block(): Bad block type");
5956 resolve_code (b
->next
, ns
);
5961 /* Does everything to resolve an ordinary assignment. Returns true
5962 if this is an interface asignment. */
5964 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
5975 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
5977 lhs
= code
->ext
.actual
->expr
;
5978 rhs
= code
->ext
.actual
->next
->expr
;
5979 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
5981 gfc_error ("Subroutine '%s' called instead of assignment at "
5982 "%L must be PURE", code
->symtree
->n
.sym
->name
,
5987 /* Make a temporary rhs when there is a default initializer
5988 and rhs is the same symbol as the lhs. */
5989 if (rhs
->expr_type
== EXPR_VARIABLE
5990 && rhs
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
5991 && has_default_initializer (rhs
->symtree
->n
.sym
->ts
.derived
)
5992 && (lhs
->symtree
->n
.sym
== rhs
->symtree
->n
.sym
))
5993 code
->ext
.actual
->next
->expr
= gfc_get_parentheses (rhs
);
6001 if (lhs
->ts
.type
== BT_CHARACTER
6002 && gfc_option
.warn_character_truncation
)
6004 if (lhs
->ts
.cl
!= NULL
6005 && lhs
->ts
.cl
->length
!= NULL
6006 && lhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6007 llen
= mpz_get_si (lhs
->ts
.cl
->length
->value
.integer
);
6009 if (rhs
->expr_type
== EXPR_CONSTANT
)
6010 rlen
= rhs
->value
.character
.length
;
6012 else if (rhs
->ts
.cl
!= NULL
6013 && rhs
->ts
.cl
->length
!= NULL
6014 && rhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6015 rlen
= mpz_get_si (rhs
->ts
.cl
->length
->value
.integer
);
6017 if (rlen
&& llen
&& rlen
> llen
)
6018 gfc_warning_now ("CHARACTER expression will be truncated "
6019 "in assignment (%d/%d) at %L",
6020 llen
, rlen
, &code
->loc
);
6023 /* Ensure that a vector index expression for the lvalue is evaluated
6027 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
6028 if (ref
->type
== REF_ARRAY
)
6030 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6031 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
6033 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
6037 if (gfc_pure (NULL
))
6039 if (gfc_impure_variable (lhs
->symtree
->n
.sym
))
6041 gfc_error ("Cannot assign to variable '%s' in PURE "
6043 lhs
->symtree
->n
.sym
->name
,
6048 if (lhs
->ts
.type
== BT_DERIVED
6049 && lhs
->expr_type
== EXPR_VARIABLE
6050 && lhs
->ts
.derived
->attr
.pointer_comp
6051 && gfc_impure_variable (rhs
->symtree
->n
.sym
))
6053 gfc_error ("The impure variable at %L is assigned to "
6054 "a derived type variable with a POINTER "
6055 "component in a PURE procedure (12.6)",
6061 gfc_check_assign (lhs
, rhs
, 1);
6065 /* Given a block of code, recursively resolve everything pointed to by this
6069 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
6071 int omp_workshare_save
;
6077 frame
.prev
= cs_base
;
6081 reachable_labels (code
);
6083 for (; code
; code
= code
->next
)
6085 frame
.current
= code
;
6086 forall_save
= forall_flag
;
6088 if (code
->op
== EXEC_FORALL
)
6091 gfc_resolve_forall (code
, ns
, forall_save
);
6094 else if (code
->block
)
6096 omp_workshare_save
= -1;
6099 case EXEC_OMP_PARALLEL_WORKSHARE
:
6100 omp_workshare_save
= omp_workshare_flag
;
6101 omp_workshare_flag
= 1;
6102 gfc_resolve_omp_parallel_blocks (code
, ns
);
6104 case EXEC_OMP_PARALLEL
:
6105 case EXEC_OMP_PARALLEL_DO
:
6106 case EXEC_OMP_PARALLEL_SECTIONS
:
6107 omp_workshare_save
= omp_workshare_flag
;
6108 omp_workshare_flag
= 0;
6109 gfc_resolve_omp_parallel_blocks (code
, ns
);
6112 gfc_resolve_omp_do_blocks (code
, ns
);
6114 case EXEC_OMP_WORKSHARE
:
6115 omp_workshare_save
= omp_workshare_flag
;
6116 omp_workshare_flag
= 1;
6119 gfc_resolve_blocks (code
->block
, ns
);
6123 if (omp_workshare_save
!= -1)
6124 omp_workshare_flag
= omp_workshare_save
;
6127 t
= gfc_resolve_expr (code
->expr
);
6128 forall_flag
= forall_save
;
6130 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
6145 /* Keep track of which entry we are up to. */
6146 current_entry_id
= code
->ext
.entry
->id
;
6150 resolve_where (code
, NULL
);
6154 if (code
->expr
!= NULL
)
6156 if (code
->expr
->ts
.type
!= BT_INTEGER
)
6157 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6158 "INTEGER variable", &code
->expr
->where
);
6159 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
6160 gfc_error ("Variable '%s' has not been assigned a target "
6161 "label at %L", code
->expr
->symtree
->n
.sym
->name
,
6162 &code
->expr
->where
);
6165 resolve_branch (code
->label
, code
);
6169 if (code
->expr
!= NULL
6170 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
6171 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6172 "INTEGER return specifier", &code
->expr
->where
);
6175 case EXEC_INIT_ASSIGN
:
6182 if (resolve_ordinary_assign (code
, ns
))
6187 case EXEC_LABEL_ASSIGN
:
6188 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
6189 gfc_error ("Label %d referenced at %L is never defined",
6190 code
->label
->value
, &code
->label
->where
);
6192 && (code
->expr
->expr_type
!= EXPR_VARIABLE
6193 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
6194 || code
->expr
->symtree
->n
.sym
->ts
.kind
6195 != gfc_default_integer_kind
6196 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
6197 gfc_error ("ASSIGN statement at %L requires a scalar "
6198 "default INTEGER variable", &code
->expr
->where
);
6201 case EXEC_POINTER_ASSIGN
:
6205 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
6208 case EXEC_ARITHMETIC_IF
:
6210 && code
->expr
->ts
.type
!= BT_INTEGER
6211 && code
->expr
->ts
.type
!= BT_REAL
)
6212 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6213 "expression", &code
->expr
->where
);
6215 resolve_branch (code
->label
, code
);
6216 resolve_branch (code
->label2
, code
);
6217 resolve_branch (code
->label3
, code
);
6221 if (t
== SUCCESS
&& code
->expr
!= NULL
6222 && (code
->expr
->ts
.type
!= BT_LOGICAL
6223 || code
->expr
->rank
!= 0))
6224 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6225 &code
->expr
->where
);
6230 resolve_call (code
);
6234 /* Select is complicated. Also, a SELECT construct could be
6235 a transformed computed GOTO. */
6236 resolve_select (code
);
6240 if (code
->ext
.iterator
!= NULL
)
6242 gfc_iterator
*iter
= code
->ext
.iterator
;
6243 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
6244 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
6249 if (code
->expr
== NULL
)
6250 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6252 && (code
->expr
->rank
!= 0
6253 || code
->expr
->ts
.type
!= BT_LOGICAL
))
6254 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6255 "a scalar LOGICAL expression", &code
->expr
->where
);
6259 if (t
== SUCCESS
&& code
->expr
!= NULL
6260 && code
->expr
->ts
.type
!= BT_INTEGER
)
6261 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6262 "of type INTEGER", &code
->expr
->where
);
6264 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
6265 resolve_allocate_expr (a
->expr
, code
);
6269 case EXEC_DEALLOCATE
:
6270 if (t
== SUCCESS
&& code
->expr
!= NULL
6271 && code
->expr
->ts
.type
!= BT_INTEGER
)
6273 ("STAT tag in DEALLOCATE statement at %L must be of type "
6274 "INTEGER", &code
->expr
->where
);
6276 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
6277 resolve_deallocate_expr (a
->expr
);
6282 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
6285 resolve_branch (code
->ext
.open
->err
, code
);
6289 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
6292 resolve_branch (code
->ext
.close
->err
, code
);
6295 case EXEC_BACKSPACE
:
6299 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
6302 resolve_branch (code
->ext
.filepos
->err
, code
);
6306 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6309 resolve_branch (code
->ext
.inquire
->err
, code
);
6313 gcc_assert (code
->ext
.inquire
!= NULL
);
6314 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6317 resolve_branch (code
->ext
.inquire
->err
, code
);
6322 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
6325 resolve_branch (code
->ext
.dt
->err
, code
);
6326 resolve_branch (code
->ext
.dt
->end
, code
);
6327 resolve_branch (code
->ext
.dt
->eor
, code
);
6331 resolve_transfer (code
);
6335 resolve_forall_iterators (code
->ext
.forall_iterator
);
6337 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
6338 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6339 "expression", &code
->expr
->where
);
6342 case EXEC_OMP_ATOMIC
:
6343 case EXEC_OMP_BARRIER
:
6344 case EXEC_OMP_CRITICAL
:
6345 case EXEC_OMP_FLUSH
:
6347 case EXEC_OMP_MASTER
:
6348 case EXEC_OMP_ORDERED
:
6349 case EXEC_OMP_SECTIONS
:
6350 case EXEC_OMP_SINGLE
:
6351 case EXEC_OMP_WORKSHARE
:
6352 gfc_resolve_omp_directive (code
, ns
);
6355 case EXEC_OMP_PARALLEL
:
6356 case EXEC_OMP_PARALLEL_DO
:
6357 case EXEC_OMP_PARALLEL_SECTIONS
:
6358 case EXEC_OMP_PARALLEL_WORKSHARE
:
6359 omp_workshare_save
= omp_workshare_flag
;
6360 omp_workshare_flag
= 0;
6361 gfc_resolve_omp_directive (code
, ns
);
6362 omp_workshare_flag
= omp_workshare_save
;
6366 gfc_internal_error ("resolve_code(): Bad statement code");
6370 cs_base
= frame
.prev
;
6374 /* Resolve initial values and make sure they are compatible with
6378 resolve_values (gfc_symbol
*sym
)
6380 if (sym
->value
== NULL
)
6383 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
6386 gfc_check_assign_symbol (sym
, sym
->value
);
6390 /* Verify the binding labels for common blocks that are BIND(C). The label
6391 for a BIND(C) common block must be identical in all scoping units in which
6392 the common block is declared. Further, the binding label can not collide
6393 with any other global entity in the program. */
6396 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
6398 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
6400 gfc_gsymbol
*binding_label_gsym
;
6401 gfc_gsymbol
*comm_name_gsym
;
6403 /* See if a global symbol exists by the common block's name. It may
6404 be NULL if the common block is use-associated. */
6405 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
6406 comm_block_tree
->n
.common
->name
);
6407 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
6408 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6409 "with the global entity '%s' at %L",
6410 comm_block_tree
->n
.common
->binding_label
,
6411 comm_block_tree
->n
.common
->name
,
6412 &(comm_block_tree
->n
.common
->where
),
6413 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6414 else if (comm_name_gsym
!= NULL
6415 && strcmp (comm_name_gsym
->name
,
6416 comm_block_tree
->n
.common
->name
) == 0)
6418 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6420 if (comm_name_gsym
->binding_label
== NULL
)
6421 /* No binding label for common block stored yet; save this one. */
6422 comm_name_gsym
->binding_label
=
6423 comm_block_tree
->n
.common
->binding_label
;
6425 if (strcmp (comm_name_gsym
->binding_label
,
6426 comm_block_tree
->n
.common
->binding_label
) != 0)
6428 /* Common block names match but binding labels do not. */
6429 gfc_error ("Binding label '%s' for common block '%s' at %L "
6430 "does not match the binding label '%s' for common "
6432 comm_block_tree
->n
.common
->binding_label
,
6433 comm_block_tree
->n
.common
->name
,
6434 &(comm_block_tree
->n
.common
->where
),
6435 comm_name_gsym
->binding_label
,
6436 comm_name_gsym
->name
,
6437 &(comm_name_gsym
->where
));
6442 /* There is no binding label (NAME="") so we have nothing further to
6443 check and nothing to add as a global symbol for the label. */
6444 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
6447 binding_label_gsym
=
6448 gfc_find_gsymbol (gfc_gsym_root
,
6449 comm_block_tree
->n
.common
->binding_label
);
6450 if (binding_label_gsym
== NULL
)
6452 /* Need to make a global symbol for the binding label to prevent
6453 it from colliding with another. */
6454 binding_label_gsym
=
6455 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
6456 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
6457 binding_label_gsym
->type
= GSYM_COMMON
;
6461 /* If comm_name_gsym is NULL, the name common block is use
6462 associated and the name could be colliding. */
6463 if (binding_label_gsym
->type
!= GSYM_COMMON
)
6464 gfc_error ("Binding label '%s' for common block '%s' at %L "
6465 "collides with the global entity '%s' at %L",
6466 comm_block_tree
->n
.common
->binding_label
,
6467 comm_block_tree
->n
.common
->name
,
6468 &(comm_block_tree
->n
.common
->where
),
6469 binding_label_gsym
->name
,
6470 &(binding_label_gsym
->where
));
6471 else if (comm_name_gsym
!= NULL
6472 && (strcmp (binding_label_gsym
->name
,
6473 comm_name_gsym
->binding_label
) != 0)
6474 && (strcmp (binding_label_gsym
->sym_name
,
6475 comm_name_gsym
->name
) != 0))
6476 gfc_error ("Binding label '%s' for common block '%s' at %L "
6477 "collides with global entity '%s' at %L",
6478 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
6479 &(comm_block_tree
->n
.common
->where
),
6480 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6488 /* Verify any BIND(C) derived types in the namespace so we can report errors
6489 for them once, rather than for each variable declared of that type. */
6492 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
6494 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
6495 && derived_sym
->attr
.is_bind_c
== 1)
6496 verify_bind_c_derived_type (derived_sym
);
6502 /* Verify that any binding labels used in a given namespace do not collide
6503 with the names or binding labels of any global symbols. */
6506 gfc_verify_binding_labels (gfc_symbol
*sym
)
6510 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
6511 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
6513 gfc_gsymbol
*bind_c_sym
;
6515 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
6516 if (bind_c_sym
!= NULL
6517 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
6519 if (sym
->attr
.if_source
== IFSRC_DECL
6520 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
6521 && bind_c_sym
->type
!= GSYM_FUNCTION
)
6522 && ((sym
->attr
.contained
== 1
6523 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
6524 || (sym
->attr
.use_assoc
== 1
6525 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
6527 /* Make sure global procedures don't collide with anything. */
6528 gfc_error ("Binding label '%s' at %L collides with the global "
6529 "entity '%s' at %L", sym
->binding_label
,
6530 &(sym
->declared_at
), bind_c_sym
->name
,
6531 &(bind_c_sym
->where
));
6534 else if (sym
->attr
.contained
== 0
6535 && (sym
->attr
.if_source
== IFSRC_IFBODY
6536 && sym
->attr
.flavor
== FL_PROCEDURE
)
6537 && (bind_c_sym
->sym_name
!= NULL
6538 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
6540 /* Make sure procedures in interface bodies don't collide. */
6541 gfc_error ("Binding label '%s' in interface body at %L collides "
6542 "with the global entity '%s' at %L",
6544 &(sym
->declared_at
), bind_c_sym
->name
,
6545 &(bind_c_sym
->where
));
6548 else if (sym
->attr
.contained
== 0
6549 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
))
6550 if ((sym
->attr
.use_assoc
6551 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))
6552 || sym
->attr
.use_assoc
== 0)
6554 gfc_error ("Binding label '%s' at %L collides with global "
6555 "entity '%s' at %L", sym
->binding_label
,
6556 &(sym
->declared_at
), bind_c_sym
->name
,
6557 &(bind_c_sym
->where
));
6562 /* Clear the binding label to prevent checking multiple times. */
6563 sym
->binding_label
[0] = '\0';
6565 else if (bind_c_sym
== NULL
)
6567 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
6568 bind_c_sym
->where
= sym
->declared_at
;
6569 bind_c_sym
->sym_name
= sym
->name
;
6571 if (sym
->attr
.use_assoc
== 1)
6572 bind_c_sym
->mod_name
= sym
->module
;
6574 if (sym
->ns
->proc_name
!= NULL
)
6575 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
6577 if (sym
->attr
.contained
== 0)
6579 if (sym
->attr
.subroutine
)
6580 bind_c_sym
->type
= GSYM_SUBROUTINE
;
6581 else if (sym
->attr
.function
)
6582 bind_c_sym
->type
= GSYM_FUNCTION
;
6590 /* Resolve an index expression. */
6593 resolve_index_expr (gfc_expr
*e
)
6595 if (gfc_resolve_expr (e
) == FAILURE
)
6598 if (gfc_simplify_expr (e
, 0) == FAILURE
)
6601 if (gfc_specification_expr (e
) == FAILURE
)
6607 /* Resolve a charlen structure. */
6610 resolve_charlen (gfc_charlen
*cl
)
6619 specification_expr
= 1;
6621 if (resolve_index_expr (cl
->length
) == FAILURE
)
6623 specification_expr
= 0;
6627 /* "If the character length parameter value evaluates to a negative
6628 value, the length of character entities declared is zero." */
6629 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
6631 gfc_warning_now ("CHARACTER variable has zero length at %L",
6632 &cl
->length
->where
);
6633 gfc_replace_expr (cl
->length
, gfc_int_expr (0));
6640 /* Test for non-constant shape arrays. */
6643 is_non_constant_shape_array (gfc_symbol
*sym
)
6649 not_constant
= false;
6650 if (sym
->as
!= NULL
)
6652 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6653 has not been simplified; parameter array references. Do the
6654 simplification now. */
6655 for (i
= 0; i
< sym
->as
->rank
; i
++)
6657 e
= sym
->as
->lower
[i
];
6658 if (e
&& (resolve_index_expr (e
) == FAILURE
6659 || !gfc_is_constant_expr (e
)))
6660 not_constant
= true;
6662 e
= sym
->as
->upper
[i
];
6663 if (e
&& (resolve_index_expr (e
) == FAILURE
6664 || !gfc_is_constant_expr (e
)))
6665 not_constant
= true;
6668 return not_constant
;
6671 /* Given a symbol and an initialization expression, add code to initialize
6672 the symbol to the function entry. */
6674 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
6678 gfc_namespace
*ns
= sym
->ns
;
6680 /* Search for the function namespace if this is a contained
6681 function without an explicit result. */
6682 if (sym
->attr
.function
&& sym
== sym
->result
6683 && sym
->name
!= sym
->ns
->proc_name
->name
)
6686 for (;ns
; ns
= ns
->sibling
)
6687 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
6693 gfc_free_expr (init
);
6697 /* Build an l-value expression for the result. */
6698 lval
= gfc_lval_expr_from_sym (sym
);
6700 /* Add the code at scope entry. */
6701 init_st
= gfc_get_code ();
6702 init_st
->next
= ns
->code
;
6705 /* Assign the default initializer to the l-value. */
6706 init_st
->loc
= sym
->declared_at
;
6707 init_st
->op
= EXEC_INIT_ASSIGN
;
6708 init_st
->expr
= lval
;
6709 init_st
->expr2
= init
;
6712 /* Assign the default initializer to a derived type variable or result. */
6715 apply_default_init (gfc_symbol
*sym
)
6717 gfc_expr
*init
= NULL
;
6719 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
6722 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
6723 init
= gfc_default_initializer (&sym
->ts
);
6728 build_init_assign (sym
, init
);
6731 /* Build an initializer for a local integer, real, complex, logical, or
6732 character variable, based on the command line flags finit-local-zero,
6733 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
6734 null if the symbol should not have a default initialization. */
6736 build_default_init_expr (gfc_symbol
*sym
)
6739 gfc_expr
*init_expr
;
6743 /* These symbols should never have a default initialization. */
6744 if ((sym
->attr
.dimension
&& !gfc_is_compile_time_shape (sym
->as
))
6745 || sym
->attr
.external
6747 || sym
->attr
.pointer
6748 || sym
->attr
.in_equivalence
6749 || sym
->attr
.in_common
6752 || sym
->attr
.cray_pointee
6753 || sym
->attr
.cray_pointer
)
6756 /* Now we'll try to build an initializer expression. */
6757 init_expr
= gfc_get_expr ();
6758 init_expr
->expr_type
= EXPR_CONSTANT
;
6759 init_expr
->ts
.type
= sym
->ts
.type
;
6760 init_expr
->ts
.kind
= sym
->ts
.kind
;
6761 init_expr
->where
= sym
->declared_at
;
6763 /* We will only initialize integers, reals, complex, logicals, and
6764 characters, and only if the corresponding command-line flags
6765 were set. Otherwise, we free init_expr and return null. */
6766 switch (sym
->ts
.type
)
6769 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
6770 mpz_init_set_si (init_expr
->value
.integer
,
6771 gfc_option
.flag_init_integer_value
);
6774 gfc_free_expr (init_expr
);
6780 mpfr_init (init_expr
->value
.real
);
6781 switch (gfc_option
.flag_init_real
)
6783 case GFC_INIT_REAL_NAN
:
6784 mpfr_set_nan (init_expr
->value
.real
);
6787 case GFC_INIT_REAL_INF
:
6788 mpfr_set_inf (init_expr
->value
.real
, 1);
6791 case GFC_INIT_REAL_NEG_INF
:
6792 mpfr_set_inf (init_expr
->value
.real
, -1);
6795 case GFC_INIT_REAL_ZERO
:
6796 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
6800 gfc_free_expr (init_expr
);
6807 mpfr_init (init_expr
->value
.complex.r
);
6808 mpfr_init (init_expr
->value
.complex.i
);
6809 switch (gfc_option
.flag_init_real
)
6811 case GFC_INIT_REAL_NAN
:
6812 mpfr_set_nan (init_expr
->value
.complex.r
);
6813 mpfr_set_nan (init_expr
->value
.complex.i
);
6816 case GFC_INIT_REAL_INF
:
6817 mpfr_set_inf (init_expr
->value
.complex.r
, 1);
6818 mpfr_set_inf (init_expr
->value
.complex.i
, 1);
6821 case GFC_INIT_REAL_NEG_INF
:
6822 mpfr_set_inf (init_expr
->value
.complex.r
, -1);
6823 mpfr_set_inf (init_expr
->value
.complex.i
, -1);
6826 case GFC_INIT_REAL_ZERO
:
6827 mpfr_set_ui (init_expr
->value
.complex.r
, 0.0, GFC_RND_MODE
);
6828 mpfr_set_ui (init_expr
->value
.complex.i
, 0.0, GFC_RND_MODE
);
6832 gfc_free_expr (init_expr
);
6839 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
6840 init_expr
->value
.logical
= 0;
6841 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
6842 init_expr
->value
.logical
= 1;
6845 gfc_free_expr (init_expr
);
6851 /* For characters, the length must be constant in order to
6852 create a default initializer. */
6853 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
6854 && sym
->ts
.cl
->length
6855 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6857 char_len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
6858 init_expr
->value
.character
.length
= char_len
;
6859 init_expr
->value
.character
.string
= gfc_getmem (char_len
+1);
6860 ch
= init_expr
->value
.character
.string
;
6861 for (i
= 0; i
< char_len
; i
++)
6862 *(ch
++) = gfc_option
.flag_init_character_value
;
6866 gfc_free_expr (init_expr
);
6872 gfc_free_expr (init_expr
);
6878 /* Add an initialization expression to a local variable. */
6880 apply_default_init_local (gfc_symbol
*sym
)
6882 gfc_expr
*init
= NULL
;
6884 /* The symbol should be a variable or a function return value. */
6885 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
6886 || (sym
->attr
.function
&& sym
->result
!= sym
))
6889 /* Try to build the initializer expression. If we can't initialize
6890 this symbol, then init will be NULL. */
6891 init
= build_default_init_expr (sym
);
6895 /* For saved variables, we don't want to add an initializer at
6896 function entry, so we just add a static initializer. */
6897 if (sym
->attr
.save
|| sym
->ns
->save_all
)
6899 /* Don't clobber an existing initializer! */
6900 gcc_assert (sym
->value
== NULL
);
6905 build_init_assign (sym
, init
);
6908 /* Resolution of common features of flavors variable and procedure. */
6911 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
6913 /* Constraints on deferred shape variable. */
6914 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
6916 if (sym
->attr
.allocatable
)
6918 if (sym
->attr
.dimension
)
6919 gfc_error ("Allocatable array '%s' at %L must have "
6920 "a deferred shape", sym
->name
, &sym
->declared_at
);
6922 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6923 sym
->name
, &sym
->declared_at
);
6927 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
6929 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6930 sym
->name
, &sym
->declared_at
);
6937 if (!mp_flag
&& !sym
->attr
.allocatable
6938 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
6940 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6941 sym
->name
, &sym
->declared_at
);
6949 /* Additional checks for symbols with flavor variable and derived
6950 type. To be called from resolve_fl_variable. */
6953 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
6955 gcc_assert (sym
->ts
.type
== BT_DERIVED
);
6957 /* Check to see if a derived type is blocked from being host
6958 associated by the presence of another class I symbol in the same
6959 namespace. 14.6.1.3 of the standard and the discussion on
6960 comp.lang.fortran. */
6961 if (sym
->ns
!= sym
->ts
.derived
->ns
6962 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
6965 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
6966 if (s
&& (s
->attr
.flavor
!= FL_DERIVED
6967 || !gfc_compare_derived_types (s
, sym
->ts
.derived
)))
6969 gfc_error ("The type '%s' cannot be host associated at %L "
6970 "because it is blocked by an incompatible object "
6971 "of the same name declared at %L",
6972 sym
->ts
.derived
->name
, &sym
->declared_at
,
6978 /* 4th constraint in section 11.3: "If an object of a type for which
6979 component-initialization is specified (R429) appears in the
6980 specification-part of a module and does not have the ALLOCATABLE
6981 or POINTER attribute, the object shall have the SAVE attribute."
6983 The check for initializers is performed with
6984 has_default_initializer because gfc_default_initializer generates
6985 a hidden default for allocatable components. */
6986 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
6987 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
6988 && !sym
->ns
->save_all
&& !sym
->attr
.save
6989 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
6990 && has_default_initializer (sym
->ts
.derived
))
6992 gfc_error("Object '%s' at %L must have the SAVE attribute for "
6993 "default initialization of a component",
6994 sym
->name
, &sym
->declared_at
);
6998 /* Assign default initializer. */
6999 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
7000 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
7002 sym
->value
= gfc_default_initializer (&sym
->ts
);
7009 /* Resolve symbols with flavor variable. */
7012 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
7014 int no_init_flag
, automatic_flag
;
7016 const char *auto_save_msg
;
7018 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
7021 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
7024 /* Set this flag to check that variables are parameters of all entries.
7025 This check is effected by the call to gfc_resolve_expr through
7026 is_non_constant_shape_array. */
7027 specification_expr
= 1;
7029 if (sym
->ns
->proc_name
7030 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7031 || sym
->ns
->proc_name
->attr
.is_main_program
)
7032 && !sym
->attr
.use_assoc
7033 && !sym
->attr
.allocatable
7034 && !sym
->attr
.pointer
7035 && is_non_constant_shape_array (sym
))
7037 /* The shape of a main program or module array needs to be
7039 gfc_error ("The module or main program array '%s' at %L must "
7040 "have constant shape", sym
->name
, &sym
->declared_at
);
7041 specification_expr
= 0;
7045 if (sym
->ts
.type
== BT_CHARACTER
)
7047 /* Make sure that character string variables with assumed length are
7049 e
= sym
->ts
.cl
->length
;
7050 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
7052 gfc_error ("Entity with assumed character length at %L must be a "
7053 "dummy argument or a PARAMETER", &sym
->declared_at
);
7057 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
7059 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7063 if (!gfc_is_constant_expr (e
)
7064 && !(e
->expr_type
== EXPR_VARIABLE
7065 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
7066 && sym
->ns
->proc_name
7067 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7068 || sym
->ns
->proc_name
->attr
.is_main_program
)
7069 && !sym
->attr
.use_assoc
)
7071 gfc_error ("'%s' at %L must have constant character length "
7072 "in this context", sym
->name
, &sym
->declared_at
);
7077 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
7078 apply_default_init_local (sym
); /* Try to apply a default initialization. */
7080 /* Determine if the symbol may not have an initializer. */
7081 no_init_flag
= automatic_flag
= 0;
7082 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
7083 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
7085 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
7086 && is_non_constant_shape_array (sym
))
7088 no_init_flag
= automatic_flag
= 1;
7090 /* Also, they must not have the SAVE attribute.
7091 SAVE_IMPLICIT is checked below. */
7092 if (sym
->attr
.save
== SAVE_EXPLICIT
)
7094 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7099 /* Reject illegal initializers. */
7100 if (!sym
->mark
&& sym
->value
)
7102 if (sym
->attr
.allocatable
)
7103 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7104 sym
->name
, &sym
->declared_at
);
7105 else if (sym
->attr
.external
)
7106 gfc_error ("External '%s' at %L cannot have an initializer",
7107 sym
->name
, &sym
->declared_at
);
7108 else if (sym
->attr
.dummy
7109 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
7110 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7111 sym
->name
, &sym
->declared_at
);
7112 else if (sym
->attr
.intrinsic
)
7113 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7114 sym
->name
, &sym
->declared_at
);
7115 else if (sym
->attr
.result
)
7116 gfc_error ("Function result '%s' at %L cannot have an initializer",
7117 sym
->name
, &sym
->declared_at
);
7118 else if (automatic_flag
)
7119 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7120 sym
->name
, &sym
->declared_at
);
7127 if (sym
->ts
.type
== BT_DERIVED
)
7128 return resolve_fl_variable_derived (sym
, no_init_flag
);
7134 /* Resolve a procedure. */
7137 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
7139 gfc_formal_arglist
*arg
;
7141 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
7142 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7143 "interfaces", sym
->name
, &sym
->declared_at
);
7145 if (sym
->attr
.function
7146 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
7149 if (sym
->ts
.type
== BT_CHARACTER
)
7151 gfc_charlen
*cl
= sym
->ts
.cl
;
7153 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
7154 && resolve_charlen (cl
) == FAILURE
)
7157 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
7159 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7161 gfc_error ("Character-valued statement function '%s' at %L must "
7162 "have constant length", sym
->name
, &sym
->declared_at
);
7166 if (sym
->attr
.external
&& sym
->formal
== NULL
7167 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
7169 gfc_error ("Automatic character length function '%s' at %L must "
7170 "have an explicit interface", sym
->name
,
7177 /* Ensure that derived type for are not of a private type. Internal
7178 module procedures are excluded by 2.2.3.3 - ie. they are not
7179 externally accessible and can access all the objects accessible in
7181 if (!(sym
->ns
->parent
7182 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
7183 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
7185 gfc_interface
*iface
;
7187 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
7190 && arg
->sym
->ts
.type
== BT_DERIVED
7191 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7192 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7193 arg
->sym
->ts
.derived
->ns
->default_access
)
7194 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
7195 "PRIVATE type and cannot be a dummy argument"
7196 " of '%s', which is PUBLIC at %L",
7197 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
7200 /* Stop this message from recurring. */
7201 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7206 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7207 PRIVATE to the containing module. */
7208 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7210 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7213 && arg
->sym
->ts
.type
== BT_DERIVED
7214 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7215 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7216 arg
->sym
->ts
.derived
->ns
->default_access
)
7217 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7218 "'%s' in PUBLIC interface '%s' at %L "
7219 "takes dummy arguments of '%s' which is "
7220 "PRIVATE", iface
->sym
->name
, sym
->name
,
7221 &iface
->sym
->declared_at
,
7222 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7224 /* Stop this message from recurring. */
7225 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7231 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7232 PRIVATE to the containing module. */
7233 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7235 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7238 && arg
->sym
->ts
.type
== BT_DERIVED
7239 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7240 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7241 arg
->sym
->ts
.derived
->ns
->default_access
)
7242 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7243 "'%s' in PUBLIC interface '%s' at %L "
7244 "takes dummy arguments of '%s' which is "
7245 "PRIVATE", iface
->sym
->name
, sym
->name
,
7246 &iface
->sym
->declared_at
,
7247 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7249 /* Stop this message from recurring. */
7250 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7257 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
)
7259 gfc_error ("Function '%s' at %L cannot have an initializer",
7260 sym
->name
, &sym
->declared_at
);
7264 /* An external symbol may not have an initializer because it is taken to be
7266 if (sym
->attr
.external
&& sym
->value
)
7268 gfc_error ("External object '%s' at %L may not have an initializer",
7269 sym
->name
, &sym
->declared_at
);
7273 /* An elemental function is required to return a scalar 12.7.1 */
7274 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
7276 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7277 "result", sym
->name
, &sym
->declared_at
);
7278 /* Reset so that the error only occurs once. */
7279 sym
->attr
.elemental
= 0;
7283 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7284 char-len-param shall not be array-valued, pointer-valued, recursive
7285 or pure. ....snip... A character value of * may only be used in the
7286 following ways: (i) Dummy arg of procedure - dummy associates with
7287 actual length; (ii) To declare a named constant; or (iii) External
7288 function - but length must be declared in calling scoping unit. */
7289 if (sym
->attr
.function
7290 && sym
->ts
.type
== BT_CHARACTER
7291 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
7293 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
7294 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
7296 if (sym
->as
&& sym
->as
->rank
)
7297 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7298 "array-valued", sym
->name
, &sym
->declared_at
);
7300 if (sym
->attr
.pointer
)
7301 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7302 "pointer-valued", sym
->name
, &sym
->declared_at
);
7305 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7306 "pure", sym
->name
, &sym
->declared_at
);
7308 if (sym
->attr
.recursive
)
7309 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7310 "recursive", sym
->name
, &sym
->declared_at
);
7315 /* Appendix B.2 of the standard. Contained functions give an
7316 error anyway. Fixed-form is likely to be F77/legacy. */
7317 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
7318 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
7319 "'%s' at %L is obsolescent in fortran 95",
7320 sym
->name
, &sym
->declared_at
);
7323 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
7325 gfc_formal_arglist
*curr_arg
;
7326 int has_non_interop_arg
= 0;
7328 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
7329 sym
->common_block
) == FAILURE
)
7331 /* Clear these to prevent looking at them again if there was an
7333 sym
->attr
.is_bind_c
= 0;
7334 sym
->attr
.is_c_interop
= 0;
7335 sym
->ts
.is_c_interop
= 0;
7339 /* So far, no errors have been found. */
7340 sym
->attr
.is_c_interop
= 1;
7341 sym
->ts
.is_c_interop
= 1;
7344 curr_arg
= sym
->formal
;
7345 while (curr_arg
!= NULL
)
7347 /* Skip implicitly typed dummy args here. */
7348 if (curr_arg
->sym
->attr
.implicit_type
== 0)
7349 if (verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
7350 /* If something is found to fail, record the fact so we
7351 can mark the symbol for the procedure as not being
7352 BIND(C) to try and prevent multiple errors being
7354 has_non_interop_arg
= 1;
7356 curr_arg
= curr_arg
->next
;
7359 /* See if any of the arguments were not interoperable and if so, clear
7360 the procedure symbol to prevent duplicate error messages. */
7361 if (has_non_interop_arg
!= 0)
7363 sym
->attr
.is_c_interop
= 0;
7364 sym
->ts
.is_c_interop
= 0;
7365 sym
->attr
.is_bind_c
= 0;
7373 /* Resolve the components of a derived type. */
7376 resolve_fl_derived (gfc_symbol
*sym
)
7379 gfc_dt_list
* dt_list
;
7382 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
7384 if (c
->ts
.type
== BT_CHARACTER
)
7386 if (c
->ts
.cl
->length
== NULL
7387 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
7388 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
7390 gfc_error ("Character length of component '%s' needs to "
7391 "be a constant specification expression at %L",
7393 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
7398 if (c
->ts
.type
== BT_DERIVED
7399 && sym
->component_access
!= ACCESS_PRIVATE
7400 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
7401 && !c
->ts
.derived
->attr
.use_assoc
7402 && !gfc_check_access (c
->ts
.derived
->attr
.access
,
7403 c
->ts
.derived
->ns
->default_access
))
7405 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
7406 "a component of '%s', which is PUBLIC at %L",
7407 c
->name
, sym
->name
, &sym
->declared_at
);
7411 if (sym
->attr
.sequence
)
7413 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
7415 gfc_error ("Component %s of SEQUENCE type declared at %L does "
7416 "not have the SEQUENCE attribute",
7417 c
->ts
.derived
->name
, &sym
->declared_at
);
7422 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
7423 && c
->ts
.derived
->components
== NULL
)
7425 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
7426 "that has not been declared", c
->name
, sym
->name
,
7431 if (c
->pointer
|| c
->allocatable
|| c
->as
== NULL
)
7434 for (i
= 0; i
< c
->as
->rank
; i
++)
7436 if (c
->as
->lower
[i
] == NULL
7437 || !gfc_is_constant_expr (c
->as
->lower
[i
])
7438 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
7439 || c
->as
->upper
[i
] == NULL
7440 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
7441 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
7443 gfc_error ("Component '%s' of '%s' at %L must have "
7444 "constant array bounds",
7445 c
->name
, sym
->name
, &c
->loc
);
7451 /* Add derived type to the derived type list. */
7452 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
7453 if (sym
== dt_list
->derived
)
7456 if (dt_list
== NULL
)
7458 dt_list
= gfc_get_dt_list ();
7459 dt_list
->next
= gfc_derived_types
;
7460 dt_list
->derived
= sym
;
7461 gfc_derived_types
= dt_list
;
7469 resolve_fl_namelist (gfc_symbol
*sym
)
7474 /* Reject PRIVATE objects in a PUBLIC namelist. */
7475 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
7477 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7479 if (!nl
->sym
->attr
.use_assoc
7480 && !(sym
->ns
->parent
== nl
->sym
->ns
)
7481 && !(sym
->ns
->parent
7482 && sym
->ns
->parent
->parent
== nl
->sym
->ns
)
7483 && !gfc_check_access(nl
->sym
->attr
.access
,
7484 nl
->sym
->ns
->default_access
))
7486 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7487 "cannot be member of PUBLIC namelist '%s' at %L",
7488 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7492 /* Types with private components that came here by USE-association. */
7493 if (nl
->sym
->ts
.type
== BT_DERIVED
7494 && derived_inaccessible (nl
->sym
->ts
.derived
))
7496 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
7497 "components and cannot be member of namelist '%s' at %L",
7498 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7502 /* Types with private components that are defined in the same module. */
7503 if (nl
->sym
->ts
.type
== BT_DERIVED
7504 && !(sym
->ns
->parent
== nl
->sym
->ts
.derived
->ns
)
7505 && !gfc_check_access (nl
->sym
->ts
.derived
->attr
.private_comp
7506 ? ACCESS_PRIVATE
: ACCESS_UNKNOWN
,
7507 nl
->sym
->ns
->default_access
))
7509 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7510 "cannot be a member of PUBLIC namelist '%s' at %L",
7511 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7517 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7519 /* Reject namelist arrays of assumed shape. */
7520 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
7521 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
7522 "must not have assumed shape in namelist "
7523 "'%s' at %L", nl
->sym
->name
, sym
->name
,
7524 &sym
->declared_at
) == FAILURE
)
7527 /* Reject namelist arrays that are not constant shape. */
7528 if (is_non_constant_shape_array (nl
->sym
))
7530 gfc_error ("NAMELIST array object '%s' must have constant "
7531 "shape in namelist '%s' at %L", nl
->sym
->name
,
7532 sym
->name
, &sym
->declared_at
);
7536 /* Namelist objects cannot have allocatable or pointer components. */
7537 if (nl
->sym
->ts
.type
!= BT_DERIVED
)
7540 if (nl
->sym
->ts
.derived
->attr
.alloc_comp
)
7542 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7543 "have ALLOCATABLE components",
7544 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7548 if (nl
->sym
->ts
.derived
->attr
.pointer_comp
)
7550 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7551 "have POINTER components",
7552 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7558 /* 14.1.2 A module or internal procedure represent local entities
7559 of the same type as a namelist member and so are not allowed. */
7560 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7562 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
7565 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
7566 if ((nl
->sym
== sym
->ns
->proc_name
)
7568 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
7572 if (nl
->sym
&& nl
->sym
->name
)
7573 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
7574 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
7576 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7577 "attribute in '%s' at %L", nlsym
->name
,
7588 resolve_fl_parameter (gfc_symbol
*sym
)
7590 /* A parameter array's shape needs to be constant. */
7592 && (sym
->as
->type
== AS_DEFERRED
7593 || is_non_constant_shape_array (sym
)))
7595 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7596 "or of deferred shape", sym
->name
, &sym
->declared_at
);
7600 /* Make sure a parameter that has been implicitly typed still
7601 matches the implicit type, since PARAMETER statements can precede
7602 IMPLICIT statements. */
7603 if (sym
->attr
.implicit_type
7604 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
7606 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7607 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
7611 /* Make sure the types of derived parameters are consistent. This
7612 type checking is deferred until resolution because the type may
7613 refer to a derived type from the host. */
7614 if (sym
->ts
.type
== BT_DERIVED
7615 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
7617 gfc_error ("Incompatible derived type in PARAMETER at %L",
7618 &sym
->value
->where
);
7625 /* Do anything necessary to resolve a symbol. Right now, we just
7626 assume that an otherwise unknown symbol is a variable. This sort
7627 of thing commonly happens for symbols in module. */
7630 resolve_symbol (gfc_symbol
*sym
)
7632 int check_constant
, mp_flag
;
7633 gfc_symtree
*symtree
;
7634 gfc_symtree
*this_symtree
;
7638 if (sym
->attr
.flavor
== FL_UNKNOWN
)
7641 /* If we find that a flavorless symbol is an interface in one of the
7642 parent namespaces, find its symtree in this namespace, free the
7643 symbol and set the symtree to point to the interface symbol. */
7644 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
7646 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
7647 if (symtree
&& symtree
->n
.sym
->generic
)
7649 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
7653 gfc_free_symbol (sym
);
7654 symtree
->n
.sym
->refs
++;
7655 this_symtree
->n
.sym
= symtree
->n
.sym
;
7660 /* Otherwise give it a flavor according to such attributes as
7662 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
7663 sym
->attr
.flavor
= FL_VARIABLE
;
7666 sym
->attr
.flavor
= FL_PROCEDURE
;
7667 if (sym
->attr
.dimension
)
7668 sym
->attr
.function
= 1;
7672 if (sym
->attr
.procedure
&& sym
->interface
7673 && sym
->attr
.if_source
!= IFSRC_DECL
)
7675 /* Get the attributes from the interface (now resolved). */
7676 if (sym
->interface
->attr
.if_source
|| sym
->interface
->attr
.intrinsic
)
7678 sym
->ts
= sym
->interface
->ts
;
7679 sym
->attr
.function
= sym
->interface
->attr
.function
;
7680 sym
->attr
.subroutine
= sym
->interface
->attr
.subroutine
;
7681 copy_formal_args (sym
, sym
->interface
);
7683 else if (sym
->interface
->name
[0] != '\0')
7685 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
7686 sym
->interface
->name
, sym
->name
, &sym
->declared_at
);
7691 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
7694 /* Symbols that are module procedures with results (functions) have
7695 the types and array specification copied for type checking in
7696 procedures that call them, as well as for saving to a module
7697 file. These symbols can't stand the scrutiny that their results
7699 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
7702 /* Make sure that the intrinsic is consistent with its internal
7703 representation. This needs to be done before assigning a default
7704 type to avoid spurious warnings. */
7705 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
)
7707 if (gfc_intrinsic_name (sym
->name
, 0))
7709 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
)
7710 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7711 sym
->name
, &sym
->declared_at
);
7713 else if (gfc_intrinsic_name (sym
->name
, 1))
7715 if (sym
->ts
.type
!= BT_UNKNOWN
)
7717 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7718 sym
->name
, &sym
->declared_at
);
7724 gfc_error ("Intrinsic '%s' at %L does not exist", sym
->name
, &sym
->declared_at
);
7729 /* Assign default type to symbols that need one and don't have one. */
7730 if (sym
->ts
.type
== BT_UNKNOWN
)
7732 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
7733 gfc_set_default_type (sym
, 1, NULL
);
7735 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
7737 /* The specific case of an external procedure should emit an error
7738 in the case that there is no implicit type. */
7740 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
7743 /* Result may be in another namespace. */
7744 resolve_symbol (sym
->result
);
7746 sym
->ts
= sym
->result
->ts
;
7747 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
7748 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
7749 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
7750 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
7755 /* Assumed size arrays and assumed shape arrays must be dummy
7759 && (sym
->as
->type
== AS_ASSUMED_SIZE
7760 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
7761 && sym
->attr
.dummy
== 0)
7763 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
7764 gfc_error ("Assumed size array at %L must be a dummy argument",
7767 gfc_error ("Assumed shape array at %L must be a dummy argument",
7772 /* Make sure symbols with known intent or optional are really dummy
7773 variable. Because of ENTRY statement, this has to be deferred
7774 until resolution time. */
7776 if (!sym
->attr
.dummy
7777 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
7779 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
7783 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
7785 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7786 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
7790 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
7792 gfc_charlen
*cl
= sym
->ts
.cl
;
7793 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
7795 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7796 "attribute must have constant length",
7797 sym
->name
, &sym
->declared_at
);
7801 if (sym
->ts
.is_c_interop
7802 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
7804 gfc_error ("C interoperable character dummy variable '%s' at %L "
7805 "with VALUE attribute must have length one",
7806 sym
->name
, &sym
->declared_at
);
7811 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7812 do this for something that was implicitly typed because that is handled
7813 in gfc_set_default_type. Handle dummy arguments and procedure
7814 definitions separately. Also, anything that is use associated is not
7815 handled here but instead is handled in the module it is declared in.
7816 Finally, derived type definitions are allowed to be BIND(C) since that
7817 only implies that they're interoperable, and they are checked fully for
7818 interoperability when a variable is declared of that type. */
7819 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
7820 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
7821 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
7825 /* First, make sure the variable is declared at the
7826 module-level scope (J3/04-007, Section 15.3). */
7827 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
7828 sym
->attr
.in_common
== 0)
7830 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7831 "is neither a COMMON block nor declared at the "
7832 "module level scope", sym
->name
, &(sym
->declared_at
));
7835 else if (sym
->common_head
!= NULL
)
7837 t
= verify_com_block_vars_c_interop (sym
->common_head
);
7841 /* If type() declaration, we need to verify that the components
7842 of the given type are all C interoperable, etc. */
7843 if (sym
->ts
.type
== BT_DERIVED
&&
7844 sym
->ts
.derived
->attr
.is_c_interop
!= 1)
7846 /* Make sure the user marked the derived type as BIND(C). If
7847 not, call the verify routine. This could print an error
7848 for the derived type more than once if multiple variables
7849 of that type are declared. */
7850 if (sym
->ts
.derived
->attr
.is_bind_c
!= 1)
7851 verify_bind_c_derived_type (sym
->ts
.derived
);
7855 /* Verify the variable itself as C interoperable if it
7856 is BIND(C). It is not possible for this to succeed if
7857 the verify_bind_c_derived_type failed, so don't have to handle
7858 any error returned by verify_bind_c_derived_type. */
7859 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
7865 /* clear the is_bind_c flag to prevent reporting errors more than
7866 once if something failed. */
7867 sym
->attr
.is_bind_c
= 0;
7872 /* If a derived type symbol has reached this point, without its
7873 type being declared, we have an error. Notice that most
7874 conditions that produce undefined derived types have already
7875 been dealt with. However, the likes of:
7876 implicit type(t) (t) ..... call foo (t) will get us here if
7877 the type is not declared in the scope of the implicit
7878 statement. Change the type to BT_UNKNOWN, both because it is so
7879 and to prevent an ICE. */
7880 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
->components
== NULL
7881 && !sym
->ts
.derived
->attr
.zero_comp
)
7883 gfc_error ("The derived type '%s' at %L is of type '%s', "
7884 "which has not been defined", sym
->name
,
7885 &sym
->declared_at
, sym
->ts
.derived
->name
);
7886 sym
->ts
.type
= BT_UNKNOWN
;
7890 /* Unless the derived-type declaration is use associated, Fortran 95
7891 does not allow public entries of private derived types.
7892 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
7894 if (sym
->ts
.type
== BT_DERIVED
7895 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
7896 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
7897 sym
->ts
.derived
->ns
->default_access
)
7898 && !sym
->ts
.derived
->attr
.use_assoc
7899 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
7900 "of PRIVATE derived type '%s'",
7901 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
7902 : "variable", sym
->name
, &sym
->declared_at
,
7903 sym
->ts
.derived
->name
) == FAILURE
)
7906 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7907 default initialization is defined (5.1.2.4.4). */
7908 if (sym
->ts
.type
== BT_DERIVED
7910 && sym
->attr
.intent
== INTENT_OUT
7912 && sym
->as
->type
== AS_ASSUMED_SIZE
)
7914 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
7918 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7919 "ASSUMED SIZE and so cannot have a default initializer",
7920 sym
->name
, &sym
->declared_at
);
7926 switch (sym
->attr
.flavor
)
7929 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
7934 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
7939 if (resolve_fl_namelist (sym
) == FAILURE
)
7944 if (resolve_fl_parameter (sym
) == FAILURE
)
7952 /* Resolve array specifier. Check as well some constraints
7953 on COMMON blocks. */
7955 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
7957 /* Set the formal_arg_flag so that check_conflict will not throw
7958 an error for host associated variables in the specification
7959 expression for an array_valued function. */
7960 if (sym
->attr
.function
&& sym
->as
)
7961 formal_arg_flag
= 1;
7963 gfc_resolve_array_spec (sym
->as
, check_constant
);
7965 formal_arg_flag
= 0;
7967 /* Resolve formal namespaces. */
7968 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
)
7969 gfc_resolve (sym
->formal_ns
);
7971 /* Check threadprivate restrictions. */
7972 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
7973 && (!sym
->attr
.in_common
7974 && sym
->module
== NULL
7975 && (sym
->ns
->proc_name
== NULL
7976 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
7977 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
7979 /* If we have come this far we can apply default-initializers, as
7980 described in 14.7.5, to those variables that have not already
7981 been assigned one. */
7982 if (sym
->ts
.type
== BT_DERIVED
7983 && sym
->attr
.referenced
7984 && sym
->ns
== gfc_current_ns
7986 && !sym
->attr
.allocatable
7987 && !sym
->attr
.alloc_comp
)
7989 symbol_attribute
*a
= &sym
->attr
;
7991 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
7992 && !a
->in_common
&& !a
->use_assoc
7993 && !(a
->function
&& sym
!= sym
->result
))
7994 || (a
->dummy
&& a
->intent
== INTENT_OUT
))
7995 apply_default_init (sym
);
8000 /************* Resolve DATA statements *************/
8004 gfc_data_value
*vnode
;
8010 /* Advance the values structure to point to the next value in the data list. */
8013 next_data_value (void)
8016 while (mpz_cmp_ui (values
.left
, 0) == 0)
8018 if (values
.vnode
->next
== NULL
)
8021 values
.vnode
= values
.vnode
->next
;
8022 mpz_set (values
.left
, values
.vnode
->repeat
);
8030 check_data_variable (gfc_data_variable
*var
, locus
*where
)
8036 ar_type mark
= AR_UNKNOWN
;
8038 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
8042 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
8046 mpz_init_set_si (offset
, 0);
8049 if (e
->expr_type
!= EXPR_VARIABLE
)
8050 gfc_internal_error ("check_data_variable(): Bad expression");
8052 if (e
->symtree
->n
.sym
->ns
->is_block_data
8053 && !e
->symtree
->n
.sym
->attr
.in_common
)
8055 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
8056 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
8061 mpz_init_set_ui (size
, 1);
8068 /* Find the array section reference. */
8069 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
8071 if (ref
->type
!= REF_ARRAY
)
8073 if (ref
->u
.ar
.type
== AR_ELEMENT
)
8079 /* Set marks according to the reference pattern. */
8080 switch (ref
->u
.ar
.type
)
8088 /* Get the start position of array section. */
8089 gfc_get_section_index (ar
, section_index
, &offset
);
8097 if (gfc_array_size (e
, &size
) == FAILURE
)
8099 gfc_error ("Nonconstant array section at %L in DATA statement",
8108 while (mpz_cmp_ui (size
, 0) > 0)
8110 if (next_data_value () == FAILURE
)
8112 gfc_error ("DATA statement at %L has more variables than values",
8118 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
8122 /* If we have more than one element left in the repeat count,
8123 and we have more than one element left in the target variable,
8124 then create a range assignment. */
8125 /* FIXME: Only done for full arrays for now, since array sections
8127 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
8128 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
8132 if (mpz_cmp (size
, values
.left
) >= 0)
8134 mpz_init_set (range
, values
.left
);
8135 mpz_sub (size
, size
, values
.left
);
8136 mpz_set_ui (values
.left
, 0);
8140 mpz_init_set (range
, size
);
8141 mpz_sub (values
.left
, values
.left
, size
);
8142 mpz_set_ui (size
, 0);
8145 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
8148 mpz_add (offset
, offset
, range
);
8152 /* Assign initial value to symbol. */
8155 mpz_sub_ui (values
.left
, values
.left
, 1);
8156 mpz_sub_ui (size
, size
, 1);
8158 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
8162 if (mark
== AR_FULL
)
8163 mpz_add_ui (offset
, offset
, 1);
8165 /* Modify the array section indexes and recalculate the offset
8166 for next element. */
8167 else if (mark
== AR_SECTION
)
8168 gfc_advance_section (section_index
, ar
, &offset
);
8172 if (mark
== AR_SECTION
)
8174 for (i
= 0; i
< ar
->dimen
; i
++)
8175 mpz_clear (section_index
[i
]);
8185 static try traverse_data_var (gfc_data_variable
*, locus
*);
8187 /* Iterate over a list of elements in a DATA statement. */
8190 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
8193 iterator_stack frame
;
8194 gfc_expr
*e
, *start
, *end
, *step
;
8195 try retval
= SUCCESS
;
8197 mpz_init (frame
.value
);
8199 start
= gfc_copy_expr (var
->iter
.start
);
8200 end
= gfc_copy_expr (var
->iter
.end
);
8201 step
= gfc_copy_expr (var
->iter
.step
);
8203 if (gfc_simplify_expr (start
, 1) == FAILURE
8204 || start
->expr_type
!= EXPR_CONSTANT
)
8206 gfc_error ("iterator start at %L does not simplify", &start
->where
);
8210 if (gfc_simplify_expr (end
, 1) == FAILURE
8211 || end
->expr_type
!= EXPR_CONSTANT
)
8213 gfc_error ("iterator end at %L does not simplify", &end
->where
);
8217 if (gfc_simplify_expr (step
, 1) == FAILURE
8218 || step
->expr_type
!= EXPR_CONSTANT
)
8220 gfc_error ("iterator step at %L does not simplify", &step
->where
);
8225 mpz_init_set (trip
, end
->value
.integer
);
8226 mpz_sub (trip
, trip
, start
->value
.integer
);
8227 mpz_add (trip
, trip
, step
->value
.integer
);
8229 mpz_div (trip
, trip
, step
->value
.integer
);
8231 mpz_set (frame
.value
, start
->value
.integer
);
8233 frame
.prev
= iter_stack
;
8234 frame
.variable
= var
->iter
.var
->symtree
;
8235 iter_stack
= &frame
;
8237 while (mpz_cmp_ui (trip
, 0) > 0)
8239 if (traverse_data_var (var
->list
, where
) == FAILURE
)
8246 e
= gfc_copy_expr (var
->expr
);
8247 if (gfc_simplify_expr (e
, 1) == FAILURE
)
8255 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
8257 mpz_sub_ui (trip
, trip
, 1);
8262 mpz_clear (frame
.value
);
8264 gfc_free_expr (start
);
8265 gfc_free_expr (end
);
8266 gfc_free_expr (step
);
8268 iter_stack
= frame
.prev
;
8273 /* Type resolve variables in the variable list of a DATA statement. */
8276 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
8280 for (; var
; var
= var
->next
)
8282 if (var
->expr
== NULL
)
8283 t
= traverse_data_list (var
, where
);
8285 t
= check_data_variable (var
, where
);
8295 /* Resolve the expressions and iterators associated with a data statement.
8296 This is separate from the assignment checking because data lists should
8297 only be resolved once. */
8300 resolve_data_variables (gfc_data_variable
*d
)
8302 for (; d
; d
= d
->next
)
8304 if (d
->list
== NULL
)
8306 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
8311 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
8314 if (resolve_data_variables (d
->list
) == FAILURE
)
8323 /* Resolve a single DATA statement. We implement this by storing a pointer to
8324 the value list into static variables, and then recursively traversing the
8325 variables list, expanding iterators and such. */
8328 resolve_data (gfc_data
*d
)
8331 if (resolve_data_variables (d
->var
) == FAILURE
)
8334 values
.vnode
= d
->value
;
8335 if (d
->value
== NULL
)
8336 mpz_set_ui (values
.left
, 0);
8338 mpz_set (values
.left
, d
->value
->repeat
);
8340 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
8343 /* At this point, we better not have any values left. */
8345 if (next_data_value () == SUCCESS
)
8346 gfc_error ("DATA statement at %L has more values than variables",
8351 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
8352 accessed by host or use association, is a dummy argument to a pure function,
8353 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
8354 is storage associated with any such variable, shall not be used in the
8355 following contexts: (clients of this function). */
8357 /* Determines if a variable is not 'pure', ie not assignable within a pure
8358 procedure. Returns zero if assignment is OK, nonzero if there is a
8361 gfc_impure_variable (gfc_symbol
*sym
)
8365 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
8368 if (sym
->ns
!= gfc_current_ns
)
8369 return !sym
->attr
.function
;
8371 proc
= sym
->ns
->proc_name
;
8372 if (sym
->attr
.dummy
&& gfc_pure (proc
)
8373 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
8375 proc
->attr
.function
))
8378 /* TODO: Sort out what can be storage associated, if anything, and include
8379 it here. In principle equivalences should be scanned but it does not
8380 seem to be possible to storage associate an impure variable this way. */
8385 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
8386 symbol of the current procedure. */
8389 gfc_pure (gfc_symbol
*sym
)
8391 symbol_attribute attr
;
8394 sym
= gfc_current_ns
->proc_name
;
8400 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
8404 /* Test whether the current procedure is elemental or not. */
8407 gfc_elemental (gfc_symbol
*sym
)
8409 symbol_attribute attr
;
8412 sym
= gfc_current_ns
->proc_name
;
8417 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
8421 /* Warn about unused labels. */
8424 warn_unused_fortran_label (gfc_st_label
*label
)
8429 warn_unused_fortran_label (label
->left
);
8431 if (label
->defined
== ST_LABEL_UNKNOWN
)
8434 switch (label
->referenced
)
8436 case ST_LABEL_UNKNOWN
:
8437 gfc_warning ("Label %d at %L defined but not used", label
->value
,
8441 case ST_LABEL_BAD_TARGET
:
8442 gfc_warning ("Label %d at %L defined but cannot be used",
8443 label
->value
, &label
->where
);
8450 warn_unused_fortran_label (label
->right
);
8454 /* Returns the sequence type of a symbol or sequence. */
8457 sequence_type (gfc_typespec ts
)
8466 if (ts
.derived
->components
== NULL
)
8467 return SEQ_NONDEFAULT
;
8469 result
= sequence_type (ts
.derived
->components
->ts
);
8470 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
8471 if (sequence_type (c
->ts
) != result
)
8477 if (ts
.kind
!= gfc_default_character_kind
)
8478 return SEQ_NONDEFAULT
;
8480 return SEQ_CHARACTER
;
8483 if (ts
.kind
!= gfc_default_integer_kind
)
8484 return SEQ_NONDEFAULT
;
8489 if (!(ts
.kind
== gfc_default_real_kind
8490 || ts
.kind
== gfc_default_double_kind
))
8491 return SEQ_NONDEFAULT
;
8496 if (ts
.kind
!= gfc_default_complex_kind
)
8497 return SEQ_NONDEFAULT
;
8502 if (ts
.kind
!= gfc_default_logical_kind
)
8503 return SEQ_NONDEFAULT
;
8508 return SEQ_NONDEFAULT
;
8513 /* Resolve derived type EQUIVALENCE object. */
8516 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
8519 gfc_component
*c
= derived
->components
;
8524 /* Shall not be an object of nonsequence derived type. */
8525 if (!derived
->attr
.sequence
)
8527 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8528 "attribute to be an EQUIVALENCE object", sym
->name
,
8533 /* Shall not have allocatable components. */
8534 if (derived
->attr
.alloc_comp
)
8536 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8537 "components to be an EQUIVALENCE object",sym
->name
,
8542 for (; c
; c
= c
->next
)
8546 && (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
8549 /* Shall not be an object of sequence derived type containing a pointer
8550 in the structure. */
8553 gfc_error ("Derived type variable '%s' at %L with pointer "
8554 "component(s) cannot be an EQUIVALENCE object",
8555 sym
->name
, &e
->where
);
8563 /* Resolve equivalence object.
8564 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8565 an allocatable array, an object of nonsequence derived type, an object of
8566 sequence derived type containing a pointer at any level of component
8567 selection, an automatic object, a function name, an entry name, a result
8568 name, a named constant, a structure component, or a subobject of any of
8569 the preceding objects. A substring shall not have length zero. A
8570 derived type shall not have components with default initialization nor
8571 shall two objects of an equivalence group be initialized.
8572 Either all or none of the objects shall have an protected attribute.
8573 The simple constraints are done in symbol.c(check_conflict) and the rest
8574 are implemented here. */
8577 resolve_equivalence (gfc_equiv
*eq
)
8580 gfc_symbol
*derived
;
8581 gfc_symbol
*first_sym
;
8584 locus
*last_where
= NULL
;
8585 seq_type eq_type
, last_eq_type
;
8586 gfc_typespec
*last_ts
;
8587 int object
, cnt_protected
;
8588 const char *value_name
;
8592 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
8594 first_sym
= eq
->expr
->symtree
->n
.sym
;
8598 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
8602 e
->ts
= e
->symtree
->n
.sym
->ts
;
8603 /* match_varspec might not know yet if it is seeing
8604 array reference or substring reference, as it doesn't
8606 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
8608 gfc_ref
*ref
= e
->ref
;
8609 sym
= e
->symtree
->n
.sym
;
8611 if (sym
->attr
.dimension
)
8613 ref
->u
.ar
.as
= sym
->as
;
8617 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8618 if (e
->ts
.type
== BT_CHARACTER
8620 && ref
->type
== REF_ARRAY
8621 && ref
->u
.ar
.dimen
== 1
8622 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
8623 && ref
->u
.ar
.stride
[0] == NULL
)
8625 gfc_expr
*start
= ref
->u
.ar
.start
[0];
8626 gfc_expr
*end
= ref
->u
.ar
.end
[0];
8629 /* Optimize away the (:) reference. */
8630 if (start
== NULL
&& end
== NULL
)
8635 e
->ref
->next
= ref
->next
;
8640 ref
->type
= REF_SUBSTRING
;
8642 start
= gfc_int_expr (1);
8643 ref
->u
.ss
.start
= start
;
8644 if (end
== NULL
&& e
->ts
.cl
)
8645 end
= gfc_copy_expr (e
->ts
.cl
->length
);
8646 ref
->u
.ss
.end
= end
;
8647 ref
->u
.ss
.length
= e
->ts
.cl
;
8654 /* Any further ref is an error. */
8657 gcc_assert (ref
->type
== REF_ARRAY
);
8658 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8664 if (gfc_resolve_expr (e
) == FAILURE
)
8667 sym
= e
->symtree
->n
.sym
;
8669 if (sym
->attr
.protected)
8671 if (cnt_protected
> 0 && cnt_protected
!= object
)
8673 gfc_error ("Either all or none of the objects in the "
8674 "EQUIVALENCE set at %L shall have the "
8675 "PROTECTED attribute",
8680 /* Shall not equivalence common block variables in a PURE procedure. */
8681 if (sym
->ns
->proc_name
8682 && sym
->ns
->proc_name
->attr
.pure
8683 && sym
->attr
.in_common
)
8685 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8686 "object in the pure procedure '%s'",
8687 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
8691 /* Shall not be a named constant. */
8692 if (e
->expr_type
== EXPR_CONSTANT
)
8694 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8695 "object", sym
->name
, &e
->where
);
8699 derived
= e
->ts
.derived
;
8700 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
8703 /* Check that the types correspond correctly:
8705 A numeric sequence structure may be equivalenced to another sequence
8706 structure, an object of default integer type, default real type, double
8707 precision real type, default logical type such that components of the
8708 structure ultimately only become associated to objects of the same
8709 kind. A character sequence structure may be equivalenced to an object
8710 of default character kind or another character sequence structure.
8711 Other objects may be equivalenced only to objects of the same type and
8714 /* Identical types are unconditionally OK. */
8715 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
8716 goto identical_types
;
8718 last_eq_type
= sequence_type (*last_ts
);
8719 eq_type
= sequence_type (sym
->ts
);
8721 /* Since the pair of objects is not of the same type, mixed or
8722 non-default sequences can be rejected. */
8724 msg
= "Sequence %s with mixed components in EQUIVALENCE "
8725 "statement at %L with different type objects";
8727 && last_eq_type
== SEQ_MIXED
8728 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
8730 || (eq_type
== SEQ_MIXED
8731 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8732 &e
->where
) == FAILURE
))
8735 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
8736 "statement at %L with objects of different type";
8738 && last_eq_type
== SEQ_NONDEFAULT
8739 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
8740 last_where
) == FAILURE
)
8741 || (eq_type
== SEQ_NONDEFAULT
8742 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8743 &e
->where
) == FAILURE
))
8746 msg
="Non-CHARACTER object '%s' in default CHARACTER "
8747 "EQUIVALENCE statement at %L";
8748 if (last_eq_type
== SEQ_CHARACTER
8749 && eq_type
!= SEQ_CHARACTER
8750 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8751 &e
->where
) == FAILURE
)
8754 msg
="Non-NUMERIC object '%s' in default NUMERIC "
8755 "EQUIVALENCE statement at %L";
8756 if (last_eq_type
== SEQ_NUMERIC
8757 && eq_type
!= SEQ_NUMERIC
8758 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8759 &e
->where
) == FAILURE
)
8764 last_where
= &e
->where
;
8769 /* Shall not be an automatic array. */
8770 if (e
->ref
->type
== REF_ARRAY
8771 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
8773 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8774 "an EQUIVALENCE object", sym
->name
, &e
->where
);
8781 /* Shall not be a structure component. */
8782 if (r
->type
== REF_COMPONENT
)
8784 gfc_error ("Structure component '%s' at %L cannot be an "
8785 "EQUIVALENCE object",
8786 r
->u
.c
.component
->name
, &e
->where
);
8790 /* A substring shall not have length zero. */
8791 if (r
->type
== REF_SUBSTRING
)
8793 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
8795 gfc_error ("Substring at %L has length zero",
8796 &r
->u
.ss
.start
->where
);
8806 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8809 resolve_fntype (gfc_namespace
*ns
)
8814 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
8817 /* If there are any entries, ns->proc_name is the entry master
8818 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8820 sym
= ns
->entries
->sym
;
8822 sym
= ns
->proc_name
;
8823 if (sym
->result
== sym
8824 && sym
->ts
.type
== BT_UNKNOWN
8825 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
8826 && !sym
->attr
.untyped
)
8828 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8829 sym
->name
, &sym
->declared_at
);
8830 sym
->attr
.untyped
= 1;
8833 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
8834 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
8835 sym
->ts
.derived
->ns
->default_access
)
8836 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
8838 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8839 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
8843 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
8845 if (el
->sym
->result
== el
->sym
8846 && el
->sym
->ts
.type
== BT_UNKNOWN
8847 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
8848 && !el
->sym
->attr
.untyped
)
8850 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8851 el
->sym
->name
, &el
->sym
->declared_at
);
8852 el
->sym
->attr
.untyped
= 1;
8857 /* 12.3.2.1.1 Defined operators. */
8860 gfc_resolve_uops (gfc_symtree
*symtree
)
8864 gfc_formal_arglist
*formal
;
8866 if (symtree
== NULL
)
8869 gfc_resolve_uops (symtree
->left
);
8870 gfc_resolve_uops (symtree
->right
);
8872 for (itr
= symtree
->n
.uop
->operator; itr
; itr
= itr
->next
)
8875 if (!sym
->attr
.function
)
8876 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8877 sym
->name
, &sym
->declared_at
);
8879 if (sym
->ts
.type
== BT_CHARACTER
8880 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
8881 && !(sym
->result
&& sym
->result
->ts
.cl
8882 && sym
->result
->ts
.cl
->length
))
8883 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8884 "character length", sym
->name
, &sym
->declared_at
);
8886 formal
= sym
->formal
;
8887 if (!formal
|| !formal
->sym
)
8889 gfc_error ("User operator procedure '%s' at %L must have at least "
8890 "one argument", sym
->name
, &sym
->declared_at
);
8894 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
8895 gfc_error ("First argument of operator interface at %L must be "
8896 "INTENT(IN)", &sym
->declared_at
);
8898 if (formal
->sym
->attr
.optional
)
8899 gfc_error ("First argument of operator interface at %L cannot be "
8900 "optional", &sym
->declared_at
);
8902 formal
= formal
->next
;
8903 if (!formal
|| !formal
->sym
)
8906 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
8907 gfc_error ("Second argument of operator interface at %L must be "
8908 "INTENT(IN)", &sym
->declared_at
);
8910 if (formal
->sym
->attr
.optional
)
8911 gfc_error ("Second argument of operator interface at %L cannot be "
8912 "optional", &sym
->declared_at
);
8915 gfc_error ("Operator interface at %L must have, at most, two "
8916 "arguments", &sym
->declared_at
);
8921 /* Examine all of the expressions associated with a program unit,
8922 assign types to all intermediate expressions, make sure that all
8923 assignments are to compatible types and figure out which names
8924 refer to which functions or subroutines. It doesn't check code
8925 block, which is handled by resolve_code. */
8928 resolve_types (gfc_namespace
*ns
)
8935 gfc_current_ns
= ns
;
8937 resolve_entries (ns
);
8939 resolve_common_blocks (ns
->common_root
);
8941 resolve_contained_functions (ns
);
8943 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
8945 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
8946 resolve_charlen (cl
);
8948 gfc_traverse_ns (ns
, resolve_symbol
);
8950 resolve_fntype (ns
);
8952 for (n
= ns
->contained
; n
; n
= n
->sibling
)
8954 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
8955 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8956 "also be PURE", n
->proc_name
->name
,
8957 &n
->proc_name
->declared_at
);
8963 gfc_check_interfaces (ns
);
8965 gfc_traverse_ns (ns
, resolve_values
);
8971 for (d
= ns
->data
; d
; d
= d
->next
)
8975 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
8977 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
8979 if (ns
->common_root
!= NULL
)
8980 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
8982 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
8983 resolve_equivalence (eq
);
8985 /* Warn about unused labels. */
8986 if (warn_unused_label
)
8987 warn_unused_fortran_label (ns
->st_labels
);
8989 gfc_resolve_uops (ns
->uop_root
);
8993 /* Call resolve_code recursively. */
8996 resolve_codes (gfc_namespace
*ns
)
9000 for (n
= ns
->contained
; n
; n
= n
->sibling
)
9003 gfc_current_ns
= ns
;
9005 /* Set to an out of range value. */
9006 current_entry_id
= -1;
9008 bitmap_obstack_initialize (&labels_obstack
);
9009 resolve_code (ns
->code
, ns
);
9010 bitmap_obstack_release (&labels_obstack
);
9014 /* This function is called after a complete program unit has been compiled.
9015 Its purpose is to examine all of the expressions associated with a program
9016 unit, assign types to all intermediate expressions, make sure that all
9017 assignments are to compatible types and figure out which names refer to
9018 which functions or subroutines. */
9021 gfc_resolve (gfc_namespace
*ns
)
9023 gfc_namespace
*old_ns
;
9025 old_ns
= gfc_current_ns
;
9030 gfc_current_ns
= old_ns
;