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"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
41 /* Stack to keep track of the nesting of blocks as we move through the
42 code. See resolve_branch() and resolve_code(). */
44 typedef struct code_stack
46 struct gfc_code
*head
, *current
, *tail
;
47 struct code_stack
*prev
;
49 /* This bitmap keeps track of the targets valid for a branch from
51 bitmap reachable_labels
;
55 static code_stack
*cs_base
= NULL
;
58 /* Nonzero if we're inside a FORALL block. */
60 static int forall_flag
;
62 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
64 static int omp_workshare_flag
;
66 /* Nonzero if we are processing a formal arglist. The corresponding function
67 resets the flag each time that it is read. */
68 static int formal_arg_flag
= 0;
70 /* True if we are resolving a specification expression. */
71 static int specification_expr
= 0;
73 /* The id of the last entry seen. */
74 static int current_entry_id
;
76 /* We use bitmaps to determine if a branch target is valid. */
77 static bitmap_obstack labels_obstack
;
80 gfc_is_formal_arg (void)
82 return formal_arg_flag
;
85 /* Resolve types of formal argument lists. These have to be done early so that
86 the formal argument lists of module procedures can be copied to the
87 containing module before the individual procedures are resolved
88 individually. We also resolve argument lists of procedures in interface
89 blocks because they are self-contained scoping units.
91 Since a dummy argument cannot be a non-dummy procedure, the only
92 resort left for untyped names are the IMPLICIT types. */
95 resolve_formal_arglist (gfc_symbol
*proc
)
97 gfc_formal_arglist
*f
;
101 if (proc
->result
!= NULL
)
106 if (gfc_elemental (proc
)
107 || sym
->attr
.pointer
|| sym
->attr
.allocatable
108 || (sym
->as
&& sym
->as
->rank
> 0))
109 proc
->attr
.always_explicit
= 1;
113 for (f
= proc
->formal
; f
; f
= f
->next
)
119 /* Alternate return placeholder. */
120 if (gfc_elemental (proc
))
121 gfc_error ("Alternate return specifier in elemental subroutine "
122 "'%s' at %L is not allowed", proc
->name
,
124 if (proc
->attr
.function
)
125 gfc_error ("Alternate return specifier in function "
126 "'%s' at %L is not allowed", proc
->name
,
131 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
132 resolve_formal_arglist (sym
);
134 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
136 if (gfc_pure (proc
) && !gfc_pure (sym
))
138 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
139 "also be PURE", sym
->name
, &sym
->declared_at
);
143 if (gfc_elemental (proc
))
145 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
146 "procedure", &sym
->declared_at
);
150 if (sym
->attr
.function
151 && sym
->ts
.type
== BT_UNKNOWN
152 && sym
->attr
.intrinsic
)
154 gfc_intrinsic_sym
*isym
;
155 isym
= gfc_find_function (sym
->name
);
156 if (isym
== NULL
|| !isym
->specific
)
158 gfc_error ("Unable to find a specific INTRINSIC procedure "
159 "for the reference '%s' at %L", sym
->name
,
168 if (sym
->ts
.type
== BT_UNKNOWN
)
170 if (!sym
->attr
.function
|| sym
->result
== sym
)
171 gfc_set_default_type (sym
, 1, sym
->ns
);
174 gfc_resolve_array_spec (sym
->as
, 0);
176 /* We can't tell if an array with dimension (:) is assumed or deferred
177 shape until we know if it has the pointer or allocatable attributes.
179 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
180 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
182 sym
->as
->type
= AS_ASSUMED_SHAPE
;
183 for (i
= 0; i
< sym
->as
->rank
; i
++)
184 sym
->as
->lower
[i
] = gfc_int_expr (1);
187 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
188 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
189 || sym
->attr
.optional
)
190 proc
->attr
.always_explicit
= 1;
192 /* If the flavor is unknown at this point, it has to be a variable.
193 A procedure specification would have already set the type. */
195 if (sym
->attr
.flavor
== FL_UNKNOWN
)
196 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
198 if (gfc_pure (proc
) && !sym
->attr
.pointer
199 && sym
->attr
.flavor
!= FL_PROCEDURE
)
201 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
202 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
203 "INTENT(IN)", sym
->name
, proc
->name
,
206 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
207 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
208 "have its INTENT specified", sym
->name
, proc
->name
,
212 if (gfc_elemental (proc
))
216 gfc_error ("Argument '%s' of elemental procedure at %L must "
217 "be scalar", sym
->name
, &sym
->declared_at
);
221 if (sym
->attr
.pointer
)
223 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
224 "have the POINTER attribute", sym
->name
,
230 /* Each dummy shall be specified to be scalar. */
231 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
235 gfc_error ("Argument '%s' of statement function at %L must "
236 "be scalar", sym
->name
, &sym
->declared_at
);
240 if (sym
->ts
.type
== BT_CHARACTER
)
242 gfc_charlen
*cl
= sym
->ts
.cl
;
243 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
245 gfc_error ("Character-valued argument '%s' of statement "
246 "function at %L must have constant length",
247 sym
->name
, &sym
->declared_at
);
257 /* Work function called when searching for symbols that have argument lists
258 associated with them. */
261 find_arglists (gfc_symbol
*sym
)
263 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
266 resolve_formal_arglist (sym
);
270 /* Given a namespace, resolve all formal argument lists within the namespace.
274 resolve_formal_arglists (gfc_namespace
*ns
)
279 gfc_traverse_ns (ns
, find_arglists
);
284 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
288 /* If this namespace is not a function or an entry master function,
290 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
291 || sym
->attr
.entry_master
)
294 /* Try to find out of what the return type is. */
295 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
297 t
= gfc_set_default_type (sym
->result
, 0, ns
);
299 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
301 if (sym
->result
== sym
)
302 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
303 sym
->name
, &sym
->declared_at
);
305 gfc_error ("Result '%s' of contained function '%s' at %L has "
306 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
307 &sym
->result
->declared_at
);
308 sym
->result
->attr
.untyped
= 1;
312 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
313 type, lists the only ways a character length value of * can be used:
314 dummy arguments of procedures, named constants, and function results
315 in external functions. Internal function results are not on that list;
316 ergo, not permitted. */
318 if (sym
->result
->ts
.type
== BT_CHARACTER
)
320 gfc_charlen
*cl
= sym
->result
->ts
.cl
;
321 if (!cl
|| !cl
->length
)
322 gfc_error ("Character-valued internal function '%s' at %L must "
323 "not be assumed length", sym
->name
, &sym
->declared_at
);
328 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
329 introduce duplicates. */
332 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
334 gfc_formal_arglist
*f
, *new_arglist
;
337 for (; new_args
!= NULL
; new_args
= new_args
->next
)
339 new_sym
= new_args
->sym
;
340 /* See if this arg is already in the formal argument list. */
341 for (f
= proc
->formal
; f
; f
= f
->next
)
343 if (new_sym
== f
->sym
)
350 /* Add a new argument. Argument order is not important. */
351 new_arglist
= gfc_get_formal_arglist ();
352 new_arglist
->sym
= new_sym
;
353 new_arglist
->next
= proc
->formal
;
354 proc
->formal
= new_arglist
;
359 /* Flag the arguments that are not present in all entries. */
362 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
364 gfc_formal_arglist
*f
, *head
;
367 for (f
= proc
->formal
; f
; f
= f
->next
)
372 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
374 if (new_args
->sym
== f
->sym
)
381 f
->sym
->attr
.not_always_present
= 1;
386 /* Resolve alternate entry points. If a symbol has multiple entry points we
387 create a new master symbol for the main routine, and turn the existing
388 symbol into an entry point. */
391 resolve_entries (gfc_namespace
*ns
)
393 gfc_namespace
*old_ns
;
397 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
398 static int master_count
= 0;
400 if (ns
->proc_name
== NULL
)
403 /* No need to do anything if this procedure doesn't have alternate entry
408 /* We may already have resolved alternate entry points. */
409 if (ns
->proc_name
->attr
.entry_master
)
412 /* If this isn't a procedure something has gone horribly wrong. */
413 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
415 /* Remember the current namespace. */
416 old_ns
= gfc_current_ns
;
420 /* Add the main entry point to the list of entry points. */
421 el
= gfc_get_entry_list ();
422 el
->sym
= ns
->proc_name
;
424 el
->next
= ns
->entries
;
426 ns
->proc_name
->attr
.entry
= 1;
428 /* If it is a module function, it needs to be in the right namespace
429 so that gfc_get_fake_result_decl can gather up the results. The
430 need for this arose in get_proc_name, where these beasts were
431 left in their own namespace, to keep prior references linked to
432 the entry declaration.*/
433 if (ns
->proc_name
->attr
.function
434 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
437 /* Do the same for entries where the master is not a module
438 procedure. These are retained in the module namespace because
439 of the module procedure declaration. */
440 for (el
= el
->next
; el
; el
= el
->next
)
441 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
442 && el
->sym
->attr
.mod_proc
)
446 /* Add an entry statement for it. */
453 /* Create a new symbol for the master function. */
454 /* Give the internal function a unique name (within this file).
455 Also include the function name so the user has some hope of figuring
456 out what is going on. */
457 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
458 master_count
++, ns
->proc_name
->name
);
459 gfc_get_ha_symbol (name
, &proc
);
460 gcc_assert (proc
!= NULL
);
462 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
463 if (ns
->proc_name
->attr
.subroutine
)
464 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
468 gfc_typespec
*ts
, *fts
;
469 gfc_array_spec
*as
, *fas
;
470 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
472 fas
= ns
->entries
->sym
->as
;
473 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
474 fts
= &ns
->entries
->sym
->result
->ts
;
475 if (fts
->type
== BT_UNKNOWN
)
476 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
477 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
479 ts
= &el
->sym
->result
->ts
;
481 as
= as
? as
: el
->sym
->result
->as
;
482 if (ts
->type
== BT_UNKNOWN
)
483 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
485 if (! gfc_compare_types (ts
, fts
)
486 || (el
->sym
->result
->attr
.dimension
487 != ns
->entries
->sym
->result
->attr
.dimension
)
488 || (el
->sym
->result
->attr
.pointer
489 != ns
->entries
->sym
->result
->attr
.pointer
))
492 else if (as
&& fas
&& gfc_compare_array_spec (as
, fas
) == 0)
493 gfc_error ("Procedure %s at %L has entries with mismatched "
494 "array specifications", ns
->entries
->sym
->name
,
495 &ns
->entries
->sym
->declared_at
);
500 sym
= ns
->entries
->sym
->result
;
501 /* All result types the same. */
503 if (sym
->attr
.dimension
)
504 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
505 if (sym
->attr
.pointer
)
506 gfc_add_pointer (&proc
->attr
, NULL
);
510 /* Otherwise the result will be passed through a union by
512 proc
->attr
.mixed_entry_master
= 1;
513 for (el
= ns
->entries
; el
; el
= el
->next
)
515 sym
= el
->sym
->result
;
516 if (sym
->attr
.dimension
)
518 if (el
== ns
->entries
)
519 gfc_error ("FUNCTION result %s can't be an array in "
520 "FUNCTION %s at %L", sym
->name
,
521 ns
->entries
->sym
->name
, &sym
->declared_at
);
523 gfc_error ("ENTRY result %s can't be an array in "
524 "FUNCTION %s at %L", sym
->name
,
525 ns
->entries
->sym
->name
, &sym
->declared_at
);
527 else if (sym
->attr
.pointer
)
529 if (el
== ns
->entries
)
530 gfc_error ("FUNCTION result %s can't be a POINTER in "
531 "FUNCTION %s at %L", sym
->name
,
532 ns
->entries
->sym
->name
, &sym
->declared_at
);
534 gfc_error ("ENTRY result %s can't be a POINTER in "
535 "FUNCTION %s at %L", sym
->name
,
536 ns
->entries
->sym
->name
, &sym
->declared_at
);
541 if (ts
->type
== BT_UNKNOWN
)
542 ts
= gfc_get_default_type (sym
, NULL
);
546 if (ts
->kind
== gfc_default_integer_kind
)
550 if (ts
->kind
== gfc_default_real_kind
551 || ts
->kind
== gfc_default_double_kind
)
555 if (ts
->kind
== gfc_default_complex_kind
)
559 if (ts
->kind
== gfc_default_logical_kind
)
563 /* We will issue error elsewhere. */
571 if (el
== ns
->entries
)
572 gfc_error ("FUNCTION result %s can't be of type %s "
573 "in FUNCTION %s at %L", sym
->name
,
574 gfc_typename (ts
), ns
->entries
->sym
->name
,
577 gfc_error ("ENTRY result %s can't be of type %s "
578 "in FUNCTION %s at %L", sym
->name
,
579 gfc_typename (ts
), ns
->entries
->sym
->name
,
586 proc
->attr
.access
= ACCESS_PRIVATE
;
587 proc
->attr
.entry_master
= 1;
589 /* Merge all the entry point arguments. */
590 for (el
= ns
->entries
; el
; el
= el
->next
)
591 merge_argument_lists (proc
, el
->sym
->formal
);
593 /* Check the master formal arguments for any that are not
594 present in all entry points. */
595 for (el
= ns
->entries
; el
; el
= el
->next
)
596 check_argument_lists (proc
, el
->sym
->formal
);
598 /* Use the master function for the function body. */
599 ns
->proc_name
= proc
;
601 /* Finalize the new symbols. */
602 gfc_commit_symbols ();
604 /* Restore the original namespace. */
605 gfc_current_ns
= old_ns
;
610 has_default_initializer (gfc_symbol
*der
)
614 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
615 for (c
= der
->components
; c
; c
= c
->next
)
616 if ((c
->ts
.type
!= BT_DERIVED
&& c
->initializer
)
617 || (c
->ts
.type
== BT_DERIVED
618 && (!c
->pointer
&& has_default_initializer (c
->ts
.derived
))))
625 /* Resolve common blocks. */
627 resolve_common_blocks (gfc_symtree
*common_root
)
629 gfc_symbol
*sym
, *csym
;
631 if (common_root
== NULL
)
634 if (common_root
->left
)
635 resolve_common_blocks (common_root
->left
);
636 if (common_root
->right
)
637 resolve_common_blocks (common_root
->right
);
639 for (csym
= common_root
->n
.common
->head
; csym
; csym
= csym
->common_next
)
641 if (csym
->ts
.type
!= BT_DERIVED
)
644 if (!(csym
->ts
.derived
->attr
.sequence
645 || csym
->ts
.derived
->attr
.is_bind_c
))
646 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
647 "has neither the SEQUENCE nor the BIND(C) "
648 "attribute", csym
->name
, &csym
->declared_at
);
649 if (csym
->ts
.derived
->attr
.alloc_comp
)
650 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
651 "has an ultimate component that is "
652 "allocatable", csym
->name
, &csym
->declared_at
);
653 if (has_default_initializer (csym
->ts
.derived
))
654 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
655 "may not have default initializer", csym
->name
,
659 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
663 if (sym
->attr
.flavor
== FL_PARAMETER
)
664 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
665 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
667 if (sym
->attr
.intrinsic
)
668 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
669 sym
->name
, &common_root
->n
.common
->where
);
670 else if (sym
->attr
.result
671 ||(sym
->attr
.function
&& gfc_current_ns
->proc_name
== sym
))
672 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
673 "that is also a function result", sym
->name
,
674 &common_root
->n
.common
->where
);
675 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
676 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
677 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
678 "that is also a global procedure", sym
->name
,
679 &common_root
->n
.common
->where
);
683 /* Resolve contained function types. Because contained functions can call one
684 another, they have to be worked out before any of the contained procedures
687 The good news is that if a function doesn't already have a type, the only
688 way it can get one is through an IMPLICIT type or a RESULT variable, because
689 by definition contained functions are contained namespace they're contained
690 in, not in a sibling or parent namespace. */
693 resolve_contained_functions (gfc_namespace
*ns
)
695 gfc_namespace
*child
;
698 resolve_formal_arglists (ns
);
700 for (child
= ns
->contained
; child
; child
= child
->sibling
)
702 /* Resolve alternate entry points first. */
703 resolve_entries (child
);
705 /* Then check function return types. */
706 resolve_contained_fntype (child
->proc_name
, child
);
707 for (el
= child
->entries
; el
; el
= el
->next
)
708 resolve_contained_fntype (el
->sym
, child
);
713 /* Resolve all of the elements of a structure constructor and make sure that
714 the types are correct. */
717 resolve_structure_cons (gfc_expr
*expr
)
719 gfc_constructor
*cons
;
725 cons
= expr
->value
.constructor
;
726 /* A constructor may have references if it is the result of substituting a
727 parameter variable. In this case we just pull out the component we
730 comp
= expr
->ref
->u
.c
.sym
->components
;
732 comp
= expr
->ts
.derived
->components
;
734 /* See if the user is trying to invoke a structure constructor for one of
735 the iso_c_binding derived types. */
736 if (expr
->ts
.derived
&& expr
->ts
.derived
->ts
.is_iso_c
&& cons
737 && cons
->expr
!= NULL
)
739 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
740 expr
->ts
.derived
->name
, &(expr
->where
));
744 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
751 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
757 rank
= comp
->as
? comp
->as
->rank
: 0;
758 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
759 && (comp
->allocatable
|| cons
->expr
->rank
))
761 gfc_error ("The rank of the element in the derived type "
762 "constructor at %L does not match that of the "
763 "component (%d/%d)", &cons
->expr
->where
,
764 cons
->expr
->rank
, rank
);
768 /* If we don't have the right type, try to convert it. */
770 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
773 if (comp
->pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
774 gfc_error ("The element in the derived type constructor at %L, "
775 "for pointer component '%s', is %s but should be %s",
776 &cons
->expr
->where
, comp
->name
,
777 gfc_basic_typename (cons
->expr
->ts
.type
),
778 gfc_basic_typename (comp
->ts
.type
));
780 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
783 if (!comp
->pointer
|| cons
->expr
->expr_type
== EXPR_NULL
)
786 a
= gfc_expr_attr (cons
->expr
);
788 if (!a
.pointer
&& !a
.target
)
791 gfc_error ("The element in the derived type constructor at %L, "
792 "for pointer component '%s' should be a POINTER or "
793 "a TARGET", &cons
->expr
->where
, comp
->name
);
801 /****************** Expression name resolution ******************/
803 /* Returns 0 if a symbol was not declared with a type or
804 attribute declaration statement, nonzero otherwise. */
807 was_declared (gfc_symbol
*sym
)
813 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
816 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
817 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
818 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
825 /* Determine if a symbol is generic or not. */
828 generic_sym (gfc_symbol
*sym
)
832 if (sym
->attr
.generic
||
833 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
836 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
839 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
846 return generic_sym (s
);
853 /* Determine if a symbol is specific or not. */
856 specific_sym (gfc_symbol
*sym
)
860 if (sym
->attr
.if_source
== IFSRC_IFBODY
861 || sym
->attr
.proc
== PROC_MODULE
862 || sym
->attr
.proc
== PROC_INTERNAL
863 || sym
->attr
.proc
== PROC_ST_FUNCTION
864 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
865 || sym
->attr
.external
)
868 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
871 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
873 return (s
== NULL
) ? 0 : specific_sym (s
);
877 /* Figure out if the procedure is specific, generic or unknown. */
880 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
884 procedure_kind (gfc_symbol
*sym
)
886 if (generic_sym (sym
))
887 return PTYPE_GENERIC
;
889 if (specific_sym (sym
))
890 return PTYPE_SPECIFIC
;
892 return PTYPE_UNKNOWN
;
895 /* Check references to assumed size arrays. The flag need_full_assumed_size
896 is nonzero when matching actual arguments. */
898 static int need_full_assumed_size
= 0;
901 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
907 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
910 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
911 if (ref
->type
== REF_ARRAY
)
912 for (dim
= 0; dim
< ref
->u
.ar
.as
->rank
; dim
++)
913 last
= (ref
->u
.ar
.end
[dim
] == NULL
)
914 && (ref
->u
.ar
.type
== DIMEN_ELEMENT
);
918 gfc_error ("The upper bound in the last dimension must "
919 "appear in the reference to the assumed size "
920 "array '%s' at %L", sym
->name
, &e
->where
);
927 /* Look for bad assumed size array references in argument expressions
928 of elemental and array valued intrinsic procedures. Since this is
929 called from procedure resolution functions, it only recurses at
933 resolve_assumed_size_actual (gfc_expr
*e
)
938 switch (e
->expr_type
)
941 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
946 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
947 || resolve_assumed_size_actual (e
->value
.op
.op2
))
958 /* Resolve an actual argument list. Most of the time, this is just
959 resolving the expressions in the list.
960 The exception is that we sometimes have to decide whether arguments
961 that look like procedure arguments are really simple variable
965 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
)
968 gfc_symtree
*parent_st
;
971 for (; arg
; arg
= arg
->next
)
976 /* Check the label is a valid branching target. */
979 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
981 gfc_error ("Label %d referenced at %L is never defined",
982 arg
->label
->value
, &arg
->label
->where
);
989 if (e
->expr_type
== FL_VARIABLE
&& e
->symtree
->ambiguous
)
991 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
996 if (e
->ts
.type
!= BT_PROCEDURE
)
998 if (gfc_resolve_expr (e
) != SUCCESS
)
1003 /* See if the expression node should really be a variable reference. */
1005 sym
= e
->symtree
->n
.sym
;
1007 if (sym
->attr
.flavor
== FL_PROCEDURE
1008 || sym
->attr
.intrinsic
1009 || sym
->attr
.external
)
1013 /* If a procedure is not already determined to be something else
1014 check if it is intrinsic. */
1015 if (!sym
->attr
.intrinsic
1016 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1017 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1018 && gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
1019 sym
->attr
.intrinsic
= 1;
1021 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1023 gfc_error ("Statement function '%s' at %L is not allowed as an "
1024 "actual argument", sym
->name
, &e
->where
);
1027 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1028 sym
->attr
.subroutine
);
1029 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1031 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1032 "actual argument", sym
->name
, &e
->where
);
1035 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1036 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1038 gfc_error ("Internal procedure '%s' is not allowed as an "
1039 "actual argument at %L", sym
->name
, &e
->where
);
1042 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1044 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1045 "allowed as an actual argument at %L", sym
->name
,
1049 /* Check if a generic interface has a specific procedure
1050 with the same name before emitting an error. */
1051 if (sym
->attr
.generic
)
1054 for (p
= sym
->generic
; p
; p
= p
->next
)
1055 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1057 e
->symtree
= gfc_find_symtree
1058 (p
->sym
->ns
->sym_root
, sym
->name
);
1063 if (p
== NULL
|| e
->symtree
== NULL
)
1064 gfc_error ("GENERIC procedure '%s' is not "
1065 "allowed as an actual argument at %L", sym
->name
,
1069 /* If the symbol is the function that names the current (or
1070 parent) scope, then we really have a variable reference. */
1072 if (sym
->attr
.function
&& sym
->result
== sym
1073 && (sym
->ns
->proc_name
== sym
1074 || (sym
->ns
->parent
!= NULL
1075 && sym
->ns
->parent
->proc_name
== sym
)))
1078 /* If all else fails, see if we have a specific intrinsic. */
1079 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1081 gfc_intrinsic_sym
*isym
;
1083 isym
= gfc_find_function (sym
->name
);
1084 if (isym
== NULL
|| !isym
->specific
)
1086 gfc_error ("Unable to find a specific INTRINSIC procedure "
1087 "for the reference '%s' at %L", sym
->name
,
1092 sym
->attr
.intrinsic
= 1;
1093 sym
->attr
.function
= 1;
1098 /* See if the name is a module procedure in a parent unit. */
1100 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1103 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1105 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1109 if (parent_st
== NULL
)
1112 sym
= parent_st
->n
.sym
;
1113 e
->symtree
= parent_st
; /* Point to the right thing. */
1115 if (sym
->attr
.flavor
== FL_PROCEDURE
1116 || sym
->attr
.intrinsic
1117 || sym
->attr
.external
)
1123 e
->expr_type
= EXPR_VARIABLE
;
1125 if (sym
->as
!= NULL
)
1127 e
->rank
= sym
->as
->rank
;
1128 e
->ref
= gfc_get_ref ();
1129 e
->ref
->type
= REF_ARRAY
;
1130 e
->ref
->u
.ar
.type
= AR_FULL
;
1131 e
->ref
->u
.ar
.as
= sym
->as
;
1134 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1135 primary.c (match_actual_arg). If above code determines that it
1136 is a variable instead, it needs to be resolved as it was not
1137 done at the beginning of this function. */
1138 if (gfc_resolve_expr (e
) != SUCCESS
)
1142 /* Check argument list functions %VAL, %LOC and %REF. There is
1143 nothing to do for %REF. */
1144 if (arg
->name
&& arg
->name
[0] == '%')
1146 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1148 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1150 gfc_error ("By-value argument at %L is not of numeric "
1157 gfc_error ("By-value argument at %L cannot be an array or "
1158 "an array section", &e
->where
);
1162 /* Intrinsics are still PROC_UNKNOWN here. However,
1163 since same file external procedures are not resolvable
1164 in gfortran, it is a good deal easier to leave them to
1166 if (ptype
!= PROC_UNKNOWN
1167 && ptype
!= PROC_DUMMY
1168 && ptype
!= PROC_EXTERNAL
1169 && ptype
!= PROC_MODULE
)
1171 gfc_error ("By-value argument at %L is not allowed "
1172 "in this context", &e
->where
);
1177 /* Statement functions have already been excluded above. */
1178 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1179 && e
->ts
.type
== BT_PROCEDURE
)
1181 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1183 gfc_error ("Passing internal procedure at %L by location "
1184 "not allowed", &e
->where
);
1195 /* Do the checks of the actual argument list that are specific to elemental
1196 procedures. If called with c == NULL, we have a function, otherwise if
1197 expr == NULL, we have a subroutine. */
1200 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1202 gfc_actual_arglist
*arg0
;
1203 gfc_actual_arglist
*arg
;
1204 gfc_symbol
*esym
= NULL
;
1205 gfc_intrinsic_sym
*isym
= NULL
;
1207 gfc_intrinsic_arg
*iformal
= NULL
;
1208 gfc_formal_arglist
*eformal
= NULL
;
1209 bool formal_optional
= false;
1210 bool set_by_optional
= false;
1214 /* Is this an elemental procedure? */
1215 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1217 if (expr
->value
.function
.esym
!= NULL
1218 && expr
->value
.function
.esym
->attr
.elemental
)
1220 arg0
= expr
->value
.function
.actual
;
1221 esym
= expr
->value
.function
.esym
;
1223 else if (expr
->value
.function
.isym
!= NULL
1224 && expr
->value
.function
.isym
->elemental
)
1226 arg0
= expr
->value
.function
.actual
;
1227 isym
= expr
->value
.function
.isym
;
1232 else if (c
&& c
->ext
.actual
!= NULL
&& c
->symtree
->n
.sym
->attr
.elemental
)
1234 arg0
= c
->ext
.actual
;
1235 esym
= c
->symtree
->n
.sym
;
1240 /* The rank of an elemental is the rank of its array argument(s). */
1241 for (arg
= arg0
; arg
; arg
= arg
->next
)
1243 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1245 rank
= arg
->expr
->rank
;
1246 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1247 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1248 set_by_optional
= true;
1250 /* Function specific; set the result rank and shape. */
1254 if (!expr
->shape
&& arg
->expr
->shape
)
1256 expr
->shape
= gfc_get_shape (rank
);
1257 for (i
= 0; i
< rank
; i
++)
1258 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1265 /* If it is an array, it shall not be supplied as an actual argument
1266 to an elemental procedure unless an array of the same rank is supplied
1267 as an actual argument corresponding to a nonoptional dummy argument of
1268 that elemental procedure(12.4.1.5). */
1269 formal_optional
= false;
1271 iformal
= isym
->formal
;
1273 eformal
= esym
->formal
;
1275 for (arg
= arg0
; arg
; arg
= arg
->next
)
1279 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1280 formal_optional
= true;
1281 eformal
= eformal
->next
;
1283 else if (isym
&& iformal
)
1285 if (iformal
->optional
)
1286 formal_optional
= true;
1287 iformal
= iformal
->next
;
1290 formal_optional
= true;
1292 if (pedantic
&& arg
->expr
!= NULL
1293 && arg
->expr
->expr_type
== EXPR_VARIABLE
1294 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1297 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1298 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1300 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1301 "MISSING, it cannot be the actual argument of an "
1302 "ELEMENTAL procedure unless there is a non-optional "
1303 "argument with the same rank (12.4.1.5)",
1304 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1309 for (arg
= arg0
; arg
; arg
= arg
->next
)
1311 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1314 /* Being elemental, the last upper bound of an assumed size array
1315 argument must be present. */
1316 if (resolve_assumed_size_actual (arg
->expr
))
1319 /* Elemental procedure's array actual arguments must conform. */
1322 if (gfc_check_conformance ("elemental procedure", arg
->expr
, e
)
1330 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1331 is an array, the intent inout/out variable needs to be also an array. */
1332 if (rank
> 0 && esym
&& expr
== NULL
)
1333 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1334 arg
= arg
->next
, eformal
= eformal
->next
)
1335 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1336 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1337 && arg
->expr
&& arg
->expr
->rank
== 0)
1339 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1340 "ELEMENTAL subroutine '%s' is a scalar, but another "
1341 "actual argument is an array", &arg
->expr
->where
,
1342 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1343 : "INOUT", eformal
->sym
->name
, esym
->name
);
1350 /* Go through each actual argument in ACTUAL and see if it can be
1351 implemented as an inlined, non-copying intrinsic. FNSYM is the
1352 function being called, or NULL if not known. */
1355 find_noncopying_intrinsics (gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
)
1357 gfc_actual_arglist
*ap
;
1360 for (ap
= actual
; ap
; ap
= ap
->next
)
1362 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1363 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
1364 ap
->expr
->inline_noncopying_intrinsic
= 1;
1368 /* This function does the checking of references to global procedures
1369 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1370 77 and 95 standards. It checks for a gsymbol for the name, making
1371 one if it does not already exist. If it already exists, then the
1372 reference being resolved must correspond to the type of gsymbol.
1373 Otherwise, the new symbol is equipped with the attributes of the
1374 reference. The corresponding code that is called in creating
1375 global entities is parse.c. */
1378 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1383 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1385 gsym
= gfc_get_gsymbol (sym
->name
);
1387 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1388 gfc_global_used (gsym
, where
);
1390 if (gsym
->type
== GSYM_UNKNOWN
)
1393 gsym
->where
= *where
;
1400 /************* Function resolution *************/
1402 /* Resolve a function call known to be generic.
1403 Section 14.1.2.4.1. */
1406 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
1410 if (sym
->attr
.generic
)
1412 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1415 expr
->value
.function
.name
= s
->name
;
1416 expr
->value
.function
.esym
= s
;
1418 if (s
->ts
.type
!= BT_UNKNOWN
)
1420 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1421 expr
->ts
= s
->result
->ts
;
1424 expr
->rank
= s
->as
->rank
;
1425 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1426 expr
->rank
= s
->result
->as
->rank
;
1428 gfc_set_sym_referenced (expr
->value
.function
.esym
);
1433 /* TODO: Need to search for elemental references in generic
1437 if (sym
->attr
.intrinsic
)
1438 return gfc_intrinsic_func_interface (expr
, 0);
1445 resolve_generic_f (gfc_expr
*expr
)
1450 sym
= expr
->symtree
->n
.sym
;
1454 m
= resolve_generic_f0 (expr
, sym
);
1457 else if (m
== MATCH_ERROR
)
1461 if (sym
->ns
->parent
== NULL
)
1463 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1467 if (!generic_sym (sym
))
1471 /* Last ditch attempt. See if the reference is to an intrinsic
1472 that possesses a matching interface. 14.1.2.4 */
1473 if (sym
&& !gfc_intrinsic_name (sym
->name
, 0))
1475 gfc_error ("There is no specific function for the generic '%s' at %L",
1476 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1480 m
= gfc_intrinsic_func_interface (expr
, 0);
1484 gfc_error ("Generic function '%s' at %L is not consistent with a "
1485 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
1492 /* Resolve a function call known to be specific. */
1495 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
1499 /* See if we have an intrinsic interface. */
1501 if (sym
->interface
!= NULL
&& sym
->interface
->attr
.intrinsic
)
1503 gfc_intrinsic_sym
*isym
;
1504 isym
= gfc_find_function (sym
->interface
->name
);
1506 /* Existance of isym should be checked already. */
1510 sym
->attr
.function
= 1;
1511 sym
->attr
.proc
= PROC_EXTERNAL
;
1515 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1517 if (sym
->attr
.dummy
)
1519 sym
->attr
.proc
= PROC_DUMMY
;
1523 sym
->attr
.proc
= PROC_EXTERNAL
;
1527 if (sym
->attr
.proc
== PROC_MODULE
1528 || sym
->attr
.proc
== PROC_ST_FUNCTION
1529 || sym
->attr
.proc
== PROC_INTERNAL
)
1532 if (sym
->attr
.intrinsic
)
1534 m
= gfc_intrinsic_func_interface (expr
, 1);
1538 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1539 "with an intrinsic", sym
->name
, &expr
->where
);
1547 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1550 expr
->value
.function
.name
= sym
->name
;
1551 expr
->value
.function
.esym
= sym
;
1552 if (sym
->as
!= NULL
)
1553 expr
->rank
= sym
->as
->rank
;
1560 resolve_specific_f (gfc_expr
*expr
)
1565 sym
= expr
->symtree
->n
.sym
;
1569 m
= resolve_specific_f0 (sym
, expr
);
1572 if (m
== MATCH_ERROR
)
1575 if (sym
->ns
->parent
== NULL
)
1578 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1584 gfc_error ("Unable to resolve the specific function '%s' at %L",
1585 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1591 /* Resolve a procedure call not known to be generic nor specific. */
1594 resolve_unknown_f (gfc_expr
*expr
)
1599 sym
= expr
->symtree
->n
.sym
;
1601 if (sym
->attr
.dummy
)
1603 sym
->attr
.proc
= PROC_DUMMY
;
1604 expr
->value
.function
.name
= sym
->name
;
1608 /* See if we have an intrinsic function reference. */
1610 if (gfc_intrinsic_name (sym
->name
, 0))
1612 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1617 /* The reference is to an external name. */
1619 sym
->attr
.proc
= PROC_EXTERNAL
;
1620 expr
->value
.function
.name
= sym
->name
;
1621 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1623 if (sym
->as
!= NULL
)
1624 expr
->rank
= sym
->as
->rank
;
1626 /* Type of the expression is either the type of the symbol or the
1627 default type of the symbol. */
1630 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1632 if (sym
->ts
.type
!= BT_UNKNOWN
)
1636 ts
= gfc_get_default_type (sym
, sym
->ns
);
1638 if (ts
->type
== BT_UNKNOWN
)
1640 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1641 sym
->name
, &expr
->where
);
1652 /* Return true, if the symbol is an external procedure. */
1654 is_external_proc (gfc_symbol
*sym
)
1656 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
1657 && !(sym
->attr
.intrinsic
1658 || gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
1659 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1660 && !sym
->attr
.use_assoc
1668 /* Figure out if a function reference is pure or not. Also set the name
1669 of the function for a potential error message. Return nonzero if the
1670 function is PURE, zero if not. */
1672 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
1675 pure_function (gfc_expr
*e
, const char **name
)
1681 if (e
->symtree
!= NULL
1682 && e
->symtree
->n
.sym
!= NULL
1683 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1684 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
1686 if (e
->value
.function
.esym
)
1688 pure
= gfc_pure (e
->value
.function
.esym
);
1689 *name
= e
->value
.function
.esym
->name
;
1691 else if (e
->value
.function
.isym
)
1693 pure
= e
->value
.function
.isym
->pure
1694 || e
->value
.function
.isym
->elemental
;
1695 *name
= e
->value
.function
.isym
->name
;
1699 /* Implicit functions are not pure. */
1701 *name
= e
->value
.function
.name
;
1709 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
1710 int *f ATTRIBUTE_UNUSED
)
1714 /* Don't bother recursing into other statement functions
1715 since they will be checked individually for purity. */
1716 if (e
->expr_type
!= EXPR_FUNCTION
1718 || e
->symtree
->n
.sym
== sym
1719 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1722 return pure_function (e
, &name
) ? false : true;
1727 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
1729 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
1734 is_scalar_expr_ptr (gfc_expr
*expr
)
1736 try retval
= SUCCESS
;
1741 /* See if we have a gfc_ref, which means we have a substring, array
1742 reference, or a component. */
1743 if (expr
->ref
!= NULL
)
1746 while (ref
->next
!= NULL
)
1752 if (ref
->u
.ss
.length
!= NULL
1753 && ref
->u
.ss
.length
->length
!= NULL
1755 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1757 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1759 start
= (int) mpz_get_si (ref
->u
.ss
.start
->value
.integer
);
1760 end
= (int) mpz_get_si (ref
->u
.ss
.end
->value
.integer
);
1761 if (end
- start
+ 1 != 1)
1768 if (ref
->u
.ar
.type
== AR_ELEMENT
)
1770 else if (ref
->u
.ar
.type
== AR_FULL
)
1772 /* The user can give a full array if the array is of size 1. */
1773 if (ref
->u
.ar
.as
!= NULL
1774 && ref
->u
.ar
.as
->rank
== 1
1775 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
1776 && ref
->u
.ar
.as
->lower
[0] != NULL
1777 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
1778 && ref
->u
.ar
.as
->upper
[0] != NULL
1779 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
1781 /* If we have a character string, we need to check if
1782 its length is one. */
1783 if (expr
->ts
.type
== BT_CHARACTER
)
1785 if (expr
->ts
.cl
== NULL
1786 || expr
->ts
.cl
->length
== NULL
1787 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1)
1793 /* We have constant lower and upper bounds. If the
1794 difference between is 1, it can be considered a
1796 start
= (int) mpz_get_si
1797 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
1798 end
= (int) mpz_get_si
1799 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
1800 if (end
- start
+ 1 != 1)
1815 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
1817 /* Character string. Make sure it's of length 1. */
1818 if (expr
->ts
.cl
== NULL
1819 || expr
->ts
.cl
->length
== NULL
1820 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1) != 0)
1823 else if (expr
->rank
!= 0)
1830 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1831 and, in the case of c_associated, set the binding label based on
1835 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
1836 gfc_symbol
**new_sym
)
1838 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1839 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
1840 int optional_arg
= 0;
1841 try retval
= SUCCESS
;
1842 gfc_symbol
*args_sym
;
1843 gfc_typespec
*arg_ts
;
1844 gfc_ref
*parent_ref
;
1847 if (args
->expr
->expr_type
== EXPR_CONSTANT
1848 || args
->expr
->expr_type
== EXPR_OP
1849 || args
->expr
->expr_type
== EXPR_NULL
)
1851 gfc_error ("Argument to '%s' at %L is not a variable",
1852 sym
->name
, &(args
->expr
->where
));
1856 args_sym
= args
->expr
->symtree
->n
.sym
;
1858 /* The typespec for the actual arg should be that stored in the expr
1859 and not necessarily that of the expr symbol (args_sym), because
1860 the actual expression could be a part-ref of the expr symbol. */
1861 arg_ts
= &(args
->expr
->ts
);
1863 /* Get the parent reference (if any) for the expression. This happens for
1864 cases such as a%b%c. */
1865 parent_ref
= args
->expr
->ref
;
1867 if (parent_ref
!= NULL
)
1869 curr_ref
= parent_ref
->next
;
1870 while (curr_ref
!= NULL
&& curr_ref
->next
!= NULL
)
1872 parent_ref
= curr_ref
;
1873 curr_ref
= curr_ref
->next
;
1877 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
1878 is for a REF_COMPONENT, then we need to use it as the parent_ref for
1879 the name, etc. Otherwise, the current parent_ref should be correct. */
1880 if (curr_ref
!= NULL
&& curr_ref
->type
== REF_COMPONENT
)
1881 parent_ref
= curr_ref
;
1883 if (parent_ref
== args
->expr
->ref
)
1885 else if (parent_ref
!= NULL
&& parent_ref
->type
!= REF_COMPONENT
)
1886 gfc_internal_error ("Unexpected expression reference type in "
1887 "gfc_iso_c_func_interface");
1889 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
1891 /* If the user gave two args then they are providing something for
1892 the optional arg (the second cptr). Therefore, set the name and
1893 binding label to the c_associated for two cptrs. Otherwise,
1894 set c_associated to expect one cptr. */
1898 sprintf (name
, "%s_2", sym
->name
);
1899 sprintf (binding_label
, "%s_2", sym
->binding_label
);
1905 sprintf (name
, "%s_1", sym
->name
);
1906 sprintf (binding_label
, "%s_1", sym
->binding_label
);
1910 /* Get a new symbol for the version of c_associated that
1912 *new_sym
= get_iso_c_sym (sym
, name
, binding_label
, optional_arg
);
1914 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
1915 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
1917 sprintf (name
, "%s", sym
->name
);
1918 sprintf (binding_label
, "%s", sym
->binding_label
);
1920 /* Error check the call. */
1921 if (args
->next
!= NULL
)
1923 gfc_error_now ("More actual than formal arguments in '%s' "
1924 "call at %L", name
, &(args
->expr
->where
));
1927 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
1929 /* Make sure we have either the target or pointer attribute. */
1930 if (!(args_sym
->attr
.target
)
1931 && !(args_sym
->attr
.pointer
)
1932 && (parent_ref
== NULL
||
1933 !parent_ref
->u
.c
.component
->pointer
))
1935 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1936 "a TARGET or an associated pointer",
1938 sym
->name
, &(args
->expr
->where
));
1942 /* See if we have interoperable type and type param. */
1943 if (verify_c_interop (arg_ts
,
1944 (parent_ref
? parent_ref
->u
.c
.component
->name
1946 &(args
->expr
->where
)) == SUCCESS
1947 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
1949 if (args_sym
->attr
.target
== 1)
1951 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1952 has the target attribute and is interoperable. */
1953 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1954 allocatable variable that has the TARGET attribute and
1955 is not an array of zero size. */
1956 if (args_sym
->attr
.allocatable
== 1)
1958 if (args_sym
->attr
.dimension
!= 0
1959 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
1961 gfc_error_now ("Allocatable variable '%s' used as a "
1962 "parameter to '%s' at %L must not be "
1963 "an array of zero size",
1964 args_sym
->name
, sym
->name
,
1965 &(args
->expr
->where
));
1971 /* A non-allocatable target variable with C
1972 interoperable type and type parameters must be
1974 if (args_sym
&& args_sym
->attr
.dimension
)
1976 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
1978 gfc_error ("Assumed-shape array '%s' at %L "
1979 "cannot be an argument to the "
1980 "procedure '%s' because "
1981 "it is not C interoperable",
1983 &(args
->expr
->where
), sym
->name
);
1986 else if (args_sym
->as
->type
== AS_DEFERRED
)
1988 gfc_error ("Deferred-shape array '%s' at %L "
1989 "cannot be an argument to the "
1990 "procedure '%s' because "
1991 "it is not C interoperable",
1993 &(args
->expr
->where
), sym
->name
);
1998 /* Make sure it's not a character string. Arrays of
1999 any type should be ok if the variable is of a C
2000 interoperable type. */
2001 if (arg_ts
->type
== BT_CHARACTER
)
2002 if (arg_ts
->cl
!= NULL
2003 && (arg_ts
->cl
->length
== NULL
2004 || arg_ts
->cl
->length
->expr_type
2007 (arg_ts
->cl
->length
->value
.integer
, 1)
2009 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2011 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2012 "at %L must have a length of 1",
2013 args_sym
->name
, sym
->name
,
2014 &(args
->expr
->where
));
2019 else if ((args_sym
->attr
.pointer
== 1 ||
2021 && parent_ref
->u
.c
.component
->pointer
))
2022 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2024 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2026 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2027 "associated scalar POINTER", args_sym
->name
,
2028 sym
->name
, &(args
->expr
->where
));
2034 /* The parameter is not required to be C interoperable. If it
2035 is not C interoperable, it must be a nonpolymorphic scalar
2036 with no length type parameters. It still must have either
2037 the pointer or target attribute, and it can be
2038 allocatable (but must be allocated when c_loc is called). */
2039 if (args
->expr
->rank
!= 0
2040 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2042 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2043 "scalar", args_sym
->name
, sym
->name
,
2044 &(args
->expr
->where
));
2047 else if (arg_ts
->type
== BT_CHARACTER
2048 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2050 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2051 "%L must have a length of 1",
2052 args_sym
->name
, sym
->name
,
2053 &(args
->expr
->where
));
2058 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2060 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2062 /* TODO: Update this error message to allow for procedure
2063 pointers once they are implemented. */
2064 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2066 args_sym
->name
, sym
->name
,
2067 &(args
->expr
->where
));
2070 else if (args_sym
->attr
.is_bind_c
!= 1)
2072 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2074 args_sym
->name
, sym
->name
,
2075 &(args
->expr
->where
));
2080 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2085 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2086 "iso_c_binding function: '%s'!\n", sym
->name
);
2093 /* Resolve a function call, which means resolving the arguments, then figuring
2094 out which entity the name refers to. */
2095 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2096 to INTENT(OUT) or INTENT(INOUT). */
2099 resolve_function (gfc_expr
*expr
)
2101 gfc_actual_arglist
*arg
;
2106 procedure_type p
= PROC_INTRINSIC
;
2110 sym
= expr
->symtree
->n
.sym
;
2112 if (sym
&& sym
->attr
.flavor
== FL_VARIABLE
)
2114 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2118 if (sym
&& sym
->attr
.abstract
)
2120 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2121 sym
->name
, &expr
->where
);
2125 /* If the procedure is external, check for usage. */
2126 if (sym
&& is_external_proc (sym
))
2127 resolve_global_procedure (sym
, &expr
->where
, 0);
2129 /* Switch off assumed size checking and do this again for certain kinds
2130 of procedure, once the procedure itself is resolved. */
2131 need_full_assumed_size
++;
2133 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2134 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2136 if (resolve_actual_arglist (expr
->value
.function
.actual
, p
) == FAILURE
)
2139 /* Need to setup the call to the correct c_associated, depending on
2140 the number of cptrs to user gives to compare. */
2141 if (sym
&& sym
->attr
.is_iso_c
== 1)
2143 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
2147 /* Get the symtree for the new symbol (resolved func).
2148 the old one will be freed later, when it's no longer used. */
2149 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
2152 /* Resume assumed_size checking. */
2153 need_full_assumed_size
--;
2155 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2157 && sym
->ts
.cl
->length
== NULL
2159 && expr
->value
.function
.esym
== NULL
2160 && !sym
->attr
.contained
)
2162 /* Internal procedures are taken care of in resolve_contained_fntype. */
2163 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2164 "be used at %L since it is not a dummy argument",
2165 sym
->name
, &expr
->where
);
2169 /* See if function is already resolved. */
2171 if (expr
->value
.function
.name
!= NULL
)
2173 if (expr
->ts
.type
== BT_UNKNOWN
)
2179 /* Apply the rules of section 14.1.2. */
2181 switch (procedure_kind (sym
))
2184 t
= resolve_generic_f (expr
);
2187 case PTYPE_SPECIFIC
:
2188 t
= resolve_specific_f (expr
);
2192 t
= resolve_unknown_f (expr
);
2196 gfc_internal_error ("resolve_function(): bad function type");
2200 /* If the expression is still a function (it might have simplified),
2201 then we check to see if we are calling an elemental function. */
2203 if (expr
->expr_type
!= EXPR_FUNCTION
)
2206 temp
= need_full_assumed_size
;
2207 need_full_assumed_size
= 0;
2209 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
2212 if (omp_workshare_flag
2213 && expr
->value
.function
.esym
2214 && ! gfc_elemental (expr
->value
.function
.esym
))
2216 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2217 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2222 #define GENERIC_ID expr->value.function.isym->id
2223 else if (expr
->value
.function
.actual
!= NULL
2224 && expr
->value
.function
.isym
!= NULL
2225 && GENERIC_ID
!= GFC_ISYM_LBOUND
2226 && GENERIC_ID
!= GFC_ISYM_LEN
2227 && GENERIC_ID
!= GFC_ISYM_LOC
2228 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2230 /* Array intrinsics must also have the last upper bound of an
2231 assumed size array argument. UBOUND and SIZE have to be
2232 excluded from the check if the second argument is anything
2235 inquiry
= GENERIC_ID
== GFC_ISYM_UBOUND
2236 || GENERIC_ID
== GFC_ISYM_SIZE
;
2238 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2240 if (inquiry
&& arg
->next
!= NULL
&& arg
->next
->expr
)
2242 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2245 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2250 if (arg
->expr
!= NULL
2251 && arg
->expr
->rank
> 0
2252 && resolve_assumed_size_actual (arg
->expr
))
2258 need_full_assumed_size
= temp
;
2261 if (!pure_function (expr
, &name
) && name
)
2265 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2266 "FORALL %s", name
, &expr
->where
,
2267 forall_flag
== 2 ? "mask" : "block");
2270 else if (gfc_pure (NULL
))
2272 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2273 "procedure within a PURE procedure", name
, &expr
->where
);
2278 /* Functions without the RECURSIVE attribution are not allowed to
2279 * call themselves. */
2280 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
2282 gfc_symbol
*esym
, *proc
;
2283 esym
= expr
->value
.function
.esym
;
2284 proc
= gfc_current_ns
->proc_name
;
2287 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2288 "RECURSIVE", name
, &expr
->where
);
2292 if (esym
->attr
.entry
&& esym
->ns
->entries
&& proc
->ns
->entries
2293 && esym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2295 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2296 "'%s' is not declared as RECURSIVE",
2297 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
2302 /* Character lengths of use associated functions may contains references to
2303 symbols not referenced from the current program unit otherwise. Make sure
2304 those symbols are marked as referenced. */
2306 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
2307 && expr
->value
.function
.esym
->attr
.use_assoc
)
2309 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
2313 find_noncopying_intrinsics (expr
->value
.function
.esym
,
2314 expr
->value
.function
.actual
);
2316 /* Make sure that the expression has a typespec that works. */
2317 if (expr
->ts
.type
== BT_UNKNOWN
)
2319 if (expr
->symtree
->n
.sym
->result
2320 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
)
2321 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
2328 /************* Subroutine resolution *************/
2331 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
2337 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2338 sym
->name
, &c
->loc
);
2339 else if (gfc_pure (NULL
))
2340 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
2346 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2350 if (sym
->attr
.generic
)
2352 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
2355 c
->resolved_sym
= s
;
2356 pure_subroutine (c
, s
);
2360 /* TODO: Need to search for elemental references in generic interface. */
2363 if (sym
->attr
.intrinsic
)
2364 return gfc_intrinsic_sub_interface (c
, 0);
2371 resolve_generic_s (gfc_code
*c
)
2376 sym
= c
->symtree
->n
.sym
;
2380 m
= resolve_generic_s0 (c
, sym
);
2383 else if (m
== MATCH_ERROR
)
2387 if (sym
->ns
->parent
== NULL
)
2389 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2393 if (!generic_sym (sym
))
2397 /* Last ditch attempt. See if the reference is to an intrinsic
2398 that possesses a matching interface. 14.1.2.4 */
2399 sym
= c
->symtree
->n
.sym
;
2401 if (!gfc_intrinsic_name (sym
->name
, 1))
2403 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2404 sym
->name
, &c
->loc
);
2408 m
= gfc_intrinsic_sub_interface (c
, 0);
2412 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2413 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
2419 /* Set the name and binding label of the subroutine symbol in the call
2420 expression represented by 'c' to include the type and kind of the
2421 second parameter. This function is for resolving the appropriate
2422 version of c_f_pointer() and c_f_procpointer(). For example, a
2423 call to c_f_pointer() for a default integer pointer could have a
2424 name of c_f_pointer_i4. If no second arg exists, which is an error
2425 for these two functions, it defaults to the generic symbol's name
2426 and binding label. */
2429 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
2430 char *name
, char *binding_label
)
2432 gfc_expr
*arg
= NULL
;
2436 /* The second arg of c_f_pointer and c_f_procpointer determines
2437 the type and kind for the procedure name. */
2438 arg
= c
->ext
.actual
->next
->expr
;
2442 /* Set up the name to have the given symbol's name,
2443 plus the type and kind. */
2444 /* a derived type is marked with the type letter 'u' */
2445 if (arg
->ts
.type
== BT_DERIVED
)
2448 kind
= 0; /* set the kind as 0 for now */
2452 type
= gfc_type_letter (arg
->ts
.type
);
2453 kind
= arg
->ts
.kind
;
2456 if (arg
->ts
.type
== BT_CHARACTER
)
2457 /* Kind info for character strings not needed. */
2460 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
2461 /* Set up the binding label as the given symbol's label plus
2462 the type and kind. */
2463 sprintf (binding_label
, "%s_%c%d", sym
->binding_label
, type
, kind
);
2467 /* If the second arg is missing, set the name and label as
2468 was, cause it should at least be found, and the missing
2469 arg error will be caught by compare_parameters(). */
2470 sprintf (name
, "%s", sym
->name
);
2471 sprintf (binding_label
, "%s", sym
->binding_label
);
2478 /* Resolve a generic version of the iso_c_binding procedure given
2479 (sym) to the specific one based on the type and kind of the
2480 argument(s). Currently, this function resolves c_f_pointer() and
2481 c_f_procpointer based on the type and kind of the second argument
2482 (FPTR). Other iso_c_binding procedures aren't specially handled.
2483 Upon successfully exiting, c->resolved_sym will hold the resolved
2484 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2488 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
2490 gfc_symbol
*new_sym
;
2491 /* this is fine, since we know the names won't use the max */
2492 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2493 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2494 /* default to success; will override if find error */
2495 match m
= MATCH_YES
;
2497 /* Make sure the actual arguments are in the necessary order (based on the
2498 formal args) before resolving. */
2499 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
2501 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
2502 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
2504 set_name_and_label (c
, sym
, name
, binding_label
);
2506 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
2508 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
2510 /* Make sure we got a third arg if the second arg has non-zero
2511 rank. We must also check that the type and rank are
2512 correct since we short-circuit this check in
2513 gfc_procedure_use() (called above to sort actual args). */
2514 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
2516 if(c
->ext
.actual
->next
->next
== NULL
2517 || c
->ext
.actual
->next
->next
->expr
== NULL
)
2520 gfc_error ("Missing SHAPE parameter for call to %s "
2521 "at %L", sym
->name
, &(c
->loc
));
2523 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
2525 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
2528 gfc_error ("SHAPE parameter for call to %s at %L must "
2529 "be a rank 1 INTEGER array", sym
->name
,
2536 if (m
!= MATCH_ERROR
)
2538 /* the 1 means to add the optional arg to formal list */
2539 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
2541 /* for error reporting, say it's declared where the original was */
2542 new_sym
->declared_at
= sym
->declared_at
;
2547 /* no differences for c_loc or c_funloc */
2551 /* set the resolved symbol */
2552 if (m
!= MATCH_ERROR
)
2553 c
->resolved_sym
= new_sym
;
2555 c
->resolved_sym
= sym
;
2561 /* Resolve a subroutine call known to be specific. */
2564 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2568 /* See if we have an intrinsic interface. */
2569 if (sym
->interface
!= NULL
&& !sym
->interface
->attr
.abstract
2570 && !sym
->interface
->attr
.subroutine
)
2572 gfc_intrinsic_sym
*isym
;
2574 isym
= gfc_find_function (sym
->interface
->name
);
2576 /* Existance of isym should be checked already. */
2580 sym
->attr
.function
= 1;
2584 if(sym
->attr
.is_iso_c
)
2586 m
= gfc_iso_c_sub_interface (c
,sym
);
2590 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2592 if (sym
->attr
.dummy
)
2594 sym
->attr
.proc
= PROC_DUMMY
;
2598 sym
->attr
.proc
= PROC_EXTERNAL
;
2602 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
2605 if (sym
->attr
.intrinsic
)
2607 m
= gfc_intrinsic_sub_interface (c
, 1);
2611 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2612 "with an intrinsic", sym
->name
, &c
->loc
);
2620 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2622 c
->resolved_sym
= sym
;
2623 pure_subroutine (c
, sym
);
2630 resolve_specific_s (gfc_code
*c
)
2635 sym
= c
->symtree
->n
.sym
;
2639 m
= resolve_specific_s0 (c
, sym
);
2642 if (m
== MATCH_ERROR
)
2645 if (sym
->ns
->parent
== NULL
)
2648 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2654 sym
= c
->symtree
->n
.sym
;
2655 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2656 sym
->name
, &c
->loc
);
2662 /* Resolve a subroutine call not known to be generic nor specific. */
2665 resolve_unknown_s (gfc_code
*c
)
2669 sym
= c
->symtree
->n
.sym
;
2671 if (sym
->attr
.dummy
)
2673 sym
->attr
.proc
= PROC_DUMMY
;
2677 /* See if we have an intrinsic function reference. */
2679 if (gfc_intrinsic_name (sym
->name
, 1))
2681 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
2686 /* The reference is to an external name. */
2689 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2691 c
->resolved_sym
= sym
;
2693 pure_subroutine (c
, sym
);
2699 /* Resolve a subroutine call. Although it was tempting to use the same code
2700 for functions, subroutines and functions are stored differently and this
2701 makes things awkward. */
2704 resolve_call (gfc_code
*c
)
2707 procedure_type ptype
= PROC_INTRINSIC
;
2709 if (c
->symtree
&& c
->symtree
->n
.sym
2710 && c
->symtree
->n
.sym
->ts
.type
!= BT_UNKNOWN
)
2712 gfc_error ("'%s' at %L has a type, which is not consistent with "
2713 "the CALL at %L", c
->symtree
->n
.sym
->name
,
2714 &c
->symtree
->n
.sym
->declared_at
, &c
->loc
);
2718 /* If external, check for usage. */
2719 if (c
->symtree
&& is_external_proc (c
->symtree
->n
.sym
))
2720 resolve_global_procedure (c
->symtree
->n
.sym
, &c
->loc
, 1);
2722 /* Subroutines without the RECURSIVE attribution are not allowed to
2723 * call themselves. */
2724 if (c
->symtree
&& c
->symtree
->n
.sym
&& !c
->symtree
->n
.sym
->attr
.recursive
)
2726 gfc_symbol
*csym
, *proc
;
2727 csym
= c
->symtree
->n
.sym
;
2728 proc
= gfc_current_ns
->proc_name
;
2731 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2732 "RECURSIVE", csym
->name
, &c
->loc
);
2736 if (csym
->attr
.entry
&& csym
->ns
->entries
&& proc
->ns
->entries
2737 && csym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2739 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2740 "'%s' is not declared as RECURSIVE",
2741 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
2746 /* Switch off assumed size checking and do this again for certain kinds
2747 of procedure, once the procedure itself is resolved. */
2748 need_full_assumed_size
++;
2750 if (c
->symtree
&& c
->symtree
->n
.sym
)
2751 ptype
= c
->symtree
->n
.sym
->attr
.proc
;
2753 if (resolve_actual_arglist (c
->ext
.actual
, ptype
) == FAILURE
)
2756 /* Resume assumed_size checking. */
2757 need_full_assumed_size
--;
2760 if (c
->resolved_sym
== NULL
)
2761 switch (procedure_kind (c
->symtree
->n
.sym
))
2764 t
= resolve_generic_s (c
);
2767 case PTYPE_SPECIFIC
:
2768 t
= resolve_specific_s (c
);
2772 t
= resolve_unknown_s (c
);
2776 gfc_internal_error ("resolve_subroutine(): bad function type");
2779 /* Some checks of elemental subroutine actual arguments. */
2780 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
2784 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
2789 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2790 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2791 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2792 if their shapes do not match. If either op1->shape or op2->shape is
2793 NULL, return SUCCESS. */
2796 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
2803 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
2805 for (i
= 0; i
< op1
->rank
; i
++)
2807 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
2809 gfc_error ("Shapes for operands at %L and %L are not conformable",
2810 &op1
->where
, &op2
->where
);
2821 /* Resolve an operator expression node. This can involve replacing the
2822 operation with a user defined function call. */
2825 resolve_operator (gfc_expr
*e
)
2827 gfc_expr
*op1
, *op2
;
2829 bool dual_locus_error
;
2832 /* Resolve all subnodes-- give them types. */
2834 switch (e
->value
.op
.operator)
2837 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
2840 /* Fall through... */
2843 case INTRINSIC_UPLUS
:
2844 case INTRINSIC_UMINUS
:
2845 case INTRINSIC_PARENTHESES
:
2846 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
2851 /* Typecheck the new node. */
2853 op1
= e
->value
.op
.op1
;
2854 op2
= e
->value
.op
.op2
;
2855 dual_locus_error
= false;
2857 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
2858 || (op2
&& op2
->expr_type
== EXPR_NULL
))
2860 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
2864 switch (e
->value
.op
.operator)
2866 case INTRINSIC_UPLUS
:
2867 case INTRINSIC_UMINUS
:
2868 if (op1
->ts
.type
== BT_INTEGER
2869 || op1
->ts
.type
== BT_REAL
2870 || op1
->ts
.type
== BT_COMPLEX
)
2876 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
2877 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
2880 case INTRINSIC_PLUS
:
2881 case INTRINSIC_MINUS
:
2882 case INTRINSIC_TIMES
:
2883 case INTRINSIC_DIVIDE
:
2884 case INTRINSIC_POWER
:
2885 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2887 gfc_type_convert_binary (e
);
2892 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2893 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2894 gfc_typename (&op2
->ts
));
2897 case INTRINSIC_CONCAT
:
2898 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2900 e
->ts
.type
= BT_CHARACTER
;
2901 e
->ts
.kind
= op1
->ts
.kind
;
2906 _("Operands of string concatenation operator at %%L are %s/%s"),
2907 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
2913 case INTRINSIC_NEQV
:
2914 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2916 e
->ts
.type
= BT_LOGICAL
;
2917 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
2918 if (op1
->ts
.kind
< e
->ts
.kind
)
2919 gfc_convert_type (op1
, &e
->ts
, 2);
2920 else if (op2
->ts
.kind
< e
->ts
.kind
)
2921 gfc_convert_type (op2
, &e
->ts
, 2);
2925 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
2926 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2927 gfc_typename (&op2
->ts
));
2932 if (op1
->ts
.type
== BT_LOGICAL
)
2934 e
->ts
.type
= BT_LOGICAL
;
2935 e
->ts
.kind
= op1
->ts
.kind
;
2939 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
2940 gfc_typename (&op1
->ts
));
2944 case INTRINSIC_GT_OS
:
2946 case INTRINSIC_GE_OS
:
2948 case INTRINSIC_LT_OS
:
2950 case INTRINSIC_LE_OS
:
2951 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
2953 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
2957 /* Fall through... */
2960 case INTRINSIC_EQ_OS
:
2962 case INTRINSIC_NE_OS
:
2963 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2965 e
->ts
.type
= BT_LOGICAL
;
2966 e
->ts
.kind
= gfc_default_logical_kind
;
2970 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2972 gfc_type_convert_binary (e
);
2974 e
->ts
.type
= BT_LOGICAL
;
2975 e
->ts
.kind
= gfc_default_logical_kind
;
2979 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2981 _("Logicals at %%L must be compared with %s instead of %s"),
2982 (e
->value
.op
.operator == INTRINSIC_EQ
2983 || e
->value
.op
.operator == INTRINSIC_EQ_OS
)
2984 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.operator));
2987 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2988 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2989 gfc_typename (&op2
->ts
));
2993 case INTRINSIC_USER
:
2994 if (e
->value
.op
.uop
->operator == NULL
)
2995 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
2996 else if (op2
== NULL
)
2997 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
2998 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3000 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3001 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3002 gfc_typename (&op2
->ts
));
3006 case INTRINSIC_PARENTHESES
:
3008 if (e
->ts
.type
== BT_CHARACTER
)
3009 e
->ts
.cl
= op1
->ts
.cl
;
3013 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3016 /* Deal with arrayness of an operand through an operator. */
3020 switch (e
->value
.op
.operator)
3022 case INTRINSIC_PLUS
:
3023 case INTRINSIC_MINUS
:
3024 case INTRINSIC_TIMES
:
3025 case INTRINSIC_DIVIDE
:
3026 case INTRINSIC_POWER
:
3027 case INTRINSIC_CONCAT
:
3031 case INTRINSIC_NEQV
:
3033 case INTRINSIC_EQ_OS
:
3035 case INTRINSIC_NE_OS
:
3037 case INTRINSIC_GT_OS
:
3039 case INTRINSIC_GE_OS
:
3041 case INTRINSIC_LT_OS
:
3043 case INTRINSIC_LE_OS
:
3045 if (op1
->rank
== 0 && op2
->rank
== 0)
3048 if (op1
->rank
== 0 && op2
->rank
!= 0)
3050 e
->rank
= op2
->rank
;
3052 if (e
->shape
== NULL
)
3053 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3056 if (op1
->rank
!= 0 && op2
->rank
== 0)
3058 e
->rank
= op1
->rank
;
3060 if (e
->shape
== NULL
)
3061 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3064 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3066 if (op1
->rank
== op2
->rank
)
3068 e
->rank
= op1
->rank
;
3069 if (e
->shape
== NULL
)
3071 t
= compare_shapes(op1
, op2
);
3075 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3080 /* Allow higher level expressions to work. */
3083 /* Try user-defined operators, and otherwise throw an error. */
3084 dual_locus_error
= true;
3086 _("Inconsistent ranks for operator at %%L and %%L"));
3093 case INTRINSIC_PARENTHESES
:
3095 case INTRINSIC_UPLUS
:
3096 case INTRINSIC_UMINUS
:
3097 /* Simply copy arrayness attribute */
3098 e
->rank
= op1
->rank
;
3100 if (e
->shape
== NULL
)
3101 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3109 /* Attempt to simplify the expression. */
3112 t
= gfc_simplify_expr (e
, 0);
3113 /* Some calls do not succeed in simplification and return FAILURE
3114 even though there is no error; eg. variable references to
3115 PARAMETER arrays. */
3116 if (!gfc_is_constant_expr (e
))
3123 if (gfc_extend_expr (e
) == SUCCESS
)
3126 if (dual_locus_error
)
3127 gfc_error (msg
, &op1
->where
, &op2
->where
);
3129 gfc_error (msg
, &e
->where
);
3135 /************** Array resolution subroutines **************/
3138 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3141 /* Compare two integer expressions. */
3144 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3148 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3149 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3152 /* If either of the types isn't INTEGER, we must have
3153 raised an error earlier. */
3155 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3158 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3168 /* Compare an integer expression with an integer. */
3171 compare_bound_int (gfc_expr
*a
, int b
)
3175 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3178 if (a
->ts
.type
!= BT_INTEGER
)
3179 gfc_internal_error ("compare_bound_int(): Bad expression");
3181 i
= mpz_cmp_si (a
->value
.integer
, b
);
3191 /* Compare an integer expression with a mpz_t. */
3194 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3198 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3201 if (a
->ts
.type
!= BT_INTEGER
)
3202 gfc_internal_error ("compare_bound_int(): Bad expression");
3204 i
= mpz_cmp (a
->value
.integer
, b
);
3214 /* Compute the last value of a sequence given by a triplet.
3215 Return 0 if it wasn't able to compute the last value, or if the
3216 sequence if empty, and 1 otherwise. */
3219 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3220 gfc_expr
*stride
, mpz_t last
)
3224 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3225 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3226 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3229 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3230 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3233 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
3235 if (compare_bound (start
, end
) == CMP_GT
)
3237 mpz_set (last
, end
->value
.integer
);
3241 if (compare_bound_int (stride
, 0) == CMP_GT
)
3243 /* Stride is positive */
3244 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3249 /* Stride is negative */
3250 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3255 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3256 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3257 mpz_sub (last
, end
->value
.integer
, rem
);
3264 /* Compare a single dimension of an array reference to the array
3268 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3272 /* Given start, end and stride values, calculate the minimum and
3273 maximum referenced indexes. */
3275 switch (ar
->dimen_type
[i
])
3281 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3283 gfc_warning ("Array reference at %L is out of bounds "
3284 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3285 mpz_get_si (ar
->start
[i
]->value
.integer
),
3286 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3289 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3291 gfc_warning ("Array reference at %L is out of bounds "
3292 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3293 mpz_get_si (ar
->start
[i
]->value
.integer
),
3294 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3302 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3303 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3305 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3307 /* Check for zero stride, which is not allowed. */
3308 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3310 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3314 /* if start == len || (stride > 0 && start < len)
3315 || (stride < 0 && start > len),
3316 then the array section contains at least one element. In this
3317 case, there is an out-of-bounds access if
3318 (start < lower || start > upper). */
3319 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3320 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3321 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3322 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3323 && comp_start_end
== CMP_GT
))
3325 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3327 gfc_warning ("Lower array reference at %L is out of bounds "
3328 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3329 mpz_get_si (AR_START
->value
.integer
),
3330 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3333 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3335 gfc_warning ("Lower array reference at %L is out of bounds "
3336 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3337 mpz_get_si (AR_START
->value
.integer
),
3338 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3343 /* If we can compute the highest index of the array section,
3344 then it also has to be between lower and upper. */
3345 mpz_init (last_value
);
3346 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
3349 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
3351 gfc_warning ("Upper array reference at %L is out of bounds "
3352 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3353 mpz_get_si (last_value
),
3354 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3355 mpz_clear (last_value
);
3358 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
3360 gfc_warning ("Upper array reference at %L is out of bounds "
3361 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3362 mpz_get_si (last_value
),
3363 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3364 mpz_clear (last_value
);
3368 mpz_clear (last_value
);
3376 gfc_internal_error ("check_dimension(): Bad array reference");
3383 /* Compare an array reference with an array specification. */
3386 compare_spec_to_ref (gfc_array_ref
*ar
)
3393 /* TODO: Full array sections are only allowed as actual parameters. */
3394 if (as
->type
== AS_ASSUMED_SIZE
3395 && (/*ar->type == AR_FULL
3396 ||*/ (ar
->type
== AR_SECTION
3397 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
3399 gfc_error ("Rightmost upper bound of assumed size array section "
3400 "not specified at %L", &ar
->where
);
3404 if (ar
->type
== AR_FULL
)
3407 if (as
->rank
!= ar
->dimen
)
3409 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3410 &ar
->where
, ar
->dimen
, as
->rank
);
3414 for (i
= 0; i
< as
->rank
; i
++)
3415 if (check_dimension (i
, ar
, as
) == FAILURE
)
3422 /* Resolve one part of an array index. */
3425 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
3432 if (gfc_resolve_expr (index
) == FAILURE
)
3435 if (check_scalar
&& index
->rank
!= 0)
3437 gfc_error ("Array index at %L must be scalar", &index
->where
);
3441 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
3443 gfc_error ("Array index at %L must be of INTEGER type",
3448 if (index
->ts
.type
== BT_REAL
)
3449 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
3450 &index
->where
) == FAILURE
)
3453 if (index
->ts
.kind
!= gfc_index_integer_kind
3454 || index
->ts
.type
!= BT_INTEGER
)
3457 ts
.type
= BT_INTEGER
;
3458 ts
.kind
= gfc_index_integer_kind
;
3460 gfc_convert_type_warn (index
, &ts
, 2, 0);
3466 /* Resolve a dim argument to an intrinsic function. */
3469 gfc_resolve_dim_arg (gfc_expr
*dim
)
3474 if (gfc_resolve_expr (dim
) == FAILURE
)
3479 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
3484 if (dim
->ts
.type
!= BT_INTEGER
)
3486 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
3490 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
3494 ts
.type
= BT_INTEGER
;
3495 ts
.kind
= gfc_index_integer_kind
;
3497 gfc_convert_type_warn (dim
, &ts
, 2, 0);
3503 /* Given an expression that contains array references, update those array
3504 references to point to the right array specifications. While this is
3505 filled in during matching, this information is difficult to save and load
3506 in a module, so we take care of it here.
3508 The idea here is that the original array reference comes from the
3509 base symbol. We traverse the list of reference structures, setting
3510 the stored reference to references. Component references can
3511 provide an additional array specification. */
3514 find_array_spec (gfc_expr
*e
)
3518 gfc_symbol
*derived
;
3521 as
= e
->symtree
->n
.sym
->as
;
3524 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3529 gfc_internal_error ("find_array_spec(): Missing spec");
3536 if (derived
== NULL
)
3537 derived
= e
->symtree
->n
.sym
->ts
.derived
;
3539 c
= derived
->components
;
3541 for (; c
; c
= c
->next
)
3542 if (c
== ref
->u
.c
.component
)
3544 /* Track the sequence of component references. */
3545 if (c
->ts
.type
== BT_DERIVED
)
3546 derived
= c
->ts
.derived
;
3551 gfc_internal_error ("find_array_spec(): Component not found");
3556 gfc_internal_error ("find_array_spec(): unused as(1)");
3567 gfc_internal_error ("find_array_spec(): unused as(2)");
3571 /* Resolve an array reference. */
3574 resolve_array_ref (gfc_array_ref
*ar
)
3576 int i
, check_scalar
;
3579 for (i
= 0; i
< ar
->dimen
; i
++)
3581 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
3583 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
3585 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
3587 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
3592 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
3596 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3600 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
3601 if (e
->expr_type
== EXPR_VARIABLE
3602 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
3603 ar
->start
[i
] = gfc_get_parentheses (e
);
3607 gfc_error ("Array index at %L is an array of rank %d",
3608 &ar
->c_where
[i
], e
->rank
);
3613 /* If the reference type is unknown, figure out what kind it is. */
3615 if (ar
->type
== AR_UNKNOWN
)
3617 ar
->type
= AR_ELEMENT
;
3618 for (i
= 0; i
< ar
->dimen
; i
++)
3619 if (ar
->dimen_type
[i
] == DIMEN_RANGE
3620 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3622 ar
->type
= AR_SECTION
;
3627 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
3635 resolve_substring (gfc_ref
*ref
)
3637 if (ref
->u
.ss
.start
!= NULL
)
3639 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
3642 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
3644 gfc_error ("Substring start index at %L must be of type INTEGER",
3645 &ref
->u
.ss
.start
->where
);
3649 if (ref
->u
.ss
.start
->rank
!= 0)
3651 gfc_error ("Substring start index at %L must be scalar",
3652 &ref
->u
.ss
.start
->where
);
3656 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
3657 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3658 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3660 gfc_error ("Substring start index at %L is less than one",
3661 &ref
->u
.ss
.start
->where
);
3666 if (ref
->u
.ss
.end
!= NULL
)
3668 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
3671 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
3673 gfc_error ("Substring end index at %L must be of type INTEGER",
3674 &ref
->u
.ss
.end
->where
);
3678 if (ref
->u
.ss
.end
->rank
!= 0)
3680 gfc_error ("Substring end index at %L must be scalar",
3681 &ref
->u
.ss
.end
->where
);
3685 if (ref
->u
.ss
.length
!= NULL
3686 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
3687 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3688 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3690 gfc_error ("Substring end index at %L exceeds the string length",
3691 &ref
->u
.ss
.start
->where
);
3700 /* This function supplies missing substring charlens. */
3703 gfc_resolve_substring_charlen (gfc_expr
*e
)
3706 gfc_expr
*start
, *end
;
3708 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
3709 if (char_ref
->type
== REF_SUBSTRING
)
3715 gcc_assert (char_ref
->next
== NULL
);
3719 if (e
->ts
.cl
->length
)
3720 gfc_free_expr (e
->ts
.cl
->length
);
3721 else if (e
->expr_type
== EXPR_VARIABLE
3722 && e
->symtree
->n
.sym
->attr
.dummy
)
3726 e
->ts
.type
= BT_CHARACTER
;
3727 e
->ts
.kind
= gfc_default_character_kind
;
3731 e
->ts
.cl
= gfc_get_charlen ();
3732 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
3733 gfc_current_ns
->cl_list
= e
->ts
.cl
;
3736 if (char_ref
->u
.ss
.start
)
3737 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
3739 start
= gfc_int_expr (1);
3741 if (char_ref
->u
.ss
.end
)
3742 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
3743 else if (e
->expr_type
== EXPR_VARIABLE
)
3744 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.cl
->length
);
3751 /* Length = (end - start +1). */
3752 e
->ts
.cl
->length
= gfc_subtract (end
, start
);
3753 e
->ts
.cl
->length
= gfc_add (e
->ts
.cl
->length
, gfc_int_expr (1));
3755 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
3756 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
3758 /* Make sure that the length is simplified. */
3759 gfc_simplify_expr (e
->ts
.cl
->length
, 1);
3760 gfc_resolve_expr (e
->ts
.cl
->length
);
3764 /* Resolve subtype references. */
3767 resolve_ref (gfc_expr
*expr
)
3769 int current_part_dimension
, n_components
, seen_part_dimension
;
3772 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3773 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
3775 find_array_spec (expr
);
3779 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3783 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
3791 resolve_substring (ref
);
3795 /* Check constraints on part references. */
3797 current_part_dimension
= 0;
3798 seen_part_dimension
= 0;
3801 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3806 switch (ref
->u
.ar
.type
)
3810 current_part_dimension
= 1;
3814 current_part_dimension
= 0;
3818 gfc_internal_error ("resolve_ref(): Bad array reference");
3824 if (current_part_dimension
|| seen_part_dimension
)
3826 if (ref
->u
.c
.component
->pointer
)
3828 gfc_error ("Component to the right of a part reference "
3829 "with nonzero rank must not have the POINTER "
3830 "attribute at %L", &expr
->where
);
3833 else if (ref
->u
.c
.component
->allocatable
)
3835 gfc_error ("Component to the right of a part reference "
3836 "with nonzero rank must not have the ALLOCATABLE "
3837 "attribute at %L", &expr
->where
);
3849 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
3850 || ref
->next
== NULL
)
3851 && current_part_dimension
3852 && seen_part_dimension
)
3854 gfc_error ("Two or more part references with nonzero rank must "
3855 "not be specified at %L", &expr
->where
);
3859 if (ref
->type
== REF_COMPONENT
)
3861 if (current_part_dimension
)
3862 seen_part_dimension
= 1;
3864 /* reset to make sure */
3865 current_part_dimension
= 0;
3873 /* Given an expression, determine its shape. This is easier than it sounds.
3874 Leaves the shape array NULL if it is not possible to determine the shape. */
3877 expression_shape (gfc_expr
*e
)
3879 mpz_t array
[GFC_MAX_DIMENSIONS
];
3882 if (e
->rank
== 0 || e
->shape
!= NULL
)
3885 for (i
= 0; i
< e
->rank
; i
++)
3886 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
3889 e
->shape
= gfc_get_shape (e
->rank
);
3891 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
3896 for (i
--; i
>= 0; i
--)
3897 mpz_clear (array
[i
]);
3901 /* Given a variable expression node, compute the rank of the expression by
3902 examining the base symbol and any reference structures it may have. */
3905 expression_rank (gfc_expr
*e
)
3912 if (e
->expr_type
== EXPR_ARRAY
)
3914 /* Constructors can have a rank different from one via RESHAPE(). */
3916 if (e
->symtree
== NULL
)
3922 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
3923 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
3929 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3931 if (ref
->type
!= REF_ARRAY
)
3934 if (ref
->u
.ar
.type
== AR_FULL
)
3936 rank
= ref
->u
.ar
.as
->rank
;
3940 if (ref
->u
.ar
.type
== AR_SECTION
)
3942 /* Figure out the rank of the section. */
3944 gfc_internal_error ("expression_rank(): Two array specs");
3946 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3947 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
3948 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
3958 expression_shape (e
);
3962 /* Resolve a variable expression. */
3965 resolve_variable (gfc_expr
*e
)
3972 if (e
->symtree
== NULL
)
3975 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
3978 sym
= e
->symtree
->n
.sym
;
3979 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
3981 e
->ts
.type
= BT_PROCEDURE
;
3985 if (sym
->ts
.type
!= BT_UNKNOWN
)
3986 gfc_variable_attr (e
, &e
->ts
);
3989 /* Must be a simple variable reference. */
3990 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
3995 if (check_assumed_size_reference (sym
, e
))
3998 /* Deal with forward references to entries during resolve_code, to
3999 satisfy, at least partially, 12.5.2.5. */
4000 if (gfc_current_ns
->entries
4001 && current_entry_id
== sym
->entry_id
4004 && cs_base
->current
->op
!= EXEC_ENTRY
)
4006 gfc_entry_list
*entry
;
4007 gfc_formal_arglist
*formal
;
4011 /* If the symbol is a dummy... */
4012 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4014 entry
= gfc_current_ns
->entries
;
4017 /* ...test if the symbol is a parameter of previous entries. */
4018 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4019 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4021 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4025 /* If it has not been seen as a dummy, this is an error. */
4028 if (specification_expr
)
4029 gfc_error ("Variable '%s', used in a specification expression"
4030 ", is referenced at %L before the ENTRY statement "
4031 "in which it is a parameter",
4032 sym
->name
, &cs_base
->current
->loc
);
4034 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4035 "statement in which it is a parameter",
4036 sym
->name
, &cs_base
->current
->loc
);
4041 /* Now do the same check on the specification expressions. */
4042 specification_expr
= 1;
4043 if (sym
->ts
.type
== BT_CHARACTER
4044 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
4048 for (n
= 0; n
< sym
->as
->rank
; n
++)
4050 specification_expr
= 1;
4051 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
4053 specification_expr
= 1;
4054 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
4057 specification_expr
= 0;
4060 /* Update the symbol's entry level. */
4061 sym
->entry_id
= current_entry_id
+ 1;
4068 /* Checks to see that the correct symbol has been host associated.
4069 The only situation where this arises is that in which a twice
4070 contained function is parsed after the host association is made.
4071 Therefore, on detecting this, the line is rematched, having got
4072 rid of the existing references and actual_arg_list. */
4074 check_host_association (gfc_expr
*e
)
4076 gfc_symbol
*sym
, *old_sym
;
4080 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
4082 if (e
->symtree
== NULL
|| e
->symtree
->n
.sym
== NULL
)
4085 old_sym
= e
->symtree
->n
.sym
;
4087 if (old_sym
->attr
.use_assoc
)
4090 if (gfc_current_ns
->parent
4091 && old_sym
->ns
!= gfc_current_ns
)
4093 gfc_find_symbol (old_sym
->name
, gfc_current_ns
, 1, &sym
);
4094 if (sym
&& old_sym
!= sym
4095 && sym
->attr
.flavor
== FL_PROCEDURE
4096 && sym
->attr
.contained
)
4098 temp_locus
= gfc_current_locus
;
4099 gfc_current_locus
= e
->where
;
4101 gfc_buffer_error (1);
4103 gfc_free_ref_list (e
->ref
);
4108 gfc_free_actual_arglist (e
->value
.function
.actual
);
4109 e
->value
.function
.actual
= NULL
;
4112 if (e
->shape
!= NULL
)
4114 for (n
= 0; n
< e
->rank
; n
++)
4115 mpz_clear (e
->shape
[n
]);
4117 gfc_free (e
->shape
);
4120 gfc_match_rvalue (&expr
);
4122 gfc_buffer_error (0);
4124 gcc_assert (expr
&& sym
== expr
->symtree
->n
.sym
);
4130 gfc_current_locus
= temp_locus
;
4133 /* This might have changed! */
4134 return e
->expr_type
== EXPR_FUNCTION
;
4139 gfc_resolve_character_operator (gfc_expr
*e
)
4141 gfc_expr
*op1
= e
->value
.op
.op1
;
4142 gfc_expr
*op2
= e
->value
.op
.op2
;
4143 gfc_expr
*e1
= NULL
;
4144 gfc_expr
*e2
= NULL
;
4146 gcc_assert (e
->value
.op
.operator == INTRINSIC_CONCAT
);
4148 if (op1
->ts
.cl
&& op1
->ts
.cl
->length
)
4149 e1
= gfc_copy_expr (op1
->ts
.cl
->length
);
4150 else if (op1
->expr_type
== EXPR_CONSTANT
)
4151 e1
= gfc_int_expr (op1
->value
.character
.length
);
4153 if (op2
->ts
.cl
&& op2
->ts
.cl
->length
)
4154 e2
= gfc_copy_expr (op2
->ts
.cl
->length
);
4155 else if (op2
->expr_type
== EXPR_CONSTANT
)
4156 e2
= gfc_int_expr (op2
->value
.character
.length
);
4158 e
->ts
.cl
= gfc_get_charlen ();
4159 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4160 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4165 e
->ts
.cl
->length
= gfc_add (e1
, e2
);
4166 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
4167 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
4168 gfc_simplify_expr (e
->ts
.cl
->length
, 0);
4169 gfc_resolve_expr (e
->ts
.cl
->length
);
4175 /* Ensure that an character expression has a charlen and, if possible, a
4176 length expression. */
4179 fixup_charlen (gfc_expr
*e
)
4181 /* The cases fall through so that changes in expression type and the need
4182 for multiple fixes are picked up. In all circumstances, a charlen should
4183 be available for the middle end to hang a backend_decl on. */
4184 switch (e
->expr_type
)
4187 gfc_resolve_character_operator (e
);
4190 if (e
->expr_type
== EXPR_ARRAY
)
4191 gfc_resolve_character_array_constructor (e
);
4193 case EXPR_SUBSTRING
:
4194 if (!e
->ts
.cl
&& e
->ref
)
4195 gfc_resolve_substring_charlen (e
);
4200 e
->ts
.cl
= gfc_get_charlen ();
4201 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4202 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4210 /* Resolve an expression. That is, make sure that types of operands agree
4211 with their operators, intrinsic operators are converted to function calls
4212 for overloaded types and unresolved function references are resolved. */
4215 gfc_resolve_expr (gfc_expr
*e
)
4222 switch (e
->expr_type
)
4225 t
= resolve_operator (e
);
4231 if (check_host_association (e
))
4232 t
= resolve_function (e
);
4235 t
= resolve_variable (e
);
4237 expression_rank (e
);
4240 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.cl
== NULL
&& e
->ref
4241 && e
->ref
->type
!= REF_SUBSTRING
)
4242 gfc_resolve_substring_charlen (e
);
4246 case EXPR_SUBSTRING
:
4247 t
= resolve_ref (e
);
4257 if (resolve_ref (e
) == FAILURE
)
4260 t
= gfc_resolve_array_constructor (e
);
4261 /* Also try to expand a constructor. */
4264 expression_rank (e
);
4265 gfc_expand_constructor (e
);
4268 /* This provides the opportunity for the length of constructors with
4269 character valued function elements to propagate the string length
4270 to the expression. */
4271 if (e
->ts
.type
== BT_CHARACTER
)
4272 gfc_resolve_character_array_constructor (e
);
4276 case EXPR_STRUCTURE
:
4277 t
= resolve_ref (e
);
4281 t
= resolve_structure_cons (e
);
4285 t
= gfc_simplify_expr (e
, 0);
4289 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4292 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.cl
)
4299 /* Resolve an expression from an iterator. They must be scalar and have
4300 INTEGER or (optionally) REAL type. */
4303 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
4304 const char *name_msgid
)
4306 if (gfc_resolve_expr (expr
) == FAILURE
)
4309 if (expr
->rank
!= 0)
4311 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
4315 if (expr
->ts
.type
!= BT_INTEGER
)
4317 if (expr
->ts
.type
== BT_REAL
)
4320 return gfc_notify_std (GFC_STD_F95_DEL
,
4321 "Deleted feature: %s at %L must be integer",
4322 _(name_msgid
), &expr
->where
);
4325 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
4332 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
4340 /* Resolve the expressions in an iterator structure. If REAL_OK is
4341 false allow only INTEGER type iterators, otherwise allow REAL types. */
4344 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
4346 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
4350 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
4352 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4357 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
4358 "Start expression in DO loop") == FAILURE
)
4361 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
4362 "End expression in DO loop") == FAILURE
)
4365 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
4366 "Step expression in DO loop") == FAILURE
)
4369 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
4371 if ((iter
->step
->ts
.type
== BT_INTEGER
4372 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
4373 || (iter
->step
->ts
.type
== BT_REAL
4374 && mpfr_sgn (iter
->step
->value
.real
) == 0))
4376 gfc_error ("Step expression in DO loop at %L cannot be zero",
4377 &iter
->step
->where
);
4382 /* Convert start, end, and step to the same type as var. */
4383 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
4384 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
4385 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4387 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
4388 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
4389 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4391 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
4392 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
4393 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
4399 /* Traversal function for find_forall_index. f == 2 signals that
4400 that variable itself is not to be checked - only the references. */
4403 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
4405 if (expr
->expr_type
!= EXPR_VARIABLE
)
4408 /* A scalar assignment */
4409 if (!expr
->ref
|| *f
== 1)
4411 if (expr
->symtree
->n
.sym
== sym
)
4423 /* Check whether the FORALL index appears in the expression or not.
4424 Returns SUCCESS if SYM is found in EXPR. */
4427 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
4429 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
4436 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4437 to be a scalar INTEGER variable. The subscripts and stride are scalar
4438 INTEGERs, and if stride is a constant it must be nonzero.
4439 Furthermore "A subscript or stride in a forall-triplet-spec shall
4440 not contain a reference to any index-name in the
4441 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4444 resolve_forall_iterators (gfc_forall_iterator
*it
)
4446 gfc_forall_iterator
*iter
, *iter2
;
4448 for (iter
= it
; iter
; iter
= iter
->next
)
4450 if (gfc_resolve_expr (iter
->var
) == SUCCESS
4451 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
4452 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4455 if (gfc_resolve_expr (iter
->start
) == SUCCESS
4456 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
4457 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4458 &iter
->start
->where
);
4459 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
4460 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4462 if (gfc_resolve_expr (iter
->end
) == SUCCESS
4463 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
4464 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4466 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
4467 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4469 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
4471 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
4472 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4473 &iter
->stride
->where
, "INTEGER");
4475 if (iter
->stride
->expr_type
== EXPR_CONSTANT
4476 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
4477 gfc_error ("FORALL stride expression at %L cannot be zero",
4478 &iter
->stride
->where
);
4480 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
4481 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
4484 for (iter
= it
; iter
; iter
= iter
->next
)
4485 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
4487 if (find_forall_index (iter2
->start
,
4488 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
4489 || find_forall_index (iter2
->end
,
4490 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
4491 || find_forall_index (iter2
->stride
,
4492 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
4493 gfc_error ("FORALL index '%s' may not appear in triplet "
4494 "specification at %L", iter
->var
->symtree
->name
,
4495 &iter2
->start
->where
);
4500 /* Given a pointer to a symbol that is a derived type, see if it's
4501 inaccessible, i.e. if it's defined in another module and the components are
4502 PRIVATE. The search is recursive if necessary. Returns zero if no
4503 inaccessible components are found, nonzero otherwise. */
4506 derived_inaccessible (gfc_symbol
*sym
)
4510 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
4513 for (c
= sym
->components
; c
; c
= c
->next
)
4515 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
4523 /* Resolve the argument of a deallocate expression. The expression must be
4524 a pointer or a full array. */
4527 resolve_deallocate_expr (gfc_expr
*e
)
4529 symbol_attribute attr
;
4530 int allocatable
, pointer
, check_intent_in
;
4533 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4534 check_intent_in
= 1;
4536 if (gfc_resolve_expr (e
) == FAILURE
)
4539 if (e
->expr_type
!= EXPR_VARIABLE
)
4542 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
4543 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
4544 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4547 check_intent_in
= 0;
4552 if (ref
->u
.ar
.type
!= AR_FULL
)
4557 allocatable
= (ref
->u
.c
.component
->as
!= NULL
4558 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
4559 pointer
= ref
->u
.c
.component
->pointer
;
4568 attr
= gfc_expr_attr (e
);
4570 if (allocatable
== 0 && attr
.pointer
== 0)
4573 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4574 "ALLOCATABLE or a POINTER", &e
->where
);
4578 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
4580 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4581 e
->symtree
->n
.sym
->name
, &e
->where
);
4589 /* Returns true if the expression e contains a reference to the symbol sym. */
4591 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
4593 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
4600 find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
4602 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
4606 /* Given the expression node e for an allocatable/pointer of derived type to be
4607 allocated, get the expression node to be initialized afterwards (needed for
4608 derived types with default initializers, and derived types with allocatable
4609 components that need nullification.) */
4612 expr_to_initialize (gfc_expr
*e
)
4618 result
= gfc_copy_expr (e
);
4620 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4621 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
4622 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
4624 ref
->u
.ar
.type
= AR_FULL
;
4626 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4627 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
4629 result
->rank
= ref
->u
.ar
.dimen
;
4637 /* Resolve the expression in an ALLOCATE statement, doing the additional
4638 checks to see whether the expression is OK or not. The expression must
4639 have a trailing array reference that gives the size of the array. */
4642 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
4644 int i
, pointer
, allocatable
, dimension
, check_intent_in
;
4645 symbol_attribute attr
;
4646 gfc_ref
*ref
, *ref2
;
4653 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4654 check_intent_in
= 1;
4656 if (gfc_resolve_expr (e
) == FAILURE
)
4659 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
4660 sym
= code
->expr
->symtree
->n
.sym
;
4664 /* Make sure the expression is allocatable or a pointer. If it is
4665 pointer, the next-to-last reference must be a pointer. */
4669 if (e
->expr_type
!= EXPR_VARIABLE
)
4672 attr
= gfc_expr_attr (e
);
4673 pointer
= attr
.pointer
;
4674 dimension
= attr
.dimension
;
4678 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
4679 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
4680 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
4682 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
4684 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4685 "not be allocated in the same statement at %L",
4686 sym
->name
, &e
->where
);
4690 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
4693 check_intent_in
= 0;
4698 if (ref
->next
!= NULL
)
4703 allocatable
= (ref
->u
.c
.component
->as
!= NULL
4704 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
4706 pointer
= ref
->u
.c
.component
->pointer
;
4707 dimension
= ref
->u
.c
.component
->dimension
;
4718 if (allocatable
== 0 && pointer
== 0)
4720 gfc_error ("Expression in ALLOCATE statement at %L must be "
4721 "ALLOCATABLE or a POINTER", &e
->where
);
4726 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
4728 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4729 e
->symtree
->n
.sym
->name
, &e
->where
);
4733 /* Add default initializer for those derived types that need them. */
4734 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
4736 init_st
= gfc_get_code ();
4737 init_st
->loc
= code
->loc
;
4738 init_st
->op
= EXEC_INIT_ASSIGN
;
4739 init_st
->expr
= expr_to_initialize (e
);
4740 init_st
->expr2
= init_e
;
4741 init_st
->next
= code
->next
;
4742 code
->next
= init_st
;
4745 if (pointer
&& dimension
== 0)
4748 /* Make sure the next-to-last reference node is an array specification. */
4750 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
4752 gfc_error ("Array specification required in ALLOCATE statement "
4753 "at %L", &e
->where
);
4757 /* Make sure that the array section reference makes sense in the
4758 context of an ALLOCATE specification. */
4762 for (i
= 0; i
< ar
->dimen
; i
++)
4764 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
4767 switch (ar
->dimen_type
[i
])
4773 if (ar
->start
[i
] != NULL
4774 && ar
->end
[i
] != NULL
4775 && ar
->stride
[i
] == NULL
)
4778 /* Fall Through... */
4782 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4789 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
4791 sym
= a
->expr
->symtree
->n
.sym
;
4793 /* TODO - check derived type components. */
4794 if (sym
->ts
.type
== BT_DERIVED
)
4797 if ((ar
->start
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->start
[i
]))
4798 || (ar
->end
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->end
[i
])))
4800 gfc_error ("'%s' must not appear an the array specification at "
4801 "%L in the same ALLOCATE statement where it is "
4802 "itself allocated", sym
->name
, &ar
->where
);
4812 /************ SELECT CASE resolution subroutines ************/
4814 /* Callback function for our mergesort variant. Determines interval
4815 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4816 op1 > op2. Assumes we're not dealing with the default case.
4817 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4818 There are nine situations to check. */
4821 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
4825 if (op1
->low
== NULL
) /* op1 = (:L) */
4827 /* op2 = (:N), so overlap. */
4829 /* op2 = (M:) or (M:N), L < M */
4830 if (op2
->low
!= NULL
4831 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
4834 else if (op1
->high
== NULL
) /* op1 = (K:) */
4836 /* op2 = (M:), so overlap. */
4838 /* op2 = (:N) or (M:N), K > N */
4839 if (op2
->high
!= NULL
4840 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
4843 else /* op1 = (K:L) */
4845 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
4846 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
4848 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
4849 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
4851 else /* op2 = (M:N) */
4855 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
4858 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
4867 /* Merge-sort a double linked case list, detecting overlap in the
4868 process. LIST is the head of the double linked case list before it
4869 is sorted. Returns the head of the sorted list if we don't see any
4870 overlap, or NULL otherwise. */
4873 check_case_overlap (gfc_case
*list
)
4875 gfc_case
*p
, *q
, *e
, *tail
;
4876 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
4878 /* If the passed list was empty, return immediately. */
4885 /* Loop unconditionally. The only exit from this loop is a return
4886 statement, when we've finished sorting the case list. */
4893 /* Count the number of merges we do in this pass. */
4896 /* Loop while there exists a merge to be done. */
4901 /* Count this merge. */
4904 /* Cut the list in two pieces by stepping INSIZE places
4905 forward in the list, starting from P. */
4908 for (i
= 0; i
< insize
; i
++)
4917 /* Now we have two lists. Merge them! */
4918 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
4920 /* See from which the next case to merge comes from. */
4923 /* P is empty so the next case must come from Q. */
4928 else if (qsize
== 0 || q
== NULL
)
4937 cmp
= compare_cases (p
, q
);
4940 /* The whole case range for P is less than the
4948 /* The whole case range for Q is greater than
4949 the case range for P. */
4956 /* The cases overlap, or they are the same
4957 element in the list. Either way, we must
4958 issue an error and get the next case from P. */
4959 /* FIXME: Sort P and Q by line number. */
4960 gfc_error ("CASE label at %L overlaps with CASE "
4961 "label at %L", &p
->where
, &q
->where
);
4969 /* Add the next element to the merged list. */
4978 /* P has now stepped INSIZE places along, and so has Q. So
4979 they're the same. */
4984 /* If we have done only one merge or none at all, we've
4985 finished sorting the cases. */
4994 /* Otherwise repeat, merging lists twice the size. */
5000 /* Check to see if an expression is suitable for use in a CASE statement.
5001 Makes sure that all case expressions are scalar constants of the same
5002 type. Return FAILURE if anything is wrong. */
5005 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
5007 if (e
== NULL
) return SUCCESS
;
5009 if (e
->ts
.type
!= case_expr
->ts
.type
)
5011 gfc_error ("Expression in CASE statement at %L must be of type %s",
5012 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
5016 /* C805 (R808) For a given case-construct, each case-value shall be of
5017 the same type as case-expr. For character type, length differences
5018 are allowed, but the kind type parameters shall be the same. */
5020 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
5022 gfc_error("Expression in CASE statement at %L must be kind %d",
5023 &e
->where
, case_expr
->ts
.kind
);
5027 /* Convert the case value kind to that of case expression kind, if needed.
5028 FIXME: Should a warning be issued? */
5029 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
5030 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
5034 gfc_error ("Expression in CASE statement at %L must be scalar",
5043 /* Given a completely parsed select statement, we:
5045 - Validate all expressions and code within the SELECT.
5046 - Make sure that the selection expression is not of the wrong type.
5047 - Make sure that no case ranges overlap.
5048 - Eliminate unreachable cases and unreachable code resulting from
5049 removing case labels.
5051 The standard does allow unreachable cases, e.g. CASE (5:3). But
5052 they are a hassle for code generation, and to prevent that, we just
5053 cut them out here. This is not necessary for overlapping cases
5054 because they are illegal and we never even try to generate code.
5056 We have the additional caveat that a SELECT construct could have
5057 been a computed GOTO in the source code. Fortunately we can fairly
5058 easily work around that here: The case_expr for a "real" SELECT CASE
5059 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5060 we have to do is make sure that the case_expr is a scalar integer
5064 resolve_select (gfc_code
*code
)
5067 gfc_expr
*case_expr
;
5068 gfc_case
*cp
, *default_case
, *tail
, *head
;
5069 int seen_unreachable
;
5075 if (code
->expr
== NULL
)
5077 /* This was actually a computed GOTO statement. */
5078 case_expr
= code
->expr2
;
5079 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
5080 gfc_error ("Selection expression in computed GOTO statement "
5081 "at %L must be a scalar integer expression",
5084 /* Further checking is not necessary because this SELECT was built
5085 by the compiler, so it should always be OK. Just move the
5086 case_expr from expr2 to expr so that we can handle computed
5087 GOTOs as normal SELECTs from here on. */
5088 code
->expr
= code
->expr2
;
5093 case_expr
= code
->expr
;
5095 type
= case_expr
->ts
.type
;
5096 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
5098 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5099 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
5101 /* Punt. Going on here just produce more garbage error messages. */
5105 if (case_expr
->rank
!= 0)
5107 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5108 "expression", &case_expr
->where
);
5114 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5115 of the SELECT CASE expression and its CASE values. Walk the lists
5116 of case values, and if we find a mismatch, promote case_expr to
5117 the appropriate kind. */
5119 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
5121 for (body
= code
->block
; body
; body
= body
->block
)
5123 /* Walk the case label list. */
5124 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5126 /* Intercept the DEFAULT case. It does not have a kind. */
5127 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5130 /* Unreachable case ranges are discarded, so ignore. */
5131 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5132 && cp
->low
!= cp
->high
5133 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
5136 /* FIXME: Should a warning be issued? */
5138 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
5139 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
5141 if (cp
->high
!= NULL
5142 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
5143 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
5148 /* Assume there is no DEFAULT case. */
5149 default_case
= NULL
;
5154 for (body
= code
->block
; body
; body
= body
->block
)
5156 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5158 seen_unreachable
= 0;
5160 /* Walk the case label list, making sure that all case labels
5162 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5164 /* Count the number of cases in the whole construct. */
5167 /* Intercept the DEFAULT case. */
5168 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5170 if (default_case
!= NULL
)
5172 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5173 "by a second DEFAULT CASE at %L",
5174 &default_case
->where
, &cp
->where
);
5185 /* Deal with single value cases and case ranges. Errors are
5186 issued from the validation function. */
5187 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
5188 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
5194 if (type
== BT_LOGICAL
5195 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
5196 || cp
->low
!= cp
->high
))
5198 gfc_error ("Logical range in CASE statement at %L is not "
5199 "allowed", &cp
->low
->where
);
5204 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
5207 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
5208 if (value
& seen_logical
)
5210 gfc_error ("constant logical value in CASE statement "
5211 "is repeated at %L",
5216 seen_logical
|= value
;
5219 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5220 && cp
->low
!= cp
->high
5221 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
5223 if (gfc_option
.warn_surprising
)
5224 gfc_warning ("Range specification at %L can never "
5225 "be matched", &cp
->where
);
5227 cp
->unreachable
= 1;
5228 seen_unreachable
= 1;
5232 /* If the case range can be matched, it can also overlap with
5233 other cases. To make sure it does not, we put it in a
5234 double linked list here. We sort that with a merge sort
5235 later on to detect any overlapping cases. */
5239 head
->right
= head
->left
= NULL
;
5244 tail
->right
->left
= tail
;
5251 /* It there was a failure in the previous case label, give up
5252 for this case label list. Continue with the next block. */
5256 /* See if any case labels that are unreachable have been seen.
5257 If so, we eliminate them. This is a bit of a kludge because
5258 the case lists for a single case statement (label) is a
5259 single forward linked lists. */
5260 if (seen_unreachable
)
5262 /* Advance until the first case in the list is reachable. */
5263 while (body
->ext
.case_list
!= NULL
5264 && body
->ext
.case_list
->unreachable
)
5266 gfc_case
*n
= body
->ext
.case_list
;
5267 body
->ext
.case_list
= body
->ext
.case_list
->next
;
5269 gfc_free_case_list (n
);
5272 /* Strip all other unreachable cases. */
5273 if (body
->ext
.case_list
)
5275 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
5277 if (cp
->next
->unreachable
)
5279 gfc_case
*n
= cp
->next
;
5280 cp
->next
= cp
->next
->next
;
5282 gfc_free_case_list (n
);
5289 /* See if there were overlapping cases. If the check returns NULL,
5290 there was overlap. In that case we don't do anything. If head
5291 is non-NULL, we prepend the DEFAULT case. The sorted list can
5292 then used during code generation for SELECT CASE constructs with
5293 a case expression of a CHARACTER type. */
5296 head
= check_case_overlap (head
);
5298 /* Prepend the default_case if it is there. */
5299 if (head
!= NULL
&& default_case
)
5301 default_case
->left
= NULL
;
5302 default_case
->right
= head
;
5303 head
->left
= default_case
;
5307 /* Eliminate dead blocks that may be the result if we've seen
5308 unreachable case labels for a block. */
5309 for (body
= code
; body
&& body
->block
; body
= body
->block
)
5311 if (body
->block
->ext
.case_list
== NULL
)
5313 /* Cut the unreachable block from the code chain. */
5314 gfc_code
*c
= body
->block
;
5315 body
->block
= c
->block
;
5317 /* Kill the dead block, but not the blocks below it. */
5319 gfc_free_statements (c
);
5323 /* More than two cases is legal but insane for logical selects.
5324 Issue a warning for it. */
5325 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
5327 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5332 /* Resolve a transfer statement. This is making sure that:
5333 -- a derived type being transferred has only non-pointer components
5334 -- a derived type being transferred doesn't have private components, unless
5335 it's being transferred from the module where the type was defined
5336 -- we're not trying to transfer a whole assumed size array. */
5339 resolve_transfer (gfc_code
*code
)
5348 if (exp
->expr_type
!= EXPR_VARIABLE
&& exp
->expr_type
!= EXPR_FUNCTION
)
5351 sym
= exp
->symtree
->n
.sym
;
5354 /* Go to actual component transferred. */
5355 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
5356 if (ref
->type
== REF_COMPONENT
)
5357 ts
= &ref
->u
.c
.component
->ts
;
5359 if (ts
->type
== BT_DERIVED
)
5361 /* Check that transferred derived type doesn't contain POINTER
5363 if (ts
->derived
->attr
.pointer_comp
)
5365 gfc_error ("Data transfer element at %L cannot have "
5366 "POINTER components", &code
->loc
);
5370 if (ts
->derived
->attr
.alloc_comp
)
5372 gfc_error ("Data transfer element at %L cannot have "
5373 "ALLOCATABLE components", &code
->loc
);
5377 if (derived_inaccessible (ts
->derived
))
5379 gfc_error ("Data transfer element at %L cannot have "
5380 "PRIVATE components",&code
->loc
);
5385 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
5386 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
5388 gfc_error ("Data transfer element at %L cannot be a full reference to "
5389 "an assumed-size array", &code
->loc
);
5395 /*********** Toplevel code resolution subroutines ***********/
5397 /* Find the set of labels that are reachable from this block. We also
5398 record the last statement in each block so that we don't have to do
5399 a linear search to find the END DO statements of the blocks. */
5402 reachable_labels (gfc_code
*block
)
5409 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
5411 /* Collect labels in this block. */
5412 for (c
= block
; c
; c
= c
->next
)
5415 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
5417 if (!c
->next
&& cs_base
->prev
)
5418 cs_base
->prev
->tail
= c
;
5421 /* Merge with labels from parent block. */
5424 gcc_assert (cs_base
->prev
->reachable_labels
);
5425 bitmap_ior_into (cs_base
->reachable_labels
,
5426 cs_base
->prev
->reachable_labels
);
5430 /* Given a branch to a label and a namespace, if the branch is conforming.
5431 The code node describes where the branch is located. */
5434 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
5441 /* Step one: is this a valid branching target? */
5443 if (label
->defined
== ST_LABEL_UNKNOWN
)
5445 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
5450 if (label
->defined
!= ST_LABEL_TARGET
)
5452 gfc_error ("Statement at %L is not a valid branch target statement "
5453 "for the branch statement at %L", &label
->where
, &code
->loc
);
5457 /* Step two: make sure this branch is not a branch to itself ;-) */
5459 if (code
->here
== label
)
5461 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
5465 /* Step three: See if the label is in the same block as the
5466 branching statement. The hard work has been done by setting up
5467 the bitmap reachable_labels. */
5469 if (!bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
5471 /* The label is not in an enclosing block, so illegal. This was
5472 allowed in Fortran 66, so we allow it as extension. No
5473 further checks are necessary in this case. */
5474 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
5475 "as the GOTO statement at %L", &label
->where
,
5480 /* Step four: Make sure that the branching target is legal if
5481 the statement is an END {SELECT,IF}. */
5483 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5484 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
5487 if (stack
&& stack
->current
->next
->op
== EXEC_NOP
)
5489 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps to "
5490 "END of construct at %L", &code
->loc
,
5491 &stack
->current
->next
->loc
);
5492 return; /* We know this is not an END DO. */
5495 /* Step five: Make sure that we're not jumping to the end of a DO
5496 loop from within the loop. */
5498 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5499 if ((stack
->current
->op
== EXEC_DO
5500 || stack
->current
->op
== EXEC_DO_WHILE
)
5501 && stack
->tail
->here
== label
&& stack
->tail
->op
== EXEC_NOP
)
5503 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps "
5504 "to END of construct at %L", &code
->loc
,
5512 /* Check whether EXPR1 has the same shape as EXPR2. */
5515 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
5517 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5518 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
5519 try result
= FAILURE
;
5522 /* Compare the rank. */
5523 if (expr1
->rank
!= expr2
->rank
)
5526 /* Compare the size of each dimension. */
5527 for (i
=0; i
<expr1
->rank
; i
++)
5529 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
5532 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
5535 if (mpz_cmp (shape
[i
], shape2
[i
]))
5539 /* When either of the two expression is an assumed size array, we
5540 ignore the comparison of dimension sizes. */
5545 for (i
--; i
>= 0; i
--)
5547 mpz_clear (shape
[i
]);
5548 mpz_clear (shape2
[i
]);
5554 /* Check whether a WHERE assignment target or a WHERE mask expression
5555 has the same shape as the outmost WHERE mask expression. */
5558 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
5564 cblock
= code
->block
;
5566 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5567 In case of nested WHERE, only the outmost one is stored. */
5568 if (mask
== NULL
) /* outmost WHERE */
5570 else /* inner WHERE */
5577 /* Check if the mask-expr has a consistent shape with the
5578 outmost WHERE mask-expr. */
5579 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
5580 gfc_error ("WHERE mask at %L has inconsistent shape",
5581 &cblock
->expr
->where
);
5584 /* the assignment statement of a WHERE statement, or the first
5585 statement in where-body-construct of a WHERE construct */
5586 cnext
= cblock
->next
;
5591 /* WHERE assignment statement */
5594 /* Check shape consistent for WHERE assignment target. */
5595 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
5596 gfc_error ("WHERE assignment target at %L has "
5597 "inconsistent shape", &cnext
->expr
->where
);
5601 case EXEC_ASSIGN_CALL
:
5602 resolve_call (cnext
);
5605 /* WHERE or WHERE construct is part of a where-body-construct */
5607 resolve_where (cnext
, e
);
5611 gfc_error ("Unsupported statement inside WHERE at %L",
5614 /* the next statement within the same where-body-construct */
5615 cnext
= cnext
->next
;
5617 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5618 cblock
= cblock
->block
;
5623 /* Resolve assignment in FORALL construct.
5624 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5625 FORALL index variables. */
5628 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
5632 for (n
= 0; n
< nvar
; n
++)
5634 gfc_symbol
*forall_index
;
5636 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
5638 /* Check whether the assignment target is one of the FORALL index
5640 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
5641 && (code
->expr
->symtree
->n
.sym
== forall_index
))
5642 gfc_error ("Assignment to a FORALL index variable at %L",
5643 &code
->expr
->where
);
5646 /* If one of the FORALL index variables doesn't appear in the
5647 assignment target, then there will be a many-to-one
5649 if (find_forall_index (code
->expr
, forall_index
, 0) == FAILURE
)
5650 gfc_error ("The FORALL with index '%s' cause more than one "
5651 "assignment to this object at %L",
5652 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
5658 /* Resolve WHERE statement in FORALL construct. */
5661 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
5662 gfc_expr
**var_expr
)
5667 cblock
= code
->block
;
5670 /* the assignment statement of a WHERE statement, or the first
5671 statement in where-body-construct of a WHERE construct */
5672 cnext
= cblock
->next
;
5677 /* WHERE assignment statement */
5679 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
5682 /* WHERE operator assignment statement */
5683 case EXEC_ASSIGN_CALL
:
5684 resolve_call (cnext
);
5687 /* WHERE or WHERE construct is part of a where-body-construct */
5689 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
5693 gfc_error ("Unsupported statement inside WHERE at %L",
5696 /* the next statement within the same where-body-construct */
5697 cnext
= cnext
->next
;
5699 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5700 cblock
= cblock
->block
;
5705 /* Traverse the FORALL body to check whether the following errors exist:
5706 1. For assignment, check if a many-to-one assignment happens.
5707 2. For WHERE statement, check the WHERE body to see if there is any
5708 many-to-one assignment. */
5711 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
5715 c
= code
->block
->next
;
5721 case EXEC_POINTER_ASSIGN
:
5722 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
5725 case EXEC_ASSIGN_CALL
:
5729 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5730 there is no need to handle it here. */
5734 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
5739 /* The next statement in the FORALL body. */
5745 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5746 gfc_resolve_forall_body to resolve the FORALL body. */
5749 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
5751 static gfc_expr
**var_expr
;
5752 static int total_var
= 0;
5753 static int nvar
= 0;
5754 gfc_forall_iterator
*fa
;
5758 /* Start to resolve a FORALL construct */
5759 if (forall_save
== 0)
5761 /* Count the total number of FORALL index in the nested FORALL
5762 construct in order to allocate the VAR_EXPR with proper size. */
5764 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
5766 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5768 next
= next
->block
->next
;
5771 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5772 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
5775 /* The information about FORALL iterator, including FORALL index start, end
5776 and stride. The FORALL index can not appear in start, end or stride. */
5777 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5779 /* Check if any outer FORALL index name is the same as the current
5781 for (i
= 0; i
< nvar
; i
++)
5783 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
5785 gfc_error ("An outer FORALL construct already has an index "
5786 "with this name %L", &fa
->var
->where
);
5790 /* Record the current FORALL index. */
5791 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
5796 /* Resolve the FORALL body. */
5797 gfc_resolve_forall_body (code
, nvar
, var_expr
);
5799 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5800 gfc_resolve_blocks (code
->block
, ns
);
5802 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5803 for (i
= 0; i
< total_var
; i
++)
5804 gfc_free_expr (var_expr
[i
]);
5806 /* Reset the counters. */
5812 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5815 static void resolve_code (gfc_code
*, gfc_namespace
*);
5818 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
5822 for (; b
; b
= b
->block
)
5824 t
= gfc_resolve_expr (b
->expr
);
5825 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
5831 if (t
== SUCCESS
&& b
->expr
!= NULL
5832 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
5833 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5840 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
== 0))
5841 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5846 resolve_branch (b
->label
, b
);
5858 case EXEC_OMP_ATOMIC
:
5859 case EXEC_OMP_CRITICAL
:
5861 case EXEC_OMP_MASTER
:
5862 case EXEC_OMP_ORDERED
:
5863 case EXEC_OMP_PARALLEL
:
5864 case EXEC_OMP_PARALLEL_DO
:
5865 case EXEC_OMP_PARALLEL_SECTIONS
:
5866 case EXEC_OMP_PARALLEL_WORKSHARE
:
5867 case EXEC_OMP_SECTIONS
:
5868 case EXEC_OMP_SINGLE
:
5869 case EXEC_OMP_WORKSHARE
:
5873 gfc_internal_error ("resolve_block(): Bad block type");
5876 resolve_code (b
->next
, ns
);
5881 /* Does everything to resolve an ordinary assignment. Returns true
5882 if this is an interface asignment. */
5884 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
5894 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
5896 lhs
= code
->ext
.actual
->expr
;
5897 rhs
= code
->ext
.actual
->next
->expr
;
5898 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
5900 gfc_error ("Subroutine '%s' called instead of assignment at "
5901 "%L must be PURE", code
->symtree
->n
.sym
->name
,
5906 /* Make a temporary rhs when there is a default initializer
5907 and rhs is the same symbol as the lhs. */
5908 if (rhs
->expr_type
== EXPR_VARIABLE
5909 && rhs
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
5910 && has_default_initializer (rhs
->symtree
->n
.sym
->ts
.derived
)
5911 && (lhs
->symtree
->n
.sym
== rhs
->symtree
->n
.sym
))
5912 code
->ext
.actual
->next
->expr
= gfc_get_parentheses (rhs
);
5921 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
5922 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
5923 &code
->loc
) == FAILURE
)
5926 /* Handle the case of a BOZ literal on the RHS. */
5927 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
5930 if (gfc_option
.warn_surprising
)
5931 gfc_warning ("BOZ literal at %L is bitwise transferred "
5932 "non-integer symbol '%s'", &code
->loc
,
5933 lhs
->symtree
->n
.sym
->name
);
5935 gfc_convert_boz (rhs
, &lhs
->ts
);
5936 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
5938 if (rc
== ARITH_UNDERFLOW
)
5939 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
5940 ". This check can be disabled with the option "
5941 "-fno-range-check", &rhs
->where
);
5942 else if (rc
== ARITH_OVERFLOW
)
5943 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
5944 ". This check can be disabled with the option "
5945 "-fno-range-check", &rhs
->where
);
5946 else if (rc
== ARITH_NAN
)
5947 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
5948 ". This check can be disabled with the option "
5949 "-fno-range-check", &rhs
->where
);
5955 if (lhs
->ts
.type
== BT_CHARACTER
5956 && gfc_option
.warn_character_truncation
)
5958 if (lhs
->ts
.cl
!= NULL
5959 && lhs
->ts
.cl
->length
!= NULL
5960 && lhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5961 llen
= mpz_get_si (lhs
->ts
.cl
->length
->value
.integer
);
5963 if (rhs
->expr_type
== EXPR_CONSTANT
)
5964 rlen
= rhs
->value
.character
.length
;
5966 else if (rhs
->ts
.cl
!= NULL
5967 && rhs
->ts
.cl
->length
!= NULL
5968 && rhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5969 rlen
= mpz_get_si (rhs
->ts
.cl
->length
->value
.integer
);
5971 if (rlen
&& llen
&& rlen
> llen
)
5972 gfc_warning_now ("CHARACTER expression will be truncated "
5973 "in assignment (%d/%d) at %L",
5974 llen
, rlen
, &code
->loc
);
5977 /* Ensure that a vector index expression for the lvalue is evaluated
5978 to a temporary if the lvalue symbol is referenced in it. */
5981 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
5982 if (ref
->type
== REF_ARRAY
)
5984 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5985 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
5986 && find_sym_in_expr (lhs
->symtree
->n
.sym
,
5987 ref
->u
.ar
.start
[n
]))
5989 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
5993 if (gfc_pure (NULL
))
5995 if (gfc_impure_variable (lhs
->symtree
->n
.sym
))
5997 gfc_error ("Cannot assign to variable '%s' in PURE "
5999 lhs
->symtree
->n
.sym
->name
,
6004 if (lhs
->ts
.type
== BT_DERIVED
6005 && lhs
->expr_type
== EXPR_VARIABLE
6006 && lhs
->ts
.derived
->attr
.pointer_comp
6007 && gfc_impure_variable (rhs
->symtree
->n
.sym
))
6009 gfc_error ("The impure variable at %L is assigned to "
6010 "a derived type variable with a POINTER "
6011 "component in a PURE procedure (12.6)",
6017 gfc_check_assign (lhs
, rhs
, 1);
6021 /* Given a block of code, recursively resolve everything pointed to by this
6025 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
6027 int omp_workshare_save
;
6033 frame
.prev
= cs_base
;
6037 reachable_labels (code
);
6039 for (; code
; code
= code
->next
)
6041 frame
.current
= code
;
6042 forall_save
= forall_flag
;
6044 if (code
->op
== EXEC_FORALL
)
6047 gfc_resolve_forall (code
, ns
, forall_save
);
6050 else if (code
->block
)
6052 omp_workshare_save
= -1;
6055 case EXEC_OMP_PARALLEL_WORKSHARE
:
6056 omp_workshare_save
= omp_workshare_flag
;
6057 omp_workshare_flag
= 1;
6058 gfc_resolve_omp_parallel_blocks (code
, ns
);
6060 case EXEC_OMP_PARALLEL
:
6061 case EXEC_OMP_PARALLEL_DO
:
6062 case EXEC_OMP_PARALLEL_SECTIONS
:
6063 omp_workshare_save
= omp_workshare_flag
;
6064 omp_workshare_flag
= 0;
6065 gfc_resolve_omp_parallel_blocks (code
, ns
);
6068 gfc_resolve_omp_do_blocks (code
, ns
);
6070 case EXEC_OMP_WORKSHARE
:
6071 omp_workshare_save
= omp_workshare_flag
;
6072 omp_workshare_flag
= 1;
6075 gfc_resolve_blocks (code
->block
, ns
);
6079 if (omp_workshare_save
!= -1)
6080 omp_workshare_flag
= omp_workshare_save
;
6083 t
= gfc_resolve_expr (code
->expr
);
6084 forall_flag
= forall_save
;
6086 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
6101 /* Keep track of which entry we are up to. */
6102 current_entry_id
= code
->ext
.entry
->id
;
6106 resolve_where (code
, NULL
);
6110 if (code
->expr
!= NULL
)
6112 if (code
->expr
->ts
.type
!= BT_INTEGER
)
6113 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6114 "INTEGER variable", &code
->expr
->where
);
6115 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
6116 gfc_error ("Variable '%s' has not been assigned a target "
6117 "label at %L", code
->expr
->symtree
->n
.sym
->name
,
6118 &code
->expr
->where
);
6121 resolve_branch (code
->label
, code
);
6125 if (code
->expr
!= NULL
6126 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
6127 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6128 "INTEGER return specifier", &code
->expr
->where
);
6131 case EXEC_INIT_ASSIGN
:
6138 if (resolve_ordinary_assign (code
, ns
))
6143 case EXEC_LABEL_ASSIGN
:
6144 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
6145 gfc_error ("Label %d referenced at %L is never defined",
6146 code
->label
->value
, &code
->label
->where
);
6148 && (code
->expr
->expr_type
!= EXPR_VARIABLE
6149 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
6150 || code
->expr
->symtree
->n
.sym
->ts
.kind
6151 != gfc_default_integer_kind
6152 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
6153 gfc_error ("ASSIGN statement at %L requires a scalar "
6154 "default INTEGER variable", &code
->expr
->where
);
6157 case EXEC_POINTER_ASSIGN
:
6161 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
6164 case EXEC_ARITHMETIC_IF
:
6166 && code
->expr
->ts
.type
!= BT_INTEGER
6167 && code
->expr
->ts
.type
!= BT_REAL
)
6168 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6169 "expression", &code
->expr
->where
);
6171 resolve_branch (code
->label
, code
);
6172 resolve_branch (code
->label2
, code
);
6173 resolve_branch (code
->label3
, code
);
6177 if (t
== SUCCESS
&& code
->expr
!= NULL
6178 && (code
->expr
->ts
.type
!= BT_LOGICAL
6179 || code
->expr
->rank
!= 0))
6180 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6181 &code
->expr
->where
);
6186 resolve_call (code
);
6190 /* Select is complicated. Also, a SELECT construct could be
6191 a transformed computed GOTO. */
6192 resolve_select (code
);
6196 if (code
->ext
.iterator
!= NULL
)
6198 gfc_iterator
*iter
= code
->ext
.iterator
;
6199 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
6200 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
6205 if (code
->expr
== NULL
)
6206 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6208 && (code
->expr
->rank
!= 0
6209 || code
->expr
->ts
.type
!= BT_LOGICAL
))
6210 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6211 "a scalar LOGICAL expression", &code
->expr
->where
);
6215 if (t
== SUCCESS
&& code
->expr
!= NULL
6216 && code
->expr
->ts
.type
!= BT_INTEGER
)
6217 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6218 "of type INTEGER", &code
->expr
->where
);
6220 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
6221 resolve_allocate_expr (a
->expr
, code
);
6225 case EXEC_DEALLOCATE
:
6226 if (t
== SUCCESS
&& code
->expr
!= NULL
6227 && code
->expr
->ts
.type
!= BT_INTEGER
)
6229 ("STAT tag in DEALLOCATE statement at %L must be of type "
6230 "INTEGER", &code
->expr
->where
);
6232 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
6233 resolve_deallocate_expr (a
->expr
);
6238 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
6241 resolve_branch (code
->ext
.open
->err
, code
);
6245 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
6248 resolve_branch (code
->ext
.close
->err
, code
);
6251 case EXEC_BACKSPACE
:
6255 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
6258 resolve_branch (code
->ext
.filepos
->err
, code
);
6262 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6265 resolve_branch (code
->ext
.inquire
->err
, code
);
6269 gcc_assert (code
->ext
.inquire
!= NULL
);
6270 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6273 resolve_branch (code
->ext
.inquire
->err
, code
);
6278 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
6281 resolve_branch (code
->ext
.dt
->err
, code
);
6282 resolve_branch (code
->ext
.dt
->end
, code
);
6283 resolve_branch (code
->ext
.dt
->eor
, code
);
6287 resolve_transfer (code
);
6291 resolve_forall_iterators (code
->ext
.forall_iterator
);
6293 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
6294 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6295 "expression", &code
->expr
->where
);
6298 case EXEC_OMP_ATOMIC
:
6299 case EXEC_OMP_BARRIER
:
6300 case EXEC_OMP_CRITICAL
:
6301 case EXEC_OMP_FLUSH
:
6303 case EXEC_OMP_MASTER
:
6304 case EXEC_OMP_ORDERED
:
6305 case EXEC_OMP_SECTIONS
:
6306 case EXEC_OMP_SINGLE
:
6307 case EXEC_OMP_WORKSHARE
:
6308 gfc_resolve_omp_directive (code
, ns
);
6311 case EXEC_OMP_PARALLEL
:
6312 case EXEC_OMP_PARALLEL_DO
:
6313 case EXEC_OMP_PARALLEL_SECTIONS
:
6314 case EXEC_OMP_PARALLEL_WORKSHARE
:
6315 omp_workshare_save
= omp_workshare_flag
;
6316 omp_workshare_flag
= 0;
6317 gfc_resolve_omp_directive (code
, ns
);
6318 omp_workshare_flag
= omp_workshare_save
;
6322 gfc_internal_error ("resolve_code(): Bad statement code");
6326 cs_base
= frame
.prev
;
6330 /* Resolve initial values and make sure they are compatible with
6334 resolve_values (gfc_symbol
*sym
)
6336 if (sym
->value
== NULL
)
6339 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
6342 gfc_check_assign_symbol (sym
, sym
->value
);
6346 /* Verify the binding labels for common blocks that are BIND(C). The label
6347 for a BIND(C) common block must be identical in all scoping units in which
6348 the common block is declared. Further, the binding label can not collide
6349 with any other global entity in the program. */
6352 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
6354 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
6356 gfc_gsymbol
*binding_label_gsym
;
6357 gfc_gsymbol
*comm_name_gsym
;
6359 /* See if a global symbol exists by the common block's name. It may
6360 be NULL if the common block is use-associated. */
6361 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
6362 comm_block_tree
->n
.common
->name
);
6363 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
6364 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6365 "with the global entity '%s' at %L",
6366 comm_block_tree
->n
.common
->binding_label
,
6367 comm_block_tree
->n
.common
->name
,
6368 &(comm_block_tree
->n
.common
->where
),
6369 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6370 else if (comm_name_gsym
!= NULL
6371 && strcmp (comm_name_gsym
->name
,
6372 comm_block_tree
->n
.common
->name
) == 0)
6374 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6376 if (comm_name_gsym
->binding_label
== NULL
)
6377 /* No binding label for common block stored yet; save this one. */
6378 comm_name_gsym
->binding_label
=
6379 comm_block_tree
->n
.common
->binding_label
;
6381 if (strcmp (comm_name_gsym
->binding_label
,
6382 comm_block_tree
->n
.common
->binding_label
) != 0)
6384 /* Common block names match but binding labels do not. */
6385 gfc_error ("Binding label '%s' for common block '%s' at %L "
6386 "does not match the binding label '%s' for common "
6388 comm_block_tree
->n
.common
->binding_label
,
6389 comm_block_tree
->n
.common
->name
,
6390 &(comm_block_tree
->n
.common
->where
),
6391 comm_name_gsym
->binding_label
,
6392 comm_name_gsym
->name
,
6393 &(comm_name_gsym
->where
));
6398 /* There is no binding label (NAME="") so we have nothing further to
6399 check and nothing to add as a global symbol for the label. */
6400 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
6403 binding_label_gsym
=
6404 gfc_find_gsymbol (gfc_gsym_root
,
6405 comm_block_tree
->n
.common
->binding_label
);
6406 if (binding_label_gsym
== NULL
)
6408 /* Need to make a global symbol for the binding label to prevent
6409 it from colliding with another. */
6410 binding_label_gsym
=
6411 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
6412 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
6413 binding_label_gsym
->type
= GSYM_COMMON
;
6417 /* If comm_name_gsym is NULL, the name common block is use
6418 associated and the name could be colliding. */
6419 if (binding_label_gsym
->type
!= GSYM_COMMON
)
6420 gfc_error ("Binding label '%s' for common block '%s' at %L "
6421 "collides with the global entity '%s' at %L",
6422 comm_block_tree
->n
.common
->binding_label
,
6423 comm_block_tree
->n
.common
->name
,
6424 &(comm_block_tree
->n
.common
->where
),
6425 binding_label_gsym
->name
,
6426 &(binding_label_gsym
->where
));
6427 else if (comm_name_gsym
!= NULL
6428 && (strcmp (binding_label_gsym
->name
,
6429 comm_name_gsym
->binding_label
) != 0)
6430 && (strcmp (binding_label_gsym
->sym_name
,
6431 comm_name_gsym
->name
) != 0))
6432 gfc_error ("Binding label '%s' for common block '%s' at %L "
6433 "collides with global entity '%s' at %L",
6434 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
6435 &(comm_block_tree
->n
.common
->where
),
6436 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6444 /* Verify any BIND(C) derived types in the namespace so we can report errors
6445 for them once, rather than for each variable declared of that type. */
6448 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
6450 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
6451 && derived_sym
->attr
.is_bind_c
== 1)
6452 verify_bind_c_derived_type (derived_sym
);
6458 /* Verify that any binding labels used in a given namespace do not collide
6459 with the names or binding labels of any global symbols. */
6462 gfc_verify_binding_labels (gfc_symbol
*sym
)
6466 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
6467 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
6469 gfc_gsymbol
*bind_c_sym
;
6471 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
6472 if (bind_c_sym
!= NULL
6473 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
6475 if (sym
->attr
.if_source
== IFSRC_DECL
6476 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
6477 && bind_c_sym
->type
!= GSYM_FUNCTION
)
6478 && ((sym
->attr
.contained
== 1
6479 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
6480 || (sym
->attr
.use_assoc
== 1
6481 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
6483 /* Make sure global procedures don't collide with anything. */
6484 gfc_error ("Binding label '%s' at %L collides with the global "
6485 "entity '%s' at %L", sym
->binding_label
,
6486 &(sym
->declared_at
), bind_c_sym
->name
,
6487 &(bind_c_sym
->where
));
6490 else if (sym
->attr
.contained
== 0
6491 && (sym
->attr
.if_source
== IFSRC_IFBODY
6492 && sym
->attr
.flavor
== FL_PROCEDURE
)
6493 && (bind_c_sym
->sym_name
!= NULL
6494 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
6496 /* Make sure procedures in interface bodies don't collide. */
6497 gfc_error ("Binding label '%s' in interface body at %L collides "
6498 "with the global entity '%s' at %L",
6500 &(sym
->declared_at
), bind_c_sym
->name
,
6501 &(bind_c_sym
->where
));
6504 else if (sym
->attr
.contained
== 0
6505 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
))
6506 if ((sym
->attr
.use_assoc
6507 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))
6508 || sym
->attr
.use_assoc
== 0)
6510 gfc_error ("Binding label '%s' at %L collides with global "
6511 "entity '%s' at %L", sym
->binding_label
,
6512 &(sym
->declared_at
), bind_c_sym
->name
,
6513 &(bind_c_sym
->where
));
6518 /* Clear the binding label to prevent checking multiple times. */
6519 sym
->binding_label
[0] = '\0';
6521 else if (bind_c_sym
== NULL
)
6523 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
6524 bind_c_sym
->where
= sym
->declared_at
;
6525 bind_c_sym
->sym_name
= sym
->name
;
6527 if (sym
->attr
.use_assoc
== 1)
6528 bind_c_sym
->mod_name
= sym
->module
;
6530 if (sym
->ns
->proc_name
!= NULL
)
6531 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
6533 if (sym
->attr
.contained
== 0)
6535 if (sym
->attr
.subroutine
)
6536 bind_c_sym
->type
= GSYM_SUBROUTINE
;
6537 else if (sym
->attr
.function
)
6538 bind_c_sym
->type
= GSYM_FUNCTION
;
6546 /* Resolve an index expression. */
6549 resolve_index_expr (gfc_expr
*e
)
6551 if (gfc_resolve_expr (e
) == FAILURE
)
6554 if (gfc_simplify_expr (e
, 0) == FAILURE
)
6557 if (gfc_specification_expr (e
) == FAILURE
)
6563 /* Resolve a charlen structure. */
6566 resolve_charlen (gfc_charlen
*cl
)
6575 specification_expr
= 1;
6577 if (resolve_index_expr (cl
->length
) == FAILURE
)
6579 specification_expr
= 0;
6583 /* "If the character length parameter value evaluates to a negative
6584 value, the length of character entities declared is zero." */
6585 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
6587 gfc_warning_now ("CHARACTER variable has zero length at %L",
6588 &cl
->length
->where
);
6589 gfc_replace_expr (cl
->length
, gfc_int_expr (0));
6596 /* Test for non-constant shape arrays. */
6599 is_non_constant_shape_array (gfc_symbol
*sym
)
6605 not_constant
= false;
6606 if (sym
->as
!= NULL
)
6608 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6609 has not been simplified; parameter array references. Do the
6610 simplification now. */
6611 for (i
= 0; i
< sym
->as
->rank
; i
++)
6613 e
= sym
->as
->lower
[i
];
6614 if (e
&& (resolve_index_expr (e
) == FAILURE
6615 || !gfc_is_constant_expr (e
)))
6616 not_constant
= true;
6618 e
= sym
->as
->upper
[i
];
6619 if (e
&& (resolve_index_expr (e
) == FAILURE
6620 || !gfc_is_constant_expr (e
)))
6621 not_constant
= true;
6624 return not_constant
;
6627 /* Given a symbol and an initialization expression, add code to initialize
6628 the symbol to the function entry. */
6630 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
6634 gfc_namespace
*ns
= sym
->ns
;
6636 /* Search for the function namespace if this is a contained
6637 function without an explicit result. */
6638 if (sym
->attr
.function
&& sym
== sym
->result
6639 && sym
->name
!= sym
->ns
->proc_name
->name
)
6642 for (;ns
; ns
= ns
->sibling
)
6643 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
6649 gfc_free_expr (init
);
6653 /* Build an l-value expression for the result. */
6654 lval
= gfc_lval_expr_from_sym (sym
);
6656 /* Add the code at scope entry. */
6657 init_st
= gfc_get_code ();
6658 init_st
->next
= ns
->code
;
6661 /* Assign the default initializer to the l-value. */
6662 init_st
->loc
= sym
->declared_at
;
6663 init_st
->op
= EXEC_INIT_ASSIGN
;
6664 init_st
->expr
= lval
;
6665 init_st
->expr2
= init
;
6668 /* Assign the default initializer to a derived type variable or result. */
6671 apply_default_init (gfc_symbol
*sym
)
6673 gfc_expr
*init
= NULL
;
6675 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
6678 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
6679 init
= gfc_default_initializer (&sym
->ts
);
6684 build_init_assign (sym
, init
);
6687 /* Build an initializer for a local integer, real, complex, logical, or
6688 character variable, based on the command line flags finit-local-zero,
6689 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
6690 null if the symbol should not have a default initialization. */
6692 build_default_init_expr (gfc_symbol
*sym
)
6695 gfc_expr
*init_expr
;
6699 /* These symbols should never have a default initialization. */
6700 if ((sym
->attr
.dimension
&& !gfc_is_compile_time_shape (sym
->as
))
6701 || sym
->attr
.external
6703 || sym
->attr
.pointer
6704 || sym
->attr
.in_equivalence
6705 || sym
->attr
.in_common
6708 || sym
->attr
.cray_pointee
6709 || sym
->attr
.cray_pointer
)
6712 /* Now we'll try to build an initializer expression. */
6713 init_expr
= gfc_get_expr ();
6714 init_expr
->expr_type
= EXPR_CONSTANT
;
6715 init_expr
->ts
.type
= sym
->ts
.type
;
6716 init_expr
->ts
.kind
= sym
->ts
.kind
;
6717 init_expr
->where
= sym
->declared_at
;
6719 /* We will only initialize integers, reals, complex, logicals, and
6720 characters, and only if the corresponding command-line flags
6721 were set. Otherwise, we free init_expr and return null. */
6722 switch (sym
->ts
.type
)
6725 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
6726 mpz_init_set_si (init_expr
->value
.integer
,
6727 gfc_option
.flag_init_integer_value
);
6730 gfc_free_expr (init_expr
);
6736 mpfr_init (init_expr
->value
.real
);
6737 switch (gfc_option
.flag_init_real
)
6739 case GFC_INIT_REAL_NAN
:
6740 mpfr_set_nan (init_expr
->value
.real
);
6743 case GFC_INIT_REAL_INF
:
6744 mpfr_set_inf (init_expr
->value
.real
, 1);
6747 case GFC_INIT_REAL_NEG_INF
:
6748 mpfr_set_inf (init_expr
->value
.real
, -1);
6751 case GFC_INIT_REAL_ZERO
:
6752 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
6756 gfc_free_expr (init_expr
);
6763 mpfr_init (init_expr
->value
.complex.r
);
6764 mpfr_init (init_expr
->value
.complex.i
);
6765 switch (gfc_option
.flag_init_real
)
6767 case GFC_INIT_REAL_NAN
:
6768 mpfr_set_nan (init_expr
->value
.complex.r
);
6769 mpfr_set_nan (init_expr
->value
.complex.i
);
6772 case GFC_INIT_REAL_INF
:
6773 mpfr_set_inf (init_expr
->value
.complex.r
, 1);
6774 mpfr_set_inf (init_expr
->value
.complex.i
, 1);
6777 case GFC_INIT_REAL_NEG_INF
:
6778 mpfr_set_inf (init_expr
->value
.complex.r
, -1);
6779 mpfr_set_inf (init_expr
->value
.complex.i
, -1);
6782 case GFC_INIT_REAL_ZERO
:
6783 mpfr_set_ui (init_expr
->value
.complex.r
, 0.0, GFC_RND_MODE
);
6784 mpfr_set_ui (init_expr
->value
.complex.i
, 0.0, GFC_RND_MODE
);
6788 gfc_free_expr (init_expr
);
6795 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
6796 init_expr
->value
.logical
= 0;
6797 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
6798 init_expr
->value
.logical
= 1;
6801 gfc_free_expr (init_expr
);
6807 /* For characters, the length must be constant in order to
6808 create a default initializer. */
6809 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
6810 && sym
->ts
.cl
->length
6811 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6813 char_len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
6814 init_expr
->value
.character
.length
= char_len
;
6815 init_expr
->value
.character
.string
= gfc_getmem (char_len
+1);
6816 ch
= init_expr
->value
.character
.string
;
6817 for (i
= 0; i
< char_len
; i
++)
6818 *(ch
++) = gfc_option
.flag_init_character_value
;
6822 gfc_free_expr (init_expr
);
6828 gfc_free_expr (init_expr
);
6834 /* Add an initialization expression to a local variable. */
6836 apply_default_init_local (gfc_symbol
*sym
)
6838 gfc_expr
*init
= NULL
;
6840 /* The symbol should be a variable or a function return value. */
6841 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
6842 || (sym
->attr
.function
&& sym
->result
!= sym
))
6845 /* Try to build the initializer expression. If we can't initialize
6846 this symbol, then init will be NULL. */
6847 init
= build_default_init_expr (sym
);
6851 /* For saved variables, we don't want to add an initializer at
6852 function entry, so we just add a static initializer. */
6853 if (sym
->attr
.save
|| sym
->ns
->save_all
)
6855 /* Don't clobber an existing initializer! */
6856 gcc_assert (sym
->value
== NULL
);
6861 build_init_assign (sym
, init
);
6864 /* Resolution of common features of flavors variable and procedure. */
6867 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
6869 /* Constraints on deferred shape variable. */
6870 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
6872 if (sym
->attr
.allocatable
)
6874 if (sym
->attr
.dimension
)
6875 gfc_error ("Allocatable array '%s' at %L must have "
6876 "a deferred shape", sym
->name
, &sym
->declared_at
);
6878 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6879 sym
->name
, &sym
->declared_at
);
6883 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
6885 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6886 sym
->name
, &sym
->declared_at
);
6893 if (!mp_flag
&& !sym
->attr
.allocatable
6894 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
6896 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6897 sym
->name
, &sym
->declared_at
);
6905 /* Additional checks for symbols with flavor variable and derived
6906 type. To be called from resolve_fl_variable. */
6909 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
6911 gcc_assert (sym
->ts
.type
== BT_DERIVED
);
6913 /* Check to see if a derived type is blocked from being host
6914 associated by the presence of another class I symbol in the same
6915 namespace. 14.6.1.3 of the standard and the discussion on
6916 comp.lang.fortran. */
6917 if (sym
->ns
!= sym
->ts
.derived
->ns
6918 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
6921 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
6922 if (s
&& (s
->attr
.flavor
!= FL_DERIVED
6923 || !gfc_compare_derived_types (s
, sym
->ts
.derived
)))
6925 gfc_error ("The type '%s' cannot be host associated at %L "
6926 "because it is blocked by an incompatible object "
6927 "of the same name declared at %L",
6928 sym
->ts
.derived
->name
, &sym
->declared_at
,
6934 /* 4th constraint in section 11.3: "If an object of a type for which
6935 component-initialization is specified (R429) appears in the
6936 specification-part of a module and does not have the ALLOCATABLE
6937 or POINTER attribute, the object shall have the SAVE attribute."
6939 The check for initializers is performed with
6940 has_default_initializer because gfc_default_initializer generates
6941 a hidden default for allocatable components. */
6942 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
6943 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
6944 && !sym
->ns
->save_all
&& !sym
->attr
.save
6945 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
6946 && has_default_initializer (sym
->ts
.derived
))
6948 gfc_error("Object '%s' at %L must have the SAVE attribute for "
6949 "default initialization of a component",
6950 sym
->name
, &sym
->declared_at
);
6954 /* Assign default initializer. */
6955 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
6956 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
6958 sym
->value
= gfc_default_initializer (&sym
->ts
);
6965 /* Resolve symbols with flavor variable. */
6968 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
6970 int no_init_flag
, automatic_flag
;
6972 const char *auto_save_msg
;
6974 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
6977 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
6980 /* Set this flag to check that variables are parameters of all entries.
6981 This check is effected by the call to gfc_resolve_expr through
6982 is_non_constant_shape_array. */
6983 specification_expr
= 1;
6985 if (sym
->ns
->proc_name
6986 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
6987 || sym
->ns
->proc_name
->attr
.is_main_program
)
6988 && !sym
->attr
.use_assoc
6989 && !sym
->attr
.allocatable
6990 && !sym
->attr
.pointer
6991 && is_non_constant_shape_array (sym
))
6993 /* The shape of a main program or module array needs to be
6995 gfc_error ("The module or main program array '%s' at %L must "
6996 "have constant shape", sym
->name
, &sym
->declared_at
);
6997 specification_expr
= 0;
7001 if (sym
->ts
.type
== BT_CHARACTER
)
7003 /* Make sure that character string variables with assumed length are
7005 e
= sym
->ts
.cl
->length
;
7006 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
7008 gfc_error ("Entity with assumed character length at %L must be a "
7009 "dummy argument or a PARAMETER", &sym
->declared_at
);
7013 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
7015 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7019 if (!gfc_is_constant_expr (e
)
7020 && !(e
->expr_type
== EXPR_VARIABLE
7021 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
7022 && sym
->ns
->proc_name
7023 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7024 || sym
->ns
->proc_name
->attr
.is_main_program
)
7025 && !sym
->attr
.use_assoc
)
7027 gfc_error ("'%s' at %L must have constant character length "
7028 "in this context", sym
->name
, &sym
->declared_at
);
7033 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
7034 apply_default_init_local (sym
); /* Try to apply a default initialization. */
7036 /* Determine if the symbol may not have an initializer. */
7037 no_init_flag
= automatic_flag
= 0;
7038 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
7039 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
7041 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
7042 && is_non_constant_shape_array (sym
))
7044 no_init_flag
= automatic_flag
= 1;
7046 /* Also, they must not have the SAVE attribute.
7047 SAVE_IMPLICIT is checked below. */
7048 if (sym
->attr
.save
== SAVE_EXPLICIT
)
7050 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7055 /* Reject illegal initializers. */
7056 if (!sym
->mark
&& sym
->value
)
7058 if (sym
->attr
.allocatable
)
7059 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7060 sym
->name
, &sym
->declared_at
);
7061 else if (sym
->attr
.external
)
7062 gfc_error ("External '%s' at %L cannot have an initializer",
7063 sym
->name
, &sym
->declared_at
);
7064 else if (sym
->attr
.dummy
7065 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
7066 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7067 sym
->name
, &sym
->declared_at
);
7068 else if (sym
->attr
.intrinsic
)
7069 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7070 sym
->name
, &sym
->declared_at
);
7071 else if (sym
->attr
.result
)
7072 gfc_error ("Function result '%s' at %L cannot have an initializer",
7073 sym
->name
, &sym
->declared_at
);
7074 else if (automatic_flag
)
7075 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7076 sym
->name
, &sym
->declared_at
);
7083 if (sym
->ts
.type
== BT_DERIVED
)
7084 return resolve_fl_variable_derived (sym
, no_init_flag
);
7090 /* Resolve a procedure. */
7093 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
7095 gfc_formal_arglist
*arg
;
7097 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
7098 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7099 "interfaces", sym
->name
, &sym
->declared_at
);
7101 if (sym
->attr
.function
7102 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
7105 if (sym
->ts
.type
== BT_CHARACTER
)
7107 gfc_charlen
*cl
= sym
->ts
.cl
;
7109 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
7110 && resolve_charlen (cl
) == FAILURE
)
7113 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
7115 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7117 gfc_error ("Character-valued statement function '%s' at %L must "
7118 "have constant length", sym
->name
, &sym
->declared_at
);
7122 if (sym
->attr
.external
&& sym
->formal
== NULL
7123 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
7125 gfc_error ("Automatic character length function '%s' at %L must "
7126 "have an explicit interface", sym
->name
,
7133 /* Ensure that derived type for are not of a private type. Internal
7134 module procedures are excluded by 2.2.3.3 - ie. they are not
7135 externally accessible and can access all the objects accessible in
7137 if (!(sym
->ns
->parent
7138 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
7139 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
7141 gfc_interface
*iface
;
7143 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
7146 && arg
->sym
->ts
.type
== BT_DERIVED
7147 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7148 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7149 arg
->sym
->ts
.derived
->ns
->default_access
)
7150 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
7151 "PRIVATE type and cannot be a dummy argument"
7152 " of '%s', which is PUBLIC at %L",
7153 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
7156 /* Stop this message from recurring. */
7157 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7162 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7163 PRIVATE to the containing module. */
7164 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7166 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7169 && arg
->sym
->ts
.type
== BT_DERIVED
7170 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7171 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7172 arg
->sym
->ts
.derived
->ns
->default_access
)
7173 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7174 "'%s' in PUBLIC interface '%s' at %L "
7175 "takes dummy arguments of '%s' which is "
7176 "PRIVATE", iface
->sym
->name
, sym
->name
,
7177 &iface
->sym
->declared_at
,
7178 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7180 /* Stop this message from recurring. */
7181 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7187 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7188 PRIVATE to the containing module. */
7189 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7191 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7194 && arg
->sym
->ts
.type
== BT_DERIVED
7195 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7196 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7197 arg
->sym
->ts
.derived
->ns
->default_access
)
7198 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7199 "'%s' in PUBLIC interface '%s' at %L "
7200 "takes dummy arguments of '%s' which is "
7201 "PRIVATE", iface
->sym
->name
, sym
->name
,
7202 &iface
->sym
->declared_at
,
7203 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7205 /* Stop this message from recurring. */
7206 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7213 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
)
7215 gfc_error ("Function '%s' at %L cannot have an initializer",
7216 sym
->name
, &sym
->declared_at
);
7220 /* An external symbol may not have an initializer because it is taken to be
7222 if (sym
->attr
.external
&& sym
->value
)
7224 gfc_error ("External object '%s' at %L may not have an initializer",
7225 sym
->name
, &sym
->declared_at
);
7229 /* An elemental function is required to return a scalar 12.7.1 */
7230 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
7232 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7233 "result", sym
->name
, &sym
->declared_at
);
7234 /* Reset so that the error only occurs once. */
7235 sym
->attr
.elemental
= 0;
7239 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7240 char-len-param shall not be array-valued, pointer-valued, recursive
7241 or pure. ....snip... A character value of * may only be used in the
7242 following ways: (i) Dummy arg of procedure - dummy associates with
7243 actual length; (ii) To declare a named constant; or (iii) External
7244 function - but length must be declared in calling scoping unit. */
7245 if (sym
->attr
.function
7246 && sym
->ts
.type
== BT_CHARACTER
7247 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
7249 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
7250 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
7252 if (sym
->as
&& sym
->as
->rank
)
7253 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7254 "array-valued", sym
->name
, &sym
->declared_at
);
7256 if (sym
->attr
.pointer
)
7257 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7258 "pointer-valued", sym
->name
, &sym
->declared_at
);
7261 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7262 "pure", sym
->name
, &sym
->declared_at
);
7264 if (sym
->attr
.recursive
)
7265 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7266 "recursive", sym
->name
, &sym
->declared_at
);
7271 /* Appendix B.2 of the standard. Contained functions give an
7272 error anyway. Fixed-form is likely to be F77/legacy. */
7273 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
7274 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
7275 "'%s' at %L is obsolescent in fortran 95",
7276 sym
->name
, &sym
->declared_at
);
7279 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
7281 gfc_formal_arglist
*curr_arg
;
7282 int has_non_interop_arg
= 0;
7284 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
7285 sym
->common_block
) == FAILURE
)
7287 /* Clear these to prevent looking at them again if there was an
7289 sym
->attr
.is_bind_c
= 0;
7290 sym
->attr
.is_c_interop
= 0;
7291 sym
->ts
.is_c_interop
= 0;
7295 /* So far, no errors have been found. */
7296 sym
->attr
.is_c_interop
= 1;
7297 sym
->ts
.is_c_interop
= 1;
7300 curr_arg
= sym
->formal
;
7301 while (curr_arg
!= NULL
)
7303 /* Skip implicitly typed dummy args here. */
7304 if (curr_arg
->sym
->attr
.implicit_type
== 0)
7305 if (verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
7306 /* If something is found to fail, record the fact so we
7307 can mark the symbol for the procedure as not being
7308 BIND(C) to try and prevent multiple errors being
7310 has_non_interop_arg
= 1;
7312 curr_arg
= curr_arg
->next
;
7315 /* See if any of the arguments were not interoperable and if so, clear
7316 the procedure symbol to prevent duplicate error messages. */
7317 if (has_non_interop_arg
!= 0)
7319 sym
->attr
.is_c_interop
= 0;
7320 sym
->ts
.is_c_interop
= 0;
7321 sym
->attr
.is_bind_c
= 0;
7329 /* Resolve the components of a derived type. */
7332 resolve_fl_derived (gfc_symbol
*sym
)
7335 gfc_dt_list
* dt_list
;
7338 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
7340 if (c
->ts
.type
== BT_CHARACTER
)
7342 if (c
->ts
.cl
->length
== NULL
7343 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
7344 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
7346 gfc_error ("Character length of component '%s' needs to "
7347 "be a constant specification expression at %L",
7349 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
7354 if (c
->ts
.type
== BT_DERIVED
7355 && sym
->component_access
!= ACCESS_PRIVATE
7356 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
7357 && !c
->ts
.derived
->attr
.use_assoc
7358 && !gfc_check_access (c
->ts
.derived
->attr
.access
,
7359 c
->ts
.derived
->ns
->default_access
))
7361 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
7362 "a component of '%s', which is PUBLIC at %L",
7363 c
->name
, sym
->name
, &sym
->declared_at
);
7367 if (sym
->attr
.sequence
)
7369 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
7371 gfc_error ("Component %s of SEQUENCE type declared at %L does "
7372 "not have the SEQUENCE attribute",
7373 c
->ts
.derived
->name
, &sym
->declared_at
);
7378 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
7379 && c
->ts
.derived
->components
== NULL
)
7381 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
7382 "that has not been declared", c
->name
, sym
->name
,
7387 if (c
->pointer
|| c
->allocatable
|| c
->as
== NULL
)
7390 for (i
= 0; i
< c
->as
->rank
; i
++)
7392 if (c
->as
->lower
[i
] == NULL
7393 || !gfc_is_constant_expr (c
->as
->lower
[i
])
7394 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
7395 || c
->as
->upper
[i
] == NULL
7396 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
7397 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
7399 gfc_error ("Component '%s' of '%s' at %L must have "
7400 "constant array bounds",
7401 c
->name
, sym
->name
, &c
->loc
);
7407 /* Add derived type to the derived type list. */
7408 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
7409 if (sym
== dt_list
->derived
)
7412 if (dt_list
== NULL
)
7414 dt_list
= gfc_get_dt_list ();
7415 dt_list
->next
= gfc_derived_types
;
7416 dt_list
->derived
= sym
;
7417 gfc_derived_types
= dt_list
;
7425 resolve_fl_namelist (gfc_symbol
*sym
)
7430 /* Reject PRIVATE objects in a PUBLIC namelist. */
7431 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
7433 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7435 if (!nl
->sym
->attr
.use_assoc
7436 && !(sym
->ns
->parent
== nl
->sym
->ns
)
7437 && !(sym
->ns
->parent
7438 && sym
->ns
->parent
->parent
== nl
->sym
->ns
)
7439 && !gfc_check_access(nl
->sym
->attr
.access
,
7440 nl
->sym
->ns
->default_access
))
7442 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7443 "cannot be member of PUBLIC namelist '%s' at %L",
7444 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7448 /* Types with private components that came here by USE-association. */
7449 if (nl
->sym
->ts
.type
== BT_DERIVED
7450 && derived_inaccessible (nl
->sym
->ts
.derived
))
7452 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
7453 "components and cannot be member of namelist '%s' at %L",
7454 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7458 /* Types with private components that are defined in the same module. */
7459 if (nl
->sym
->ts
.type
== BT_DERIVED
7460 && !(sym
->ns
->parent
== nl
->sym
->ts
.derived
->ns
)
7461 && !gfc_check_access (nl
->sym
->ts
.derived
->attr
.private_comp
7462 ? ACCESS_PRIVATE
: ACCESS_UNKNOWN
,
7463 nl
->sym
->ns
->default_access
))
7465 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7466 "cannot be a member of PUBLIC namelist '%s' at %L",
7467 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7473 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7475 /* Reject namelist arrays of assumed shape. */
7476 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
7477 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
7478 "must not have assumed shape in namelist "
7479 "'%s' at %L", nl
->sym
->name
, sym
->name
,
7480 &sym
->declared_at
) == FAILURE
)
7483 /* Reject namelist arrays that are not constant shape. */
7484 if (is_non_constant_shape_array (nl
->sym
))
7486 gfc_error ("NAMELIST array object '%s' must have constant "
7487 "shape in namelist '%s' at %L", nl
->sym
->name
,
7488 sym
->name
, &sym
->declared_at
);
7492 /* Namelist objects cannot have allocatable or pointer components. */
7493 if (nl
->sym
->ts
.type
!= BT_DERIVED
)
7496 if (nl
->sym
->ts
.derived
->attr
.alloc_comp
)
7498 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7499 "have ALLOCATABLE components",
7500 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7504 if (nl
->sym
->ts
.derived
->attr
.pointer_comp
)
7506 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7507 "have POINTER components",
7508 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7514 /* 14.1.2 A module or internal procedure represent local entities
7515 of the same type as a namelist member and so are not allowed. */
7516 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7518 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
7521 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
7522 if ((nl
->sym
== sym
->ns
->proc_name
)
7524 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
7528 if (nl
->sym
&& nl
->sym
->name
)
7529 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
7530 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
7532 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7533 "attribute in '%s' at %L", nlsym
->name
,
7544 resolve_fl_parameter (gfc_symbol
*sym
)
7546 /* A parameter array's shape needs to be constant. */
7548 && (sym
->as
->type
== AS_DEFERRED
7549 || is_non_constant_shape_array (sym
)))
7551 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7552 "or of deferred shape", sym
->name
, &sym
->declared_at
);
7556 /* Make sure a parameter that has been implicitly typed still
7557 matches the implicit type, since PARAMETER statements can precede
7558 IMPLICIT statements. */
7559 if (sym
->attr
.implicit_type
7560 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
7562 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7563 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
7567 /* Make sure the types of derived parameters are consistent. This
7568 type checking is deferred until resolution because the type may
7569 refer to a derived type from the host. */
7570 if (sym
->ts
.type
== BT_DERIVED
7571 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
7573 gfc_error ("Incompatible derived type in PARAMETER at %L",
7574 &sym
->value
->where
);
7581 /* Do anything necessary to resolve a symbol. Right now, we just
7582 assume that an otherwise unknown symbol is a variable. This sort
7583 of thing commonly happens for symbols in module. */
7586 resolve_symbol (gfc_symbol
*sym
)
7588 int check_constant
, mp_flag
;
7589 gfc_symtree
*symtree
;
7590 gfc_symtree
*this_symtree
;
7594 if (sym
->attr
.flavor
== FL_UNKNOWN
)
7597 /* If we find that a flavorless symbol is an interface in one of the
7598 parent namespaces, find its symtree in this namespace, free the
7599 symbol and set the symtree to point to the interface symbol. */
7600 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
7602 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
7603 if (symtree
&& symtree
->n
.sym
->generic
)
7605 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
7609 gfc_free_symbol (sym
);
7610 symtree
->n
.sym
->refs
++;
7611 this_symtree
->n
.sym
= symtree
->n
.sym
;
7616 /* Otherwise give it a flavor according to such attributes as
7618 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
7619 sym
->attr
.flavor
= FL_VARIABLE
;
7622 sym
->attr
.flavor
= FL_PROCEDURE
;
7623 if (sym
->attr
.dimension
)
7624 sym
->attr
.function
= 1;
7628 if (sym
->attr
.procedure
&& sym
->interface
7629 && sym
->attr
.if_source
!= IFSRC_DECL
)
7631 if (sym
->interface
->attr
.procedure
)
7632 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
7633 "in a later PROCEDURE statement", sym
->interface
->name
,
7634 sym
->name
,&sym
->declared_at
);
7636 /* Get the attributes from the interface (now resolved). */
7637 if (sym
->interface
->attr
.if_source
|| sym
->interface
->attr
.intrinsic
)
7639 sym
->ts
= sym
->interface
->ts
;
7640 sym
->attr
.function
= sym
->interface
->attr
.function
;
7641 sym
->attr
.subroutine
= sym
->interface
->attr
.subroutine
;
7642 copy_formal_args (sym
, sym
->interface
);
7644 else if (sym
->interface
->name
[0] != '\0')
7646 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
7647 sym
->interface
->name
, sym
->name
, &sym
->declared_at
);
7652 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
7655 /* Symbols that are module procedures with results (functions) have
7656 the types and array specification copied for type checking in
7657 procedures that call them, as well as for saving to a module
7658 file. These symbols can't stand the scrutiny that their results
7660 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
7663 /* Make sure that the intrinsic is consistent with its internal
7664 representation. This needs to be done before assigning a default
7665 type to avoid spurious warnings. */
7666 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
)
7668 if (gfc_intrinsic_name (sym
->name
, 0))
7670 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
)
7671 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7672 sym
->name
, &sym
->declared_at
);
7674 else if (gfc_intrinsic_name (sym
->name
, 1))
7676 if (sym
->ts
.type
!= BT_UNKNOWN
)
7678 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7679 sym
->name
, &sym
->declared_at
);
7685 gfc_error ("Intrinsic '%s' at %L does not exist", sym
->name
, &sym
->declared_at
);
7690 /* Assign default type to symbols that need one and don't have one. */
7691 if (sym
->ts
.type
== BT_UNKNOWN
)
7693 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
7694 gfc_set_default_type (sym
, 1, NULL
);
7696 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
7698 /* The specific case of an external procedure should emit an error
7699 in the case that there is no implicit type. */
7701 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
7704 /* Result may be in another namespace. */
7705 resolve_symbol (sym
->result
);
7707 sym
->ts
= sym
->result
->ts
;
7708 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
7709 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
7710 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
7711 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
7716 /* Assumed size arrays and assumed shape arrays must be dummy
7720 && (sym
->as
->type
== AS_ASSUMED_SIZE
7721 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
7722 && sym
->attr
.dummy
== 0)
7724 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
7725 gfc_error ("Assumed size array at %L must be a dummy argument",
7728 gfc_error ("Assumed shape array at %L must be a dummy argument",
7733 /* Make sure symbols with known intent or optional are really dummy
7734 variable. Because of ENTRY statement, this has to be deferred
7735 until resolution time. */
7737 if (!sym
->attr
.dummy
7738 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
7740 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
7744 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
7746 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7747 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
7751 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
7753 gfc_charlen
*cl
= sym
->ts
.cl
;
7754 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
7756 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7757 "attribute must have constant length",
7758 sym
->name
, &sym
->declared_at
);
7762 if (sym
->ts
.is_c_interop
7763 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
7765 gfc_error ("C interoperable character dummy variable '%s' at %L "
7766 "with VALUE attribute must have length one",
7767 sym
->name
, &sym
->declared_at
);
7772 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7773 do this for something that was implicitly typed because that is handled
7774 in gfc_set_default_type. Handle dummy arguments and procedure
7775 definitions separately. Also, anything that is use associated is not
7776 handled here but instead is handled in the module it is declared in.
7777 Finally, derived type definitions are allowed to be BIND(C) since that
7778 only implies that they're interoperable, and they are checked fully for
7779 interoperability when a variable is declared of that type. */
7780 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
7781 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
7782 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
7786 /* First, make sure the variable is declared at the
7787 module-level scope (J3/04-007, Section 15.3). */
7788 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
7789 sym
->attr
.in_common
== 0)
7791 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7792 "is neither a COMMON block nor declared at the "
7793 "module level scope", sym
->name
, &(sym
->declared_at
));
7796 else if (sym
->common_head
!= NULL
)
7798 t
= verify_com_block_vars_c_interop (sym
->common_head
);
7802 /* If type() declaration, we need to verify that the components
7803 of the given type are all C interoperable, etc. */
7804 if (sym
->ts
.type
== BT_DERIVED
&&
7805 sym
->ts
.derived
->attr
.is_c_interop
!= 1)
7807 /* Make sure the user marked the derived type as BIND(C). If
7808 not, call the verify routine. This could print an error
7809 for the derived type more than once if multiple variables
7810 of that type are declared. */
7811 if (sym
->ts
.derived
->attr
.is_bind_c
!= 1)
7812 verify_bind_c_derived_type (sym
->ts
.derived
);
7816 /* Verify the variable itself as C interoperable if it
7817 is BIND(C). It is not possible for this to succeed if
7818 the verify_bind_c_derived_type failed, so don't have to handle
7819 any error returned by verify_bind_c_derived_type. */
7820 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
7826 /* clear the is_bind_c flag to prevent reporting errors more than
7827 once if something failed. */
7828 sym
->attr
.is_bind_c
= 0;
7833 /* If a derived type symbol has reached this point, without its
7834 type being declared, we have an error. Notice that most
7835 conditions that produce undefined derived types have already
7836 been dealt with. However, the likes of:
7837 implicit type(t) (t) ..... call foo (t) will get us here if
7838 the type is not declared in the scope of the implicit
7839 statement. Change the type to BT_UNKNOWN, both because it is so
7840 and to prevent an ICE. */
7841 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
->components
== NULL
7842 && !sym
->ts
.derived
->attr
.zero_comp
)
7844 gfc_error ("The derived type '%s' at %L is of type '%s', "
7845 "which has not been defined", sym
->name
,
7846 &sym
->declared_at
, sym
->ts
.derived
->name
);
7847 sym
->ts
.type
= BT_UNKNOWN
;
7851 /* Unless the derived-type declaration is use associated, Fortran 95
7852 does not allow public entries of private derived types.
7853 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
7855 if (sym
->ts
.type
== BT_DERIVED
7856 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7857 && !sym
->ts
.derived
->attr
.use_assoc
7858 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
7859 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
7860 sym
->ts
.derived
->ns
->default_access
)
7861 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
7862 "of PRIVATE derived type '%s'",
7863 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
7864 : "variable", sym
->name
, &sym
->declared_at
,
7865 sym
->ts
.derived
->name
) == FAILURE
)
7868 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7869 default initialization is defined (5.1.2.4.4). */
7870 if (sym
->ts
.type
== BT_DERIVED
7872 && sym
->attr
.intent
== INTENT_OUT
7874 && sym
->as
->type
== AS_ASSUMED_SIZE
)
7876 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
7880 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7881 "ASSUMED SIZE and so cannot have a default initializer",
7882 sym
->name
, &sym
->declared_at
);
7888 switch (sym
->attr
.flavor
)
7891 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
7896 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
7901 if (resolve_fl_namelist (sym
) == FAILURE
)
7906 if (resolve_fl_parameter (sym
) == FAILURE
)
7914 /* Resolve array specifier. Check as well some constraints
7915 on COMMON blocks. */
7917 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
7919 /* Set the formal_arg_flag so that check_conflict will not throw
7920 an error for host associated variables in the specification
7921 expression for an array_valued function. */
7922 if (sym
->attr
.function
&& sym
->as
)
7923 formal_arg_flag
= 1;
7925 gfc_resolve_array_spec (sym
->as
, check_constant
);
7927 formal_arg_flag
= 0;
7929 /* Resolve formal namespaces. */
7930 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
)
7931 gfc_resolve (sym
->formal_ns
);
7933 /* Check threadprivate restrictions. */
7934 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
7935 && (!sym
->attr
.in_common
7936 && sym
->module
== NULL
7937 && (sym
->ns
->proc_name
== NULL
7938 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
7939 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
7941 /* If we have come this far we can apply default-initializers, as
7942 described in 14.7.5, to those variables that have not already
7943 been assigned one. */
7944 if (sym
->ts
.type
== BT_DERIVED
7945 && sym
->attr
.referenced
7946 && sym
->ns
== gfc_current_ns
7948 && !sym
->attr
.allocatable
7949 && !sym
->attr
.alloc_comp
)
7951 symbol_attribute
*a
= &sym
->attr
;
7953 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
7954 && !a
->in_common
&& !a
->use_assoc
7955 && !(a
->function
&& sym
!= sym
->result
))
7956 || (a
->dummy
&& a
->intent
== INTENT_OUT
))
7957 apply_default_init (sym
);
7962 /************* Resolve DATA statements *************/
7966 gfc_data_value
*vnode
;
7972 /* Advance the values structure to point to the next value in the data list. */
7975 next_data_value (void)
7978 while (mpz_cmp_ui (values
.left
, 0) == 0)
7980 if (values
.vnode
->next
== NULL
)
7983 values
.vnode
= values
.vnode
->next
;
7984 mpz_set (values
.left
, values
.vnode
->repeat
);
7992 check_data_variable (gfc_data_variable
*var
, locus
*where
)
7998 ar_type mark
= AR_UNKNOWN
;
8000 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
8004 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
8008 mpz_init_set_si (offset
, 0);
8011 if (e
->expr_type
!= EXPR_VARIABLE
)
8012 gfc_internal_error ("check_data_variable(): Bad expression");
8014 if (e
->symtree
->n
.sym
->ns
->is_block_data
8015 && !e
->symtree
->n
.sym
->attr
.in_common
)
8017 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
8018 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
8021 if (e
->ref
== NULL
&& e
->symtree
->n
.sym
->as
)
8023 gfc_error ("DATA array '%s' at %L must be specified in a previous"
8024 " declaration", e
->symtree
->n
.sym
->name
, where
);
8030 mpz_init_set_ui (size
, 1);
8037 /* Find the array section reference. */
8038 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
8040 if (ref
->type
!= REF_ARRAY
)
8042 if (ref
->u
.ar
.type
== AR_ELEMENT
)
8048 /* Set marks according to the reference pattern. */
8049 switch (ref
->u
.ar
.type
)
8057 /* Get the start position of array section. */
8058 gfc_get_section_index (ar
, section_index
, &offset
);
8066 if (gfc_array_size (e
, &size
) == FAILURE
)
8068 gfc_error ("Nonconstant array section at %L in DATA statement",
8077 while (mpz_cmp_ui (size
, 0) > 0)
8079 if (next_data_value () == FAILURE
)
8081 gfc_error ("DATA statement at %L has more variables than values",
8087 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
8091 /* If we have more than one element left in the repeat count,
8092 and we have more than one element left in the target variable,
8093 then create a range assignment. */
8094 /* FIXME: Only done for full arrays for now, since array sections
8096 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
8097 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
8101 if (mpz_cmp (size
, values
.left
) >= 0)
8103 mpz_init_set (range
, values
.left
);
8104 mpz_sub (size
, size
, values
.left
);
8105 mpz_set_ui (values
.left
, 0);
8109 mpz_init_set (range
, size
);
8110 mpz_sub (values
.left
, values
.left
, size
);
8111 mpz_set_ui (size
, 0);
8114 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
8117 mpz_add (offset
, offset
, range
);
8121 /* Assign initial value to symbol. */
8124 mpz_sub_ui (values
.left
, values
.left
, 1);
8125 mpz_sub_ui (size
, size
, 1);
8127 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
8131 if (mark
== AR_FULL
)
8132 mpz_add_ui (offset
, offset
, 1);
8134 /* Modify the array section indexes and recalculate the offset
8135 for next element. */
8136 else if (mark
== AR_SECTION
)
8137 gfc_advance_section (section_index
, ar
, &offset
);
8141 if (mark
== AR_SECTION
)
8143 for (i
= 0; i
< ar
->dimen
; i
++)
8144 mpz_clear (section_index
[i
]);
8154 static try traverse_data_var (gfc_data_variable
*, locus
*);
8156 /* Iterate over a list of elements in a DATA statement. */
8159 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
8162 iterator_stack frame
;
8163 gfc_expr
*e
, *start
, *end
, *step
;
8164 try retval
= SUCCESS
;
8166 mpz_init (frame
.value
);
8168 start
= gfc_copy_expr (var
->iter
.start
);
8169 end
= gfc_copy_expr (var
->iter
.end
);
8170 step
= gfc_copy_expr (var
->iter
.step
);
8172 if (gfc_simplify_expr (start
, 1) == FAILURE
8173 || start
->expr_type
!= EXPR_CONSTANT
)
8175 gfc_error ("iterator start at %L does not simplify", &start
->where
);
8179 if (gfc_simplify_expr (end
, 1) == FAILURE
8180 || end
->expr_type
!= EXPR_CONSTANT
)
8182 gfc_error ("iterator end at %L does not simplify", &end
->where
);
8186 if (gfc_simplify_expr (step
, 1) == FAILURE
8187 || step
->expr_type
!= EXPR_CONSTANT
)
8189 gfc_error ("iterator step at %L does not simplify", &step
->where
);
8194 mpz_init_set (trip
, end
->value
.integer
);
8195 mpz_sub (trip
, trip
, start
->value
.integer
);
8196 mpz_add (trip
, trip
, step
->value
.integer
);
8198 mpz_div (trip
, trip
, step
->value
.integer
);
8200 mpz_set (frame
.value
, start
->value
.integer
);
8202 frame
.prev
= iter_stack
;
8203 frame
.variable
= var
->iter
.var
->symtree
;
8204 iter_stack
= &frame
;
8206 while (mpz_cmp_ui (trip
, 0) > 0)
8208 if (traverse_data_var (var
->list
, where
) == FAILURE
)
8215 e
= gfc_copy_expr (var
->expr
);
8216 if (gfc_simplify_expr (e
, 1) == FAILURE
)
8224 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
8226 mpz_sub_ui (trip
, trip
, 1);
8231 mpz_clear (frame
.value
);
8233 gfc_free_expr (start
);
8234 gfc_free_expr (end
);
8235 gfc_free_expr (step
);
8237 iter_stack
= frame
.prev
;
8242 /* Type resolve variables in the variable list of a DATA statement. */
8245 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
8249 for (; var
; var
= var
->next
)
8251 if (var
->expr
== NULL
)
8252 t
= traverse_data_list (var
, where
);
8254 t
= check_data_variable (var
, where
);
8264 /* Resolve the expressions and iterators associated with a data statement.
8265 This is separate from the assignment checking because data lists should
8266 only be resolved once. */
8269 resolve_data_variables (gfc_data_variable
*d
)
8271 for (; d
; d
= d
->next
)
8273 if (d
->list
== NULL
)
8275 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
8280 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
8283 if (resolve_data_variables (d
->list
) == FAILURE
)
8292 /* Resolve a single DATA statement. We implement this by storing a pointer to
8293 the value list into static variables, and then recursively traversing the
8294 variables list, expanding iterators and such. */
8297 resolve_data (gfc_data
*d
)
8300 if (resolve_data_variables (d
->var
) == FAILURE
)
8303 values
.vnode
= d
->value
;
8304 if (d
->value
== NULL
)
8305 mpz_set_ui (values
.left
, 0);
8307 mpz_set (values
.left
, d
->value
->repeat
);
8309 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
8312 /* At this point, we better not have any values left. */
8314 if (next_data_value () == SUCCESS
)
8315 gfc_error ("DATA statement at %L has more values than variables",
8320 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
8321 accessed by host or use association, is a dummy argument to a pure function,
8322 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
8323 is storage associated with any such variable, shall not be used in the
8324 following contexts: (clients of this function). */
8326 /* Determines if a variable is not 'pure', ie not assignable within a pure
8327 procedure. Returns zero if assignment is OK, nonzero if there is a
8330 gfc_impure_variable (gfc_symbol
*sym
)
8334 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
8337 if (sym
->ns
!= gfc_current_ns
)
8338 return !sym
->attr
.function
;
8340 proc
= sym
->ns
->proc_name
;
8341 if (sym
->attr
.dummy
&& gfc_pure (proc
)
8342 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
8344 proc
->attr
.function
))
8347 /* TODO: Sort out what can be storage associated, if anything, and include
8348 it here. In principle equivalences should be scanned but it does not
8349 seem to be possible to storage associate an impure variable this way. */
8354 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
8355 symbol of the current procedure. */
8358 gfc_pure (gfc_symbol
*sym
)
8360 symbol_attribute attr
;
8363 sym
= gfc_current_ns
->proc_name
;
8369 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
8373 /* Test whether the current procedure is elemental or not. */
8376 gfc_elemental (gfc_symbol
*sym
)
8378 symbol_attribute attr
;
8381 sym
= gfc_current_ns
->proc_name
;
8386 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
8390 /* Warn about unused labels. */
8393 warn_unused_fortran_label (gfc_st_label
*label
)
8398 warn_unused_fortran_label (label
->left
);
8400 if (label
->defined
== ST_LABEL_UNKNOWN
)
8403 switch (label
->referenced
)
8405 case ST_LABEL_UNKNOWN
:
8406 gfc_warning ("Label %d at %L defined but not used", label
->value
,
8410 case ST_LABEL_BAD_TARGET
:
8411 gfc_warning ("Label %d at %L defined but cannot be used",
8412 label
->value
, &label
->where
);
8419 warn_unused_fortran_label (label
->right
);
8423 /* Returns the sequence type of a symbol or sequence. */
8426 sequence_type (gfc_typespec ts
)
8435 if (ts
.derived
->components
== NULL
)
8436 return SEQ_NONDEFAULT
;
8438 result
= sequence_type (ts
.derived
->components
->ts
);
8439 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
8440 if (sequence_type (c
->ts
) != result
)
8446 if (ts
.kind
!= gfc_default_character_kind
)
8447 return SEQ_NONDEFAULT
;
8449 return SEQ_CHARACTER
;
8452 if (ts
.kind
!= gfc_default_integer_kind
)
8453 return SEQ_NONDEFAULT
;
8458 if (!(ts
.kind
== gfc_default_real_kind
8459 || ts
.kind
== gfc_default_double_kind
))
8460 return SEQ_NONDEFAULT
;
8465 if (ts
.kind
!= gfc_default_complex_kind
)
8466 return SEQ_NONDEFAULT
;
8471 if (ts
.kind
!= gfc_default_logical_kind
)
8472 return SEQ_NONDEFAULT
;
8477 return SEQ_NONDEFAULT
;
8482 /* Resolve derived type EQUIVALENCE object. */
8485 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
8488 gfc_component
*c
= derived
->components
;
8493 /* Shall not be an object of nonsequence derived type. */
8494 if (!derived
->attr
.sequence
)
8496 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8497 "attribute to be an EQUIVALENCE object", sym
->name
,
8502 /* Shall not have allocatable components. */
8503 if (derived
->attr
.alloc_comp
)
8505 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8506 "components to be an EQUIVALENCE object",sym
->name
,
8511 for (; c
; c
= c
->next
)
8515 && (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
8518 /* Shall not be an object of sequence derived type containing a pointer
8519 in the structure. */
8522 gfc_error ("Derived type variable '%s' at %L with pointer "
8523 "component(s) cannot be an EQUIVALENCE object",
8524 sym
->name
, &e
->where
);
8532 /* Resolve equivalence object.
8533 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8534 an allocatable array, an object of nonsequence derived type, an object of
8535 sequence derived type containing a pointer at any level of component
8536 selection, an automatic object, a function name, an entry name, a result
8537 name, a named constant, a structure component, or a subobject of any of
8538 the preceding objects. A substring shall not have length zero. A
8539 derived type shall not have components with default initialization nor
8540 shall two objects of an equivalence group be initialized.
8541 Either all or none of the objects shall have an protected attribute.
8542 The simple constraints are done in symbol.c(check_conflict) and the rest
8543 are implemented here. */
8546 resolve_equivalence (gfc_equiv
*eq
)
8549 gfc_symbol
*derived
;
8550 gfc_symbol
*first_sym
;
8553 locus
*last_where
= NULL
;
8554 seq_type eq_type
, last_eq_type
;
8555 gfc_typespec
*last_ts
;
8556 int object
, cnt_protected
;
8557 const char *value_name
;
8561 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
8563 first_sym
= eq
->expr
->symtree
->n
.sym
;
8567 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
8571 e
->ts
= e
->symtree
->n
.sym
->ts
;
8572 /* match_varspec might not know yet if it is seeing
8573 array reference or substring reference, as it doesn't
8575 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
8577 gfc_ref
*ref
= e
->ref
;
8578 sym
= e
->symtree
->n
.sym
;
8580 if (sym
->attr
.dimension
)
8582 ref
->u
.ar
.as
= sym
->as
;
8586 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8587 if (e
->ts
.type
== BT_CHARACTER
8589 && ref
->type
== REF_ARRAY
8590 && ref
->u
.ar
.dimen
== 1
8591 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
8592 && ref
->u
.ar
.stride
[0] == NULL
)
8594 gfc_expr
*start
= ref
->u
.ar
.start
[0];
8595 gfc_expr
*end
= ref
->u
.ar
.end
[0];
8598 /* Optimize away the (:) reference. */
8599 if (start
== NULL
&& end
== NULL
)
8604 e
->ref
->next
= ref
->next
;
8609 ref
->type
= REF_SUBSTRING
;
8611 start
= gfc_int_expr (1);
8612 ref
->u
.ss
.start
= start
;
8613 if (end
== NULL
&& e
->ts
.cl
)
8614 end
= gfc_copy_expr (e
->ts
.cl
->length
);
8615 ref
->u
.ss
.end
= end
;
8616 ref
->u
.ss
.length
= e
->ts
.cl
;
8623 /* Any further ref is an error. */
8626 gcc_assert (ref
->type
== REF_ARRAY
);
8627 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8633 if (gfc_resolve_expr (e
) == FAILURE
)
8636 sym
= e
->symtree
->n
.sym
;
8638 if (sym
->attr
.protected)
8640 if (cnt_protected
> 0 && cnt_protected
!= object
)
8642 gfc_error ("Either all or none of the objects in the "
8643 "EQUIVALENCE set at %L shall have the "
8644 "PROTECTED attribute",
8649 /* Shall not equivalence common block variables in a PURE procedure. */
8650 if (sym
->ns
->proc_name
8651 && sym
->ns
->proc_name
->attr
.pure
8652 && sym
->attr
.in_common
)
8654 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8655 "object in the pure procedure '%s'",
8656 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
8660 /* Shall not be a named constant. */
8661 if (e
->expr_type
== EXPR_CONSTANT
)
8663 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8664 "object", sym
->name
, &e
->where
);
8668 derived
= e
->ts
.derived
;
8669 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
8672 /* Check that the types correspond correctly:
8674 A numeric sequence structure may be equivalenced to another sequence
8675 structure, an object of default integer type, default real type, double
8676 precision real type, default logical type such that components of the
8677 structure ultimately only become associated to objects of the same
8678 kind. A character sequence structure may be equivalenced to an object
8679 of default character kind or another character sequence structure.
8680 Other objects may be equivalenced only to objects of the same type and
8683 /* Identical types are unconditionally OK. */
8684 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
8685 goto identical_types
;
8687 last_eq_type
= sequence_type (*last_ts
);
8688 eq_type
= sequence_type (sym
->ts
);
8690 /* Since the pair of objects is not of the same type, mixed or
8691 non-default sequences can be rejected. */
8693 msg
= "Sequence %s with mixed components in EQUIVALENCE "
8694 "statement at %L with different type objects";
8696 && last_eq_type
== SEQ_MIXED
8697 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
8699 || (eq_type
== SEQ_MIXED
8700 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8701 &e
->where
) == FAILURE
))
8704 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
8705 "statement at %L with objects of different type";
8707 && last_eq_type
== SEQ_NONDEFAULT
8708 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
8709 last_where
) == FAILURE
)
8710 || (eq_type
== SEQ_NONDEFAULT
8711 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8712 &e
->where
) == FAILURE
))
8715 msg
="Non-CHARACTER object '%s' in default CHARACTER "
8716 "EQUIVALENCE statement at %L";
8717 if (last_eq_type
== SEQ_CHARACTER
8718 && eq_type
!= SEQ_CHARACTER
8719 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8720 &e
->where
) == FAILURE
)
8723 msg
="Non-NUMERIC object '%s' in default NUMERIC "
8724 "EQUIVALENCE statement at %L";
8725 if (last_eq_type
== SEQ_NUMERIC
8726 && eq_type
!= SEQ_NUMERIC
8727 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8728 &e
->where
) == FAILURE
)
8733 last_where
= &e
->where
;
8738 /* Shall not be an automatic array. */
8739 if (e
->ref
->type
== REF_ARRAY
8740 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
8742 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8743 "an EQUIVALENCE object", sym
->name
, &e
->where
);
8750 /* Shall not be a structure component. */
8751 if (r
->type
== REF_COMPONENT
)
8753 gfc_error ("Structure component '%s' at %L cannot be an "
8754 "EQUIVALENCE object",
8755 r
->u
.c
.component
->name
, &e
->where
);
8759 /* A substring shall not have length zero. */
8760 if (r
->type
== REF_SUBSTRING
)
8762 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
8764 gfc_error ("Substring at %L has length zero",
8765 &r
->u
.ss
.start
->where
);
8775 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8778 resolve_fntype (gfc_namespace
*ns
)
8783 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
8786 /* If there are any entries, ns->proc_name is the entry master
8787 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8789 sym
= ns
->entries
->sym
;
8791 sym
= ns
->proc_name
;
8792 if (sym
->result
== sym
8793 && sym
->ts
.type
== BT_UNKNOWN
8794 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
8795 && !sym
->attr
.untyped
)
8797 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8798 sym
->name
, &sym
->declared_at
);
8799 sym
->attr
.untyped
= 1;
8802 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
8803 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
8804 sym
->ts
.derived
->ns
->default_access
)
8805 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
8807 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8808 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
8812 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
8814 if (el
->sym
->result
== el
->sym
8815 && el
->sym
->ts
.type
== BT_UNKNOWN
8816 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
8817 && !el
->sym
->attr
.untyped
)
8819 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8820 el
->sym
->name
, &el
->sym
->declared_at
);
8821 el
->sym
->attr
.untyped
= 1;
8826 /* 12.3.2.1.1 Defined operators. */
8829 gfc_resolve_uops (gfc_symtree
*symtree
)
8833 gfc_formal_arglist
*formal
;
8835 if (symtree
== NULL
)
8838 gfc_resolve_uops (symtree
->left
);
8839 gfc_resolve_uops (symtree
->right
);
8841 for (itr
= symtree
->n
.uop
->operator; itr
; itr
= itr
->next
)
8844 if (!sym
->attr
.function
)
8845 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8846 sym
->name
, &sym
->declared_at
);
8848 if (sym
->ts
.type
== BT_CHARACTER
8849 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
8850 && !(sym
->result
&& sym
->result
->ts
.cl
8851 && sym
->result
->ts
.cl
->length
))
8852 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8853 "character length", sym
->name
, &sym
->declared_at
);
8855 formal
= sym
->formal
;
8856 if (!formal
|| !formal
->sym
)
8858 gfc_error ("User operator procedure '%s' at %L must have at least "
8859 "one argument", sym
->name
, &sym
->declared_at
);
8863 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
8864 gfc_error ("First argument of operator interface at %L must be "
8865 "INTENT(IN)", &sym
->declared_at
);
8867 if (formal
->sym
->attr
.optional
)
8868 gfc_error ("First argument of operator interface at %L cannot be "
8869 "optional", &sym
->declared_at
);
8871 formal
= formal
->next
;
8872 if (!formal
|| !formal
->sym
)
8875 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
8876 gfc_error ("Second argument of operator interface at %L must be "
8877 "INTENT(IN)", &sym
->declared_at
);
8879 if (formal
->sym
->attr
.optional
)
8880 gfc_error ("Second argument of operator interface at %L cannot be "
8881 "optional", &sym
->declared_at
);
8884 gfc_error ("Operator interface at %L must have, at most, two "
8885 "arguments", &sym
->declared_at
);
8890 /* Examine all of the expressions associated with a program unit,
8891 assign types to all intermediate expressions, make sure that all
8892 assignments are to compatible types and figure out which names
8893 refer to which functions or subroutines. It doesn't check code
8894 block, which is handled by resolve_code. */
8897 resolve_types (gfc_namespace
*ns
)
8904 gfc_current_ns
= ns
;
8906 resolve_entries (ns
);
8908 resolve_common_blocks (ns
->common_root
);
8910 resolve_contained_functions (ns
);
8912 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
8914 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
8915 resolve_charlen (cl
);
8917 gfc_traverse_ns (ns
, resolve_symbol
);
8919 resolve_fntype (ns
);
8921 for (n
= ns
->contained
; n
; n
= n
->sibling
)
8923 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
8924 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8925 "also be PURE", n
->proc_name
->name
,
8926 &n
->proc_name
->declared_at
);
8932 gfc_check_interfaces (ns
);
8934 gfc_traverse_ns (ns
, resolve_values
);
8940 for (d
= ns
->data
; d
; d
= d
->next
)
8944 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
8946 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
8948 if (ns
->common_root
!= NULL
)
8949 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
8951 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
8952 resolve_equivalence (eq
);
8954 /* Warn about unused labels. */
8955 if (warn_unused_label
)
8956 warn_unused_fortran_label (ns
->st_labels
);
8958 gfc_resolve_uops (ns
->uop_root
);
8962 /* Call resolve_code recursively. */
8965 resolve_codes (gfc_namespace
*ns
)
8969 for (n
= ns
->contained
; n
; n
= n
->sibling
)
8972 gfc_current_ns
= ns
;
8974 /* Set to an out of range value. */
8975 current_entry_id
= -1;
8977 bitmap_obstack_initialize (&labels_obstack
);
8978 resolve_code (ns
->code
, ns
);
8979 bitmap_obstack_release (&labels_obstack
);
8983 /* This function is called after a complete program unit has been compiled.
8984 Its purpose is to examine all of the expressions associated with a program
8985 unit, assign types to all intermediate expressions, make sure that all
8986 assignments are to compatible types and figure out which names refer to
8987 which functions or subroutines. */
8990 gfc_resolve (gfc_namespace
*ns
)
8992 gfc_namespace
*old_ns
;
8994 old_ns
= gfc_current_ns
;
8999 gfc_current_ns
= old_ns
;