1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
26 #include "arith.h" /* For gfc_compare_expr(). */
29 /* Stack to push the current if we descend into a block during
30 resolution. See resolve_branch() and resolve_code(). */
32 typedef struct code_stack
34 struct gfc_code
*head
, *current
;
35 struct code_stack
*prev
;
39 static code_stack
*cs_base
= NULL
;
42 /* Nonzero if we're inside a FORALL block */
44 static int forall_flag
;
46 /* Resolve types of formal argument lists. These have to be done early so that
47 the formal argument lists of module procedures can be copied to the
48 containing module before the individual procedures are resolved
49 individually. We also resolve argument lists of procedures in interface
50 blocks because they are self-contained scoping units.
52 Since a dummy argument cannot be a non-dummy procedure, the only
53 resort left for untyped names are the IMPLICIT types. */
56 resolve_formal_arglist (gfc_symbol
* proc
)
58 gfc_formal_arglist
*f
;
62 /* TODO: Procedures whose return character length parameter is not constant
63 or assumed must also have explicit interfaces. */
64 if (proc
->result
!= NULL
)
69 if (gfc_elemental (proc
)
70 || sym
->attr
.pointer
|| sym
->attr
.allocatable
71 || (sym
->as
&& sym
->as
->rank
> 0))
72 proc
->attr
.always_explicit
= 1;
74 for (f
= proc
->formal
; f
; f
= f
->next
)
80 /* Alternate return placeholder. */
81 if (gfc_elemental (proc
))
82 gfc_error ("Alternate return specifier in elemental subroutine "
83 "'%s' at %L is not allowed", proc
->name
,
85 if (proc
->attr
.function
)
86 gfc_error ("Alternate return specifier in function "
87 "'%s' at %L is not allowed", proc
->name
,
92 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
93 resolve_formal_arglist (sym
);
95 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
97 if (gfc_pure (proc
) && !gfc_pure (sym
))
100 ("Dummy procedure '%s' of PURE procedure at %L must also "
101 "be PURE", sym
->name
, &sym
->declared_at
);
105 if (gfc_elemental (proc
))
108 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
116 if (sym
->ts
.type
== BT_UNKNOWN
)
118 if (!sym
->attr
.function
|| sym
->result
== sym
)
119 gfc_set_default_type (sym
, 1, sym
->ns
);
122 /* Set the type of the RESULT, then copy. */
123 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
124 gfc_set_default_type (sym
->result
, 1, sym
->result
->ns
);
126 sym
->ts
= sym
->result
->ts
;
128 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
132 gfc_resolve_array_spec (sym
->as
, 0);
134 /* We can't tell if an array with dimension (:) is assumed or deferred
135 shape until we know if it has the pointer or allocatable attributes.
137 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
138 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
140 sym
->as
->type
= AS_ASSUMED_SHAPE
;
141 for (i
= 0; i
< sym
->as
->rank
; i
++)
142 sym
->as
->lower
[i
] = gfc_int_expr (1);
145 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
146 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
147 || sym
->attr
.optional
)
148 proc
->attr
.always_explicit
= 1;
150 /* If the flavor is unknown at this point, it has to be a variable.
151 A procedure specification would have already set the type. */
153 if (sym
->attr
.flavor
== FL_UNKNOWN
)
154 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
158 if (proc
->attr
.function
&& !sym
->attr
.pointer
159 && sym
->attr
.flavor
!= FL_PROCEDURE
160 && sym
->attr
.intent
!= INTENT_IN
)
162 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
163 "INTENT(IN)", sym
->name
, proc
->name
,
166 if (proc
->attr
.subroutine
&& !sym
->attr
.pointer
167 && sym
->attr
.intent
== INTENT_UNKNOWN
)
170 ("Argument '%s' of pure subroutine '%s' at %L must have "
171 "its INTENT specified", sym
->name
, proc
->name
,
176 if (gfc_elemental (proc
))
181 ("Argument '%s' of elemental procedure at %L must be scalar",
182 sym
->name
, &sym
->declared_at
);
186 if (sym
->attr
.pointer
)
189 ("Argument '%s' of elemental procedure at %L cannot have "
190 "the POINTER attribute", sym
->name
, &sym
->declared_at
);
195 /* Each dummy shall be specified to be scalar. */
196 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
201 ("Argument '%s' of statement function at %L must be scalar",
202 sym
->name
, &sym
->declared_at
);
206 if (sym
->ts
.type
== BT_CHARACTER
)
208 gfc_charlen
*cl
= sym
->ts
.cl
;
209 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
212 ("Character-valued argument '%s' of statement function at "
213 "%L must has constant length",
214 sym
->name
, &sym
->declared_at
);
223 /* Work function called when searching for symbols that have argument lists
224 associated with them. */
227 find_arglists (gfc_symbol
* sym
)
230 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
233 resolve_formal_arglist (sym
);
237 /* Given a namespace, resolve all formal argument lists within the namespace.
241 resolve_formal_arglists (gfc_namespace
* ns
)
247 gfc_traverse_ns (ns
, find_arglists
);
252 resolve_contained_fntype (gfc_symbol
* sym
, gfc_namespace
* ns
)
256 /* If this namespace is not a function, ignore it. */
258 || !(sym
->attr
.function
259 || sym
->attr
.flavor
== FL_VARIABLE
))
262 /* Try to find out of what the return type is. */
263 if (sym
->result
!= NULL
)
266 if (sym
->ts
.type
== BT_UNKNOWN
)
268 t
= gfc_set_default_type (sym
, 0, ns
);
270 if (t
== FAILURE
&& !sym
->attr
.untyped
)
272 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
273 sym
->name
, &sym
->declared_at
); /* FIXME */
274 sym
->attr
.untyped
= 1;
280 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
281 introduce duplicates. */
284 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
286 gfc_formal_arglist
*f
, *new_arglist
;
289 for (; new_args
!= NULL
; new_args
= new_args
->next
)
291 new_sym
= new_args
->sym
;
292 /* See if ths arg is already in the formal argument list. */
293 for (f
= proc
->formal
; f
; f
= f
->next
)
295 if (new_sym
== f
->sym
)
302 /* Add a new argument. Argument order is not important. */
303 new_arglist
= gfc_get_formal_arglist ();
304 new_arglist
->sym
= new_sym
;
305 new_arglist
->next
= proc
->formal
;
306 proc
->formal
= new_arglist
;
311 /* Resolve alternate entry points. If a symbol has multiple entry points we
312 create a new master symbol for the main routine, and turn the existing
313 symbol into an entry point. */
316 resolve_entries (gfc_namespace
* ns
)
318 gfc_namespace
*old_ns
;
322 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
323 static int master_count
= 0;
325 if (ns
->proc_name
== NULL
)
328 /* No need to do anything if this procedure doesn't have alternate entry
333 /* We may already have resolved alternate entry points. */
334 if (ns
->proc_name
->attr
.entry_master
)
337 /* If this isn't a procedure something has gone horribly wrong. */
338 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
340 /* Remember the current namespace. */
341 old_ns
= gfc_current_ns
;
345 /* Add the main entry point to the list of entry points. */
346 el
= gfc_get_entry_list ();
347 el
->sym
= ns
->proc_name
;
349 el
->next
= ns
->entries
;
351 ns
->proc_name
->attr
.entry
= 1;
353 /* Add an entry statement for it. */
360 /* Create a new symbol for the master function. */
361 /* Give the internal function a unique name (within this file).
362 Also include the function name so the user has some hope of figuring
363 out what is going on. */
364 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
365 master_count
++, ns
->proc_name
->name
);
366 gfc_get_ha_symbol (name
, &proc
);
367 gcc_assert (proc
!= NULL
);
369 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
370 if (ns
->proc_name
->attr
.subroutine
)
371 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
375 gfc_typespec
*ts
, *fts
;
377 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
379 fts
= &ns
->entries
->sym
->result
->ts
;
380 if (fts
->type
== BT_UNKNOWN
)
381 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
382 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
384 ts
= &el
->sym
->result
->ts
;
385 if (ts
->type
== BT_UNKNOWN
)
386 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
387 if (! gfc_compare_types (ts
, fts
)
388 || (el
->sym
->result
->attr
.dimension
389 != ns
->entries
->sym
->result
->attr
.dimension
)
390 || (el
->sym
->result
->attr
.pointer
391 != ns
->entries
->sym
->result
->attr
.pointer
))
397 sym
= ns
->entries
->sym
->result
;
398 /* All result types the same. */
400 if (sym
->attr
.dimension
)
401 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
402 if (sym
->attr
.pointer
)
403 gfc_add_pointer (&proc
->attr
, NULL
);
407 /* Otherwise the result will be passed through an union by
409 proc
->attr
.mixed_entry_master
= 1;
410 for (el
= ns
->entries
; el
; el
= el
->next
)
412 sym
= el
->sym
->result
;
413 if (sym
->attr
.dimension
)
414 gfc_error ("%s result %s can't be an array in FUNCTION %s at %L",
415 el
== ns
->entries
? "FUNCTION" : "ENTRY", sym
->name
,
416 ns
->entries
->sym
->name
, &sym
->declared_at
);
417 else if (sym
->attr
.pointer
)
418 gfc_error ("%s result %s can't be a POINTER in FUNCTION %s at %L",
419 el
== ns
->entries
? "FUNCTION" : "ENTRY", sym
->name
,
420 ns
->entries
->sym
->name
, &sym
->declared_at
);
424 if (ts
->type
== BT_UNKNOWN
)
425 ts
= gfc_get_default_type (sym
, NULL
);
429 if (ts
->kind
== gfc_default_integer_kind
)
433 if (ts
->kind
== gfc_default_real_kind
434 || ts
->kind
== gfc_default_double_kind
)
438 if (ts
->kind
== gfc_default_complex_kind
)
442 if (ts
->kind
== gfc_default_logical_kind
)
446 /* We will issue error elsewhere. */
453 gfc_error ("%s result %s can't be of type %s in FUNCTION %s at %L",
454 el
== ns
->entries
? "FUNCTION" : "ENTRY", sym
->name
,
455 gfc_typename (ts
), ns
->entries
->sym
->name
,
461 proc
->attr
.access
= ACCESS_PRIVATE
;
462 proc
->attr
.entry_master
= 1;
464 /* Merge all the entry point arguments. */
465 for (el
= ns
->entries
; el
; el
= el
->next
)
466 merge_argument_lists (proc
, el
->sym
->formal
);
468 /* Use the master function for the function body. */
469 ns
->proc_name
= proc
;
471 /* Finalize the new symbols. */
472 gfc_commit_symbols ();
474 /* Restore the original namespace. */
475 gfc_current_ns
= old_ns
;
479 /* Resolve contained function types. Because contained functions can call one
480 another, they have to be worked out before any of the contained procedures
483 The good news is that if a function doesn't already have a type, the only
484 way it can get one is through an IMPLICIT type or a RESULT variable, because
485 by definition contained functions are contained namespace they're contained
486 in, not in a sibling or parent namespace. */
489 resolve_contained_functions (gfc_namespace
* ns
)
491 gfc_namespace
*child
;
494 resolve_formal_arglists (ns
);
496 for (child
= ns
->contained
; child
; child
= child
->sibling
)
498 /* Resolve alternate entry points first. */
499 resolve_entries (child
);
501 /* Then check function return types. */
502 resolve_contained_fntype (child
->proc_name
, child
);
503 for (el
= child
->entries
; el
; el
= el
->next
)
504 resolve_contained_fntype (el
->sym
, child
);
509 /* Resolve all of the elements of a structure constructor and make sure that
510 the types are correct. */
513 resolve_structure_cons (gfc_expr
* expr
)
515 gfc_constructor
*cons
;
520 cons
= expr
->value
.constructor
;
521 /* A constructor may have references if it is the result of substituting a
522 parameter variable. In this case we just pull out the component we
525 comp
= expr
->ref
->u
.c
.sym
->components
;
527 comp
= expr
->ts
.derived
->components
;
529 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
537 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
543 /* If we don't have the right type, try to convert it. */
545 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
)
546 && gfc_convert_type (cons
->expr
, &comp
->ts
, 1) == FAILURE
)
555 /****************** Expression name resolution ******************/
557 /* Returns 0 if a symbol was not declared with a type or
558 attribute declaration statement, nonzero otherwise. */
561 was_declared (gfc_symbol
* sym
)
567 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
570 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
571 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
572 || a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
579 /* Determine if a symbol is generic or not. */
582 generic_sym (gfc_symbol
* sym
)
586 if (sym
->attr
.generic
||
587 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
590 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
593 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
595 return (s
== NULL
) ? 0 : generic_sym (s
);
599 /* Determine if a symbol is specific or not. */
602 specific_sym (gfc_symbol
* sym
)
606 if (sym
->attr
.if_source
== IFSRC_IFBODY
607 || sym
->attr
.proc
== PROC_MODULE
608 || sym
->attr
.proc
== PROC_INTERNAL
609 || sym
->attr
.proc
== PROC_ST_FUNCTION
610 || (sym
->attr
.intrinsic
&&
611 gfc_specific_intrinsic (sym
->name
))
612 || sym
->attr
.external
)
615 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
618 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
620 return (s
== NULL
) ? 0 : specific_sym (s
);
624 /* Figure out if the procedure is specific, generic or unknown. */
627 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
631 procedure_kind (gfc_symbol
* sym
)
634 if (generic_sym (sym
))
635 return PTYPE_GENERIC
;
637 if (specific_sym (sym
))
638 return PTYPE_SPECIFIC
;
640 return PTYPE_UNKNOWN
;
644 /* Resolve an actual argument list. Most of the time, this is just
645 resolving the expressions in the list.
646 The exception is that we sometimes have to decide whether arguments
647 that look like procedure arguments are really simple variable
651 resolve_actual_arglist (gfc_actual_arglist
* arg
)
654 gfc_symtree
*parent_st
;
657 for (; arg
; arg
= arg
->next
)
663 /* Check the label is a valid branching target. */
666 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
668 gfc_error ("Label %d referenced at %L is never defined",
669 arg
->label
->value
, &arg
->label
->where
);
676 if (e
->ts
.type
!= BT_PROCEDURE
)
678 if (gfc_resolve_expr (e
) != SUCCESS
)
683 /* See if the expression node should really be a variable
686 sym
= e
->symtree
->n
.sym
;
688 if (sym
->attr
.flavor
== FL_PROCEDURE
689 || sym
->attr
.intrinsic
690 || sym
->attr
.external
)
693 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
695 gfc_error ("Statement function '%s' at %L is not allowed as an "
696 "actual argument", sym
->name
, &e
->where
);
699 /* If the symbol is the function that names the current (or
700 parent) scope, then we really have a variable reference. */
702 if (sym
->attr
.function
&& sym
->result
== sym
703 && (sym
->ns
->proc_name
== sym
704 || (sym
->ns
->parent
!= NULL
705 && sym
->ns
->parent
->proc_name
== sym
)))
711 /* See if the name is a module procedure in a parent unit. */
713 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
716 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
718 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
722 if (parent_st
== NULL
)
725 sym
= parent_st
->n
.sym
;
726 e
->symtree
= parent_st
; /* Point to the right thing. */
728 if (sym
->attr
.flavor
== FL_PROCEDURE
729 || sym
->attr
.intrinsic
730 || sym
->attr
.external
)
736 e
->expr_type
= EXPR_VARIABLE
;
740 e
->rank
= sym
->as
->rank
;
741 e
->ref
= gfc_get_ref ();
742 e
->ref
->type
= REF_ARRAY
;
743 e
->ref
->u
.ar
.type
= AR_FULL
;
744 e
->ref
->u
.ar
.as
= sym
->as
;
752 /************* Function resolution *************/
754 /* Resolve a function call known to be generic.
755 Section 14.1.2.4.1. */
758 resolve_generic_f0 (gfc_expr
* expr
, gfc_symbol
* sym
)
762 if (sym
->attr
.generic
)
765 gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
768 expr
->value
.function
.name
= s
->name
;
769 expr
->value
.function
.esym
= s
;
772 expr
->rank
= s
->as
->rank
;
776 /* TODO: Need to search for elemental references in generic interface */
779 if (sym
->attr
.intrinsic
)
780 return gfc_intrinsic_func_interface (expr
, 0);
787 resolve_generic_f (gfc_expr
* expr
)
792 sym
= expr
->symtree
->n
.sym
;
796 m
= resolve_generic_f0 (expr
, sym
);
799 else if (m
== MATCH_ERROR
)
803 if (sym
->ns
->parent
== NULL
)
805 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
809 if (!generic_sym (sym
))
813 /* Last ditch attempt. */
815 if (!gfc_generic_intrinsic (expr
->symtree
->n
.sym
->name
))
817 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
818 expr
->symtree
->n
.sym
->name
, &expr
->where
);
822 m
= gfc_intrinsic_func_interface (expr
, 0);
827 ("Generic function '%s' at %L is not consistent with a specific "
828 "intrinsic interface", expr
->symtree
->n
.sym
->name
, &expr
->where
);
834 /* Resolve a function call known to be specific. */
837 resolve_specific_f0 (gfc_symbol
* sym
, gfc_expr
* expr
)
841 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
845 sym
->attr
.proc
= PROC_DUMMY
;
849 sym
->attr
.proc
= PROC_EXTERNAL
;
853 if (sym
->attr
.proc
== PROC_MODULE
854 || sym
->attr
.proc
== PROC_ST_FUNCTION
855 || sym
->attr
.proc
== PROC_INTERNAL
)
858 if (sym
->attr
.intrinsic
)
860 m
= gfc_intrinsic_func_interface (expr
, 1);
865 ("Function '%s' at %L is INTRINSIC but is not compatible with "
866 "an intrinsic", sym
->name
, &expr
->where
);
874 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
877 expr
->value
.function
.name
= sym
->name
;
878 expr
->value
.function
.esym
= sym
;
880 expr
->rank
= sym
->as
->rank
;
887 resolve_specific_f (gfc_expr
* expr
)
892 sym
= expr
->symtree
->n
.sym
;
896 m
= resolve_specific_f0 (sym
, expr
);
899 if (m
== MATCH_ERROR
)
902 if (sym
->ns
->parent
== NULL
)
905 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
911 gfc_error ("Unable to resolve the specific function '%s' at %L",
912 expr
->symtree
->n
.sym
->name
, &expr
->where
);
918 /* Resolve a procedure call not known to be generic nor specific. */
921 resolve_unknown_f (gfc_expr
* expr
)
926 sym
= expr
->symtree
->n
.sym
;
930 sym
->attr
.proc
= PROC_DUMMY
;
931 expr
->value
.function
.name
= sym
->name
;
935 /* See if we have an intrinsic function reference. */
937 if (gfc_intrinsic_name (sym
->name
, 0))
939 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
944 /* The reference is to an external name. */
946 sym
->attr
.proc
= PROC_EXTERNAL
;
947 expr
->value
.function
.name
= sym
->name
;
948 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
951 expr
->rank
= sym
->as
->rank
;
953 /* Type of the expression is either the type of the symbol or the
954 default type of the symbol. */
957 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
959 if (sym
->ts
.type
!= BT_UNKNOWN
)
963 ts
= gfc_get_default_type (sym
, sym
->ns
);
965 if (ts
->type
== BT_UNKNOWN
)
967 gfc_error ("Function '%s' at %L has no IMPLICIT type",
968 sym
->name
, &expr
->where
);
979 /* Figure out if a function reference is pure or not. Also set the name
980 of the function for a potential error message. Return nonzero if the
981 function is PURE, zero if not. */
984 pure_function (gfc_expr
* e
, const char **name
)
988 if (e
->value
.function
.esym
)
990 pure
= gfc_pure (e
->value
.function
.esym
);
991 *name
= e
->value
.function
.esym
->name
;
993 else if (e
->value
.function
.isym
)
995 pure
= e
->value
.function
.isym
->pure
996 || e
->value
.function
.isym
->elemental
;
997 *name
= e
->value
.function
.isym
->name
;
1001 /* Implicit functions are not pure. */
1003 *name
= e
->value
.function
.name
;
1010 /* Resolve a function call, which means resolving the arguments, then figuring
1011 out which entity the name refers to. */
1012 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1013 to INTENT(OUT) or INTENT(INOUT). */
1016 resolve_function (gfc_expr
* expr
)
1018 gfc_actual_arglist
*arg
;
1022 if (resolve_actual_arglist (expr
->value
.function
.actual
) == FAILURE
)
1025 /* See if function is already resolved. */
1027 if (expr
->value
.function
.name
!= NULL
)
1029 if (expr
->ts
.type
== BT_UNKNOWN
)
1030 expr
->ts
= expr
->symtree
->n
.sym
->ts
;
1035 /* Apply the rules of section 14.1.2. */
1037 switch (procedure_kind (expr
->symtree
->n
.sym
))
1040 t
= resolve_generic_f (expr
);
1043 case PTYPE_SPECIFIC
:
1044 t
= resolve_specific_f (expr
);
1048 t
= resolve_unknown_f (expr
);
1052 gfc_internal_error ("resolve_function(): bad function type");
1056 /* If the expression is still a function (it might have simplified),
1057 then we check to see if we are calling an elemental function. */
1059 if (expr
->expr_type
!= EXPR_FUNCTION
)
1062 if (expr
->value
.function
.actual
!= NULL
1063 && ((expr
->value
.function
.esym
!= NULL
1064 && expr
->value
.function
.esym
->attr
.elemental
)
1065 || (expr
->value
.function
.isym
!= NULL
1066 && expr
->value
.function
.isym
->elemental
)))
1069 /* The rank of an elemental is the rank of its array argument(s). */
1071 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1073 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1075 expr
->rank
= arg
->expr
->rank
;
1081 if (!pure_function (expr
, &name
))
1086 ("Function reference to '%s' at %L is inside a FORALL block",
1087 name
, &expr
->where
);
1090 else if (gfc_pure (NULL
))
1092 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1093 "procedure within a PURE procedure", name
, &expr
->where
);
1102 /************* Subroutine resolution *************/
1105 pure_subroutine (gfc_code
* c
, gfc_symbol
* sym
)
1112 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1113 sym
->name
, &c
->loc
);
1114 else if (gfc_pure (NULL
))
1115 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1121 resolve_generic_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1125 if (sym
->attr
.generic
)
1127 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1130 c
->resolved_sym
= s
;
1131 pure_subroutine (c
, s
);
1135 /* TODO: Need to search for elemental references in generic interface. */
1138 if (sym
->attr
.intrinsic
)
1139 return gfc_intrinsic_sub_interface (c
, 0);
1146 resolve_generic_s (gfc_code
* c
)
1151 sym
= c
->symtree
->n
.sym
;
1153 m
= resolve_generic_s0 (c
, sym
);
1156 if (m
== MATCH_ERROR
)
1159 if (sym
->ns
->parent
!= NULL
)
1161 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1164 m
= resolve_generic_s0 (c
, sym
);
1167 if (m
== MATCH_ERROR
)
1172 /* Last ditch attempt. */
1174 if (!gfc_generic_intrinsic (sym
->name
))
1177 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1178 sym
->name
, &c
->loc
);
1182 m
= gfc_intrinsic_sub_interface (c
, 0);
1186 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1187 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1193 /* Resolve a subroutine call known to be specific. */
1196 resolve_specific_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1200 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1202 if (sym
->attr
.dummy
)
1204 sym
->attr
.proc
= PROC_DUMMY
;
1208 sym
->attr
.proc
= PROC_EXTERNAL
;
1212 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1215 if (sym
->attr
.intrinsic
)
1217 m
= gfc_intrinsic_sub_interface (c
, 1);
1221 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1222 "with an intrinsic", sym
->name
, &c
->loc
);
1230 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1232 c
->resolved_sym
= sym
;
1233 pure_subroutine (c
, sym
);
1240 resolve_specific_s (gfc_code
* c
)
1245 sym
= c
->symtree
->n
.sym
;
1247 m
= resolve_specific_s0 (c
, sym
);
1250 if (m
== MATCH_ERROR
)
1253 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1257 m
= resolve_specific_s0 (c
, sym
);
1260 if (m
== MATCH_ERROR
)
1264 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1265 sym
->name
, &c
->loc
);
1271 /* Resolve a subroutine call not known to be generic nor specific. */
1274 resolve_unknown_s (gfc_code
* c
)
1278 sym
= c
->symtree
->n
.sym
;
1280 if (sym
->attr
.dummy
)
1282 sym
->attr
.proc
= PROC_DUMMY
;
1286 /* See if we have an intrinsic function reference. */
1288 if (gfc_intrinsic_name (sym
->name
, 1))
1290 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1295 /* The reference is to an external name. */
1298 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1300 c
->resolved_sym
= sym
;
1302 pure_subroutine (c
, sym
);
1308 /* Resolve a subroutine call. Although it was tempting to use the same code
1309 for functions, subroutines and functions are stored differently and this
1310 makes things awkward. */
1313 resolve_call (gfc_code
* c
)
1317 if (resolve_actual_arglist (c
->ext
.actual
) == FAILURE
)
1320 if (c
->resolved_sym
!= NULL
)
1323 switch (procedure_kind (c
->symtree
->n
.sym
))
1326 t
= resolve_generic_s (c
);
1329 case PTYPE_SPECIFIC
:
1330 t
= resolve_specific_s (c
);
1334 t
= resolve_unknown_s (c
);
1338 gfc_internal_error ("resolve_subroutine(): bad function type");
1344 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1345 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1346 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1347 if their shapes do not match. If either op1->shape or op2->shape is
1348 NULL, return SUCCESS. */
1351 compare_shapes (gfc_expr
* op1
, gfc_expr
* op2
)
1358 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
1360 for (i
= 0; i
< op1
->rank
; i
++)
1362 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
1364 gfc_error ("Shapes for operands at %L and %L are not conformable",
1365 &op1
->where
, &op2
->where
);
1375 /* Resolve an operator expression node. This can involve replacing the
1376 operation with a user defined function call. */
1379 resolve_operator (gfc_expr
* e
)
1381 gfc_expr
*op1
, *op2
;
1385 /* Resolve all subnodes-- give them types. */
1387 switch (e
->value
.op
.operator)
1390 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
1393 /* Fall through... */
1396 case INTRINSIC_UPLUS
:
1397 case INTRINSIC_UMINUS
:
1398 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
1403 /* Typecheck the new node. */
1405 op1
= e
->value
.op
.op1
;
1406 op2
= e
->value
.op
.op2
;
1408 switch (e
->value
.op
.operator)
1410 case INTRINSIC_UPLUS
:
1411 case INTRINSIC_UMINUS
:
1412 if (op1
->ts
.type
== BT_INTEGER
1413 || op1
->ts
.type
== BT_REAL
1414 || op1
->ts
.type
== BT_COMPLEX
)
1420 sprintf (msg
, "Operand of unary numeric operator '%s' at %%L is %s",
1421 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
1424 case INTRINSIC_PLUS
:
1425 case INTRINSIC_MINUS
:
1426 case INTRINSIC_TIMES
:
1427 case INTRINSIC_DIVIDE
:
1428 case INTRINSIC_POWER
:
1429 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1431 gfc_type_convert_binary (e
);
1436 "Operands of binary numeric operator '%s' at %%L are %s/%s",
1437 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1438 gfc_typename (&op2
->ts
));
1441 case INTRINSIC_CONCAT
:
1442 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1444 e
->ts
.type
= BT_CHARACTER
;
1445 e
->ts
.kind
= op1
->ts
.kind
;
1450 "Operands of string concatenation operator at %%L are %s/%s",
1451 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
1457 case INTRINSIC_NEQV
:
1458 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
1460 e
->ts
.type
= BT_LOGICAL
;
1461 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
1462 if (op1
->ts
.kind
< e
->ts
.kind
)
1463 gfc_convert_type (op1
, &e
->ts
, 2);
1464 else if (op2
->ts
.kind
< e
->ts
.kind
)
1465 gfc_convert_type (op2
, &e
->ts
, 2);
1469 sprintf (msg
, "Operands of logical operator '%s' at %%L are %s/%s",
1470 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1471 gfc_typename (&op2
->ts
));
1476 if (op1
->ts
.type
== BT_LOGICAL
)
1478 e
->ts
.type
= BT_LOGICAL
;
1479 e
->ts
.kind
= op1
->ts
.kind
;
1483 sprintf (msg
, "Operand of .NOT. operator at %%L is %s",
1484 gfc_typename (&op1
->ts
));
1491 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1493 strcpy (msg
, "COMPLEX quantities cannot be compared at %L");
1497 /* Fall through... */
1501 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1503 e
->ts
.type
= BT_LOGICAL
;
1504 e
->ts
.kind
= gfc_default_logical_kind
;
1508 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1510 gfc_type_convert_binary (e
);
1512 e
->ts
.type
= BT_LOGICAL
;
1513 e
->ts
.kind
= gfc_default_logical_kind
;
1517 sprintf (msg
, "Operands of comparison operator '%s' at %%L are %s/%s",
1518 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1519 gfc_typename (&op2
->ts
));
1523 case INTRINSIC_USER
:
1525 sprintf (msg
, "Operand of user operator '%s' at %%L is %s",
1526 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
1528 sprintf (msg
, "Operands of user operator '%s' at %%L are %s/%s",
1529 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
1530 gfc_typename (&op2
->ts
));
1535 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1538 /* Deal with arrayness of an operand through an operator. */
1542 switch (e
->value
.op
.operator)
1544 case INTRINSIC_PLUS
:
1545 case INTRINSIC_MINUS
:
1546 case INTRINSIC_TIMES
:
1547 case INTRINSIC_DIVIDE
:
1548 case INTRINSIC_POWER
:
1549 case INTRINSIC_CONCAT
:
1553 case INTRINSIC_NEQV
:
1561 if (op1
->rank
== 0 && op2
->rank
== 0)
1564 if (op1
->rank
== 0 && op2
->rank
!= 0)
1566 e
->rank
= op2
->rank
;
1568 if (e
->shape
== NULL
)
1569 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1572 if (op1
->rank
!= 0 && op2
->rank
== 0)
1574 e
->rank
= op1
->rank
;
1576 if (e
->shape
== NULL
)
1577 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1580 if (op1
->rank
!= 0 && op2
->rank
!= 0)
1582 if (op1
->rank
== op2
->rank
)
1584 e
->rank
= op1
->rank
;
1585 if (e
->shape
== NULL
)
1587 t
= compare_shapes(op1
, op2
);
1591 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1596 gfc_error ("Inconsistent ranks for operator at %L and %L",
1597 &op1
->where
, &op2
->where
);
1600 /* Allow higher level expressions to work. */
1608 case INTRINSIC_UPLUS
:
1609 case INTRINSIC_UMINUS
:
1610 e
->rank
= op1
->rank
;
1612 if (e
->shape
== NULL
)
1613 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1615 /* Simply copy arrayness attribute */
1622 /* Attempt to simplify the expression. */
1624 t
= gfc_simplify_expr (e
, 0);
1629 if (gfc_extend_expr (e
) == SUCCESS
)
1632 gfc_error (msg
, &e
->where
);
1638 /************** Array resolution subroutines **************/
1642 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
1645 /* Compare two integer expressions. */
1648 compare_bound (gfc_expr
* a
, gfc_expr
* b
)
1652 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
1653 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
1656 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
1657 gfc_internal_error ("compare_bound(): Bad expression");
1659 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
1669 /* Compare an integer expression with an integer. */
1672 compare_bound_int (gfc_expr
* a
, int b
)
1676 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
1679 if (a
->ts
.type
!= BT_INTEGER
)
1680 gfc_internal_error ("compare_bound_int(): Bad expression");
1682 i
= mpz_cmp_si (a
->value
.integer
, b
);
1692 /* Compare a single dimension of an array reference to the array
1696 check_dimension (int i
, gfc_array_ref
* ar
, gfc_array_spec
* as
)
1699 /* Given start, end and stride values, calculate the minimum and
1700 maximum referenced indexes. */
1708 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1710 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1716 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
1718 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
1722 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1724 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1727 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1728 it is legal (see 6.2.2.3.1). */
1733 gfc_internal_error ("check_dimension(): Bad array reference");
1739 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
1744 /* Compare an array reference with an array specification. */
1747 compare_spec_to_ref (gfc_array_ref
* ar
)
1754 /* TODO: Full array sections are only allowed as actual parameters. */
1755 if (as
->type
== AS_ASSUMED_SIZE
1756 && (/*ar->type == AR_FULL
1757 ||*/ (ar
->type
== AR_SECTION
1758 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
1760 gfc_error ("Rightmost upper bound of assumed size array section"
1761 " not specified at %L", &ar
->where
);
1765 if (ar
->type
== AR_FULL
)
1768 if (as
->rank
!= ar
->dimen
)
1770 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1771 &ar
->where
, ar
->dimen
, as
->rank
);
1775 for (i
= 0; i
< as
->rank
; i
++)
1776 if (check_dimension (i
, ar
, as
) == FAILURE
)
1783 /* Resolve one part of an array index. */
1786 gfc_resolve_index (gfc_expr
* index
, int check_scalar
)
1793 if (gfc_resolve_expr (index
) == FAILURE
)
1796 if (check_scalar
&& index
->rank
!= 0)
1798 gfc_error ("Array index at %L must be scalar", &index
->where
);
1802 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
1804 gfc_error ("Array index at %L must be of INTEGER type",
1809 if (index
->ts
.type
== BT_REAL
)
1810 if (gfc_notify_std (GFC_STD_GNU
, "Extension: REAL array index at %L",
1811 &index
->where
) == FAILURE
)
1814 if (index
->ts
.kind
!= gfc_index_integer_kind
1815 || index
->ts
.type
!= BT_INTEGER
)
1817 ts
.type
= BT_INTEGER
;
1818 ts
.kind
= gfc_index_integer_kind
;
1820 gfc_convert_type_warn (index
, &ts
, 2, 0);
1827 /* Given an expression that contains array references, update those array
1828 references to point to the right array specifications. While this is
1829 filled in during matching, this information is difficult to save and load
1830 in a module, so we take care of it here.
1832 The idea here is that the original array reference comes from the
1833 base symbol. We traverse the list of reference structures, setting
1834 the stored reference to references. Component references can
1835 provide an additional array specification. */
1838 find_array_spec (gfc_expr
* e
)
1844 as
= e
->symtree
->n
.sym
->as
;
1845 c
= e
->symtree
->n
.sym
->components
;
1847 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1852 gfc_internal_error ("find_array_spec(): Missing spec");
1859 for (; c
; c
= c
->next
)
1860 if (c
== ref
->u
.c
.component
)
1864 gfc_internal_error ("find_array_spec(): Component not found");
1869 gfc_internal_error ("find_array_spec(): unused as(1)");
1873 c
= c
->ts
.derived
->components
;
1881 gfc_internal_error ("find_array_spec(): unused as(2)");
1885 /* Resolve an array reference. */
1888 resolve_array_ref (gfc_array_ref
* ar
)
1890 int i
, check_scalar
;
1892 for (i
= 0; i
< ar
->dimen
; i
++)
1894 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
1896 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
1898 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
1900 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
1903 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
1904 switch (ar
->start
[i
]->rank
)
1907 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
1911 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
1915 gfc_error ("Array index at %L is an array of rank %d",
1916 &ar
->c_where
[i
], ar
->start
[i
]->rank
);
1921 /* If the reference type is unknown, figure out what kind it is. */
1923 if (ar
->type
== AR_UNKNOWN
)
1925 ar
->type
= AR_ELEMENT
;
1926 for (i
= 0; i
< ar
->dimen
; i
++)
1927 if (ar
->dimen_type
[i
] == DIMEN_RANGE
1928 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
1930 ar
->type
= AR_SECTION
;
1935 if (compare_spec_to_ref (ar
) == FAILURE
)
1943 resolve_substring (gfc_ref
* ref
)
1946 if (ref
->u
.ss
.start
!= NULL
)
1948 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
1951 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
1953 gfc_error ("Substring start index at %L must be of type INTEGER",
1954 &ref
->u
.ss
.start
->where
);
1958 if (ref
->u
.ss
.start
->rank
!= 0)
1960 gfc_error ("Substring start index at %L must be scalar",
1961 &ref
->u
.ss
.start
->where
);
1965 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
)
1967 gfc_error ("Substring start index at %L is less than one",
1968 &ref
->u
.ss
.start
->where
);
1973 if (ref
->u
.ss
.end
!= NULL
)
1975 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
1978 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
1980 gfc_error ("Substring end index at %L must be of type INTEGER",
1981 &ref
->u
.ss
.end
->where
);
1985 if (ref
->u
.ss
.end
->rank
!= 0)
1987 gfc_error ("Substring end index at %L must be scalar",
1988 &ref
->u
.ss
.end
->where
);
1992 if (ref
->u
.ss
.length
!= NULL
1993 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
)
1995 gfc_error ("Substring end index at %L is out of bounds",
1996 &ref
->u
.ss
.start
->where
);
2005 /* Resolve subtype references. */
2008 resolve_ref (gfc_expr
* expr
)
2010 int current_part_dimension
, n_components
, seen_part_dimension
;
2013 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2014 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
2016 find_array_spec (expr
);
2020 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2024 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
2032 resolve_substring (ref
);
2036 /* Check constraints on part references. */
2038 current_part_dimension
= 0;
2039 seen_part_dimension
= 0;
2042 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2047 switch (ref
->u
.ar
.type
)
2051 current_part_dimension
= 1;
2055 current_part_dimension
= 0;
2059 gfc_internal_error ("resolve_ref(): Bad array reference");
2065 if ((current_part_dimension
|| seen_part_dimension
)
2066 && ref
->u
.c
.component
->pointer
)
2069 ("Component to the right of a part reference with nonzero "
2070 "rank must not have the POINTER attribute at %L",
2082 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
2083 || ref
->next
== NULL
)
2084 && current_part_dimension
2085 && seen_part_dimension
)
2088 gfc_error ("Two or more part references with nonzero rank must "
2089 "not be specified at %L", &expr
->where
);
2093 if (ref
->type
== REF_COMPONENT
)
2095 if (current_part_dimension
)
2096 seen_part_dimension
= 1;
2098 /* reset to make sure */
2099 current_part_dimension
= 0;
2107 /* Given an expression, determine its shape. This is easier than it sounds.
2108 Leaves the shape array NULL if it is not possible to determine the shape. */
2111 expression_shape (gfc_expr
* e
)
2113 mpz_t array
[GFC_MAX_DIMENSIONS
];
2116 if (e
->rank
== 0 || e
->shape
!= NULL
)
2119 for (i
= 0; i
< e
->rank
; i
++)
2120 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2123 e
->shape
= gfc_get_shape (e
->rank
);
2125 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
2130 for (i
--; i
>= 0; i
--)
2131 mpz_clear (array
[i
]);
2135 /* Given a variable expression node, compute the rank of the expression by
2136 examining the base symbol and any reference structures it may have. */
2139 expression_rank (gfc_expr
* e
)
2146 if (e
->expr_type
== EXPR_ARRAY
)
2148 /* Constructors can have a rank different from one via RESHAPE(). */
2150 if (e
->symtree
== NULL
)
2156 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
2157 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
2163 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2165 if (ref
->type
!= REF_ARRAY
)
2168 if (ref
->u
.ar
.type
== AR_FULL
)
2170 rank
= ref
->u
.ar
.as
->rank
;
2174 if (ref
->u
.ar
.type
== AR_SECTION
)
2176 /* Figure out the rank of the section. */
2178 gfc_internal_error ("expression_rank(): Two array specs");
2180 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2181 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
2182 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2192 expression_shape (e
);
2196 /* Resolve a variable expression. */
2199 resolve_variable (gfc_expr
* e
)
2203 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
2206 if (e
->symtree
== NULL
)
2209 sym
= e
->symtree
->n
.sym
;
2210 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2212 e
->ts
.type
= BT_PROCEDURE
;
2216 if (sym
->ts
.type
!= BT_UNKNOWN
)
2217 gfc_variable_attr (e
, &e
->ts
);
2220 /* Must be a simple variable reference. */
2221 if (gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2230 /* Resolve an expression. That is, make sure that types of operands agree
2231 with their operators, intrinsic operators are converted to function calls
2232 for overloaded types and unresolved function references are resolved. */
2235 gfc_resolve_expr (gfc_expr
* e
)
2242 switch (e
->expr_type
)
2245 t
= resolve_operator (e
);
2249 t
= resolve_function (e
);
2253 t
= resolve_variable (e
);
2255 expression_rank (e
);
2258 case EXPR_SUBSTRING
:
2259 t
= resolve_ref (e
);
2269 if (resolve_ref (e
) == FAILURE
)
2272 t
= gfc_resolve_array_constructor (e
);
2273 /* Also try to expand a constructor. */
2276 expression_rank (e
);
2277 gfc_expand_constructor (e
);
2282 case EXPR_STRUCTURE
:
2283 t
= resolve_ref (e
);
2287 t
= resolve_structure_cons (e
);
2291 t
= gfc_simplify_expr (e
, 0);
2295 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2302 /* Resolve an expression from an iterator. They must be scalar and have
2303 INTEGER or (optionally) REAL type. */
2306 gfc_resolve_iterator_expr (gfc_expr
* expr
, bool real_ok
, const char * name
)
2308 if (gfc_resolve_expr (expr
) == FAILURE
)
2311 if (expr
->rank
!= 0)
2313 gfc_error ("%s at %L must be a scalar", name
, &expr
->where
);
2317 if (!(expr
->ts
.type
== BT_INTEGER
2318 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
2320 gfc_error ("%s at %L must be INTEGER%s",
2323 real_ok
? " or REAL" : "");
2330 /* Resolve the expressions in an iterator structure. If REAL_OK is
2331 false allow only INTEGER type iterators, otherwise allow REAL types. */
2334 gfc_resolve_iterator (gfc_iterator
* iter
, bool real_ok
)
2337 if (iter
->var
->ts
.type
== BT_REAL
)
2338 gfc_notify_std (GFC_STD_F95_DEL
,
2339 "Obsolete: REAL DO loop iterator at %L",
2342 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
2346 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
2348 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2353 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
2354 "Start expression in DO loop") == FAILURE
)
2357 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
2358 "End expression in DO loop") == FAILURE
)
2361 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
2362 "Step expression in DO loop") == FAILURE
)
2365 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
2367 if ((iter
->step
->ts
.type
== BT_INTEGER
2368 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
2369 || (iter
->step
->ts
.type
== BT_REAL
2370 && mpfr_sgn (iter
->step
->value
.real
) == 0))
2372 gfc_error ("Step expression in DO loop at %L cannot be zero",
2373 &iter
->step
->where
);
2378 /* Convert start, end, and step to the same type as var. */
2379 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
2380 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
2381 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2383 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
2384 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
2385 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2387 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
2388 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
2389 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
2395 /* Resolve a list of FORALL iterators. */
2398 resolve_forall_iterators (gfc_forall_iterator
* iter
)
2403 if (gfc_resolve_expr (iter
->var
) == SUCCESS
2404 && iter
->var
->ts
.type
!= BT_INTEGER
)
2405 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2408 if (gfc_resolve_expr (iter
->start
) == SUCCESS
2409 && iter
->start
->ts
.type
!= BT_INTEGER
)
2410 gfc_error ("FORALL start expression at %L must be INTEGER",
2411 &iter
->start
->where
);
2412 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
2413 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2415 if (gfc_resolve_expr (iter
->end
) == SUCCESS
2416 && iter
->end
->ts
.type
!= BT_INTEGER
)
2417 gfc_error ("FORALL end expression at %L must be INTEGER",
2419 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
2420 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2422 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
2423 && iter
->stride
->ts
.type
!= BT_INTEGER
)
2424 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2425 &iter
->stride
->where
);
2426 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
2427 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
2434 /* Given a pointer to a symbol that is a derived type, see if any components
2435 have the POINTER attribute. The search is recursive if necessary.
2436 Returns zero if no pointer components are found, nonzero otherwise. */
2439 derived_pointer (gfc_symbol
* sym
)
2443 for (c
= sym
->components
; c
; c
= c
->next
)
2448 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
2456 /* Resolve the argument of a deallocate expression. The expression must be
2457 a pointer or a full array. */
2460 resolve_deallocate_expr (gfc_expr
* e
)
2462 symbol_attribute attr
;
2466 if (gfc_resolve_expr (e
) == FAILURE
)
2469 attr
= gfc_expr_attr (e
);
2473 if (e
->expr_type
!= EXPR_VARIABLE
)
2476 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2477 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2481 if (ref
->u
.ar
.type
!= AR_FULL
)
2486 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2487 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2495 if (allocatable
== 0)
2498 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2499 "ALLOCATABLE or a POINTER", &e
->where
);
2506 /* Resolve the expression in an ALLOCATE statement, doing the additional
2507 checks to see whether the expression is OK or not. The expression must
2508 have a trailing array reference that gives the size of the array. */
2511 resolve_allocate_expr (gfc_expr
* e
)
2513 int i
, pointer
, allocatable
, dimension
;
2514 symbol_attribute attr
;
2515 gfc_ref
*ref
, *ref2
;
2518 if (gfc_resolve_expr (e
) == FAILURE
)
2521 /* Make sure the expression is allocatable or a pointer. If it is
2522 pointer, the next-to-last reference must be a pointer. */
2526 if (e
->expr_type
!= EXPR_VARIABLE
)
2530 attr
= gfc_expr_attr (e
);
2531 pointer
= attr
.pointer
;
2532 dimension
= attr
.dimension
;
2537 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2538 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
2539 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
2541 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
2545 if (ref
->next
!= NULL
)
2550 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2551 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2553 pointer
= ref
->u
.c
.component
->pointer
;
2554 dimension
= ref
->u
.c
.component
->dimension
;
2564 if (allocatable
== 0 && pointer
== 0)
2566 gfc_error ("Expression in ALLOCATE statement at %L must be "
2567 "ALLOCATABLE or a POINTER", &e
->where
);
2571 if (pointer
&& dimension
== 0)
2574 /* Make sure the next-to-last reference node is an array specification. */
2576 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
2578 gfc_error ("Array specification required in ALLOCATE statement "
2579 "at %L", &e
->where
);
2583 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
2586 /* Make sure that the array section reference makes sense in the
2587 context of an ALLOCATE specification. */
2591 for (i
= 0; i
< ar
->dimen
; i
++)
2592 switch (ar
->dimen_type
[i
])
2598 if (ar
->start
[i
] != NULL
2599 && ar
->end
[i
] != NULL
2600 && ar
->stride
[i
] == NULL
)
2603 /* Fall Through... */
2607 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2616 /************ SELECT CASE resolution subroutines ************/
2618 /* Callback function for our mergesort variant. Determines interval
2619 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2620 op1 > op2. Assumes we're not dealing with the default case.
2621 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2622 There are nine situations to check. */
2625 compare_cases (const gfc_case
* op1
, const gfc_case
* op2
)
2629 if (op1
->low
== NULL
) /* op1 = (:L) */
2631 /* op2 = (:N), so overlap. */
2633 /* op2 = (M:) or (M:N), L < M */
2634 if (op2
->low
!= NULL
2635 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2638 else if (op1
->high
== NULL
) /* op1 = (K:) */
2640 /* op2 = (M:), so overlap. */
2642 /* op2 = (:N) or (M:N), K > N */
2643 if (op2
->high
!= NULL
2644 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2647 else /* op1 = (K:L) */
2649 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
2650 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
2651 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
2652 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
2653 else /* op2 = (M:N) */
2657 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2660 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2669 /* Merge-sort a double linked case list, detecting overlap in the
2670 process. LIST is the head of the double linked case list before it
2671 is sorted. Returns the head of the sorted list if we don't see any
2672 overlap, or NULL otherwise. */
2675 check_case_overlap (gfc_case
* list
)
2677 gfc_case
*p
, *q
, *e
, *tail
;
2678 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
2680 /* If the passed list was empty, return immediately. */
2687 /* Loop unconditionally. The only exit from this loop is a return
2688 statement, when we've finished sorting the case list. */
2695 /* Count the number of merges we do in this pass. */
2698 /* Loop while there exists a merge to be done. */
2703 /* Count this merge. */
2706 /* Cut the list in two pieces by stepping INSIZE places
2707 forward in the list, starting from P. */
2710 for (i
= 0; i
< insize
; i
++)
2719 /* Now we have two lists. Merge them! */
2720 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
2723 /* See from which the next case to merge comes from. */
2726 /* P is empty so the next case must come from Q. */
2731 else if (qsize
== 0 || q
== NULL
)
2740 cmp
= compare_cases (p
, q
);
2743 /* The whole case range for P is less than the
2751 /* The whole case range for Q is greater than
2752 the case range for P. */
2759 /* The cases overlap, or they are the same
2760 element in the list. Either way, we must
2761 issue an error and get the next case from P. */
2762 /* FIXME: Sort P and Q by line number. */
2763 gfc_error ("CASE label at %L overlaps with CASE "
2764 "label at %L", &p
->where
, &q
->where
);
2772 /* Add the next element to the merged list. */
2781 /* P has now stepped INSIZE places along, and so has Q. So
2782 they're the same. */
2787 /* If we have done only one merge or none at all, we've
2788 finished sorting the cases. */
2797 /* Otherwise repeat, merging lists twice the size. */
2803 /* Check to see if an expression is suitable for use in a CASE statement.
2804 Makes sure that all case expressions are scalar constants of the same
2805 type. Return FAILURE if anything is wrong. */
2808 validate_case_label_expr (gfc_expr
* e
, gfc_expr
* case_expr
)
2810 if (e
== NULL
) return SUCCESS
;
2812 if (e
->ts
.type
!= case_expr
->ts
.type
)
2814 gfc_error ("Expression in CASE statement at %L must be of type %s",
2815 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
2819 /* C805 (R808) For a given case-construct, each case-value shall be of
2820 the same type as case-expr. For character type, length differences
2821 are allowed, but the kind type parameters shall be the same. */
2823 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
2825 gfc_error("Expression in CASE statement at %L must be kind %d",
2826 &e
->where
, case_expr
->ts
.kind
);
2830 /* Convert the case value kind to that of case expression kind, if needed.
2831 FIXME: Should a warning be issued? */
2832 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
2833 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
2837 gfc_error ("Expression in CASE statement at %L must be scalar",
2846 /* Given a completely parsed select statement, we:
2848 - Validate all expressions and code within the SELECT.
2849 - Make sure that the selection expression is not of the wrong type.
2850 - Make sure that no case ranges overlap.
2851 - Eliminate unreachable cases and unreachable code resulting from
2852 removing case labels.
2854 The standard does allow unreachable cases, e.g. CASE (5:3). But
2855 they are a hassle for code generation, and to prevent that, we just
2856 cut them out here. This is not necessary for overlapping cases
2857 because they are illegal and we never even try to generate code.
2859 We have the additional caveat that a SELECT construct could have
2860 been a computed GOTO in the source code. Fortunately we can fairly
2861 easily work around that here: The case_expr for a "real" SELECT CASE
2862 is in code->expr1, but for a computed GOTO it is in code->expr2. All
2863 we have to do is make sure that the case_expr is a scalar integer
2867 resolve_select (gfc_code
* code
)
2870 gfc_expr
*case_expr
;
2871 gfc_case
*cp
, *default_case
, *tail
, *head
;
2872 int seen_unreachable
;
2877 if (code
->expr
== NULL
)
2879 /* This was actually a computed GOTO statement. */
2880 case_expr
= code
->expr2
;
2881 if (case_expr
->ts
.type
!= BT_INTEGER
2882 || case_expr
->rank
!= 0)
2883 gfc_error ("Selection expression in computed GOTO statement "
2884 "at %L must be a scalar integer expression",
2887 /* Further checking is not necessary because this SELECT was built
2888 by the compiler, so it should always be OK. Just move the
2889 case_expr from expr2 to expr so that we can handle computed
2890 GOTOs as normal SELECTs from here on. */
2891 code
->expr
= code
->expr2
;
2896 case_expr
= code
->expr
;
2898 type
= case_expr
->ts
.type
;
2899 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
2901 gfc_error ("Argument of SELECT statement at %L cannot be %s",
2902 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
2904 /* Punt. Going on here just produce more garbage error messages. */
2908 if (case_expr
->rank
!= 0)
2910 gfc_error ("Argument of SELECT statement at %L must be a scalar "
2911 "expression", &case_expr
->where
);
2917 /* PR 19168 has a long discussion concerning a mismatch of the kinds
2918 of the SELECT CASE expression and its CASE values. Walk the lists
2919 of case values, and if we find a mismatch, promote case_expr to
2920 the appropriate kind. */
2922 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
2924 for (body
= code
->block
; body
; body
= body
->block
)
2926 /* Walk the case label list. */
2927 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
2929 /* Intercept the DEFAULT case. It does not have a kind. */
2930 if (cp
->low
== NULL
&& cp
->high
== NULL
)
2933 /* Unreachable case ranges are discarded, so ignore. */
2934 if (cp
->low
!= NULL
&& cp
->high
!= NULL
2935 && cp
->low
!= cp
->high
2936 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
2939 /* FIXME: Should a warning be issued? */
2941 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
2942 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
2944 if (cp
->high
!= NULL
2945 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
2946 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
2951 /* Assume there is no DEFAULT case. */
2952 default_case
= NULL
;
2956 for (body
= code
->block
; body
; body
= body
->block
)
2958 /* Assume the CASE list is OK, and all CASE labels can be matched. */
2960 seen_unreachable
= 0;
2962 /* Walk the case label list, making sure that all case labels
2964 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
2966 /* Count the number of cases in the whole construct. */
2969 /* Intercept the DEFAULT case. */
2970 if (cp
->low
== NULL
&& cp
->high
== NULL
)
2972 if (default_case
!= NULL
)
2974 gfc_error ("The DEFAULT CASE at %L cannot be followed "
2975 "by a second DEFAULT CASE at %L",
2976 &default_case
->where
, &cp
->where
);
2987 /* Deal with single value cases and case ranges. Errors are
2988 issued from the validation function. */
2989 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
2990 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
2996 if (type
== BT_LOGICAL
2997 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
2998 || cp
->low
!= cp
->high
))
3001 ("Logical range in CASE statement at %L is not allowed",
3007 if (cp
->low
!= NULL
&& cp
->high
!= NULL
3008 && cp
->low
!= cp
->high
3009 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
3011 if (gfc_option
.warn_surprising
)
3012 gfc_warning ("Range specification at %L can never "
3013 "be matched", &cp
->where
);
3015 cp
->unreachable
= 1;
3016 seen_unreachable
= 1;
3020 /* If the case range can be matched, it can also overlap with
3021 other cases. To make sure it does not, we put it in a
3022 double linked list here. We sort that with a merge sort
3023 later on to detect any overlapping cases. */
3027 head
->right
= head
->left
= NULL
;
3032 tail
->right
->left
= tail
;
3039 /* It there was a failure in the previous case label, give up
3040 for this case label list. Continue with the next block. */
3044 /* See if any case labels that are unreachable have been seen.
3045 If so, we eliminate them. This is a bit of a kludge because
3046 the case lists for a single case statement (label) is a
3047 single forward linked lists. */
3048 if (seen_unreachable
)
3050 /* Advance until the first case in the list is reachable. */
3051 while (body
->ext
.case_list
!= NULL
3052 && body
->ext
.case_list
->unreachable
)
3054 gfc_case
*n
= body
->ext
.case_list
;
3055 body
->ext
.case_list
= body
->ext
.case_list
->next
;
3057 gfc_free_case_list (n
);
3060 /* Strip all other unreachable cases. */
3061 if (body
->ext
.case_list
)
3063 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
3065 if (cp
->next
->unreachable
)
3067 gfc_case
*n
= cp
->next
;
3068 cp
->next
= cp
->next
->next
;
3070 gfc_free_case_list (n
);
3077 /* See if there were overlapping cases. If the check returns NULL,
3078 there was overlap. In that case we don't do anything. If head
3079 is non-NULL, we prepend the DEFAULT case. The sorted list can
3080 then used during code generation for SELECT CASE constructs with
3081 a case expression of a CHARACTER type. */
3084 head
= check_case_overlap (head
);
3086 /* Prepend the default_case if it is there. */
3087 if (head
!= NULL
&& default_case
)
3089 default_case
->left
= NULL
;
3090 default_case
->right
= head
;
3091 head
->left
= default_case
;
3095 /* Eliminate dead blocks that may be the result if we've seen
3096 unreachable case labels for a block. */
3097 for (body
= code
; body
&& body
->block
; body
= body
->block
)
3099 if (body
->block
->ext
.case_list
== NULL
)
3101 /* Cut the unreachable block from the code chain. */
3102 gfc_code
*c
= body
->block
;
3103 body
->block
= c
->block
;
3105 /* Kill the dead block, but not the blocks below it. */
3107 gfc_free_statements (c
);
3111 /* More than two cases is legal but insane for logical selects.
3112 Issue a warning for it. */
3113 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
3115 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3120 /* Resolve a transfer statement. This is making sure that:
3121 -- a derived type being transferred has only non-pointer components
3122 -- a derived type being transferred doesn't have private components
3123 -- we're not trying to transfer a whole assumed size array. */
3126 resolve_transfer (gfc_code
* code
)
3135 if (exp
->expr_type
!= EXPR_VARIABLE
)
3138 sym
= exp
->symtree
->n
.sym
;
3141 /* Go to actual component transferred. */
3142 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
3143 if (ref
->type
== REF_COMPONENT
)
3144 ts
= &ref
->u
.c
.component
->ts
;
3146 if (ts
->type
== BT_DERIVED
)
3148 /* Check that transferred derived type doesn't contain POINTER
3150 if (derived_pointer (ts
->derived
))
3152 gfc_error ("Data transfer element at %L cannot have "
3153 "POINTER components", &code
->loc
);
3157 if (ts
->derived
->component_access
== ACCESS_PRIVATE
)
3159 gfc_error ("Data transfer element at %L cannot have "
3160 "PRIVATE components",&code
->loc
);
3165 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
3166 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
3168 gfc_error ("Data transfer element at %L cannot be a full reference to "
3169 "an assumed-size array", &code
->loc
);
3175 /*********** Toplevel code resolution subroutines ***********/
3177 /* Given a branch to a label and a namespace, if the branch is conforming.
3178 The code node described where the branch is located. */
3181 resolve_branch (gfc_st_label
* label
, gfc_code
* code
)
3183 gfc_code
*block
, *found
;
3191 /* Step one: is this a valid branching target? */
3193 if (lp
->defined
== ST_LABEL_UNKNOWN
)
3195 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
3200 if (lp
->defined
!= ST_LABEL_TARGET
)
3202 gfc_error ("Statement at %L is not a valid branch target statement "
3203 "for the branch statement at %L", &lp
->where
, &code
->loc
);
3207 /* Step two: make sure this branch is not a branch to itself ;-) */
3209 if (code
->here
== label
)
3211 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
3215 /* Step three: Try to find the label in the parse tree. To do this,
3216 we traverse the tree block-by-block: first the block that
3217 contains this GOTO, then the block that it is nested in, etc. We
3218 can ignore other blocks because branching into another block is
3223 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3225 for (block
= stack
->head
; block
; block
= block
->next
)
3227 if (block
->here
== label
)
3240 /* still nothing, so illegal. */
3241 gfc_error_now ("Label at %L is not in the same block as the "
3242 "GOTO statement at %L", &lp
->where
, &code
->loc
);
3246 /* Step four: Make sure that the branching target is legal if
3247 the statement is an END {SELECT,DO,IF}. */
3249 if (found
->op
== EXEC_NOP
)
3251 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3252 if (stack
->current
->next
== found
)
3256 gfc_notify_std (GFC_STD_F95_DEL
,
3257 "Obsolete: GOTO at %L jumps to END of construct at %L",
3258 &code
->loc
, &found
->loc
);
3263 /* Check whether EXPR1 has the same shape as EXPR2. */
3266 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
3268 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3269 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
3270 try result
= FAILURE
;
3273 /* Compare the rank. */
3274 if (expr1
->rank
!= expr2
->rank
)
3277 /* Compare the size of each dimension. */
3278 for (i
=0; i
<expr1
->rank
; i
++)
3280 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
3283 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
3286 if (mpz_cmp (shape
[i
], shape2
[i
]))
3290 /* When either of the two expression is an assumed size array, we
3291 ignore the comparison of dimension sizes. */
3296 for (i
--; i
>=0; i
--)
3298 mpz_clear (shape
[i
]);
3299 mpz_clear (shape2
[i
]);
3305 /* Check whether a WHERE assignment target or a WHERE mask expression
3306 has the same shape as the outmost WHERE mask expression. */
3309 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
3315 cblock
= code
->block
;
3317 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3318 In case of nested WHERE, only the outmost one is stored. */
3319 if (mask
== NULL
) /* outmost WHERE */
3321 else /* inner WHERE */
3328 /* Check if the mask-expr has a consistent shape with the
3329 outmost WHERE mask-expr. */
3330 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
3331 gfc_error ("WHERE mask at %L has inconsistent shape",
3332 &cblock
->expr
->where
);
3335 /* the assignment statement of a WHERE statement, or the first
3336 statement in where-body-construct of a WHERE construct */
3337 cnext
= cblock
->next
;
3342 /* WHERE assignment statement */
3345 /* Check shape consistent for WHERE assignment target. */
3346 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
3347 gfc_error ("WHERE assignment target at %L has "
3348 "inconsistent shape", &cnext
->expr
->where
);
3351 /* WHERE or WHERE construct is part of a where-body-construct */
3353 resolve_where (cnext
, e
);
3357 gfc_error ("Unsupported statement inside WHERE at %L",
3360 /* the next statement within the same where-body-construct */
3361 cnext
= cnext
->next
;
3363 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3364 cblock
= cblock
->block
;
3369 /* Check whether the FORALL index appears in the expression or not. */
3372 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
3376 gfc_actual_arglist
*args
;
3379 switch (expr
->expr_type
)
3382 gcc_assert (expr
->symtree
->n
.sym
);
3384 /* A scalar assignment */
3387 if (expr
->symtree
->n
.sym
== symbol
)
3393 /* the expr is array ref, substring or struct component. */
3400 /* Check if the symbol appears in the array subscript. */
3402 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3405 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
3409 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
3413 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
3419 if (expr
->symtree
->n
.sym
== symbol
)
3422 /* Check if the symbol appears in the substring section. */
3423 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3425 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3433 gfc_error("expresion reference type error at %L", &expr
->where
);
3439 /* If the expression is a function call, then check if the symbol
3440 appears in the actual arglist of the function. */
3442 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3444 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
3449 /* It seems not to happen. */
3450 case EXPR_SUBSTRING
:
3454 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
3455 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3457 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3462 /* It seems not to happen. */
3463 case EXPR_STRUCTURE
:
3465 gfc_error ("Unsupported statement while finding forall index in "
3470 /* Find the FORALL index in the first operand. */
3471 if (expr
->value
.op
.op1
)
3473 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
3477 /* Find the FORALL index in the second operand. */
3478 if (expr
->value
.op
.op2
)
3480 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
3493 /* Resolve assignment in FORALL construct.
3494 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3495 FORALL index variables. */
3498 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3502 for (n
= 0; n
< nvar
; n
++)
3504 gfc_symbol
*forall_index
;
3506 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
3508 /* Check whether the assignment target is one of the FORALL index
3510 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
3511 && (code
->expr
->symtree
->n
.sym
== forall_index
))
3512 gfc_error ("Assignment to a FORALL index variable at %L",
3513 &code
->expr
->where
);
3516 /* If one of the FORALL index variables doesn't appear in the
3517 assignment target, then there will be a many-to-one
3519 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
3520 gfc_error ("The FORALL with index '%s' cause more than one "
3521 "assignment to this object at %L",
3522 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
3528 /* Resolve WHERE statement in FORALL construct. */
3531 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
){
3535 cblock
= code
->block
;
3538 /* the assignment statement of a WHERE statement, or the first
3539 statement in where-body-construct of a WHERE construct */
3540 cnext
= cblock
->next
;
3545 /* WHERE assignment statement */
3547 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
3550 /* WHERE or WHERE construct is part of a where-body-construct */
3552 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
3556 gfc_error ("Unsupported statement inside WHERE at %L",
3559 /* the next statement within the same where-body-construct */
3560 cnext
= cnext
->next
;
3562 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3563 cblock
= cblock
->block
;
3568 /* Traverse the FORALL body to check whether the following errors exist:
3569 1. For assignment, check if a many-to-one assignment happens.
3570 2. For WHERE statement, check the WHERE body to see if there is any
3571 many-to-one assignment. */
3574 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3578 c
= code
->block
->next
;
3584 case EXEC_POINTER_ASSIGN
:
3585 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
3588 /* Because the resolve_blocks() will handle the nested FORALL,
3589 there is no need to handle it here. */
3593 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
3598 /* The next statement in the FORALL body. */
3604 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3605 gfc_resolve_forall_body to resolve the FORALL body. */
3607 static void resolve_blocks (gfc_code
*, gfc_namespace
*);
3610 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
3612 static gfc_expr
**var_expr
;
3613 static int total_var
= 0;
3614 static int nvar
= 0;
3615 gfc_forall_iterator
*fa
;
3616 gfc_symbol
*forall_index
;
3620 /* Start to resolve a FORALL construct */
3621 if (forall_save
== 0)
3623 /* Count the total number of FORALL index in the nested FORALL
3624 construct in order to allocate the VAR_EXPR with proper size. */
3626 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
3628 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3630 next
= next
->block
->next
;
3633 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3634 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
3637 /* The information about FORALL iterator, including FORALL index start, end
3638 and stride. The FORALL index can not appear in start, end or stride. */
3639 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3641 /* Check if any outer FORALL index name is the same as the current
3643 for (i
= 0; i
< nvar
; i
++)
3645 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
3647 gfc_error ("An outer FORALL construct already has an index "
3648 "with this name %L", &fa
->var
->where
);
3652 /* Record the current FORALL index. */
3653 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
3655 forall_index
= fa
->var
->symtree
->n
.sym
;
3657 /* Check if the FORALL index appears in start, end or stride. */
3658 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
3659 gfc_error ("A FORALL index must not appear in a limit or stride "
3660 "expression in the same FORALL at %L", &fa
->start
->where
);
3661 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
3662 gfc_error ("A FORALL index must not appear in a limit or stride "
3663 "expression in the same FORALL at %L", &fa
->end
->where
);
3664 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
3665 gfc_error ("A FORALL index must not appear in a limit or stride "
3666 "expression in the same FORALL at %L", &fa
->stride
->where
);
3670 /* Resolve the FORALL body. */
3671 gfc_resolve_forall_body (code
, nvar
, var_expr
);
3673 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3674 resolve_blocks (code
->block
, ns
);
3676 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3677 for (i
= 0; i
< total_var
; i
++)
3678 gfc_free_expr (var_expr
[i
]);
3680 /* Reset the counters. */
3686 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3689 static void resolve_code (gfc_code
*, gfc_namespace
*);
3692 resolve_blocks (gfc_code
* b
, gfc_namespace
* ns
)
3696 for (; b
; b
= b
->block
)
3698 t
= gfc_resolve_expr (b
->expr
);
3699 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
3705 if (t
== SUCCESS
&& b
->expr
!= NULL
3706 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
3708 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3715 && (b
->expr
->ts
.type
!= BT_LOGICAL
3716 || b
->expr
->rank
== 0))
3718 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3723 resolve_branch (b
->label
, b
);
3733 gfc_internal_error ("resolve_block(): Bad block type");
3736 resolve_code (b
->next
, ns
);
3741 /* Given a block of code, recursively resolve everything pointed to by this
3745 resolve_code (gfc_code
* code
, gfc_namespace
* ns
)
3747 int forall_save
= 0;
3752 frame
.prev
= cs_base
;
3756 for (; code
; code
= code
->next
)
3758 frame
.current
= code
;
3760 if (code
->op
== EXEC_FORALL
)
3762 forall_save
= forall_flag
;
3764 gfc_resolve_forall (code
, ns
, forall_save
);
3767 resolve_blocks (code
->block
, ns
);
3769 if (code
->op
== EXEC_FORALL
)
3770 forall_flag
= forall_save
;
3772 t
= gfc_resolve_expr (code
->expr
);
3773 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
3789 resolve_where (code
, NULL
);
3793 if (code
->expr
!= NULL
)
3795 if (code
->expr
->ts
.type
!= BT_INTEGER
)
3796 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3797 "variable", &code
->expr
->where
);
3798 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
3799 gfc_error ("Variable '%s' has not been assigned a target label "
3800 "at %L", code
->expr
->symtree
->n
.sym
->name
,
3801 &code
->expr
->where
);
3804 resolve_branch (code
->label
, code
);
3808 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_INTEGER
)
3809 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3810 "return specifier", &code
->expr
->where
);
3817 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
3820 if (gfc_pure (NULL
))
3822 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
3825 ("Cannot assign to variable '%s' in PURE procedure at %L",
3826 code
->expr
->symtree
->n
.sym
->name
, &code
->expr
->where
);
3830 if (code
->expr2
->ts
.type
== BT_DERIVED
3831 && derived_pointer (code
->expr2
->ts
.derived
))
3834 ("Right side of assignment at %L is a derived type "
3835 "containing a POINTER in a PURE procedure",
3836 &code
->expr2
->where
);
3841 gfc_check_assign (code
->expr
, code
->expr2
, 1);
3844 case EXEC_LABEL_ASSIGN
:
3845 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
3846 gfc_error ("Label %d referenced at %L is never defined",
3847 code
->label
->value
, &code
->label
->where
);
3849 && (code
->expr
->expr_type
!= EXPR_VARIABLE
3850 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
3851 || code
->expr
->symtree
->n
.sym
->ts
.kind
3852 != gfc_default_integer_kind
3853 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
3854 gfc_error ("ASSIGN statement at %L requires a scalar "
3855 "default INTEGER variable", &code
->expr
->where
);
3858 case EXEC_POINTER_ASSIGN
:
3862 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
3865 case EXEC_ARITHMETIC_IF
:
3867 && code
->expr
->ts
.type
!= BT_INTEGER
3868 && code
->expr
->ts
.type
!= BT_REAL
)
3869 gfc_error ("Arithmetic IF statement at %L requires a numeric "
3870 "expression", &code
->expr
->where
);
3872 resolve_branch (code
->label
, code
);
3873 resolve_branch (code
->label2
, code
);
3874 resolve_branch (code
->label3
, code
);
3878 if (t
== SUCCESS
&& code
->expr
!= NULL
3879 && (code
->expr
->ts
.type
!= BT_LOGICAL
3880 || code
->expr
->rank
!= 0))
3881 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3882 &code
->expr
->where
);
3887 resolve_call (code
);
3891 /* Select is complicated. Also, a SELECT construct could be
3892 a transformed computed GOTO. */
3893 resolve_select (code
);
3897 if (code
->ext
.iterator
!= NULL
)
3898 gfc_resolve_iterator (code
->ext
.iterator
, true);
3902 if (code
->expr
== NULL
)
3903 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
3905 && (code
->expr
->rank
!= 0
3906 || code
->expr
->ts
.type
!= BT_LOGICAL
))
3907 gfc_error ("Exit condition of DO WHILE loop at %L must be "
3908 "a scalar LOGICAL expression", &code
->expr
->where
);
3912 if (t
== SUCCESS
&& code
->expr
!= NULL
3913 && code
->expr
->ts
.type
!= BT_INTEGER
)
3914 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
3915 "of type INTEGER", &code
->expr
->where
);
3917 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3918 resolve_allocate_expr (a
->expr
);
3922 case EXEC_DEALLOCATE
:
3923 if (t
== SUCCESS
&& code
->expr
!= NULL
3924 && code
->expr
->ts
.type
!= BT_INTEGER
)
3926 ("STAT tag in DEALLOCATE statement at %L must be of type "
3927 "INTEGER", &code
->expr
->where
);
3929 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3930 resolve_deallocate_expr (a
->expr
);
3935 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
3938 resolve_branch (code
->ext
.open
->err
, code
);
3942 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
3945 resolve_branch (code
->ext
.close
->err
, code
);
3948 case EXEC_BACKSPACE
:
3951 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
3954 resolve_branch (code
->ext
.filepos
->err
, code
);
3958 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
3961 resolve_branch (code
->ext
.inquire
->err
, code
);
3965 gcc_assert (code
->ext
.inquire
!= NULL
);
3966 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
3969 resolve_branch (code
->ext
.inquire
->err
, code
);
3974 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
3977 resolve_branch (code
->ext
.dt
->err
, code
);
3978 resolve_branch (code
->ext
.dt
->end
, code
);
3979 resolve_branch (code
->ext
.dt
->eor
, code
);
3983 resolve_transfer (code
);
3987 resolve_forall_iterators (code
->ext
.forall_iterator
);
3989 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
3991 ("FORALL mask clause at %L requires a LOGICAL expression",
3992 &code
->expr
->where
);
3996 gfc_internal_error ("resolve_code(): Bad statement code");
4000 cs_base
= frame
.prev
;
4004 /* Resolve initial values and make sure they are compatible with
4008 resolve_values (gfc_symbol
* sym
)
4011 if (sym
->value
== NULL
)
4014 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
4017 gfc_check_assign_symbol (sym
, sym
->value
);
4021 /* Do anything necessary to resolve a symbol. Right now, we just
4022 assume that an otherwise unknown symbol is a variable. This sort
4023 of thing commonly happens for symbols in module. */
4026 resolve_symbol (gfc_symbol
* sym
)
4028 /* Zero if we are checking a formal namespace. */
4029 static int formal_ns_flag
= 1;
4030 int formal_ns_save
, check_constant
, mp_flag
;
4035 if (sym
->attr
.flavor
== FL_UNKNOWN
)
4037 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
4038 sym
->attr
.flavor
= FL_VARIABLE
;
4041 sym
->attr
.flavor
= FL_PROCEDURE
;
4042 if (sym
->attr
.dimension
)
4043 sym
->attr
.function
= 1;
4047 /* Symbols that are module procedures with results (functions) have
4048 the types and array specification copied for type checking in
4049 procedures that call them, as well as for saving to a module
4050 file. These symbols can't stand the scrutiny that their results
4052 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
4054 /* Assign default type to symbols that need one and don't have one. */
4055 if (sym
->ts
.type
== BT_UNKNOWN
)
4057 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
4058 gfc_set_default_type (sym
, 1, NULL
);
4060 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
4063 gfc_set_default_type (sym
, 0, NULL
);
4066 /* Result may be in another namespace. */
4067 resolve_symbol (sym
->result
);
4069 sym
->ts
= sym
->result
->ts
;
4070 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
4071 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
4072 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
4077 /* Assumed size arrays and assumed shape arrays must be dummy
4081 && (sym
->as
->type
== AS_ASSUMED_SIZE
4082 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
4083 && sym
->attr
.dummy
== 0)
4085 gfc_error ("Assumed %s array at %L must be a dummy argument",
4086 sym
->as
->type
== AS_ASSUMED_SIZE
? "size" : "shape",
4091 /* A parameter array's shape needs to be constant. */
4093 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->as
!= NULL
4094 && !gfc_is_compile_time_shape (sym
->as
))
4096 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4097 "or assumed shape", sym
->name
, &sym
->declared_at
);
4101 /* Make sure that character string variables with assumed length are
4104 if (sym
->attr
.flavor
== FL_VARIABLE
&& !sym
->attr
.result
4105 && sym
->ts
.type
== BT_CHARACTER
4106 && sym
->ts
.cl
->length
== NULL
&& sym
->attr
.dummy
== 0)
4108 gfc_error ("Entity with assumed character length at %L must be a "
4109 "dummy argument or a PARAMETER", &sym
->declared_at
);
4113 /* Make sure a parameter that has been implicitly typed still
4114 matches the implicit type, since PARAMETER statements can precede
4115 IMPLICIT statements. */
4117 if (sym
->attr
.flavor
== FL_PARAMETER
4118 && sym
->attr
.implicit_type
4119 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
4120 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4121 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
4123 /* Make sure the types of derived parameters are consistent. This
4124 type checking is deferred until resolution because the type may
4125 refer to a derived type from the host. */
4127 if (sym
->attr
.flavor
== FL_PARAMETER
4128 && sym
->ts
.type
== BT_DERIVED
4129 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
4130 gfc_error ("Incompatible derived type in PARAMETER at %L",
4131 &sym
->value
->where
);
4133 /* Make sure symbols with known intent or optional are really dummy
4134 variable. Because of ENTRY statement, this has to be deferred
4135 until resolution time. */
4137 if (! sym
->attr
.dummy
4138 && (sym
->attr
.optional
4139 || sym
->attr
.intent
!= INTENT_UNKNOWN
))
4141 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
4145 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
4147 if (sym
->ts
.type
== BT_CHARACTER
)
4149 gfc_charlen
*cl
= sym
->ts
.cl
;
4150 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
4152 gfc_error ("Character-valued statement function '%s' at %L must "
4153 "have constant length", sym
->name
, &sym
->declared_at
);
4159 /* Constraints on deferred shape variable. */
4160 if (sym
->attr
.flavor
== FL_VARIABLE
4161 || (sym
->attr
.flavor
== FL_PROCEDURE
4162 && sym
->attr
.function
))
4164 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
4166 if (sym
->attr
.allocatable
)
4168 if (sym
->attr
.dimension
)
4169 gfc_error ("Allocatable array at %L must have a deferred shape",
4172 gfc_error ("Object at %L may not be ALLOCATABLE",
4177 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
4179 gfc_error ("Pointer to array at %L must have a deferred shape",
4187 if (!mp_flag
&& !sym
->attr
.allocatable
4188 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
4190 gfc_error ("Array at %L cannot have a deferred shape",
4197 switch (sym
->attr
.flavor
)
4200 /* Can the sybol have an initializer? */
4202 if (sym
->attr
.allocatable
)
4203 whynot
= "Allocatable";
4204 else if (sym
->attr
.external
)
4205 whynot
= "External";
4206 else if (sym
->attr
.dummy
)
4208 else if (sym
->attr
.intrinsic
)
4209 whynot
= "Intrinsic";
4210 else if (sym
->attr
.result
)
4211 whynot
= "Function Result";
4212 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
4214 /* Don't allow initialization of automatic arrays. */
4215 for (i
= 0; i
< sym
->as
->rank
; i
++)
4217 if (sym
->as
->lower
[i
] == NULL
4218 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4219 || sym
->as
->upper
[i
] == NULL
4220 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
4222 whynot
= "Automatic array";
4228 /* Reject illegal initializers. */
4229 if (sym
->value
&& whynot
)
4231 gfc_error ("%s '%s' at %L cannot have an initializer",
4232 whynot
, sym
->name
, &sym
->declared_at
);
4236 /* Assign default initializer. */
4237 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| whynot
))
4238 sym
->value
= gfc_default_initializer (&sym
->ts
);
4242 /* Reject PRIVATE objects in a PUBLIC namelist. */
4243 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
4245 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
4247 if (!gfc_check_access(nl
->sym
->attr
.access
,
4248 nl
->sym
->ns
->default_access
))
4249 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4250 "PUBLIC namelist at %L", nl
->sym
->name
,
4261 /* Make sure that intrinsic exist */
4262 if (sym
->attr
.intrinsic
4263 && ! gfc_intrinsic_name(sym
->name
, 0)
4264 && ! gfc_intrinsic_name(sym
->name
, 1))
4265 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
4267 /* Resolve array specifier. Check as well some constraints
4268 on COMMON blocks. */
4270 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
4271 gfc_resolve_array_spec (sym
->as
, check_constant
);
4273 /* Resolve formal namespaces. */
4275 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
4277 formal_ns_save
= formal_ns_flag
;
4279 gfc_resolve (sym
->formal_ns
);
4280 formal_ns_flag
= formal_ns_save
;
4286 /************* Resolve DATA statements *************/
4290 gfc_data_value
*vnode
;
4296 /* Advance the values structure to point to the next value in the data list. */
4299 next_data_value (void)
4301 while (values
.left
== 0)
4303 if (values
.vnode
->next
== NULL
)
4306 values
.vnode
= values
.vnode
->next
;
4307 values
.left
= values
.vnode
->repeat
;
4315 check_data_variable (gfc_data_variable
* var
, locus
* where
)
4321 ar_type mark
= AR_UNKNOWN
;
4323 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
4327 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
4331 mpz_init_set_si (offset
, 0);
4334 if (e
->expr_type
!= EXPR_VARIABLE
)
4335 gfc_internal_error ("check_data_variable(): Bad expression");
4339 mpz_init_set_ui (size
, 1);
4346 /* Find the array section reference. */
4347 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4349 if (ref
->type
!= REF_ARRAY
)
4351 if (ref
->u
.ar
.type
== AR_ELEMENT
)
4357 /* Set marks according to the reference pattern. */
4358 switch (ref
->u
.ar
.type
)
4366 /* Get the start position of array section. */
4367 gfc_get_section_index (ar
, section_index
, &offset
);
4375 if (gfc_array_size (e
, &size
) == FAILURE
)
4377 gfc_error ("Nonconstant array section at %L in DATA statement",
4386 while (mpz_cmp_ui (size
, 0) > 0)
4388 if (next_data_value () == FAILURE
)
4390 gfc_error ("DATA statement at %L has more variables than values",
4396 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
4400 /* If we have more than one element left in the repeat count,
4401 and we have more than one element left in the target variable,
4402 then create a range assignment. */
4403 /* ??? Only done for full arrays for now, since array sections
4405 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
4406 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
4410 if (mpz_cmp_ui (size
, values
.left
) >= 0)
4412 mpz_init_set_ui (range
, values
.left
);
4413 mpz_sub_ui (size
, size
, values
.left
);
4418 mpz_init_set (range
, size
);
4419 values
.left
-= mpz_get_ui (size
);
4420 mpz_set_ui (size
, 0);
4423 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
4426 mpz_add (offset
, offset
, range
);
4430 /* Assign initial value to symbol. */
4434 mpz_sub_ui (size
, size
, 1);
4436 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
4438 if (mark
== AR_FULL
)
4439 mpz_add_ui (offset
, offset
, 1);
4441 /* Modify the array section indexes and recalculate the offset
4442 for next element. */
4443 else if (mark
== AR_SECTION
)
4444 gfc_advance_section (section_index
, ar
, &offset
);
4448 if (mark
== AR_SECTION
)
4450 for (i
= 0; i
< ar
->dimen
; i
++)
4451 mpz_clear (section_index
[i
]);
4461 static try traverse_data_var (gfc_data_variable
*, locus
*);
4463 /* Iterate over a list of elements in a DATA statement. */
4466 traverse_data_list (gfc_data_variable
* var
, locus
* where
)
4469 iterator_stack frame
;
4472 mpz_init (frame
.value
);
4474 mpz_init_set (trip
, var
->iter
.end
->value
.integer
);
4475 mpz_sub (trip
, trip
, var
->iter
.start
->value
.integer
);
4476 mpz_add (trip
, trip
, var
->iter
.step
->value
.integer
);
4478 mpz_div (trip
, trip
, var
->iter
.step
->value
.integer
);
4480 mpz_set (frame
.value
, var
->iter
.start
->value
.integer
);
4482 frame
.prev
= iter_stack
;
4483 frame
.variable
= var
->iter
.var
->symtree
;
4484 iter_stack
= &frame
;
4486 while (mpz_cmp_ui (trip
, 0) > 0)
4488 if (traverse_data_var (var
->list
, where
) == FAILURE
)
4494 e
= gfc_copy_expr (var
->expr
);
4495 if (gfc_simplify_expr (e
, 1) == FAILURE
)
4501 mpz_add (frame
.value
, frame
.value
, var
->iter
.step
->value
.integer
);
4503 mpz_sub_ui (trip
, trip
, 1);
4507 mpz_clear (frame
.value
);
4509 iter_stack
= frame
.prev
;
4514 /* Type resolve variables in the variable list of a DATA statement. */
4517 traverse_data_var (gfc_data_variable
* var
, locus
* where
)
4521 for (; var
; var
= var
->next
)
4523 if (var
->expr
== NULL
)
4524 t
= traverse_data_list (var
, where
);
4526 t
= check_data_variable (var
, where
);
4536 /* Resolve the expressions and iterators associated with a data statement.
4537 This is separate from the assignment checking because data lists should
4538 only be resolved once. */
4541 resolve_data_variables (gfc_data_variable
* d
)
4543 for (; d
; d
= d
->next
)
4545 if (d
->list
== NULL
)
4547 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
4552 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
4555 if (d
->iter
.start
->expr_type
!= EXPR_CONSTANT
4556 || d
->iter
.end
->expr_type
!= EXPR_CONSTANT
4557 || d
->iter
.step
->expr_type
!= EXPR_CONSTANT
)
4558 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4560 if (resolve_data_variables (d
->list
) == FAILURE
)
4569 /* Resolve a single DATA statement. We implement this by storing a pointer to
4570 the value list into static variables, and then recursively traversing the
4571 variables list, expanding iterators and such. */
4574 resolve_data (gfc_data
* d
)
4576 if (resolve_data_variables (d
->var
) == FAILURE
)
4579 values
.vnode
= d
->value
;
4580 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
4582 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
4585 /* At this point, we better not have any values left. */
4587 if (next_data_value () == SUCCESS
)
4588 gfc_error ("DATA statement at %L has more values than variables",
4593 /* Determines if a variable is not 'pure', ie not assignable within a pure
4594 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4598 gfc_impure_variable (gfc_symbol
* sym
)
4600 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
4603 if (sym
->ns
!= gfc_current_ns
)
4604 return !sym
->attr
.function
;
4606 /* TODO: Check storage association through EQUIVALENCE statements */
4612 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4613 symbol of the current procedure. */
4616 gfc_pure (gfc_symbol
* sym
)
4618 symbol_attribute attr
;
4621 sym
= gfc_current_ns
->proc_name
;
4627 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
4631 /* Test whether the current procedure is elemental or not. */
4634 gfc_elemental (gfc_symbol
* sym
)
4636 symbol_attribute attr
;
4639 sym
= gfc_current_ns
->proc_name
;
4644 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
4648 /* Warn about unused labels. */
4651 warn_unused_label (gfc_namespace
* ns
)
4662 for (; l
; l
= l
->prev
)
4664 if (l
->defined
== ST_LABEL_UNKNOWN
)
4667 switch (l
->referenced
)
4669 case ST_LABEL_UNKNOWN
:
4670 gfc_warning ("Label %d at %L defined but not used", l
->value
,
4674 case ST_LABEL_BAD_TARGET
:
4675 gfc_warning ("Label %d at %L defined but cannot be used", l
->value
,
4686 /* Resolve derived type EQUIVALENCE object. */
4689 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
4692 gfc_component
*c
= derived
->components
;
4697 /* Shall not be an object of nonsequence derived type. */
4698 if (!derived
->attr
.sequence
)
4700 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
4701 "attribute to be an EQUIVALENCE object", sym
->name
, &e
->where
);
4705 for (; c
; c
= c
->next
)
4708 if (d
&& (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
4711 /* Shall not be an object of sequence derived type containing a pointer
4712 in the structure. */
4715 gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
4716 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
4724 /* Resolve equivalence object.
4725 An EQUIVALENCE object shall not be a dummy argument, a pointer, an
4726 allocatable array, an object of nonsequence derived type, an object of
4727 sequence derived type containing a pointer at any level of component
4728 selection, an automatic object, a function name, an entry name, a result
4729 name, a named constant, a structure component, or a subobject of any of
4730 the preceding objects. */
4733 resolve_equivalence (gfc_equiv
*eq
)
4736 gfc_symbol
*derived
;
4740 for (; eq
; eq
= eq
->eq
)
4743 if (gfc_resolve_expr (e
) == FAILURE
)
4746 sym
= e
->symtree
->n
.sym
;
4748 /* Shall not be a dummy argument. */
4749 if (sym
->attr
.dummy
)
4751 gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
4752 "object", sym
->name
, &e
->where
);
4756 /* Shall not be an allocatable array. */
4757 if (sym
->attr
.allocatable
)
4759 gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
4760 "object", sym
->name
, &e
->where
);
4764 /* Shall not be a pointer. */
4765 if (sym
->attr
.pointer
)
4767 gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
4768 sym
->name
, &e
->where
);
4772 /* Shall not be a function name, ... */
4773 if (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
4774 || sym
->attr
.subroutine
)
4776 gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
4777 sym
->name
, &e
->where
);
4781 /* Shall not be a named constant. */
4782 if (e
->expr_type
== EXPR_CONSTANT
)
4784 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
4785 "object", sym
->name
, &e
->where
);
4789 derived
= e
->ts
.derived
;
4790 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
4796 /* Shall not be an automatic array. */
4797 if (e
->ref
->type
== REF_ARRAY
4798 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
4800 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
4801 "an EQUIVALENCE object", sym
->name
, &e
->where
);
4805 /* Shall not be a structure component. */
4809 if (r
->type
== REF_COMPONENT
)
4811 gfc_error ("Structure component '%s' at %L cannot be an "
4812 "EQUIVALENCE object",
4813 r
->u
.c
.component
->name
, &e
->where
);
4822 /* Resolve function and ENTRY types, issue diagnostics if needed. */
4825 resolve_fntype (gfc_namespace
* ns
)
4830 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
4833 /* If there are any entries, ns->proc_name is the entry master
4834 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
4836 sym
= ns
->entries
->sym
;
4838 sym
= ns
->proc_name
;
4839 if (sym
->result
== sym
4840 && sym
->ts
.type
== BT_UNKNOWN
4841 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
4842 && !sym
->attr
.untyped
)
4844 gfc_error ("Function '%s' at %L has no IMPLICIT type",
4845 sym
->name
, &sym
->declared_at
);
4846 sym
->attr
.untyped
= 1;
4850 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
4852 if (el
->sym
->result
== el
->sym
4853 && el
->sym
->ts
.type
== BT_UNKNOWN
4854 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
4855 && !el
->sym
->attr
.untyped
)
4857 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
4858 el
->sym
->name
, &el
->sym
->declared_at
);
4859 el
->sym
->attr
.untyped
= 1;
4865 /* This function is called after a complete program unit has been compiled.
4866 Its purpose is to examine all of the expressions associated with a program
4867 unit, assign types to all intermediate expressions, make sure that all
4868 assignments are to compatible types and figure out which names refer to
4869 which functions or subroutines. */
4872 gfc_resolve (gfc_namespace
* ns
)
4874 gfc_namespace
*old_ns
, *n
;
4879 old_ns
= gfc_current_ns
;
4880 gfc_current_ns
= ns
;
4882 resolve_entries (ns
);
4884 resolve_contained_functions (ns
);
4886 gfc_traverse_ns (ns
, resolve_symbol
);
4888 resolve_fntype (ns
);
4890 for (n
= ns
->contained
; n
; n
= n
->sibling
)
4892 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
4893 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
4894 "also be PURE", n
->proc_name
->name
,
4895 &n
->proc_name
->declared_at
);
4901 gfc_check_interfaces (ns
);
4903 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
4905 if (cl
->length
== NULL
|| gfc_resolve_expr (cl
->length
) == FAILURE
)
4908 if (gfc_simplify_expr (cl
->length
, 0) == FAILURE
)
4911 if (gfc_specification_expr (cl
->length
) == FAILURE
)
4915 gfc_traverse_ns (ns
, resolve_values
);
4921 for (d
= ns
->data
; d
; d
= d
->next
)
4925 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
4927 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
4928 resolve_equivalence (eq
);
4931 resolve_code (ns
->code
, ns
);
4933 /* Warn about unused labels. */
4934 if (gfc_option
.warn_unused_labels
)
4935 warn_unused_label (ns
);
4937 gfc_current_ns
= old_ns
;