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(). */
28 /* Types used in equivalence statements. */
32 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
36 /* Stack to push the current if we descend into a block during
37 resolution. See resolve_branch() and resolve_code(). */
39 typedef struct code_stack
41 struct gfc_code
*head
, *current
;
42 struct code_stack
*prev
;
46 static code_stack
*cs_base
= NULL
;
49 /* Nonzero if we're inside a FORALL block */
51 static int forall_flag
;
53 /* Nonzero if we are processing a formal arglist. The corresponding function
54 resets the flag each time that it is read. */
55 static int formal_arg_flag
= 0;
58 gfc_is_formal_arg (void)
60 return formal_arg_flag
;
63 /* Resolve types of formal argument lists. These have to be done early so that
64 the formal argument lists of module procedures can be copied to the
65 containing module before the individual procedures are resolved
66 individually. We also resolve argument lists of procedures in interface
67 blocks because they are self-contained scoping units.
69 Since a dummy argument cannot be a non-dummy procedure, the only
70 resort left for untyped names are the IMPLICIT types. */
73 resolve_formal_arglist (gfc_symbol
* proc
)
75 gfc_formal_arglist
*f
;
79 /* TODO: Procedures whose return character length parameter is not constant
80 or assumed must also have explicit interfaces. */
81 if (proc
->result
!= NULL
)
86 if (gfc_elemental (proc
)
87 || sym
->attr
.pointer
|| sym
->attr
.allocatable
88 || (sym
->as
&& sym
->as
->rank
> 0))
89 proc
->attr
.always_explicit
= 1;
93 for (f
= proc
->formal
; f
; f
= f
->next
)
99 /* Alternate return placeholder. */
100 if (gfc_elemental (proc
))
101 gfc_error ("Alternate return specifier in elemental subroutine "
102 "'%s' at %L is not allowed", proc
->name
,
104 if (proc
->attr
.function
)
105 gfc_error ("Alternate return specifier in function "
106 "'%s' at %L is not allowed", proc
->name
,
111 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
112 resolve_formal_arglist (sym
);
114 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
116 if (gfc_pure (proc
) && !gfc_pure (sym
))
119 ("Dummy procedure '%s' of PURE procedure at %L must also "
120 "be PURE", sym
->name
, &sym
->declared_at
);
124 if (gfc_elemental (proc
))
127 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
135 if (sym
->ts
.type
== BT_UNKNOWN
)
137 if (!sym
->attr
.function
|| sym
->result
== sym
)
138 gfc_set_default_type (sym
, 1, sym
->ns
);
141 /* Set the type of the RESULT, then copy. */
142 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
143 gfc_set_default_type (sym
->result
, 1, sym
->result
->ns
);
145 sym
->ts
= sym
->result
->ts
;
147 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
151 gfc_resolve_array_spec (sym
->as
, 0);
153 /* We can't tell if an array with dimension (:) is assumed or deferred
154 shape until we know if it has the pointer or allocatable attributes.
156 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
157 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
159 sym
->as
->type
= AS_ASSUMED_SHAPE
;
160 for (i
= 0; i
< sym
->as
->rank
; i
++)
161 sym
->as
->lower
[i
] = gfc_int_expr (1);
164 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
165 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
166 || sym
->attr
.optional
)
167 proc
->attr
.always_explicit
= 1;
169 /* If the flavor is unknown at this point, it has to be a variable.
170 A procedure specification would have already set the type. */
172 if (sym
->attr
.flavor
== FL_UNKNOWN
)
173 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
177 if (proc
->attr
.function
&& !sym
->attr
.pointer
178 && sym
->attr
.flavor
!= FL_PROCEDURE
179 && sym
->attr
.intent
!= INTENT_IN
)
181 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
182 "INTENT(IN)", sym
->name
, proc
->name
,
185 if (proc
->attr
.subroutine
&& !sym
->attr
.pointer
186 && sym
->attr
.intent
== INTENT_UNKNOWN
)
189 ("Argument '%s' of pure subroutine '%s' at %L must have "
190 "its INTENT specified", sym
->name
, proc
->name
,
195 if (gfc_elemental (proc
))
200 ("Argument '%s' of elemental procedure at %L must be scalar",
201 sym
->name
, &sym
->declared_at
);
205 if (sym
->attr
.pointer
)
208 ("Argument '%s' of elemental procedure at %L cannot have "
209 "the POINTER attribute", sym
->name
, &sym
->declared_at
);
214 /* Each dummy shall be specified to be scalar. */
215 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
220 ("Argument '%s' of statement function at %L must be scalar",
221 sym
->name
, &sym
->declared_at
);
225 if (sym
->ts
.type
== BT_CHARACTER
)
227 gfc_charlen
*cl
= sym
->ts
.cl
;
228 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
231 ("Character-valued argument '%s' of statement function at "
232 "%L must has constant length",
233 sym
->name
, &sym
->declared_at
);
243 /* Work function called when searching for symbols that have argument lists
244 associated with them. */
247 find_arglists (gfc_symbol
* sym
)
250 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
253 resolve_formal_arglist (sym
);
257 /* Given a namespace, resolve all formal argument lists within the namespace.
261 resolve_formal_arglists (gfc_namespace
* ns
)
267 gfc_traverse_ns (ns
, find_arglists
);
272 resolve_contained_fntype (gfc_symbol
* sym
, gfc_namespace
* ns
)
276 /* If this namespace is not a function, ignore it. */
278 || !(sym
->attr
.function
279 || sym
->attr
.flavor
== FL_VARIABLE
))
282 /* Try to find out of what the return type is. */
283 if (sym
->result
!= NULL
)
286 if (sym
->ts
.type
== BT_UNKNOWN
)
288 t
= gfc_set_default_type (sym
, 0, ns
);
290 if (t
== FAILURE
&& !sym
->attr
.untyped
)
292 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
293 sym
->name
, &sym
->declared_at
); /* FIXME */
294 sym
->attr
.untyped
= 1;
300 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
301 introduce duplicates. */
304 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
306 gfc_formal_arglist
*f
, *new_arglist
;
309 for (; new_args
!= NULL
; new_args
= new_args
->next
)
311 new_sym
= new_args
->sym
;
312 /* See if ths arg is already in the formal argument list. */
313 for (f
= proc
->formal
; f
; f
= f
->next
)
315 if (new_sym
== f
->sym
)
322 /* Add a new argument. Argument order is not important. */
323 new_arglist
= gfc_get_formal_arglist ();
324 new_arglist
->sym
= new_sym
;
325 new_arglist
->next
= proc
->formal
;
326 proc
->formal
= new_arglist
;
331 /* Resolve alternate entry points. If a symbol has multiple entry points we
332 create a new master symbol for the main routine, and turn the existing
333 symbol into an entry point. */
336 resolve_entries (gfc_namespace
* ns
)
338 gfc_namespace
*old_ns
;
342 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
343 static int master_count
= 0;
345 if (ns
->proc_name
== NULL
)
348 /* No need to do anything if this procedure doesn't have alternate entry
353 /* We may already have resolved alternate entry points. */
354 if (ns
->proc_name
->attr
.entry_master
)
357 /* If this isn't a procedure something has gone horribly wrong. */
358 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
360 /* Remember the current namespace. */
361 old_ns
= gfc_current_ns
;
365 /* Add the main entry point to the list of entry points. */
366 el
= gfc_get_entry_list ();
367 el
->sym
= ns
->proc_name
;
369 el
->next
= ns
->entries
;
371 ns
->proc_name
->attr
.entry
= 1;
373 /* Add an entry statement for it. */
380 /* Create a new symbol for the master function. */
381 /* Give the internal function a unique name (within this file).
382 Also include the function name so the user has some hope of figuring
383 out what is going on. */
384 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
385 master_count
++, ns
->proc_name
->name
);
386 gfc_get_ha_symbol (name
, &proc
);
387 gcc_assert (proc
!= NULL
);
389 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
390 if (ns
->proc_name
->attr
.subroutine
)
391 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
395 gfc_typespec
*ts
, *fts
;
397 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
399 fts
= &ns
->entries
->sym
->result
->ts
;
400 if (fts
->type
== BT_UNKNOWN
)
401 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
402 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
404 ts
= &el
->sym
->result
->ts
;
405 if (ts
->type
== BT_UNKNOWN
)
406 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
407 if (! gfc_compare_types (ts
, fts
)
408 || (el
->sym
->result
->attr
.dimension
409 != ns
->entries
->sym
->result
->attr
.dimension
)
410 || (el
->sym
->result
->attr
.pointer
411 != ns
->entries
->sym
->result
->attr
.pointer
))
417 sym
= ns
->entries
->sym
->result
;
418 /* All result types the same. */
420 if (sym
->attr
.dimension
)
421 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
422 if (sym
->attr
.pointer
)
423 gfc_add_pointer (&proc
->attr
, NULL
);
427 /* Otherwise the result will be passed through a union by
429 proc
->attr
.mixed_entry_master
= 1;
430 for (el
= ns
->entries
; el
; el
= el
->next
)
432 sym
= el
->sym
->result
;
433 if (sym
->attr
.dimension
)
435 if (el
== ns
->entries
)
437 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
438 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
441 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
442 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
444 else if (sym
->attr
.pointer
)
446 if (el
== ns
->entries
)
448 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
449 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
452 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
453 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
458 if (ts
->type
== BT_UNKNOWN
)
459 ts
= gfc_get_default_type (sym
, NULL
);
463 if (ts
->kind
== gfc_default_integer_kind
)
467 if (ts
->kind
== gfc_default_real_kind
468 || ts
->kind
== gfc_default_double_kind
)
472 if (ts
->kind
== gfc_default_complex_kind
)
476 if (ts
->kind
== gfc_default_logical_kind
)
480 /* We will issue error elsewhere. */
488 if (el
== ns
->entries
)
490 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
491 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
495 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
496 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
503 proc
->attr
.access
= ACCESS_PRIVATE
;
504 proc
->attr
.entry_master
= 1;
506 /* Merge all the entry point arguments. */
507 for (el
= ns
->entries
; el
; el
= el
->next
)
508 merge_argument_lists (proc
, el
->sym
->formal
);
510 /* Use the master function for the function body. */
511 ns
->proc_name
= proc
;
513 /* Finalize the new symbols. */
514 gfc_commit_symbols ();
516 /* Restore the original namespace. */
517 gfc_current_ns
= old_ns
;
521 /* Resolve contained function types. Because contained functions can call one
522 another, they have to be worked out before any of the contained procedures
525 The good news is that if a function doesn't already have a type, the only
526 way it can get one is through an IMPLICIT type or a RESULT variable, because
527 by definition contained functions are contained namespace they're contained
528 in, not in a sibling or parent namespace. */
531 resolve_contained_functions (gfc_namespace
* ns
)
533 gfc_namespace
*child
;
536 resolve_formal_arglists (ns
);
538 for (child
= ns
->contained
; child
; child
= child
->sibling
)
540 /* Resolve alternate entry points first. */
541 resolve_entries (child
);
543 /* Then check function return types. */
544 resolve_contained_fntype (child
->proc_name
, child
);
545 for (el
= child
->entries
; el
; el
= el
->next
)
546 resolve_contained_fntype (el
->sym
, child
);
551 /* Resolve all of the elements of a structure constructor and make sure that
552 the types are correct. */
555 resolve_structure_cons (gfc_expr
* expr
)
557 gfc_constructor
*cons
;
562 cons
= expr
->value
.constructor
;
563 /* A constructor may have references if it is the result of substituting a
564 parameter variable. In this case we just pull out the component we
567 comp
= expr
->ref
->u
.c
.sym
->components
;
569 comp
= expr
->ts
.derived
->components
;
571 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
579 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
585 /* If we don't have the right type, try to convert it. */
587 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
)
588 && gfc_convert_type (cons
->expr
, &comp
->ts
, 1) == FAILURE
)
597 /****************** Expression name resolution ******************/
599 /* Returns 0 if a symbol was not declared with a type or
600 attribute declaration statement, nonzero otherwise. */
603 was_declared (gfc_symbol
* sym
)
609 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
612 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
613 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
614 || a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
621 /* Determine if a symbol is generic or not. */
624 generic_sym (gfc_symbol
* sym
)
628 if (sym
->attr
.generic
||
629 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
632 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
635 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
637 return (s
== NULL
) ? 0 : generic_sym (s
);
641 /* Determine if a symbol is specific or not. */
644 specific_sym (gfc_symbol
* sym
)
648 if (sym
->attr
.if_source
== IFSRC_IFBODY
649 || sym
->attr
.proc
== PROC_MODULE
650 || sym
->attr
.proc
== PROC_INTERNAL
651 || sym
->attr
.proc
== PROC_ST_FUNCTION
652 || (sym
->attr
.intrinsic
&&
653 gfc_specific_intrinsic (sym
->name
))
654 || sym
->attr
.external
)
657 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
660 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
662 return (s
== NULL
) ? 0 : specific_sym (s
);
666 /* Figure out if the procedure is specific, generic or unknown. */
669 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
673 procedure_kind (gfc_symbol
* sym
)
676 if (generic_sym (sym
))
677 return PTYPE_GENERIC
;
679 if (specific_sym (sym
))
680 return PTYPE_SPECIFIC
;
682 return PTYPE_UNKNOWN
;
686 /* Resolve an actual argument list. Most of the time, this is just
687 resolving the expressions in the list.
688 The exception is that we sometimes have to decide whether arguments
689 that look like procedure arguments are really simple variable
693 resolve_actual_arglist (gfc_actual_arglist
* arg
)
696 gfc_symtree
*parent_st
;
699 for (; arg
; arg
= arg
->next
)
705 /* Check the label is a valid branching target. */
708 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
710 gfc_error ("Label %d referenced at %L is never defined",
711 arg
->label
->value
, &arg
->label
->where
);
718 if (e
->ts
.type
!= BT_PROCEDURE
)
720 if (gfc_resolve_expr (e
) != SUCCESS
)
725 /* See if the expression node should really be a variable
728 sym
= e
->symtree
->n
.sym
;
730 if (sym
->attr
.flavor
== FL_PROCEDURE
731 || sym
->attr
.intrinsic
732 || sym
->attr
.external
)
735 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
737 gfc_error ("Statement function '%s' at %L is not allowed as an "
738 "actual argument", sym
->name
, &e
->where
);
741 /* If the symbol is the function that names the current (or
742 parent) scope, then we really have a variable reference. */
744 if (sym
->attr
.function
&& sym
->result
== sym
745 && (sym
->ns
->proc_name
== sym
746 || (sym
->ns
->parent
!= NULL
747 && sym
->ns
->parent
->proc_name
== sym
)))
753 /* See if the name is a module procedure in a parent unit. */
755 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
758 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
760 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
764 if (parent_st
== NULL
)
767 sym
= parent_st
->n
.sym
;
768 e
->symtree
= parent_st
; /* Point to the right thing. */
770 if (sym
->attr
.flavor
== FL_PROCEDURE
771 || sym
->attr
.intrinsic
772 || sym
->attr
.external
)
778 e
->expr_type
= EXPR_VARIABLE
;
782 e
->rank
= sym
->as
->rank
;
783 e
->ref
= gfc_get_ref ();
784 e
->ref
->type
= REF_ARRAY
;
785 e
->ref
->u
.ar
.type
= AR_FULL
;
786 e
->ref
->u
.ar
.as
= sym
->as
;
794 /************* Function resolution *************/
796 /* Resolve a function call known to be generic.
797 Section 14.1.2.4.1. */
800 resolve_generic_f0 (gfc_expr
* expr
, gfc_symbol
* sym
)
804 if (sym
->attr
.generic
)
807 gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
810 expr
->value
.function
.name
= s
->name
;
811 expr
->value
.function
.esym
= s
;
814 expr
->rank
= s
->as
->rank
;
818 /* TODO: Need to search for elemental references in generic interface */
821 if (sym
->attr
.intrinsic
)
822 return gfc_intrinsic_func_interface (expr
, 0);
829 resolve_generic_f (gfc_expr
* expr
)
834 sym
= expr
->symtree
->n
.sym
;
838 m
= resolve_generic_f0 (expr
, sym
);
841 else if (m
== MATCH_ERROR
)
845 if (sym
->ns
->parent
== NULL
)
847 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
851 if (!generic_sym (sym
))
855 /* Last ditch attempt. */
857 if (!gfc_generic_intrinsic (expr
->symtree
->n
.sym
->name
))
859 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
860 expr
->symtree
->n
.sym
->name
, &expr
->where
);
864 m
= gfc_intrinsic_func_interface (expr
, 0);
869 ("Generic function '%s' at %L is not consistent with a specific "
870 "intrinsic interface", expr
->symtree
->n
.sym
->name
, &expr
->where
);
876 /* Resolve a function call known to be specific. */
879 resolve_specific_f0 (gfc_symbol
* sym
, gfc_expr
* expr
)
883 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
887 sym
->attr
.proc
= PROC_DUMMY
;
891 sym
->attr
.proc
= PROC_EXTERNAL
;
895 if (sym
->attr
.proc
== PROC_MODULE
896 || sym
->attr
.proc
== PROC_ST_FUNCTION
897 || sym
->attr
.proc
== PROC_INTERNAL
)
900 if (sym
->attr
.intrinsic
)
902 m
= gfc_intrinsic_func_interface (expr
, 1);
907 ("Function '%s' at %L is INTRINSIC but is not compatible with "
908 "an intrinsic", sym
->name
, &expr
->where
);
916 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
919 expr
->value
.function
.name
= sym
->name
;
920 expr
->value
.function
.esym
= sym
;
922 expr
->rank
= sym
->as
->rank
;
929 resolve_specific_f (gfc_expr
* expr
)
934 sym
= expr
->symtree
->n
.sym
;
938 m
= resolve_specific_f0 (sym
, expr
);
941 if (m
== MATCH_ERROR
)
944 if (sym
->ns
->parent
== NULL
)
947 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
953 gfc_error ("Unable to resolve the specific function '%s' at %L",
954 expr
->symtree
->n
.sym
->name
, &expr
->where
);
960 /* Resolve a procedure call not known to be generic nor specific. */
963 resolve_unknown_f (gfc_expr
* expr
)
968 sym
= expr
->symtree
->n
.sym
;
972 sym
->attr
.proc
= PROC_DUMMY
;
973 expr
->value
.function
.name
= sym
->name
;
977 /* See if we have an intrinsic function reference. */
979 if (gfc_intrinsic_name (sym
->name
, 0))
981 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
986 /* The reference is to an external name. */
988 sym
->attr
.proc
= PROC_EXTERNAL
;
989 expr
->value
.function
.name
= sym
->name
;
990 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
993 expr
->rank
= sym
->as
->rank
;
995 /* Type of the expression is either the type of the symbol or the
996 default type of the symbol. */
999 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1001 if (sym
->ts
.type
!= BT_UNKNOWN
)
1005 ts
= gfc_get_default_type (sym
, sym
->ns
);
1007 if (ts
->type
== BT_UNKNOWN
)
1009 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1010 sym
->name
, &expr
->where
);
1021 /* Figure out if a function reference is pure or not. Also set the name
1022 of the function for a potential error message. Return nonzero if the
1023 function is PURE, zero if not. */
1026 pure_function (gfc_expr
* e
, const char **name
)
1030 if (e
->value
.function
.esym
)
1032 pure
= gfc_pure (e
->value
.function
.esym
);
1033 *name
= e
->value
.function
.esym
->name
;
1035 else if (e
->value
.function
.isym
)
1037 pure
= e
->value
.function
.isym
->pure
1038 || e
->value
.function
.isym
->elemental
;
1039 *name
= e
->value
.function
.isym
->name
;
1043 /* Implicit functions are not pure. */
1045 *name
= e
->value
.function
.name
;
1052 /* Resolve a function call, which means resolving the arguments, then figuring
1053 out which entity the name refers to. */
1054 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1055 to INTENT(OUT) or INTENT(INOUT). */
1058 resolve_function (gfc_expr
* expr
)
1060 gfc_actual_arglist
*arg
;
1064 if (resolve_actual_arglist (expr
->value
.function
.actual
) == FAILURE
)
1067 /* See if function is already resolved. */
1069 if (expr
->value
.function
.name
!= NULL
)
1071 if (expr
->ts
.type
== BT_UNKNOWN
)
1072 expr
->ts
= expr
->symtree
->n
.sym
->ts
;
1077 /* Apply the rules of section 14.1.2. */
1079 switch (procedure_kind (expr
->symtree
->n
.sym
))
1082 t
= resolve_generic_f (expr
);
1085 case PTYPE_SPECIFIC
:
1086 t
= resolve_specific_f (expr
);
1090 t
= resolve_unknown_f (expr
);
1094 gfc_internal_error ("resolve_function(): bad function type");
1098 /* If the expression is still a function (it might have simplified),
1099 then we check to see if we are calling an elemental function. */
1101 if (expr
->expr_type
!= EXPR_FUNCTION
)
1104 if (expr
->value
.function
.actual
!= NULL
1105 && ((expr
->value
.function
.esym
!= NULL
1106 && expr
->value
.function
.esym
->attr
.elemental
)
1107 || (expr
->value
.function
.isym
!= NULL
1108 && expr
->value
.function
.isym
->elemental
)))
1111 /* The rank of an elemental is the rank of its array argument(s). */
1113 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1115 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1117 expr
->rank
= arg
->expr
->rank
;
1123 if (!pure_function (expr
, &name
))
1128 ("Function reference to '%s' at %L is inside a FORALL block",
1129 name
, &expr
->where
);
1132 else if (gfc_pure (NULL
))
1134 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1135 "procedure within a PURE procedure", name
, &expr
->where
);
1144 /************* Subroutine resolution *************/
1147 pure_subroutine (gfc_code
* c
, gfc_symbol
* sym
)
1154 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1155 sym
->name
, &c
->loc
);
1156 else if (gfc_pure (NULL
))
1157 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1163 resolve_generic_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1167 if (sym
->attr
.generic
)
1169 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1172 c
->resolved_sym
= s
;
1173 pure_subroutine (c
, s
);
1177 /* TODO: Need to search for elemental references in generic interface. */
1180 if (sym
->attr
.intrinsic
)
1181 return gfc_intrinsic_sub_interface (c
, 0);
1188 resolve_generic_s (gfc_code
* c
)
1193 sym
= c
->symtree
->n
.sym
;
1195 m
= resolve_generic_s0 (c
, sym
);
1198 if (m
== MATCH_ERROR
)
1201 if (sym
->ns
->parent
!= NULL
)
1203 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1206 m
= resolve_generic_s0 (c
, sym
);
1209 if (m
== MATCH_ERROR
)
1214 /* Last ditch attempt. */
1216 if (!gfc_generic_intrinsic (sym
->name
))
1219 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1220 sym
->name
, &c
->loc
);
1224 m
= gfc_intrinsic_sub_interface (c
, 0);
1228 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1229 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1235 /* Resolve a subroutine call known to be specific. */
1238 resolve_specific_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1242 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1244 if (sym
->attr
.dummy
)
1246 sym
->attr
.proc
= PROC_DUMMY
;
1250 sym
->attr
.proc
= PROC_EXTERNAL
;
1254 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1257 if (sym
->attr
.intrinsic
)
1259 m
= gfc_intrinsic_sub_interface (c
, 1);
1263 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1264 "with an intrinsic", sym
->name
, &c
->loc
);
1272 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1274 c
->resolved_sym
= sym
;
1275 pure_subroutine (c
, sym
);
1282 resolve_specific_s (gfc_code
* c
)
1287 sym
= c
->symtree
->n
.sym
;
1289 m
= resolve_specific_s0 (c
, sym
);
1292 if (m
== MATCH_ERROR
)
1295 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1299 m
= resolve_specific_s0 (c
, sym
);
1302 if (m
== MATCH_ERROR
)
1306 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1307 sym
->name
, &c
->loc
);
1313 /* Resolve a subroutine call not known to be generic nor specific. */
1316 resolve_unknown_s (gfc_code
* c
)
1320 sym
= c
->symtree
->n
.sym
;
1322 if (sym
->attr
.dummy
)
1324 sym
->attr
.proc
= PROC_DUMMY
;
1328 /* See if we have an intrinsic function reference. */
1330 if (gfc_intrinsic_name (sym
->name
, 1))
1332 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1337 /* The reference is to an external name. */
1340 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1342 c
->resolved_sym
= sym
;
1344 pure_subroutine (c
, sym
);
1350 /* Resolve a subroutine call. Although it was tempting to use the same code
1351 for functions, subroutines and functions are stored differently and this
1352 makes things awkward. */
1355 resolve_call (gfc_code
* c
)
1359 if (resolve_actual_arglist (c
->ext
.actual
) == FAILURE
)
1362 if (c
->resolved_sym
!= NULL
)
1365 switch (procedure_kind (c
->symtree
->n
.sym
))
1368 t
= resolve_generic_s (c
);
1371 case PTYPE_SPECIFIC
:
1372 t
= resolve_specific_s (c
);
1376 t
= resolve_unknown_s (c
);
1380 gfc_internal_error ("resolve_subroutine(): bad function type");
1386 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1387 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1388 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1389 if their shapes do not match. If either op1->shape or op2->shape is
1390 NULL, return SUCCESS. */
1393 compare_shapes (gfc_expr
* op1
, gfc_expr
* op2
)
1400 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
1402 for (i
= 0; i
< op1
->rank
; i
++)
1404 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
1406 gfc_error ("Shapes for operands at %L and %L are not conformable",
1407 &op1
->where
, &op2
->where
);
1417 /* Resolve an operator expression node. This can involve replacing the
1418 operation with a user defined function call. */
1421 resolve_operator (gfc_expr
* e
)
1423 gfc_expr
*op1
, *op2
;
1427 /* Resolve all subnodes-- give them types. */
1429 switch (e
->value
.op
.operator)
1432 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
1435 /* Fall through... */
1438 case INTRINSIC_UPLUS
:
1439 case INTRINSIC_UMINUS
:
1440 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
1445 /* Typecheck the new node. */
1447 op1
= e
->value
.op
.op1
;
1448 op2
= e
->value
.op
.op2
;
1450 switch (e
->value
.op
.operator)
1452 case INTRINSIC_UPLUS
:
1453 case INTRINSIC_UMINUS
:
1454 if (op1
->ts
.type
== BT_INTEGER
1455 || op1
->ts
.type
== BT_REAL
1456 || op1
->ts
.type
== BT_COMPLEX
)
1462 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
1463 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
1466 case INTRINSIC_PLUS
:
1467 case INTRINSIC_MINUS
:
1468 case INTRINSIC_TIMES
:
1469 case INTRINSIC_DIVIDE
:
1470 case INTRINSIC_POWER
:
1471 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1473 gfc_type_convert_binary (e
);
1478 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1479 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1480 gfc_typename (&op2
->ts
));
1483 case INTRINSIC_CONCAT
:
1484 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1486 e
->ts
.type
= BT_CHARACTER
;
1487 e
->ts
.kind
= op1
->ts
.kind
;
1492 _("Operands of string concatenation operator at %%L are %s/%s"),
1493 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
1499 case INTRINSIC_NEQV
:
1500 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
1502 e
->ts
.type
= BT_LOGICAL
;
1503 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
1504 if (op1
->ts
.kind
< e
->ts
.kind
)
1505 gfc_convert_type (op1
, &e
->ts
, 2);
1506 else if (op2
->ts
.kind
< e
->ts
.kind
)
1507 gfc_convert_type (op2
, &e
->ts
, 2);
1511 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
1512 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1513 gfc_typename (&op2
->ts
));
1518 if (op1
->ts
.type
== BT_LOGICAL
)
1520 e
->ts
.type
= BT_LOGICAL
;
1521 e
->ts
.kind
= op1
->ts
.kind
;
1525 sprintf (msg
, _("Operand of .NOT. operator at %%L is %s"),
1526 gfc_typename (&op1
->ts
));
1533 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1535 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
1539 /* Fall through... */
1543 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1545 e
->ts
.type
= BT_LOGICAL
;
1546 e
->ts
.kind
= gfc_default_logical_kind
;
1550 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1552 gfc_type_convert_binary (e
);
1554 e
->ts
.type
= BT_LOGICAL
;
1555 e
->ts
.kind
= gfc_default_logical_kind
;
1559 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
1561 _("Logicals at %%L must be compared with %s instead of %s"),
1562 e
->value
.op
.operator == INTRINSIC_EQ
? ".EQV." : ".NEQV.",
1563 gfc_op2string (e
->value
.op
.operator));
1566 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1567 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1568 gfc_typename (&op2
->ts
));
1572 case INTRINSIC_USER
:
1574 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
1575 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
1577 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
1578 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
1579 gfc_typename (&op2
->ts
));
1584 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1587 /* Deal with arrayness of an operand through an operator. */
1591 switch (e
->value
.op
.operator)
1593 case INTRINSIC_PLUS
:
1594 case INTRINSIC_MINUS
:
1595 case INTRINSIC_TIMES
:
1596 case INTRINSIC_DIVIDE
:
1597 case INTRINSIC_POWER
:
1598 case INTRINSIC_CONCAT
:
1602 case INTRINSIC_NEQV
:
1610 if (op1
->rank
== 0 && op2
->rank
== 0)
1613 if (op1
->rank
== 0 && op2
->rank
!= 0)
1615 e
->rank
= op2
->rank
;
1617 if (e
->shape
== NULL
)
1618 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1621 if (op1
->rank
!= 0 && op2
->rank
== 0)
1623 e
->rank
= op1
->rank
;
1625 if (e
->shape
== NULL
)
1626 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1629 if (op1
->rank
!= 0 && op2
->rank
!= 0)
1631 if (op1
->rank
== op2
->rank
)
1633 e
->rank
= op1
->rank
;
1634 if (e
->shape
== NULL
)
1636 t
= compare_shapes(op1
, op2
);
1640 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1645 gfc_error ("Inconsistent ranks for operator at %L and %L",
1646 &op1
->where
, &op2
->where
);
1649 /* Allow higher level expressions to work. */
1657 case INTRINSIC_UPLUS
:
1658 case INTRINSIC_UMINUS
:
1659 e
->rank
= op1
->rank
;
1661 if (e
->shape
== NULL
)
1662 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1664 /* Simply copy arrayness attribute */
1671 /* Attempt to simplify the expression. */
1673 t
= gfc_simplify_expr (e
, 0);
1678 if (gfc_extend_expr (e
) == SUCCESS
)
1681 gfc_error (msg
, &e
->where
);
1687 /************** Array resolution subroutines **************/
1691 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
1694 /* Compare two integer expressions. */
1697 compare_bound (gfc_expr
* a
, gfc_expr
* b
)
1701 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
1702 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
1705 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
1706 gfc_internal_error ("compare_bound(): Bad expression");
1708 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
1718 /* Compare an integer expression with an integer. */
1721 compare_bound_int (gfc_expr
* a
, int b
)
1725 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
1728 if (a
->ts
.type
!= BT_INTEGER
)
1729 gfc_internal_error ("compare_bound_int(): Bad expression");
1731 i
= mpz_cmp_si (a
->value
.integer
, b
);
1741 /* Compare a single dimension of an array reference to the array
1745 check_dimension (int i
, gfc_array_ref
* ar
, gfc_array_spec
* as
)
1748 /* Given start, end and stride values, calculate the minimum and
1749 maximum referenced indexes. */
1757 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1759 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1765 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
1767 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
1771 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1773 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1776 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1777 it is legal (see 6.2.2.3.1). */
1782 gfc_internal_error ("check_dimension(): Bad array reference");
1788 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
1793 /* Compare an array reference with an array specification. */
1796 compare_spec_to_ref (gfc_array_ref
* ar
)
1803 /* TODO: Full array sections are only allowed as actual parameters. */
1804 if (as
->type
== AS_ASSUMED_SIZE
1805 && (/*ar->type == AR_FULL
1806 ||*/ (ar
->type
== AR_SECTION
1807 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
1809 gfc_error ("Rightmost upper bound of assumed size array section"
1810 " not specified at %L", &ar
->where
);
1814 if (ar
->type
== AR_FULL
)
1817 if (as
->rank
!= ar
->dimen
)
1819 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1820 &ar
->where
, ar
->dimen
, as
->rank
);
1824 for (i
= 0; i
< as
->rank
; i
++)
1825 if (check_dimension (i
, ar
, as
) == FAILURE
)
1832 /* Resolve one part of an array index. */
1835 gfc_resolve_index (gfc_expr
* index
, int check_scalar
)
1842 if (gfc_resolve_expr (index
) == FAILURE
)
1845 if (check_scalar
&& index
->rank
!= 0)
1847 gfc_error ("Array index at %L must be scalar", &index
->where
);
1851 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
1853 gfc_error ("Array index at %L must be of INTEGER type",
1858 if (index
->ts
.type
== BT_REAL
)
1859 if (gfc_notify_std (GFC_STD_GNU
, "Extension: REAL array index at %L",
1860 &index
->where
) == FAILURE
)
1863 if (index
->ts
.kind
!= gfc_index_integer_kind
1864 || index
->ts
.type
!= BT_INTEGER
)
1866 ts
.type
= BT_INTEGER
;
1867 ts
.kind
= gfc_index_integer_kind
;
1869 gfc_convert_type_warn (index
, &ts
, 2, 0);
1875 /* Resolve a dim argument to an intrinsic function. */
1878 gfc_resolve_dim_arg (gfc_expr
*dim
)
1883 if (gfc_resolve_expr (dim
) == FAILURE
)
1888 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
1892 if (dim
->ts
.type
!= BT_INTEGER
)
1894 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
1897 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
1901 ts
.type
= BT_INTEGER
;
1902 ts
.kind
= gfc_index_integer_kind
;
1904 gfc_convert_type_warn (dim
, &ts
, 2, 0);
1910 /* Given an expression that contains array references, update those array
1911 references to point to the right array specifications. While this is
1912 filled in during matching, this information is difficult to save and load
1913 in a module, so we take care of it here.
1915 The idea here is that the original array reference comes from the
1916 base symbol. We traverse the list of reference structures, setting
1917 the stored reference to references. Component references can
1918 provide an additional array specification. */
1921 find_array_spec (gfc_expr
* e
)
1927 as
= e
->symtree
->n
.sym
->as
;
1929 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1934 gfc_internal_error ("find_array_spec(): Missing spec");
1941 for (c
= e
->symtree
->n
.sym
->ts
.derived
->components
; c
; c
= c
->next
)
1942 if (c
== ref
->u
.c
.component
)
1946 gfc_internal_error ("find_array_spec(): Component not found");
1951 gfc_internal_error ("find_array_spec(): unused as(1)");
1962 gfc_internal_error ("find_array_spec(): unused as(2)");
1966 /* Resolve an array reference. */
1969 resolve_array_ref (gfc_array_ref
* ar
)
1971 int i
, check_scalar
;
1973 for (i
= 0; i
< ar
->dimen
; i
++)
1975 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
1977 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
1979 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
1981 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
1984 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
1985 switch (ar
->start
[i
]->rank
)
1988 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
1992 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
1996 gfc_error ("Array index at %L is an array of rank %d",
1997 &ar
->c_where
[i
], ar
->start
[i
]->rank
);
2002 /* If the reference type is unknown, figure out what kind it is. */
2004 if (ar
->type
== AR_UNKNOWN
)
2006 ar
->type
= AR_ELEMENT
;
2007 for (i
= 0; i
< ar
->dimen
; i
++)
2008 if (ar
->dimen_type
[i
] == DIMEN_RANGE
2009 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2011 ar
->type
= AR_SECTION
;
2016 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
2024 resolve_substring (gfc_ref
* ref
)
2027 if (ref
->u
.ss
.start
!= NULL
)
2029 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
2032 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
2034 gfc_error ("Substring start index at %L must be of type INTEGER",
2035 &ref
->u
.ss
.start
->where
);
2039 if (ref
->u
.ss
.start
->rank
!= 0)
2041 gfc_error ("Substring start index at %L must be scalar",
2042 &ref
->u
.ss
.start
->where
);
2046 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
)
2048 gfc_error ("Substring start index at %L is less than one",
2049 &ref
->u
.ss
.start
->where
);
2054 if (ref
->u
.ss
.end
!= NULL
)
2056 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
2059 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
2061 gfc_error ("Substring end index at %L must be of type INTEGER",
2062 &ref
->u
.ss
.end
->where
);
2066 if (ref
->u
.ss
.end
->rank
!= 0)
2068 gfc_error ("Substring end index at %L must be scalar",
2069 &ref
->u
.ss
.end
->where
);
2073 if (ref
->u
.ss
.length
!= NULL
2074 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
)
2076 gfc_error ("Substring end index at %L is out of bounds",
2077 &ref
->u
.ss
.start
->where
);
2086 /* Resolve subtype references. */
2089 resolve_ref (gfc_expr
* expr
)
2091 int current_part_dimension
, n_components
, seen_part_dimension
;
2094 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2095 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
2097 find_array_spec (expr
);
2101 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2105 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
2113 resolve_substring (ref
);
2117 /* Check constraints on part references. */
2119 current_part_dimension
= 0;
2120 seen_part_dimension
= 0;
2123 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2128 switch (ref
->u
.ar
.type
)
2132 current_part_dimension
= 1;
2136 current_part_dimension
= 0;
2140 gfc_internal_error ("resolve_ref(): Bad array reference");
2146 if ((current_part_dimension
|| seen_part_dimension
)
2147 && ref
->u
.c
.component
->pointer
)
2150 ("Component to the right of a part reference with nonzero "
2151 "rank must not have the POINTER attribute at %L",
2163 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
2164 || ref
->next
== NULL
)
2165 && current_part_dimension
2166 && seen_part_dimension
)
2169 gfc_error ("Two or more part references with nonzero rank must "
2170 "not be specified at %L", &expr
->where
);
2174 if (ref
->type
== REF_COMPONENT
)
2176 if (current_part_dimension
)
2177 seen_part_dimension
= 1;
2179 /* reset to make sure */
2180 current_part_dimension
= 0;
2188 /* Given an expression, determine its shape. This is easier than it sounds.
2189 Leaves the shape array NULL if it is not possible to determine the shape. */
2192 expression_shape (gfc_expr
* e
)
2194 mpz_t array
[GFC_MAX_DIMENSIONS
];
2197 if (e
->rank
== 0 || e
->shape
!= NULL
)
2200 for (i
= 0; i
< e
->rank
; i
++)
2201 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2204 e
->shape
= gfc_get_shape (e
->rank
);
2206 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
2211 for (i
--; i
>= 0; i
--)
2212 mpz_clear (array
[i
]);
2216 /* Given a variable expression node, compute the rank of the expression by
2217 examining the base symbol and any reference structures it may have. */
2220 expression_rank (gfc_expr
* e
)
2227 if (e
->expr_type
== EXPR_ARRAY
)
2229 /* Constructors can have a rank different from one via RESHAPE(). */
2231 if (e
->symtree
== NULL
)
2237 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
2238 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
2244 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2246 if (ref
->type
!= REF_ARRAY
)
2249 if (ref
->u
.ar
.type
== AR_FULL
)
2251 rank
= ref
->u
.ar
.as
->rank
;
2255 if (ref
->u
.ar
.type
== AR_SECTION
)
2257 /* Figure out the rank of the section. */
2259 gfc_internal_error ("expression_rank(): Two array specs");
2261 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2262 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
2263 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2273 expression_shape (e
);
2277 /* Resolve a variable expression. */
2280 resolve_variable (gfc_expr
* e
)
2284 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
2287 if (e
->symtree
== NULL
)
2290 sym
= e
->symtree
->n
.sym
;
2291 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2293 e
->ts
.type
= BT_PROCEDURE
;
2297 if (sym
->ts
.type
!= BT_UNKNOWN
)
2298 gfc_variable_attr (e
, &e
->ts
);
2301 /* Must be a simple variable reference. */
2302 if (gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2311 /* Resolve an expression. That is, make sure that types of operands agree
2312 with their operators, intrinsic operators are converted to function calls
2313 for overloaded types and unresolved function references are resolved. */
2316 gfc_resolve_expr (gfc_expr
* e
)
2323 switch (e
->expr_type
)
2326 t
= resolve_operator (e
);
2330 t
= resolve_function (e
);
2334 t
= resolve_variable (e
);
2336 expression_rank (e
);
2339 case EXPR_SUBSTRING
:
2340 t
= resolve_ref (e
);
2350 if (resolve_ref (e
) == FAILURE
)
2353 t
= gfc_resolve_array_constructor (e
);
2354 /* Also try to expand a constructor. */
2357 expression_rank (e
);
2358 gfc_expand_constructor (e
);
2363 case EXPR_STRUCTURE
:
2364 t
= resolve_ref (e
);
2368 t
= resolve_structure_cons (e
);
2372 t
= gfc_simplify_expr (e
, 0);
2376 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2383 /* Resolve an expression from an iterator. They must be scalar and have
2384 INTEGER or (optionally) REAL type. */
2387 gfc_resolve_iterator_expr (gfc_expr
* expr
, bool real_ok
,
2388 const char * name_msgid
)
2390 if (gfc_resolve_expr (expr
) == FAILURE
)
2393 if (expr
->rank
!= 0)
2395 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
2399 if (!(expr
->ts
.type
== BT_INTEGER
2400 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
2403 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid
),
2406 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
2413 /* Resolve the expressions in an iterator structure. If REAL_OK is
2414 false allow only INTEGER type iterators, otherwise allow REAL types. */
2417 gfc_resolve_iterator (gfc_iterator
* iter
, bool real_ok
)
2420 if (iter
->var
->ts
.type
== BT_REAL
)
2421 gfc_notify_std (GFC_STD_F95_DEL
,
2422 "Obsolete: REAL DO loop iterator at %L",
2425 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
2429 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
2431 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2436 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
2437 "Start expression in DO loop") == FAILURE
)
2440 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
2441 "End expression in DO loop") == FAILURE
)
2444 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
2445 "Step expression in DO loop") == FAILURE
)
2448 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
2450 if ((iter
->step
->ts
.type
== BT_INTEGER
2451 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
2452 || (iter
->step
->ts
.type
== BT_REAL
2453 && mpfr_sgn (iter
->step
->value
.real
) == 0))
2455 gfc_error ("Step expression in DO loop at %L cannot be zero",
2456 &iter
->step
->where
);
2461 /* Convert start, end, and step to the same type as var. */
2462 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
2463 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
2464 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2466 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
2467 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
2468 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2470 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
2471 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
2472 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
2478 /* Resolve a list of FORALL iterators. */
2481 resolve_forall_iterators (gfc_forall_iterator
* iter
)
2486 if (gfc_resolve_expr (iter
->var
) == SUCCESS
2487 && iter
->var
->ts
.type
!= BT_INTEGER
)
2488 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2491 if (gfc_resolve_expr (iter
->start
) == SUCCESS
2492 && iter
->start
->ts
.type
!= BT_INTEGER
)
2493 gfc_error ("FORALL start expression at %L must be INTEGER",
2494 &iter
->start
->where
);
2495 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
2496 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2498 if (gfc_resolve_expr (iter
->end
) == SUCCESS
2499 && iter
->end
->ts
.type
!= BT_INTEGER
)
2500 gfc_error ("FORALL end expression at %L must be INTEGER",
2502 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
2503 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2505 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
2506 && iter
->stride
->ts
.type
!= BT_INTEGER
)
2507 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2508 &iter
->stride
->where
);
2509 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
2510 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
2517 /* Given a pointer to a symbol that is a derived type, see if any components
2518 have the POINTER attribute. The search is recursive if necessary.
2519 Returns zero if no pointer components are found, nonzero otherwise. */
2522 derived_pointer (gfc_symbol
* sym
)
2526 for (c
= sym
->components
; c
; c
= c
->next
)
2531 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
2539 /* Given a pointer to a symbol that is a derived type, see if it's
2540 inaccessible, i.e. if it's defined in another module and the components are
2541 PRIVATE. The search is recursive if necessary. Returns zero if no
2542 inaccessible components are found, nonzero otherwise. */
2545 derived_inaccessible (gfc_symbol
*sym
)
2549 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
2552 for (c
= sym
->components
; c
; c
= c
->next
)
2554 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
2562 /* Resolve the argument of a deallocate expression. The expression must be
2563 a pointer or a full array. */
2566 resolve_deallocate_expr (gfc_expr
* e
)
2568 symbol_attribute attr
;
2572 if (gfc_resolve_expr (e
) == FAILURE
)
2575 attr
= gfc_expr_attr (e
);
2579 if (e
->expr_type
!= EXPR_VARIABLE
)
2582 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2583 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2587 if (ref
->u
.ar
.type
!= AR_FULL
)
2592 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2593 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2601 if (allocatable
== 0)
2604 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2605 "ALLOCATABLE or a POINTER", &e
->where
);
2612 /* Given the expression node e for an allocatable/pointer of derived type to be
2613 allocated, get the expression node to be initialized afterwards (needed for
2614 derived types with default initializers). */
2617 expr_to_initialize (gfc_expr
* e
)
2623 result
= gfc_copy_expr (e
);
2625 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
2626 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
2627 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
2629 ref
->u
.ar
.type
= AR_FULL
;
2631 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2632 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
2634 result
->rank
= ref
->u
.ar
.dimen
;
2642 /* Resolve the expression in an ALLOCATE statement, doing the additional
2643 checks to see whether the expression is OK or not. The expression must
2644 have a trailing array reference that gives the size of the array. */
2647 resolve_allocate_expr (gfc_expr
* e
, gfc_code
* code
)
2649 int i
, pointer
, allocatable
, dimension
;
2650 symbol_attribute attr
;
2651 gfc_ref
*ref
, *ref2
;
2656 if (gfc_resolve_expr (e
) == FAILURE
)
2659 /* Make sure the expression is allocatable or a pointer. If it is
2660 pointer, the next-to-last reference must be a pointer. */
2664 if (e
->expr_type
!= EXPR_VARIABLE
)
2668 attr
= gfc_expr_attr (e
);
2669 pointer
= attr
.pointer
;
2670 dimension
= attr
.dimension
;
2675 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2676 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
2677 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
2679 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
2683 if (ref
->next
!= NULL
)
2688 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2689 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2691 pointer
= ref
->u
.c
.component
->pointer
;
2692 dimension
= ref
->u
.c
.component
->dimension
;
2702 if (allocatable
== 0 && pointer
== 0)
2704 gfc_error ("Expression in ALLOCATE statement at %L must be "
2705 "ALLOCATABLE or a POINTER", &e
->where
);
2709 /* Add default initializer for those derived types that need them. */
2710 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
2712 init_st
= gfc_get_code ();
2713 init_st
->loc
= code
->loc
;
2714 init_st
->op
= EXEC_ASSIGN
;
2715 init_st
->expr
= expr_to_initialize (e
);
2716 init_st
->expr2
= init_e
;
2718 init_st
->next
= code
->next
;
2719 code
->next
= init_st
;
2722 if (pointer
&& dimension
== 0)
2725 /* Make sure the next-to-last reference node is an array specification. */
2727 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
2729 gfc_error ("Array specification required in ALLOCATE statement "
2730 "at %L", &e
->where
);
2734 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
2737 /* Make sure that the array section reference makes sense in the
2738 context of an ALLOCATE specification. */
2742 for (i
= 0; i
< ar
->dimen
; i
++)
2743 switch (ar
->dimen_type
[i
])
2749 if (ar
->start
[i
] != NULL
2750 && ar
->end
[i
] != NULL
2751 && ar
->stride
[i
] == NULL
)
2754 /* Fall Through... */
2758 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2767 /************ SELECT CASE resolution subroutines ************/
2769 /* Callback function for our mergesort variant. Determines interval
2770 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2771 op1 > op2. Assumes we're not dealing with the default case.
2772 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2773 There are nine situations to check. */
2776 compare_cases (const gfc_case
* op1
, const gfc_case
* op2
)
2780 if (op1
->low
== NULL
) /* op1 = (:L) */
2782 /* op2 = (:N), so overlap. */
2784 /* op2 = (M:) or (M:N), L < M */
2785 if (op2
->low
!= NULL
2786 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2789 else if (op1
->high
== NULL
) /* op1 = (K:) */
2791 /* op2 = (M:), so overlap. */
2793 /* op2 = (:N) or (M:N), K > N */
2794 if (op2
->high
!= NULL
2795 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2798 else /* op1 = (K:L) */
2800 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
2801 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
2802 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
2803 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
2804 else /* op2 = (M:N) */
2808 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2811 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2820 /* Merge-sort a double linked case list, detecting overlap in the
2821 process. LIST is the head of the double linked case list before it
2822 is sorted. Returns the head of the sorted list if we don't see any
2823 overlap, or NULL otherwise. */
2826 check_case_overlap (gfc_case
* list
)
2828 gfc_case
*p
, *q
, *e
, *tail
;
2829 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
2831 /* If the passed list was empty, return immediately. */
2838 /* Loop unconditionally. The only exit from this loop is a return
2839 statement, when we've finished sorting the case list. */
2846 /* Count the number of merges we do in this pass. */
2849 /* Loop while there exists a merge to be done. */
2854 /* Count this merge. */
2857 /* Cut the list in two pieces by stepping INSIZE places
2858 forward in the list, starting from P. */
2861 for (i
= 0; i
< insize
; i
++)
2870 /* Now we have two lists. Merge them! */
2871 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
2874 /* See from which the next case to merge comes from. */
2877 /* P is empty so the next case must come from Q. */
2882 else if (qsize
== 0 || q
== NULL
)
2891 cmp
= compare_cases (p
, q
);
2894 /* The whole case range for P is less than the
2902 /* The whole case range for Q is greater than
2903 the case range for P. */
2910 /* The cases overlap, or they are the same
2911 element in the list. Either way, we must
2912 issue an error and get the next case from P. */
2913 /* FIXME: Sort P and Q by line number. */
2914 gfc_error ("CASE label at %L overlaps with CASE "
2915 "label at %L", &p
->where
, &q
->where
);
2923 /* Add the next element to the merged list. */
2932 /* P has now stepped INSIZE places along, and so has Q. So
2933 they're the same. */
2938 /* If we have done only one merge or none at all, we've
2939 finished sorting the cases. */
2948 /* Otherwise repeat, merging lists twice the size. */
2954 /* Check to see if an expression is suitable for use in a CASE statement.
2955 Makes sure that all case expressions are scalar constants of the same
2956 type. Return FAILURE if anything is wrong. */
2959 validate_case_label_expr (gfc_expr
* e
, gfc_expr
* case_expr
)
2961 if (e
== NULL
) return SUCCESS
;
2963 if (e
->ts
.type
!= case_expr
->ts
.type
)
2965 gfc_error ("Expression in CASE statement at %L must be of type %s",
2966 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
2970 /* C805 (R808) For a given case-construct, each case-value shall be of
2971 the same type as case-expr. For character type, length differences
2972 are allowed, but the kind type parameters shall be the same. */
2974 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
2976 gfc_error("Expression in CASE statement at %L must be kind %d",
2977 &e
->where
, case_expr
->ts
.kind
);
2981 /* Convert the case value kind to that of case expression kind, if needed.
2982 FIXME: Should a warning be issued? */
2983 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
2984 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
2988 gfc_error ("Expression in CASE statement at %L must be scalar",
2997 /* Given a completely parsed select statement, we:
2999 - Validate all expressions and code within the SELECT.
3000 - Make sure that the selection expression is not of the wrong type.
3001 - Make sure that no case ranges overlap.
3002 - Eliminate unreachable cases and unreachable code resulting from
3003 removing case labels.
3005 The standard does allow unreachable cases, e.g. CASE (5:3). But
3006 they are a hassle for code generation, and to prevent that, we just
3007 cut them out here. This is not necessary for overlapping cases
3008 because they are illegal and we never even try to generate code.
3010 We have the additional caveat that a SELECT construct could have
3011 been a computed GOTO in the source code. Fortunately we can fairly
3012 easily work around that here: The case_expr for a "real" SELECT CASE
3013 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3014 we have to do is make sure that the case_expr is a scalar integer
3018 resolve_select (gfc_code
* code
)
3021 gfc_expr
*case_expr
;
3022 gfc_case
*cp
, *default_case
, *tail
, *head
;
3023 int seen_unreachable
;
3028 if (code
->expr
== NULL
)
3030 /* This was actually a computed GOTO statement. */
3031 case_expr
= code
->expr2
;
3032 if (case_expr
->ts
.type
!= BT_INTEGER
3033 || case_expr
->rank
!= 0)
3034 gfc_error ("Selection expression in computed GOTO statement "
3035 "at %L must be a scalar integer expression",
3038 /* Further checking is not necessary because this SELECT was built
3039 by the compiler, so it should always be OK. Just move the
3040 case_expr from expr2 to expr so that we can handle computed
3041 GOTOs as normal SELECTs from here on. */
3042 code
->expr
= code
->expr2
;
3047 case_expr
= code
->expr
;
3049 type
= case_expr
->ts
.type
;
3050 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
3052 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3053 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
3055 /* Punt. Going on here just produce more garbage error messages. */
3059 if (case_expr
->rank
!= 0)
3061 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3062 "expression", &case_expr
->where
);
3068 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3069 of the SELECT CASE expression and its CASE values. Walk the lists
3070 of case values, and if we find a mismatch, promote case_expr to
3071 the appropriate kind. */
3073 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
3075 for (body
= code
->block
; body
; body
= body
->block
)
3077 /* Walk the case label list. */
3078 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
3080 /* Intercept the DEFAULT case. It does not have a kind. */
3081 if (cp
->low
== NULL
&& cp
->high
== NULL
)
3084 /* Unreachable case ranges are discarded, so ignore. */
3085 if (cp
->low
!= NULL
&& cp
->high
!= NULL
3086 && cp
->low
!= cp
->high
3087 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
3090 /* FIXME: Should a warning be issued? */
3092 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
3093 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
3095 if (cp
->high
!= NULL
3096 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
3097 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
3102 /* Assume there is no DEFAULT case. */
3103 default_case
= NULL
;
3107 for (body
= code
->block
; body
; body
= body
->block
)
3109 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3111 seen_unreachable
= 0;
3113 /* Walk the case label list, making sure that all case labels
3115 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
3117 /* Count the number of cases in the whole construct. */
3120 /* Intercept the DEFAULT case. */
3121 if (cp
->low
== NULL
&& cp
->high
== NULL
)
3123 if (default_case
!= NULL
)
3125 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3126 "by a second DEFAULT CASE at %L",
3127 &default_case
->where
, &cp
->where
);
3138 /* Deal with single value cases and case ranges. Errors are
3139 issued from the validation function. */
3140 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
3141 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
3147 if (type
== BT_LOGICAL
3148 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
3149 || cp
->low
!= cp
->high
))
3152 ("Logical range in CASE statement at %L is not allowed",
3158 if (cp
->low
!= NULL
&& cp
->high
!= NULL
3159 && cp
->low
!= cp
->high
3160 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
3162 if (gfc_option
.warn_surprising
)
3163 gfc_warning ("Range specification at %L can never "
3164 "be matched", &cp
->where
);
3166 cp
->unreachable
= 1;
3167 seen_unreachable
= 1;
3171 /* If the case range can be matched, it can also overlap with
3172 other cases. To make sure it does not, we put it in a
3173 double linked list here. We sort that with a merge sort
3174 later on to detect any overlapping cases. */
3178 head
->right
= head
->left
= NULL
;
3183 tail
->right
->left
= tail
;
3190 /* It there was a failure in the previous case label, give up
3191 for this case label list. Continue with the next block. */
3195 /* See if any case labels that are unreachable have been seen.
3196 If so, we eliminate them. This is a bit of a kludge because
3197 the case lists for a single case statement (label) is a
3198 single forward linked lists. */
3199 if (seen_unreachable
)
3201 /* Advance until the first case in the list is reachable. */
3202 while (body
->ext
.case_list
!= NULL
3203 && body
->ext
.case_list
->unreachable
)
3205 gfc_case
*n
= body
->ext
.case_list
;
3206 body
->ext
.case_list
= body
->ext
.case_list
->next
;
3208 gfc_free_case_list (n
);
3211 /* Strip all other unreachable cases. */
3212 if (body
->ext
.case_list
)
3214 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
3216 if (cp
->next
->unreachable
)
3218 gfc_case
*n
= cp
->next
;
3219 cp
->next
= cp
->next
->next
;
3221 gfc_free_case_list (n
);
3228 /* See if there were overlapping cases. If the check returns NULL,
3229 there was overlap. In that case we don't do anything. If head
3230 is non-NULL, we prepend the DEFAULT case. The sorted list can
3231 then used during code generation for SELECT CASE constructs with
3232 a case expression of a CHARACTER type. */
3235 head
= check_case_overlap (head
);
3237 /* Prepend the default_case if it is there. */
3238 if (head
!= NULL
&& default_case
)
3240 default_case
->left
= NULL
;
3241 default_case
->right
= head
;
3242 head
->left
= default_case
;
3246 /* Eliminate dead blocks that may be the result if we've seen
3247 unreachable case labels for a block. */
3248 for (body
= code
; body
&& body
->block
; body
= body
->block
)
3250 if (body
->block
->ext
.case_list
== NULL
)
3252 /* Cut the unreachable block from the code chain. */
3253 gfc_code
*c
= body
->block
;
3254 body
->block
= c
->block
;
3256 /* Kill the dead block, but not the blocks below it. */
3258 gfc_free_statements (c
);
3262 /* More than two cases is legal but insane for logical selects.
3263 Issue a warning for it. */
3264 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
3266 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3271 /* Resolve a transfer statement. This is making sure that:
3272 -- a derived type being transferred has only non-pointer components
3273 -- a derived type being transferred doesn't have private components, unless
3274 it's being transferred from the module where the type was defined
3275 -- we're not trying to transfer a whole assumed size array. */
3278 resolve_transfer (gfc_code
* code
)
3287 if (exp
->expr_type
!= EXPR_VARIABLE
)
3290 sym
= exp
->symtree
->n
.sym
;
3293 /* Go to actual component transferred. */
3294 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
3295 if (ref
->type
== REF_COMPONENT
)
3296 ts
= &ref
->u
.c
.component
->ts
;
3298 if (ts
->type
== BT_DERIVED
)
3300 /* Check that transferred derived type doesn't contain POINTER
3302 if (derived_pointer (ts
->derived
))
3304 gfc_error ("Data transfer element at %L cannot have "
3305 "POINTER components", &code
->loc
);
3309 if (derived_inaccessible (ts
->derived
))
3311 gfc_error ("Data transfer element at %L cannot have "
3312 "PRIVATE components",&code
->loc
);
3317 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
3318 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
3320 gfc_error ("Data transfer element at %L cannot be a full reference to "
3321 "an assumed-size array", &code
->loc
);
3327 /*********** Toplevel code resolution subroutines ***********/
3329 /* Given a branch to a label and a namespace, if the branch is conforming.
3330 The code node described where the branch is located. */
3333 resolve_branch (gfc_st_label
* label
, gfc_code
* code
)
3335 gfc_code
*block
, *found
;
3343 /* Step one: is this a valid branching target? */
3345 if (lp
->defined
== ST_LABEL_UNKNOWN
)
3347 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
3352 if (lp
->defined
!= ST_LABEL_TARGET
)
3354 gfc_error ("Statement at %L is not a valid branch target statement "
3355 "for the branch statement at %L", &lp
->where
, &code
->loc
);
3359 /* Step two: make sure this branch is not a branch to itself ;-) */
3361 if (code
->here
== label
)
3363 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
3367 /* Step three: Try to find the label in the parse tree. To do this,
3368 we traverse the tree block-by-block: first the block that
3369 contains this GOTO, then the block that it is nested in, etc. We
3370 can ignore other blocks because branching into another block is
3375 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3377 for (block
= stack
->head
; block
; block
= block
->next
)
3379 if (block
->here
== label
)
3392 /* still nothing, so illegal. */
3393 gfc_error_now ("Label at %L is not in the same block as the "
3394 "GOTO statement at %L", &lp
->where
, &code
->loc
);
3398 /* Step four: Make sure that the branching target is legal if
3399 the statement is an END {SELECT,DO,IF}. */
3401 if (found
->op
== EXEC_NOP
)
3403 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3404 if (stack
->current
->next
== found
)
3408 gfc_notify_std (GFC_STD_F95_DEL
,
3409 "Obsolete: GOTO at %L jumps to END of construct at %L",
3410 &code
->loc
, &found
->loc
);
3415 /* Check whether EXPR1 has the same shape as EXPR2. */
3418 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
3420 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3421 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
3422 try result
= FAILURE
;
3425 /* Compare the rank. */
3426 if (expr1
->rank
!= expr2
->rank
)
3429 /* Compare the size of each dimension. */
3430 for (i
=0; i
<expr1
->rank
; i
++)
3432 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
3435 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
3438 if (mpz_cmp (shape
[i
], shape2
[i
]))
3442 /* When either of the two expression is an assumed size array, we
3443 ignore the comparison of dimension sizes. */
3448 for (i
--; i
>=0; i
--)
3450 mpz_clear (shape
[i
]);
3451 mpz_clear (shape2
[i
]);
3457 /* Check whether a WHERE assignment target or a WHERE mask expression
3458 has the same shape as the outmost WHERE mask expression. */
3461 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
3467 cblock
= code
->block
;
3469 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3470 In case of nested WHERE, only the outmost one is stored. */
3471 if (mask
== NULL
) /* outmost WHERE */
3473 else /* inner WHERE */
3480 /* Check if the mask-expr has a consistent shape with the
3481 outmost WHERE mask-expr. */
3482 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
3483 gfc_error ("WHERE mask at %L has inconsistent shape",
3484 &cblock
->expr
->where
);
3487 /* the assignment statement of a WHERE statement, or the first
3488 statement in where-body-construct of a WHERE construct */
3489 cnext
= cblock
->next
;
3494 /* WHERE assignment statement */
3497 /* Check shape consistent for WHERE assignment target. */
3498 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
3499 gfc_error ("WHERE assignment target at %L has "
3500 "inconsistent shape", &cnext
->expr
->where
);
3503 /* WHERE or WHERE construct is part of a where-body-construct */
3505 resolve_where (cnext
, e
);
3509 gfc_error ("Unsupported statement inside WHERE at %L",
3512 /* the next statement within the same where-body-construct */
3513 cnext
= cnext
->next
;
3515 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3516 cblock
= cblock
->block
;
3521 /* Check whether the FORALL index appears in the expression or not. */
3524 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
3528 gfc_actual_arglist
*args
;
3531 switch (expr
->expr_type
)
3534 gcc_assert (expr
->symtree
->n
.sym
);
3536 /* A scalar assignment */
3539 if (expr
->symtree
->n
.sym
== symbol
)
3545 /* the expr is array ref, substring or struct component. */
3552 /* Check if the symbol appears in the array subscript. */
3554 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3557 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
3561 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
3565 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
3571 if (expr
->symtree
->n
.sym
== symbol
)
3574 /* Check if the symbol appears in the substring section. */
3575 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3577 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3585 gfc_error("expresion reference type error at %L", &expr
->where
);
3591 /* If the expression is a function call, then check if the symbol
3592 appears in the actual arglist of the function. */
3594 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3596 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
3601 /* It seems not to happen. */
3602 case EXPR_SUBSTRING
:
3606 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
3607 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3609 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3614 /* It seems not to happen. */
3615 case EXPR_STRUCTURE
:
3617 gfc_error ("Unsupported statement while finding forall index in "
3622 /* Find the FORALL index in the first operand. */
3623 if (expr
->value
.op
.op1
)
3625 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
3629 /* Find the FORALL index in the second operand. */
3630 if (expr
->value
.op
.op2
)
3632 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
3645 /* Resolve assignment in FORALL construct.
3646 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3647 FORALL index variables. */
3650 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3654 for (n
= 0; n
< nvar
; n
++)
3656 gfc_symbol
*forall_index
;
3658 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
3660 /* Check whether the assignment target is one of the FORALL index
3662 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
3663 && (code
->expr
->symtree
->n
.sym
== forall_index
))
3664 gfc_error ("Assignment to a FORALL index variable at %L",
3665 &code
->expr
->where
);
3668 /* If one of the FORALL index variables doesn't appear in the
3669 assignment target, then there will be a many-to-one
3671 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
3672 gfc_error ("The FORALL with index '%s' cause more than one "
3673 "assignment to this object at %L",
3674 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
3680 /* Resolve WHERE statement in FORALL construct. */
3683 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
){
3687 cblock
= code
->block
;
3690 /* the assignment statement of a WHERE statement, or the first
3691 statement in where-body-construct of a WHERE construct */
3692 cnext
= cblock
->next
;
3697 /* WHERE assignment statement */
3699 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
3702 /* WHERE or WHERE construct is part of a where-body-construct */
3704 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
3708 gfc_error ("Unsupported statement inside WHERE at %L",
3711 /* the next statement within the same where-body-construct */
3712 cnext
= cnext
->next
;
3714 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3715 cblock
= cblock
->block
;
3720 /* Traverse the FORALL body to check whether the following errors exist:
3721 1. For assignment, check if a many-to-one assignment happens.
3722 2. For WHERE statement, check the WHERE body to see if there is any
3723 many-to-one assignment. */
3726 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3730 c
= code
->block
->next
;
3736 case EXEC_POINTER_ASSIGN
:
3737 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
3740 /* Because the resolve_blocks() will handle the nested FORALL,
3741 there is no need to handle it here. */
3745 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
3750 /* The next statement in the FORALL body. */
3756 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3757 gfc_resolve_forall_body to resolve the FORALL body. */
3759 static void resolve_blocks (gfc_code
*, gfc_namespace
*);
3762 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
3764 static gfc_expr
**var_expr
;
3765 static int total_var
= 0;
3766 static int nvar
= 0;
3767 gfc_forall_iterator
*fa
;
3768 gfc_symbol
*forall_index
;
3772 /* Start to resolve a FORALL construct */
3773 if (forall_save
== 0)
3775 /* Count the total number of FORALL index in the nested FORALL
3776 construct in order to allocate the VAR_EXPR with proper size. */
3778 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
3780 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3782 next
= next
->block
->next
;
3785 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3786 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
3789 /* The information about FORALL iterator, including FORALL index start, end
3790 and stride. The FORALL index can not appear in start, end or stride. */
3791 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3793 /* Check if any outer FORALL index name is the same as the current
3795 for (i
= 0; i
< nvar
; i
++)
3797 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
3799 gfc_error ("An outer FORALL construct already has an index "
3800 "with this name %L", &fa
->var
->where
);
3804 /* Record the current FORALL index. */
3805 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
3807 forall_index
= fa
->var
->symtree
->n
.sym
;
3809 /* Check if the FORALL index appears in start, end or stride. */
3810 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
3811 gfc_error ("A FORALL index must not appear in a limit or stride "
3812 "expression in the same FORALL at %L", &fa
->start
->where
);
3813 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
3814 gfc_error ("A FORALL index must not appear in a limit or stride "
3815 "expression in the same FORALL at %L", &fa
->end
->where
);
3816 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
3817 gfc_error ("A FORALL index must not appear in a limit or stride "
3818 "expression in the same FORALL at %L", &fa
->stride
->where
);
3822 /* Resolve the FORALL body. */
3823 gfc_resolve_forall_body (code
, nvar
, var_expr
);
3825 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3826 resolve_blocks (code
->block
, ns
);
3828 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3829 for (i
= 0; i
< total_var
; i
++)
3830 gfc_free_expr (var_expr
[i
]);
3832 /* Reset the counters. */
3838 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3841 static void resolve_code (gfc_code
*, gfc_namespace
*);
3844 resolve_blocks (gfc_code
* b
, gfc_namespace
* ns
)
3848 for (; b
; b
= b
->block
)
3850 t
= gfc_resolve_expr (b
->expr
);
3851 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
3857 if (t
== SUCCESS
&& b
->expr
!= NULL
3858 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
3860 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3867 && (b
->expr
->ts
.type
!= BT_LOGICAL
3868 || b
->expr
->rank
== 0))
3870 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3875 resolve_branch (b
->label
, b
);
3885 gfc_internal_error ("resolve_block(): Bad block type");
3888 resolve_code (b
->next
, ns
);
3893 /* Given a block of code, recursively resolve everything pointed to by this
3897 resolve_code (gfc_code
* code
, gfc_namespace
* ns
)
3899 int forall_save
= 0;
3904 frame
.prev
= cs_base
;
3908 for (; code
; code
= code
->next
)
3910 frame
.current
= code
;
3912 if (code
->op
== EXEC_FORALL
)
3914 forall_save
= forall_flag
;
3916 gfc_resolve_forall (code
, ns
, forall_save
);
3919 resolve_blocks (code
->block
, ns
);
3921 if (code
->op
== EXEC_FORALL
)
3922 forall_flag
= forall_save
;
3924 t
= gfc_resolve_expr (code
->expr
);
3925 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
3941 resolve_where (code
, NULL
);
3945 if (code
->expr
!= NULL
)
3947 if (code
->expr
->ts
.type
!= BT_INTEGER
)
3948 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3949 "variable", &code
->expr
->where
);
3950 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
3951 gfc_error ("Variable '%s' has not been assigned a target label "
3952 "at %L", code
->expr
->symtree
->n
.sym
->name
,
3953 &code
->expr
->where
);
3956 resolve_branch (code
->label
, code
);
3960 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_INTEGER
)
3961 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3962 "return specifier", &code
->expr
->where
);
3969 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
3972 if (gfc_pure (NULL
))
3974 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
3977 ("Cannot assign to variable '%s' in PURE procedure at %L",
3978 code
->expr
->symtree
->n
.sym
->name
, &code
->expr
->where
);
3982 if (code
->expr2
->ts
.type
== BT_DERIVED
3983 && derived_pointer (code
->expr2
->ts
.derived
))
3986 ("Right side of assignment at %L is a derived type "
3987 "containing a POINTER in a PURE procedure",
3988 &code
->expr2
->where
);
3993 gfc_check_assign (code
->expr
, code
->expr2
, 1);
3996 case EXEC_LABEL_ASSIGN
:
3997 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
3998 gfc_error ("Label %d referenced at %L is never defined",
3999 code
->label
->value
, &code
->label
->where
);
4001 && (code
->expr
->expr_type
!= EXPR_VARIABLE
4002 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
4003 || code
->expr
->symtree
->n
.sym
->ts
.kind
4004 != gfc_default_integer_kind
4005 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
4006 gfc_error ("ASSIGN statement at %L requires a scalar "
4007 "default INTEGER variable", &code
->expr
->where
);
4010 case EXEC_POINTER_ASSIGN
:
4014 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
4017 case EXEC_ARITHMETIC_IF
:
4019 && code
->expr
->ts
.type
!= BT_INTEGER
4020 && code
->expr
->ts
.type
!= BT_REAL
)
4021 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4022 "expression", &code
->expr
->where
);
4024 resolve_branch (code
->label
, code
);
4025 resolve_branch (code
->label2
, code
);
4026 resolve_branch (code
->label3
, code
);
4030 if (t
== SUCCESS
&& code
->expr
!= NULL
4031 && (code
->expr
->ts
.type
!= BT_LOGICAL
4032 || code
->expr
->rank
!= 0))
4033 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4034 &code
->expr
->where
);
4039 resolve_call (code
);
4043 /* Select is complicated. Also, a SELECT construct could be
4044 a transformed computed GOTO. */
4045 resolve_select (code
);
4049 if (code
->ext
.iterator
!= NULL
)
4050 gfc_resolve_iterator (code
->ext
.iterator
, true);
4054 if (code
->expr
== NULL
)
4055 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4057 && (code
->expr
->rank
!= 0
4058 || code
->expr
->ts
.type
!= BT_LOGICAL
))
4059 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4060 "a scalar LOGICAL expression", &code
->expr
->where
);
4064 if (t
== SUCCESS
&& code
->expr
!= NULL
4065 && code
->expr
->ts
.type
!= BT_INTEGER
)
4066 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4067 "of type INTEGER", &code
->expr
->where
);
4069 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
4070 resolve_allocate_expr (a
->expr
, code
);
4074 case EXEC_DEALLOCATE
:
4075 if (t
== SUCCESS
&& code
->expr
!= NULL
4076 && code
->expr
->ts
.type
!= BT_INTEGER
)
4078 ("STAT tag in DEALLOCATE statement at %L must be of type "
4079 "INTEGER", &code
->expr
->where
);
4081 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
4082 resolve_deallocate_expr (a
->expr
);
4087 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
4090 resolve_branch (code
->ext
.open
->err
, code
);
4094 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
4097 resolve_branch (code
->ext
.close
->err
, code
);
4100 case EXEC_BACKSPACE
:
4104 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
4107 resolve_branch (code
->ext
.filepos
->err
, code
);
4111 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
4114 resolve_branch (code
->ext
.inquire
->err
, code
);
4118 gcc_assert (code
->ext
.inquire
!= NULL
);
4119 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
4122 resolve_branch (code
->ext
.inquire
->err
, code
);
4127 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
4130 resolve_branch (code
->ext
.dt
->err
, code
);
4131 resolve_branch (code
->ext
.dt
->end
, code
);
4132 resolve_branch (code
->ext
.dt
->eor
, code
);
4136 resolve_transfer (code
);
4140 resolve_forall_iterators (code
->ext
.forall_iterator
);
4142 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
4144 ("FORALL mask clause at %L requires a LOGICAL expression",
4145 &code
->expr
->where
);
4149 gfc_internal_error ("resolve_code(): Bad statement code");
4153 cs_base
= frame
.prev
;
4157 /* Resolve initial values and make sure they are compatible with
4161 resolve_values (gfc_symbol
* sym
)
4164 if (sym
->value
== NULL
)
4167 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
4170 gfc_check_assign_symbol (sym
, sym
->value
);
4174 /* Do anything necessary to resolve a symbol. Right now, we just
4175 assume that an otherwise unknown symbol is a variable. This sort
4176 of thing commonly happens for symbols in module. */
4179 resolve_symbol (gfc_symbol
* sym
)
4181 /* Zero if we are checking a formal namespace. */
4182 static int formal_ns_flag
= 1;
4183 int formal_ns_save
, check_constant
, mp_flag
;
4186 gfc_symtree
* symtree
;
4187 gfc_symtree
* this_symtree
;
4190 gfc_formal_arglist
* arg
;
4192 if (sym
->attr
.flavor
== FL_UNKNOWN
)
4195 /* If we find that a flavorless symbol is an interface in one of the
4196 parent namespaces, find its symtree in this namespace, free the
4197 symbol and set the symtree to point to the interface symbol. */
4198 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
4200 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
4201 if (symtree
&& symtree
->n
.sym
->generic
)
4203 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4207 gfc_free_symbol (sym
);
4208 symtree
->n
.sym
->refs
++;
4209 this_symtree
->n
.sym
= symtree
->n
.sym
;
4214 /* Otherwise give it a flavor according to such attributes as
4216 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
4217 sym
->attr
.flavor
= FL_VARIABLE
;
4220 sym
->attr
.flavor
= FL_PROCEDURE
;
4221 if (sym
->attr
.dimension
)
4222 sym
->attr
.function
= 1;
4226 /* Symbols that are module procedures with results (functions) have
4227 the types and array specification copied for type checking in
4228 procedures that call them, as well as for saving to a module
4229 file. These symbols can't stand the scrutiny that their results
4231 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
4233 /* Assign default type to symbols that need one and don't have one. */
4234 if (sym
->ts
.type
== BT_UNKNOWN
)
4236 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
4237 gfc_set_default_type (sym
, 1, NULL
);
4239 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
4241 /* The specific case of an external procedure should emit an error
4242 in the case that there is no implicit type. */
4244 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
4247 /* Result may be in another namespace. */
4248 resolve_symbol (sym
->result
);
4250 sym
->ts
= sym
->result
->ts
;
4251 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
4252 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
4253 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
4258 /* Assumed size arrays and assumed shape arrays must be dummy
4262 && (sym
->as
->type
== AS_ASSUMED_SIZE
4263 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
4264 && sym
->attr
.dummy
== 0)
4266 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
4267 gfc_error ("Assumed size array at %L must be a dummy argument",
4270 gfc_error ("Assumed shape array at %L must be a dummy argument",
4275 /* A parameter array's shape needs to be constant. */
4277 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->as
!= NULL
4278 && !gfc_is_compile_time_shape (sym
->as
))
4280 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4281 "or assumed shape", sym
->name
, &sym
->declared_at
);
4285 /* Make sure that character string variables with assumed length are
4288 if (sym
->attr
.flavor
== FL_VARIABLE
&& !sym
->attr
.result
4289 && sym
->ts
.type
== BT_CHARACTER
4290 && sym
->ts
.cl
->length
== NULL
&& sym
->attr
.dummy
== 0)
4292 gfc_error ("Entity with assumed character length at %L must be a "
4293 "dummy argument or a PARAMETER", &sym
->declared_at
);
4297 /* Make sure a parameter that has been implicitly typed still
4298 matches the implicit type, since PARAMETER statements can precede
4299 IMPLICIT statements. */
4301 if (sym
->attr
.flavor
== FL_PARAMETER
4302 && sym
->attr
.implicit_type
4303 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
4304 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4305 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
4307 /* Make sure the types of derived parameters are consistent. This
4308 type checking is deferred until resolution because the type may
4309 refer to a derived type from the host. */
4311 if (sym
->attr
.flavor
== FL_PARAMETER
4312 && sym
->ts
.type
== BT_DERIVED
4313 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
4314 gfc_error ("Incompatible derived type in PARAMETER at %L",
4315 &sym
->value
->where
);
4317 /* Make sure symbols with known intent or optional are really dummy
4318 variable. Because of ENTRY statement, this has to be deferred
4319 until resolution time. */
4321 if (! sym
->attr
.dummy
4322 && (sym
->attr
.optional
4323 || sym
->attr
.intent
!= INTENT_UNKNOWN
))
4325 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
4329 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
4331 if (sym
->ts
.type
== BT_CHARACTER
)
4333 gfc_charlen
*cl
= sym
->ts
.cl
;
4334 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
4336 gfc_error ("Character-valued statement function '%s' at %L must "
4337 "have constant length", sym
->name
, &sym
->declared_at
);
4343 /* If a derived type symbol has reached this point, without its
4344 type being declared, we have an error. Notice that most
4345 conditions that produce undefined derived types have already
4346 been dealt with. However, the likes of:
4347 implicit type(t) (t) ..... call foo (t) will get us here if
4348 the type is not declared in the scope of the implicit
4349 statement. Change the type to BT_UNKNOWN, both because it is so
4350 and to prevent an ICE. */
4351 if (sym
->ts
.type
== BT_DERIVED
4352 && sym
->ts
.derived
->components
== NULL
)
4354 gfc_error ("The derived type '%s' at %L is of type '%s', "
4355 "which has not been defined.", sym
->name
,
4356 &sym
->declared_at
, sym
->ts
.derived
->name
);
4357 sym
->ts
.type
= BT_UNKNOWN
;
4361 /* Ensure that derived type components of a public derived type
4362 are not of a private type. */
4363 if (sym
->attr
.flavor
== FL_DERIVED
4364 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
4366 for (c
= sym
->components
; c
; c
= c
->next
)
4368 if (c
->ts
.type
== BT_DERIVED
4369 && !c
->ts
.derived
->attr
.use_assoc
4370 && !gfc_check_access(c
->ts
.derived
->attr
.access
,
4371 c
->ts
.derived
->ns
->default_access
))
4373 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4374 "a component of '%s', which is PUBLIC at %L",
4375 c
->name
, sym
->name
, &sym
->declared_at
);
4381 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
4382 default initialization is defined (5.1.2.4.4). */
4383 if (sym
->ts
.type
== BT_DERIVED
4385 && sym
->attr
.intent
== INTENT_OUT
4387 && sym
->as
->type
== AS_ASSUMED_SIZE
)
4389 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
4393 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
4394 "ASSUMED SIZE and so cannot have a default initializer",
4395 sym
->name
, &sym
->declared_at
);
4402 /* Ensure that derived type formal arguments of a public procedure
4403 are not of a private type. */
4404 if (sym
->attr
.flavor
== FL_PROCEDURE
4405 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
4407 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
4410 && arg
->sym
->ts
.type
== BT_DERIVED
4411 && !arg
->sym
->ts
.derived
->attr
.use_assoc
4412 && !gfc_check_access(arg
->sym
->ts
.derived
->attr
.access
,
4413 arg
->sym
->ts
.derived
->ns
->default_access
))
4415 gfc_error_now ("'%s' is a PRIVATE type and cannot be "
4416 "a dummy argument of '%s', which is PUBLIC at %L",
4417 arg
->sym
->name
, sym
->name
, &sym
->declared_at
);
4418 /* Stop this message from recurring. */
4419 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
4425 /* Constraints on deferred shape variable. */
4426 if (sym
->attr
.flavor
== FL_VARIABLE
4427 || (sym
->attr
.flavor
== FL_PROCEDURE
4428 && sym
->attr
.function
))
4430 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
4432 if (sym
->attr
.allocatable
)
4434 if (sym
->attr
.dimension
)
4435 gfc_error ("Allocatable array '%s' at %L must have "
4436 "a deferred shape", sym
->name
, &sym
->declared_at
);
4438 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4439 sym
->name
, &sym
->declared_at
);
4443 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
4445 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4446 sym
->name
, &sym
->declared_at
);
4453 if (!mp_flag
&& !sym
->attr
.allocatable
4454 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
4456 gfc_error ("Array '%s' at %L cannot have a deferred shape",
4457 sym
->name
, &sym
->declared_at
);
4463 switch (sym
->attr
.flavor
)
4466 /* Can the sybol have an initializer? */
4468 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
4469 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
4471 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
4473 /* Don't allow initialization of automatic arrays. */
4474 for (i
= 0; i
< sym
->as
->rank
; i
++)
4476 if (sym
->as
->lower
[i
] == NULL
4477 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4478 || sym
->as
->upper
[i
] == NULL
4479 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
4487 /* Reject illegal initializers. */
4488 if (sym
->value
&& flag
)
4490 if (sym
->attr
.allocatable
)
4491 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4492 sym
->name
, &sym
->declared_at
);
4493 else if (sym
->attr
.external
)
4494 gfc_error ("External '%s' at %L cannot have an initializer",
4495 sym
->name
, &sym
->declared_at
);
4496 else if (sym
->attr
.dummy
)
4497 gfc_error ("Dummy '%s' at %L cannot have an initializer",
4498 sym
->name
, &sym
->declared_at
);
4499 else if (sym
->attr
.intrinsic
)
4500 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4501 sym
->name
, &sym
->declared_at
);
4502 else if (sym
->attr
.result
)
4503 gfc_error ("Function result '%s' at %L cannot have an initializer",
4504 sym
->name
, &sym
->declared_at
);
4506 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4507 sym
->name
, &sym
->declared_at
);
4511 /* Assign default initializer. */
4512 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| flag
)
4513 && !sym
->attr
.pointer
)
4514 sym
->value
= gfc_default_initializer (&sym
->ts
);
4518 /* Reject PRIVATE objects in a PUBLIC namelist. */
4519 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
4521 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
4523 if (!nl
->sym
->attr
.use_assoc
4525 !(sym
->ns
->parent
== nl
->sym
->ns
)
4527 !gfc_check_access(nl
->sym
->attr
.access
,
4528 nl
->sym
->ns
->default_access
))
4529 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4530 "PUBLIC namelist at %L", nl
->sym
->name
,
4538 /* An external symbol falls through to here if it is not referenced. */
4539 if (sym
->attr
.external
&& sym
->value
)
4541 gfc_error ("External object '%s' at %L may not have an initializer",
4542 sym
->name
, &sym
->declared_at
);
4550 /* Make sure that intrinsic exist */
4551 if (sym
->attr
.intrinsic
4552 && ! gfc_intrinsic_name(sym
->name
, 0)
4553 && ! gfc_intrinsic_name(sym
->name
, 1))
4554 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
4556 /* Resolve array specifier. Check as well some constraints
4557 on COMMON blocks. */
4559 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
4560 gfc_resolve_array_spec (sym
->as
, check_constant
);
4562 /* Resolve formal namespaces. */
4564 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
4566 formal_ns_save
= formal_ns_flag
;
4568 gfc_resolve (sym
->formal_ns
);
4569 formal_ns_flag
= formal_ns_save
;
4575 /************* Resolve DATA statements *************/
4579 gfc_data_value
*vnode
;
4585 /* Advance the values structure to point to the next value in the data list. */
4588 next_data_value (void)
4590 while (values
.left
== 0)
4592 if (values
.vnode
->next
== NULL
)
4595 values
.vnode
= values
.vnode
->next
;
4596 values
.left
= values
.vnode
->repeat
;
4604 check_data_variable (gfc_data_variable
* var
, locus
* where
)
4610 ar_type mark
= AR_UNKNOWN
;
4612 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
4616 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
4620 mpz_init_set_si (offset
, 0);
4623 if (e
->expr_type
!= EXPR_VARIABLE
)
4624 gfc_internal_error ("check_data_variable(): Bad expression");
4628 mpz_init_set_ui (size
, 1);
4635 /* Find the array section reference. */
4636 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4638 if (ref
->type
!= REF_ARRAY
)
4640 if (ref
->u
.ar
.type
== AR_ELEMENT
)
4646 /* Set marks according to the reference pattern. */
4647 switch (ref
->u
.ar
.type
)
4655 /* Get the start position of array section. */
4656 gfc_get_section_index (ar
, section_index
, &offset
);
4664 if (gfc_array_size (e
, &size
) == FAILURE
)
4666 gfc_error ("Nonconstant array section at %L in DATA statement",
4675 while (mpz_cmp_ui (size
, 0) > 0)
4677 if (next_data_value () == FAILURE
)
4679 gfc_error ("DATA statement at %L has more variables than values",
4685 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
4689 /* If we have more than one element left in the repeat count,
4690 and we have more than one element left in the target variable,
4691 then create a range assignment. */
4692 /* ??? Only done for full arrays for now, since array sections
4694 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
4695 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
4699 if (mpz_cmp_ui (size
, values
.left
) >= 0)
4701 mpz_init_set_ui (range
, values
.left
);
4702 mpz_sub_ui (size
, size
, values
.left
);
4707 mpz_init_set (range
, size
);
4708 values
.left
-= mpz_get_ui (size
);
4709 mpz_set_ui (size
, 0);
4712 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
4715 mpz_add (offset
, offset
, range
);
4719 /* Assign initial value to symbol. */
4723 mpz_sub_ui (size
, size
, 1);
4725 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
4727 if (mark
== AR_FULL
)
4728 mpz_add_ui (offset
, offset
, 1);
4730 /* Modify the array section indexes and recalculate the offset
4731 for next element. */
4732 else if (mark
== AR_SECTION
)
4733 gfc_advance_section (section_index
, ar
, &offset
);
4737 if (mark
== AR_SECTION
)
4739 for (i
= 0; i
< ar
->dimen
; i
++)
4740 mpz_clear (section_index
[i
]);
4750 static try traverse_data_var (gfc_data_variable
*, locus
*);
4752 /* Iterate over a list of elements in a DATA statement. */
4755 traverse_data_list (gfc_data_variable
* var
, locus
* where
)
4758 iterator_stack frame
;
4761 mpz_init (frame
.value
);
4763 mpz_init_set (trip
, var
->iter
.end
->value
.integer
);
4764 mpz_sub (trip
, trip
, var
->iter
.start
->value
.integer
);
4765 mpz_add (trip
, trip
, var
->iter
.step
->value
.integer
);
4767 mpz_div (trip
, trip
, var
->iter
.step
->value
.integer
);
4769 mpz_set (frame
.value
, var
->iter
.start
->value
.integer
);
4771 frame
.prev
= iter_stack
;
4772 frame
.variable
= var
->iter
.var
->symtree
;
4773 iter_stack
= &frame
;
4775 while (mpz_cmp_ui (trip
, 0) > 0)
4777 if (traverse_data_var (var
->list
, where
) == FAILURE
)
4783 e
= gfc_copy_expr (var
->expr
);
4784 if (gfc_simplify_expr (e
, 1) == FAILURE
)
4790 mpz_add (frame
.value
, frame
.value
, var
->iter
.step
->value
.integer
);
4792 mpz_sub_ui (trip
, trip
, 1);
4796 mpz_clear (frame
.value
);
4798 iter_stack
= frame
.prev
;
4803 /* Type resolve variables in the variable list of a DATA statement. */
4806 traverse_data_var (gfc_data_variable
* var
, locus
* where
)
4810 for (; var
; var
= var
->next
)
4812 if (var
->expr
== NULL
)
4813 t
= traverse_data_list (var
, where
);
4815 t
= check_data_variable (var
, where
);
4825 /* Resolve the expressions and iterators associated with a data statement.
4826 This is separate from the assignment checking because data lists should
4827 only be resolved once. */
4830 resolve_data_variables (gfc_data_variable
* d
)
4832 for (; d
; d
= d
->next
)
4834 if (d
->list
== NULL
)
4836 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
4841 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
4844 if (d
->iter
.start
->expr_type
!= EXPR_CONSTANT
4845 || d
->iter
.end
->expr_type
!= EXPR_CONSTANT
4846 || d
->iter
.step
->expr_type
!= EXPR_CONSTANT
)
4847 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4849 if (resolve_data_variables (d
->list
) == FAILURE
)
4858 /* Resolve a single DATA statement. We implement this by storing a pointer to
4859 the value list into static variables, and then recursively traversing the
4860 variables list, expanding iterators and such. */
4863 resolve_data (gfc_data
* d
)
4865 if (resolve_data_variables (d
->var
) == FAILURE
)
4868 values
.vnode
= d
->value
;
4869 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
4871 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
4874 /* At this point, we better not have any values left. */
4876 if (next_data_value () == SUCCESS
)
4877 gfc_error ("DATA statement at %L has more values than variables",
4882 /* Determines if a variable is not 'pure', ie not assignable within a pure
4883 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4887 gfc_impure_variable (gfc_symbol
* sym
)
4889 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
4892 if (sym
->ns
!= gfc_current_ns
)
4893 return !sym
->attr
.function
;
4895 /* TODO: Check storage association through EQUIVALENCE statements */
4901 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4902 symbol of the current procedure. */
4905 gfc_pure (gfc_symbol
* sym
)
4907 symbol_attribute attr
;
4910 sym
= gfc_current_ns
->proc_name
;
4916 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
4920 /* Test whether the current procedure is elemental or not. */
4923 gfc_elemental (gfc_symbol
* sym
)
4925 symbol_attribute attr
;
4928 sym
= gfc_current_ns
->proc_name
;
4933 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
4937 /* Warn about unused labels. */
4940 warn_unused_label (gfc_namespace
* ns
)
4951 for (; l
; l
= l
->prev
)
4953 if (l
->defined
== ST_LABEL_UNKNOWN
)
4956 switch (l
->referenced
)
4958 case ST_LABEL_UNKNOWN
:
4959 gfc_warning ("Label %d at %L defined but not used", l
->value
,
4963 case ST_LABEL_BAD_TARGET
:
4964 gfc_warning ("Label %d at %L defined but cannot be used", l
->value
,
4975 /* Returns the sequence type of a symbol or sequence. */
4978 sequence_type (gfc_typespec ts
)
4987 if (ts
.derived
->components
== NULL
)
4988 return SEQ_NONDEFAULT
;
4990 result
= sequence_type (ts
.derived
->components
->ts
);
4991 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
4992 if (sequence_type (c
->ts
) != result
)
4998 if (ts
.kind
!= gfc_default_character_kind
)
4999 return SEQ_NONDEFAULT
;
5001 return SEQ_CHARACTER
;
5004 if (ts
.kind
!= gfc_default_integer_kind
)
5005 return SEQ_NONDEFAULT
;
5010 if (!(ts
.kind
== gfc_default_real_kind
5011 || ts
.kind
== gfc_default_double_kind
))
5012 return SEQ_NONDEFAULT
;
5017 if (ts
.kind
!= gfc_default_complex_kind
)
5018 return SEQ_NONDEFAULT
;
5023 if (ts
.kind
!= gfc_default_logical_kind
)
5024 return SEQ_NONDEFAULT
;
5029 return SEQ_NONDEFAULT
;
5034 /* Resolve derived type EQUIVALENCE object. */
5037 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
5040 gfc_component
*c
= derived
->components
;
5045 /* Shall not be an object of nonsequence derived type. */
5046 if (!derived
->attr
.sequence
)
5048 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5049 "attribute to be an EQUIVALENCE object", sym
->name
, &e
->where
);
5053 for (; c
; c
= c
->next
)
5056 if (d
&& (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
5059 /* Shall not be an object of sequence derived type containing a pointer
5060 in the structure. */
5063 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5064 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
5070 gfc_error ("Derived type variable '%s' at %L with default initializer "
5071 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
5079 /* Resolve equivalence object.
5080 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5081 an allocatable array, an object of nonsequence derived type, an object of
5082 sequence derived type containing a pointer at any level of component
5083 selection, an automatic object, a function name, an entry name, a result
5084 name, a named constant, a structure component, or a subobject of any of
5085 the preceding objects. A substring shall not have length zero. A
5086 derived type shall not have components with default initialization nor
5087 shall two objects of an equivalence group be initialized.
5088 The simple constraints are done in symbol.c(check_conflict) and the rest
5089 are implemented here. */
5092 resolve_equivalence (gfc_equiv
*eq
)
5095 gfc_symbol
*derived
;
5096 gfc_symbol
*first_sym
;
5099 locus
*last_where
= NULL
;
5100 seq_type eq_type
, last_eq_type
;
5101 gfc_typespec
*last_ts
;
5103 const char *value_name
;
5107 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
5109 first_sym
= eq
->expr
->symtree
->n
.sym
;
5111 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
5115 e
->ts
= e
->symtree
->n
.sym
->ts
;
5116 /* match_varspec might not know yet if it is seeing
5117 array reference or substring reference, as it doesn't
5119 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5121 gfc_ref
*ref
= e
->ref
;
5122 sym
= e
->symtree
->n
.sym
;
5124 if (sym
->attr
.dimension
)
5126 ref
->u
.ar
.as
= sym
->as
;
5130 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5131 if (e
->ts
.type
== BT_CHARACTER
5133 && ref
->type
== REF_ARRAY
5134 && ref
->u
.ar
.dimen
== 1
5135 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
5136 && ref
->u
.ar
.stride
[0] == NULL
)
5138 gfc_expr
*start
= ref
->u
.ar
.start
[0];
5139 gfc_expr
*end
= ref
->u
.ar
.end
[0];
5142 /* Optimize away the (:) reference. */
5143 if (start
== NULL
&& end
== NULL
)
5148 e
->ref
->next
= ref
->next
;
5153 ref
->type
= REF_SUBSTRING
;
5155 start
= gfc_int_expr (1);
5156 ref
->u
.ss
.start
= start
;
5157 if (end
== NULL
&& e
->ts
.cl
)
5158 end
= gfc_copy_expr (e
->ts
.cl
->length
);
5159 ref
->u
.ss
.end
= end
;
5160 ref
->u
.ss
.length
= e
->ts
.cl
;
5167 /* Any further ref is an error. */
5170 gcc_assert (ref
->type
== REF_ARRAY
);
5171 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5177 if (gfc_resolve_expr (e
) == FAILURE
)
5180 sym
= e
->symtree
->n
.sym
;
5182 /* An equivalence statement cannot have more than one initialized
5186 if (value_name
!= NULL
)
5188 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5189 "be in the EQUIVALENCE statement at %L",
5190 value_name
, sym
->name
, &e
->where
);
5194 value_name
= sym
->name
;
5197 /* Shall not equivalence common block variables in a PURE procedure. */
5198 if (sym
->ns
->proc_name
5199 && sym
->ns
->proc_name
->attr
.pure
5200 && sym
->attr
.in_common
)
5202 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5203 "object in the pure procedure '%s'",
5204 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
5208 /* Shall not be a named constant. */
5209 if (e
->expr_type
== EXPR_CONSTANT
)
5211 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5212 "object", sym
->name
, &e
->where
);
5216 derived
= e
->ts
.derived
;
5217 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
5220 /* Check that the types correspond correctly:
5222 A numeric sequence structure may be equivalenced to another sequence
5223 structure, an object of default integer type, default real type, double
5224 precision real type, default logical type such that components of the
5225 structure ultimately only become associated to objects of the same
5226 kind. A character sequence structure may be equivalenced to an object
5227 of default character kind or another character sequence structure.
5228 Other objects may be equivalenced only to objects of the same type and
5231 /* Identical types are unconditionally OK. */
5232 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
5233 goto identical_types
;
5235 last_eq_type
= sequence_type (*last_ts
);
5236 eq_type
= sequence_type (sym
->ts
);
5238 /* Since the pair of objects is not of the same type, mixed or
5239 non-default sequences can be rejected. */
5241 msg
= "Sequence %s with mixed components in EQUIVALENCE "
5242 "statement at %L with different type objects";
5244 && last_eq_type
== SEQ_MIXED
5245 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
5246 last_where
) == FAILURE
)
5247 || (eq_type
== SEQ_MIXED
5248 && gfc_notify_std (GFC_STD_GNU
, msg
,sym
->name
,
5249 &e
->where
) == FAILURE
))
5252 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
5253 "statement at %L with objects of different type";
5255 && last_eq_type
== SEQ_NONDEFAULT
5256 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
5257 last_where
) == FAILURE
)
5258 || (eq_type
== SEQ_NONDEFAULT
5259 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
5260 &e
->where
) == FAILURE
))
5263 msg
="Non-CHARACTER object '%s' in default CHARACTER "
5264 "EQUIVALENCE statement at %L";
5265 if (last_eq_type
== SEQ_CHARACTER
5266 && eq_type
!= SEQ_CHARACTER
5267 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
5268 &e
->where
) == FAILURE
)
5271 msg
="Non-NUMERIC object '%s' in default NUMERIC "
5272 "EQUIVALENCE statement at %L";
5273 if (last_eq_type
== SEQ_NUMERIC
5274 && eq_type
!= SEQ_NUMERIC
5275 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
5276 &e
->where
) == FAILURE
)
5281 last_where
= &e
->where
;
5286 /* Shall not be an automatic array. */
5287 if (e
->ref
->type
== REF_ARRAY
5288 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
5290 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
5291 "an EQUIVALENCE object", sym
->name
, &e
->where
);
5298 /* Shall not be a structure component. */
5299 if (r
->type
== REF_COMPONENT
)
5301 gfc_error ("Structure component '%s' at %L cannot be an "
5302 "EQUIVALENCE object",
5303 r
->u
.c
.component
->name
, &e
->where
);
5307 /* A substring shall not have length zero. */
5308 if (r
->type
== REF_SUBSTRING
)
5310 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
5312 gfc_error ("Substring at %L has length zero",
5313 &r
->u
.ss
.start
->where
);
5323 /* Resolve function and ENTRY types, issue diagnostics if needed. */
5326 resolve_fntype (gfc_namespace
* ns
)
5331 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
5334 /* If there are any entries, ns->proc_name is the entry master
5335 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
5337 sym
= ns
->entries
->sym
;
5339 sym
= ns
->proc_name
;
5340 if (sym
->result
== sym
5341 && sym
->ts
.type
== BT_UNKNOWN
5342 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
5343 && !sym
->attr
.untyped
)
5345 gfc_error ("Function '%s' at %L has no IMPLICIT type",
5346 sym
->name
, &sym
->declared_at
);
5347 sym
->attr
.untyped
= 1;
5351 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
5353 if (el
->sym
->result
== el
->sym
5354 && el
->sym
->ts
.type
== BT_UNKNOWN
5355 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
5356 && !el
->sym
->attr
.untyped
)
5358 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
5359 el
->sym
->name
, &el
->sym
->declared_at
);
5360 el
->sym
->attr
.untyped
= 1;
5366 /* This function is called after a complete program unit has been compiled.
5367 Its purpose is to examine all of the expressions associated with a program
5368 unit, assign types to all intermediate expressions, make sure that all
5369 assignments are to compatible types and figure out which names refer to
5370 which functions or subroutines. */
5373 gfc_resolve (gfc_namespace
* ns
)
5375 gfc_namespace
*old_ns
, *n
;
5380 old_ns
= gfc_current_ns
;
5381 gfc_current_ns
= ns
;
5383 resolve_entries (ns
);
5385 resolve_contained_functions (ns
);
5387 gfc_traverse_ns (ns
, resolve_symbol
);
5389 resolve_fntype (ns
);
5391 for (n
= ns
->contained
; n
; n
= n
->sibling
)
5393 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
5394 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
5395 "also be PURE", n
->proc_name
->name
,
5396 &n
->proc_name
->declared_at
);
5402 gfc_check_interfaces (ns
);
5404 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
5406 if (cl
->length
== NULL
|| gfc_resolve_expr (cl
->length
) == FAILURE
)
5409 if (gfc_simplify_expr (cl
->length
, 0) == FAILURE
)
5412 if (gfc_specification_expr (cl
->length
) == FAILURE
)
5416 gfc_traverse_ns (ns
, resolve_values
);
5422 for (d
= ns
->data
; d
; d
= d
->next
)
5426 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
5428 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
5429 resolve_equivalence (eq
);
5432 resolve_code (ns
->code
, ns
);
5434 /* Warn about unused labels. */
5435 if (gfc_option
.warn_unused_labels
)
5436 warn_unused_label (ns
);
5438 gfc_current_ns
= old_ns
;