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, 59 Temple Place - Suite 330,Boston, MA
26 #include "arith.h" /* For gfc_compare_expr(). */
29 /* Stack to push the current if we descend into a block during
30 resolution. See resolve_branch() and resolve_code(). */
32 typedef struct code_stack
34 struct gfc_code
*head
, *current
;
35 struct code_stack
*prev
;
39 static code_stack
*cs_base
= NULL
;
42 /* Nonzero if we're inside a FORALL block */
44 static int forall_flag
;
46 /* Resolve types of formal argument lists. These have to be done early so that
47 the formal argument lists of module procedures can be copied to the
48 containing module before the individual procedures are resolved
49 individually. We also resolve argument lists of procedures in interface
50 blocks because they are self-contained scoping units.
52 Since a dummy argument cannot be a non-dummy procedure, the only
53 resort left for untyped names are the IMPLICIT types. */
56 resolve_formal_arglist (gfc_symbol
* proc
)
58 gfc_formal_arglist
*f
;
62 /* TODO: Procedures whose return character length parameter is not constant
63 or assumed must also have explicit interfaces. */
64 if (proc
->result
!= NULL
)
69 if (gfc_elemental (proc
)
70 || sym
->attr
.pointer
|| sym
->attr
.allocatable
71 || (sym
->as
&& sym
->as
->rank
> 0))
72 proc
->attr
.always_explicit
= 1;
74 for (f
= proc
->formal
; f
; f
= f
->next
)
80 /* Alternate return placeholder. */
81 if (gfc_elemental (proc
))
82 gfc_error ("Alternate return specifier in elemental subroutine "
83 "'%s' at %L is not allowed", proc
->name
,
85 if (proc
->attr
.function
)
86 gfc_error ("Alternate return specifier in function "
87 "'%s' at %L is not allowed", proc
->name
,
92 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
93 resolve_formal_arglist (sym
);
95 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
97 if (gfc_pure (proc
) && !gfc_pure (sym
))
100 ("Dummy procedure '%s' of PURE procedure at %L must also "
101 "be PURE", sym
->name
, &sym
->declared_at
);
105 if (gfc_elemental (proc
))
108 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
116 if (sym
->ts
.type
== BT_UNKNOWN
)
118 if (!sym
->attr
.function
|| sym
->result
== sym
)
119 gfc_set_default_type (sym
, 1, sym
->ns
);
122 /* Set the type of the RESULT, then copy. */
123 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
124 gfc_set_default_type (sym
->result
, 1, sym
->result
->ns
);
126 sym
->ts
= sym
->result
->ts
;
128 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
132 gfc_resolve_array_spec (sym
->as
, 0);
134 /* We can't tell if an array with dimension (:) is assumed or deferred
135 shape until we know if it has the pointer or allocatable attributes.
137 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
138 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
140 sym
->as
->type
= AS_ASSUMED_SHAPE
;
141 for (i
= 0; i
< sym
->as
->rank
; i
++)
142 sym
->as
->lower
[i
] = gfc_int_expr (1);
145 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
146 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
147 || sym
->attr
.optional
)
148 proc
->attr
.always_explicit
= 1;
150 /* If the flavor is unknown at this point, it has to be a variable.
151 A procedure specification would have already set the type. */
153 if (sym
->attr
.flavor
== FL_UNKNOWN
)
154 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
158 if (proc
->attr
.function
&& !sym
->attr
.pointer
159 && sym
->attr
.flavor
!= FL_PROCEDURE
160 && sym
->attr
.intent
!= INTENT_IN
)
162 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
163 "INTENT(IN)", sym
->name
, proc
->name
,
166 if (proc
->attr
.subroutine
&& !sym
->attr
.pointer
167 && sym
->attr
.intent
== INTENT_UNKNOWN
)
170 ("Argument '%s' of pure subroutine '%s' at %L must have "
171 "its INTENT specified", sym
->name
, proc
->name
,
176 if (gfc_elemental (proc
))
181 ("Argument '%s' of elemental procedure at %L must be scalar",
182 sym
->name
, &sym
->declared_at
);
186 if (sym
->attr
.pointer
)
189 ("Argument '%s' of elemental procedure at %L cannot have "
190 "the POINTER attribute", sym
->name
, &sym
->declared_at
);
195 /* Each dummy shall be specified to be scalar. */
196 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
201 ("Argument '%s' of statement function at %L must be scalar",
202 sym
->name
, &sym
->declared_at
);
206 if (sym
->ts
.type
== BT_CHARACTER
)
208 gfc_charlen
*cl
= sym
->ts
.cl
;
209 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
212 ("Character-valued argument '%s' of statement function at "
213 "%L must has constant length",
214 sym
->name
, &sym
->declared_at
);
223 /* Work function called when searching for symbols that have argument lists
224 associated with them. */
227 find_arglists (gfc_symbol
* sym
)
230 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
233 resolve_formal_arglist (sym
);
237 /* Given a namespace, resolve all formal argument lists within the namespace.
241 resolve_formal_arglists (gfc_namespace
* ns
)
247 gfc_traverse_ns (ns
, find_arglists
);
252 resolve_contained_fntype (gfc_symbol
* sym
, gfc_namespace
* ns
)
256 /* If this namespace is not a function, ignore it. */
258 || !(sym
->attr
.function
259 || sym
->attr
.flavor
== FL_VARIABLE
))
262 /* Try to find out of what the return type is. */
263 if (sym
->result
!= NULL
)
266 if (sym
->ts
.type
== BT_UNKNOWN
)
268 t
= gfc_set_default_type (sym
, 0, ns
);
271 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
272 sym
->name
, &sym
->declared_at
); /* FIXME */
277 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
278 introduce duplicates. */
281 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
283 gfc_formal_arglist
*f
, *new_arglist
;
286 for (; new_args
!= NULL
; new_args
= new_args
->next
)
288 new_sym
= new_args
->sym
;
289 /* See if ths arg is already in the formal argument list. */
290 for (f
= proc
->formal
; f
; f
= f
->next
)
292 if (new_sym
== f
->sym
)
299 /* Add a new argument. Argument order is not important. */
300 new_arglist
= gfc_get_formal_arglist ();
301 new_arglist
->sym
= new_sym
;
302 new_arglist
->next
= proc
->formal
;
303 proc
->formal
= new_arglist
;
308 /* Resolve alternate entry points. If a symbol has multiple entry points we
309 create a new master symbol for the main routine, and turn the existing
310 symbol into an entry point. */
313 resolve_entries (gfc_namespace
* ns
)
315 gfc_namespace
*old_ns
;
319 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
320 static int master_count
= 0;
322 if (ns
->proc_name
== NULL
)
325 /* No need to do anything if this procedure doesn't have alternate entry
330 /* We may already have resolved alternate entry points. */
331 if (ns
->proc_name
->attr
.entry_master
)
334 /* If this isn't a procedure something has gone horribly wrong. */
335 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
337 /* Remember the current namespace. */
338 old_ns
= gfc_current_ns
;
342 /* Add the main entry point to the list of entry points. */
343 el
= gfc_get_entry_list ();
344 el
->sym
= ns
->proc_name
;
346 el
->next
= ns
->entries
;
348 ns
->proc_name
->attr
.entry
= 1;
350 /* Add an entry statement for it. */
357 /* Create a new symbol for the master function. */
358 /* Give the internal function a unique name (within this file).
359 Also include the function name so the user has some hope of figuring
360 out what is going on. */
361 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
362 master_count
++, ns
->proc_name
->name
);
363 name
[GFC_MAX_SYMBOL_LEN
] = '\0';
364 gfc_get_ha_symbol (name
, &proc
);
365 gcc_assert (proc
!= NULL
);
367 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
368 if (ns
->proc_name
->attr
.subroutine
)
369 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
372 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
373 gfc_internal_error ("TODO: Functions with alternate entry points");
375 proc
->attr
.access
= ACCESS_PRIVATE
;
376 proc
->attr
.entry_master
= 1;
378 /* Merge all the entry point arguments. */
379 for (el
= ns
->entries
; el
; el
= el
->next
)
380 merge_argument_lists (proc
, el
->sym
->formal
);
382 /* Use the master function for the function body. */
383 ns
->proc_name
= proc
;
385 /* Finalize the new symbols. */
386 gfc_commit_symbols ();
388 /* Restore the original namespace. */
389 gfc_current_ns
= old_ns
;
393 /* Resolve contained function types. Because contained functions can call one
394 another, they have to be worked out before any of the contained procedures
397 The good news is that if a function doesn't already have a type, the only
398 way it can get one is through an IMPLICIT type or a RESULT variable, because
399 by definition contained functions are contained namespace they're contained
400 in, not in a sibling or parent namespace. */
403 resolve_contained_functions (gfc_namespace
* ns
)
405 gfc_namespace
*child
;
408 resolve_formal_arglists (ns
);
410 for (child
= ns
->contained
; child
; child
= child
->sibling
)
412 /* Resolve alternate entry points first. */
413 resolve_entries (child
);
415 /* Then check function return types. */
416 resolve_contained_fntype (child
->proc_name
, child
);
417 for (el
= child
->entries
; el
; el
= el
->next
)
418 resolve_contained_fntype (el
->sym
, child
);
423 /* Resolve all of the elements of a structure constructor and make sure that
424 the types are correct. */
427 resolve_structure_cons (gfc_expr
* expr
)
429 gfc_constructor
*cons
;
434 cons
= expr
->value
.constructor
;
435 /* A constructor may have references if it is the result of substituting a
436 parameter variable. In this case we just pull out the component we
439 comp
= expr
->ref
->u
.c
.sym
->components
;
441 comp
= expr
->ts
.derived
->components
;
443 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
451 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
457 /* If we don't have the right type, try to convert it. */
459 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
)
460 && gfc_convert_type (cons
->expr
, &comp
->ts
, 1) == FAILURE
)
469 /****************** Expression name resolution ******************/
471 /* Returns 0 if a symbol was not declared with a type or
472 attribute declaration statement, nonzero otherwise. */
475 was_declared (gfc_symbol
* sym
)
481 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
484 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
485 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
486 || a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
493 /* Determine if a symbol is generic or not. */
496 generic_sym (gfc_symbol
* sym
)
500 if (sym
->attr
.generic
||
501 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
504 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
507 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
509 return (s
== NULL
) ? 0 : generic_sym (s
);
513 /* Determine if a symbol is specific or not. */
516 specific_sym (gfc_symbol
* sym
)
520 if (sym
->attr
.if_source
== IFSRC_IFBODY
521 || sym
->attr
.proc
== PROC_MODULE
522 || sym
->attr
.proc
== PROC_INTERNAL
523 || sym
->attr
.proc
== PROC_ST_FUNCTION
524 || (sym
->attr
.intrinsic
&&
525 gfc_specific_intrinsic (sym
->name
))
526 || sym
->attr
.external
)
529 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
532 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
534 return (s
== NULL
) ? 0 : specific_sym (s
);
538 /* Figure out if the procedure is specific, generic or unknown. */
541 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
545 procedure_kind (gfc_symbol
* sym
)
548 if (generic_sym (sym
))
549 return PTYPE_GENERIC
;
551 if (specific_sym (sym
))
552 return PTYPE_SPECIFIC
;
554 return PTYPE_UNKNOWN
;
558 /* Resolve an actual argument list. Most of the time, this is just
559 resolving the expressions in the list.
560 The exception is that we sometimes have to decide whether arguments
561 that look like procedure arguments are really simple variable
565 resolve_actual_arglist (gfc_actual_arglist
* arg
)
568 gfc_symtree
*parent_st
;
571 for (; arg
; arg
= arg
->next
)
577 /* Check the label is a valid branching target. */
580 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
582 gfc_error ("Label %d referenced at %L is never defined",
583 arg
->label
->value
, &arg
->label
->where
);
590 if (e
->ts
.type
!= BT_PROCEDURE
)
592 if (gfc_resolve_expr (e
) != SUCCESS
)
597 /* See if the expression node should really be a variable
600 sym
= e
->symtree
->n
.sym
;
602 if (sym
->attr
.flavor
== FL_PROCEDURE
603 || sym
->attr
.intrinsic
604 || sym
->attr
.external
)
607 /* If the symbol is the function that names the current (or
608 parent) scope, then we really have a variable reference. */
610 if (sym
->attr
.function
&& sym
->result
== sym
611 && (sym
->ns
->proc_name
== sym
612 || (sym
->ns
->parent
!= NULL
613 && sym
->ns
->parent
->proc_name
== sym
)))
619 /* See if the name is a module procedure in a parent unit. */
621 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
624 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
626 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
630 if (parent_st
== NULL
)
633 sym
= parent_st
->n
.sym
;
634 e
->symtree
= parent_st
; /* Point to the right thing. */
636 if (sym
->attr
.flavor
== FL_PROCEDURE
637 || sym
->attr
.intrinsic
638 || sym
->attr
.external
)
644 e
->expr_type
= EXPR_VARIABLE
;
648 e
->rank
= sym
->as
->rank
;
649 e
->ref
= gfc_get_ref ();
650 e
->ref
->type
= REF_ARRAY
;
651 e
->ref
->u
.ar
.type
= AR_FULL
;
652 e
->ref
->u
.ar
.as
= sym
->as
;
660 /************* Function resolution *************/
662 /* Resolve a function call known to be generic.
663 Section 14.1.2.4.1. */
666 resolve_generic_f0 (gfc_expr
* expr
, gfc_symbol
* sym
)
670 if (sym
->attr
.generic
)
673 gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
676 expr
->value
.function
.name
= s
->name
;
677 expr
->value
.function
.esym
= s
;
680 expr
->rank
= s
->as
->rank
;
684 /* TODO: Need to search for elemental references in generic interface */
687 if (sym
->attr
.intrinsic
)
688 return gfc_intrinsic_func_interface (expr
, 0);
695 resolve_generic_f (gfc_expr
* expr
)
700 sym
= expr
->symtree
->n
.sym
;
704 m
= resolve_generic_f0 (expr
, sym
);
707 else if (m
== MATCH_ERROR
)
711 if (sym
->ns
->parent
== NULL
)
713 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
717 if (!generic_sym (sym
))
721 /* Last ditch attempt. */
723 if (!gfc_generic_intrinsic (expr
->symtree
->n
.sym
->name
))
725 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
726 expr
->symtree
->n
.sym
->name
, &expr
->where
);
730 m
= gfc_intrinsic_func_interface (expr
, 0);
735 ("Generic function '%s' at %L is not consistent with a specific "
736 "intrinsic interface", expr
->symtree
->n
.sym
->name
, &expr
->where
);
742 /* Resolve a function call known to be specific. */
745 resolve_specific_f0 (gfc_symbol
* sym
, gfc_expr
* expr
)
749 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
753 sym
->attr
.proc
= PROC_DUMMY
;
757 sym
->attr
.proc
= PROC_EXTERNAL
;
761 if (sym
->attr
.proc
== PROC_MODULE
762 || sym
->attr
.proc
== PROC_ST_FUNCTION
763 || sym
->attr
.proc
== PROC_INTERNAL
)
766 if (sym
->attr
.intrinsic
)
768 m
= gfc_intrinsic_func_interface (expr
, 1);
773 ("Function '%s' at %L is INTRINSIC but is not compatible with "
774 "an intrinsic", sym
->name
, &expr
->where
);
782 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
785 expr
->value
.function
.name
= sym
->name
;
786 expr
->value
.function
.esym
= sym
;
788 expr
->rank
= sym
->as
->rank
;
795 resolve_specific_f (gfc_expr
* expr
)
800 sym
= expr
->symtree
->n
.sym
;
804 m
= resolve_specific_f0 (sym
, expr
);
807 if (m
== MATCH_ERROR
)
810 if (sym
->ns
->parent
== NULL
)
813 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
819 gfc_error ("Unable to resolve the specific function '%s' at %L",
820 expr
->symtree
->n
.sym
->name
, &expr
->where
);
826 /* Resolve a procedure call not known to be generic nor specific. */
829 resolve_unknown_f (gfc_expr
* expr
)
834 sym
= expr
->symtree
->n
.sym
;
838 sym
->attr
.proc
= PROC_DUMMY
;
839 expr
->value
.function
.name
= sym
->name
;
843 /* See if we have an intrinsic function reference. */
845 if (gfc_intrinsic_name (sym
->name
, 0))
847 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
852 /* The reference is to an external name. */
854 sym
->attr
.proc
= PROC_EXTERNAL
;
855 expr
->value
.function
.name
= sym
->name
;
856 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
859 expr
->rank
= sym
->as
->rank
;
861 /* Type of the expression is either the type of the symbol or the
862 default type of the symbol. */
865 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
867 if (sym
->ts
.type
!= BT_UNKNOWN
)
871 ts
= gfc_get_default_type (sym
, sym
->ns
);
873 if (ts
->type
== BT_UNKNOWN
)
875 gfc_error ("Function '%s' at %L has no implicit type",
876 sym
->name
, &expr
->where
);
887 /* Figure out if a function reference is pure or not. Also set the name
888 of the function for a potential error message. Return nonzero if the
889 function is PURE, zero if not. */
892 pure_function (gfc_expr
* e
, const char **name
)
896 if (e
->value
.function
.esym
)
898 pure
= gfc_pure (e
->value
.function
.esym
);
899 *name
= e
->value
.function
.esym
->name
;
901 else if (e
->value
.function
.isym
)
903 pure
= e
->value
.function
.isym
->pure
904 || e
->value
.function
.isym
->elemental
;
905 *name
= e
->value
.function
.isym
->name
;
909 /* Implicit functions are not pure. */
911 *name
= e
->value
.function
.name
;
918 /* Resolve a function call, which means resolving the arguments, then figuring
919 out which entity the name refers to. */
920 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
921 to INTENT(OUT) or INTENT(INOUT). */
924 resolve_function (gfc_expr
* expr
)
926 gfc_actual_arglist
*arg
;
930 if (resolve_actual_arglist (expr
->value
.function
.actual
) == FAILURE
)
933 /* See if function is already resolved. */
935 if (expr
->value
.function
.name
!= NULL
)
937 if (expr
->ts
.type
== BT_UNKNOWN
)
938 expr
->ts
= expr
->symtree
->n
.sym
->ts
;
943 /* Apply the rules of section 14.1.2. */
945 switch (procedure_kind (expr
->symtree
->n
.sym
))
948 t
= resolve_generic_f (expr
);
952 t
= resolve_specific_f (expr
);
956 t
= resolve_unknown_f (expr
);
960 gfc_internal_error ("resolve_function(): bad function type");
964 /* If the expression is still a function (it might have simplified),
965 then we check to see if we are calling an elemental function. */
967 if (expr
->expr_type
!= EXPR_FUNCTION
)
970 if (expr
->value
.function
.actual
!= NULL
971 && ((expr
->value
.function
.esym
!= NULL
972 && expr
->value
.function
.esym
->attr
.elemental
)
973 || (expr
->value
.function
.isym
!= NULL
974 && expr
->value
.function
.isym
->elemental
)))
977 /* The rank of an elemental is the rank of its array argument(s). */
979 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
981 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
983 expr
->rank
= arg
->expr
->rank
;
989 if (!pure_function (expr
, &name
))
994 ("Function reference to '%s' at %L is inside a FORALL block",
998 else if (gfc_pure (NULL
))
1000 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1001 "procedure within a PURE procedure", name
, &expr
->where
);
1010 /************* Subroutine resolution *************/
1013 pure_subroutine (gfc_code
* c
, gfc_symbol
* sym
)
1020 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1021 sym
->name
, &c
->loc
);
1022 else if (gfc_pure (NULL
))
1023 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1029 resolve_generic_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1033 if (sym
->attr
.generic
)
1035 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1038 c
->resolved_sym
= s
;
1039 pure_subroutine (c
, s
);
1043 /* TODO: Need to search for elemental references in generic interface. */
1046 if (sym
->attr
.intrinsic
)
1047 return gfc_intrinsic_sub_interface (c
, 0);
1054 resolve_generic_s (gfc_code
* c
)
1059 sym
= c
->symtree
->n
.sym
;
1061 m
= resolve_generic_s0 (c
, sym
);
1064 if (m
== MATCH_ERROR
)
1067 if (sym
->ns
->parent
!= NULL
)
1069 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1072 m
= resolve_generic_s0 (c
, sym
);
1075 if (m
== MATCH_ERROR
)
1080 /* Last ditch attempt. */
1082 if (!gfc_generic_intrinsic (sym
->name
))
1085 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1086 sym
->name
, &c
->loc
);
1090 m
= gfc_intrinsic_sub_interface (c
, 0);
1094 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1095 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1101 /* Resolve a subroutine call known to be specific. */
1104 resolve_specific_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1108 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1110 if (sym
->attr
.dummy
)
1112 sym
->attr
.proc
= PROC_DUMMY
;
1116 sym
->attr
.proc
= PROC_EXTERNAL
;
1120 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1123 if (sym
->attr
.intrinsic
)
1125 m
= gfc_intrinsic_sub_interface (c
, 1);
1129 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1130 "with an intrinsic", sym
->name
, &c
->loc
);
1138 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1140 c
->resolved_sym
= sym
;
1141 pure_subroutine (c
, sym
);
1148 resolve_specific_s (gfc_code
* c
)
1153 sym
= c
->symtree
->n
.sym
;
1155 m
= resolve_specific_s0 (c
, sym
);
1158 if (m
== MATCH_ERROR
)
1161 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1165 m
= resolve_specific_s0 (c
, sym
);
1168 if (m
== MATCH_ERROR
)
1172 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1173 sym
->name
, &c
->loc
);
1179 /* Resolve a subroutine call not known to be generic nor specific. */
1182 resolve_unknown_s (gfc_code
* c
)
1186 sym
= c
->symtree
->n
.sym
;
1188 if (sym
->attr
.dummy
)
1190 sym
->attr
.proc
= PROC_DUMMY
;
1194 /* See if we have an intrinsic function reference. */
1196 if (gfc_intrinsic_name (sym
->name
, 1))
1198 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1203 /* The reference is to an external name. */
1206 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1208 c
->resolved_sym
= sym
;
1210 pure_subroutine (c
, sym
);
1216 /* Resolve a subroutine call. Although it was tempting to use the same code
1217 for functions, subroutines and functions are stored differently and this
1218 makes things awkward. */
1221 resolve_call (gfc_code
* c
)
1225 if (resolve_actual_arglist (c
->ext
.actual
) == FAILURE
)
1228 if (c
->resolved_sym
!= NULL
)
1231 switch (procedure_kind (c
->symtree
->n
.sym
))
1234 t
= resolve_generic_s (c
);
1237 case PTYPE_SPECIFIC
:
1238 t
= resolve_specific_s (c
);
1242 t
= resolve_unknown_s (c
);
1246 gfc_internal_error ("resolve_subroutine(): bad function type");
1252 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1253 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1254 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1255 if their shapes do not match. If either op1->shape or op2->shape is
1256 NULL, return SUCCESS. */
1259 compare_shapes (gfc_expr
* op1
, gfc_expr
* op2
)
1266 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
1268 for (i
= 0; i
< op1
->rank
; i
++)
1270 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
1272 gfc_error ("Shapes for operands at %L and %L are not conformable",
1273 &op1
->where
, &op2
->where
);
1283 /* Resolve an operator expression node. This can involve replacing the
1284 operation with a user defined function call. */
1287 resolve_operator (gfc_expr
* e
)
1289 gfc_expr
*op1
, *op2
;
1293 /* Resolve all subnodes-- give them types. */
1295 switch (e
->value
.op
.operator)
1298 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
1301 /* Fall through... */
1304 case INTRINSIC_UPLUS
:
1305 case INTRINSIC_UMINUS
:
1306 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
1311 /* Typecheck the new node. */
1313 op1
= e
->value
.op
.op1
;
1314 op2
= e
->value
.op
.op2
;
1316 switch (e
->value
.op
.operator)
1318 case INTRINSIC_UPLUS
:
1319 case INTRINSIC_UMINUS
:
1320 if (op1
->ts
.type
== BT_INTEGER
1321 || op1
->ts
.type
== BT_REAL
1322 || op1
->ts
.type
== BT_COMPLEX
)
1328 sprintf (msg
, "Operand of unary numeric operator '%s' at %%L is %s",
1329 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
1332 case INTRINSIC_PLUS
:
1333 case INTRINSIC_MINUS
:
1334 case INTRINSIC_TIMES
:
1335 case INTRINSIC_DIVIDE
:
1336 case INTRINSIC_POWER
:
1337 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1339 gfc_type_convert_binary (e
);
1344 "Operands of binary numeric operator '%s' at %%L are %s/%s",
1345 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1346 gfc_typename (&op2
->ts
));
1349 case INTRINSIC_CONCAT
:
1350 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1352 e
->ts
.type
= BT_CHARACTER
;
1353 e
->ts
.kind
= op1
->ts
.kind
;
1358 "Operands of string concatenation operator at %%L are %s/%s",
1359 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
1365 case INTRINSIC_NEQV
:
1366 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
1368 e
->ts
.type
= BT_LOGICAL
;
1369 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
1370 if (op1
->ts
.kind
< e
->ts
.kind
)
1371 gfc_convert_type (op1
, &e
->ts
, 2);
1372 else if (op2
->ts
.kind
< e
->ts
.kind
)
1373 gfc_convert_type (op2
, &e
->ts
, 2);
1377 sprintf (msg
, "Operands of logical operator '%s' at %%L are %s/%s",
1378 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1379 gfc_typename (&op2
->ts
));
1384 if (op1
->ts
.type
== BT_LOGICAL
)
1386 e
->ts
.type
= BT_LOGICAL
;
1387 e
->ts
.kind
= op1
->ts
.kind
;
1391 sprintf (msg
, "Operand of .NOT. operator at %%L is %s",
1392 gfc_typename (&op1
->ts
));
1399 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1401 strcpy (msg
, "COMPLEX quantities cannot be compared at %L");
1405 /* Fall through... */
1409 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1411 e
->ts
.type
= BT_LOGICAL
;
1412 e
->ts
.kind
= gfc_default_logical_kind
;
1416 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1418 gfc_type_convert_binary (e
);
1420 e
->ts
.type
= BT_LOGICAL
;
1421 e
->ts
.kind
= gfc_default_logical_kind
;
1425 sprintf (msg
, "Operands of comparison operator '%s' at %%L are %s/%s",
1426 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1427 gfc_typename (&op2
->ts
));
1431 case INTRINSIC_USER
:
1433 sprintf (msg
, "Operand of user operator '%s' at %%L is %s",
1434 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
1436 sprintf (msg
, "Operands of user operator '%s' at %%L are %s/%s",
1437 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
1438 gfc_typename (&op2
->ts
));
1443 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1446 /* Deal with arrayness of an operand through an operator. */
1450 switch (e
->value
.op
.operator)
1452 case INTRINSIC_PLUS
:
1453 case INTRINSIC_MINUS
:
1454 case INTRINSIC_TIMES
:
1455 case INTRINSIC_DIVIDE
:
1456 case INTRINSIC_POWER
:
1457 case INTRINSIC_CONCAT
:
1461 case INTRINSIC_NEQV
:
1469 if (op1
->rank
== 0 && op2
->rank
== 0)
1472 if (op1
->rank
== 0 && op2
->rank
!= 0)
1474 e
->rank
= op2
->rank
;
1476 if (e
->shape
== NULL
)
1477 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1480 if (op1
->rank
!= 0 && op2
->rank
== 0)
1482 e
->rank
= op1
->rank
;
1484 if (e
->shape
== NULL
)
1485 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1488 if (op1
->rank
!= 0 && op2
->rank
!= 0)
1490 if (op1
->rank
== op2
->rank
)
1492 e
->rank
= op1
->rank
;
1493 if (e
->shape
== NULL
)
1495 t
= compare_shapes(op1
, op2
);
1499 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1504 gfc_error ("Inconsistent ranks for operator at %L and %L",
1505 &op1
->where
, &op2
->where
);
1508 /* Allow higher level expressions to work. */
1516 case INTRINSIC_UPLUS
:
1517 case INTRINSIC_UMINUS
:
1518 e
->rank
= op1
->rank
;
1520 if (e
->shape
== NULL
)
1521 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1523 /* Simply copy arrayness attribute */
1530 /* Attempt to simplify the expression. */
1532 t
= gfc_simplify_expr (e
, 0);
1537 if (gfc_extend_expr (e
) == SUCCESS
)
1540 gfc_error (msg
, &e
->where
);
1546 /************** Array resolution subroutines **************/
1550 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
1553 /* Compare two integer expressions. */
1556 compare_bound (gfc_expr
* a
, gfc_expr
* b
)
1560 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
1561 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
1564 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
1565 gfc_internal_error ("compare_bound(): Bad expression");
1567 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
1577 /* Compare an integer expression with an integer. */
1580 compare_bound_int (gfc_expr
* a
, int b
)
1584 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
1587 if (a
->ts
.type
!= BT_INTEGER
)
1588 gfc_internal_error ("compare_bound_int(): Bad expression");
1590 i
= mpz_cmp_si (a
->value
.integer
, b
);
1600 /* Compare a single dimension of an array reference to the array
1604 check_dimension (int i
, gfc_array_ref
* ar
, gfc_array_spec
* as
)
1607 /* Given start, end and stride values, calculate the minimum and
1608 maximum referenced indexes. */
1616 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1618 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1624 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
1626 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
1630 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1632 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1635 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1636 it is legal (see 6.2.2.3.1). */
1641 gfc_internal_error ("check_dimension(): Bad array reference");
1647 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
1652 /* Compare an array reference with an array specification. */
1655 compare_spec_to_ref (gfc_array_ref
* ar
)
1662 /* TODO: Full array sections are only allowed as actual parameters. */
1663 if (as
->type
== AS_ASSUMED_SIZE
1664 && (/*ar->type == AR_FULL
1665 ||*/ (ar
->type
== AR_SECTION
1666 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
1668 gfc_error ("Rightmost upper bound of assumed size array section"
1669 " not specified at %L", &ar
->where
);
1673 if (ar
->type
== AR_FULL
)
1676 if (as
->rank
!= ar
->dimen
)
1678 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1679 &ar
->where
, ar
->dimen
, as
->rank
);
1683 for (i
= 0; i
< as
->rank
; i
++)
1684 if (check_dimension (i
, ar
, as
) == FAILURE
)
1691 /* Resolve one part of an array index. */
1694 gfc_resolve_index (gfc_expr
* index
, int check_scalar
)
1701 if (gfc_resolve_expr (index
) == FAILURE
)
1704 if (check_scalar
&& index
->rank
!= 0)
1706 gfc_error ("Array index at %L must be scalar", &index
->where
);
1710 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
1712 gfc_error ("Array index at %L must be of INTEGER type",
1717 if (index
->ts
.type
== BT_REAL
)
1718 if (gfc_notify_std (GFC_STD_GNU
, "Extension: REAL array index at %L",
1719 &index
->where
) == FAILURE
)
1722 if (index
->ts
.kind
!= gfc_index_integer_kind
1723 || index
->ts
.type
!= BT_INTEGER
)
1725 ts
.type
= BT_INTEGER
;
1726 ts
.kind
= gfc_index_integer_kind
;
1728 gfc_convert_type_warn (index
, &ts
, 2, 0);
1735 /* Given an expression that contains array references, update those array
1736 references to point to the right array specifications. While this is
1737 filled in during matching, this information is difficult to save and load
1738 in a module, so we take care of it here.
1740 The idea here is that the original array reference comes from the
1741 base symbol. We traverse the list of reference structures, setting
1742 the stored reference to references. Component references can
1743 provide an additional array specification. */
1746 find_array_spec (gfc_expr
* e
)
1752 as
= e
->symtree
->n
.sym
->as
;
1753 c
= e
->symtree
->n
.sym
->components
;
1755 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1760 gfc_internal_error ("find_array_spec(): Missing spec");
1767 for (; c
; c
= c
->next
)
1768 if (c
== ref
->u
.c
.component
)
1772 gfc_internal_error ("find_array_spec(): Component not found");
1777 gfc_internal_error ("find_array_spec(): unused as(1)");
1781 c
= c
->ts
.derived
->components
;
1789 gfc_internal_error ("find_array_spec(): unused as(2)");
1793 /* Resolve an array reference. */
1796 resolve_array_ref (gfc_array_ref
* ar
)
1798 int i
, check_scalar
;
1800 for (i
= 0; i
< ar
->dimen
; i
++)
1802 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
1804 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
1806 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
1808 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
1811 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
1812 switch (ar
->start
[i
]->rank
)
1815 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
1819 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
1823 gfc_error ("Array index at %L is an array of rank %d",
1824 &ar
->c_where
[i
], ar
->start
[i
]->rank
);
1829 /* If the reference type is unknown, figure out what kind it is. */
1831 if (ar
->type
== AR_UNKNOWN
)
1833 ar
->type
= AR_ELEMENT
;
1834 for (i
= 0; i
< ar
->dimen
; i
++)
1835 if (ar
->dimen_type
[i
] == DIMEN_RANGE
1836 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
1838 ar
->type
= AR_SECTION
;
1843 if (compare_spec_to_ref (ar
) == FAILURE
)
1851 resolve_substring (gfc_ref
* ref
)
1854 if (ref
->u
.ss
.start
!= NULL
)
1856 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
1859 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
1861 gfc_error ("Substring start index at %L must be of type INTEGER",
1862 &ref
->u
.ss
.start
->where
);
1866 if (ref
->u
.ss
.start
->rank
!= 0)
1868 gfc_error ("Substring start index at %L must be scalar",
1869 &ref
->u
.ss
.start
->where
);
1873 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
)
1875 gfc_error ("Substring start index at %L is less than one",
1876 &ref
->u
.ss
.start
->where
);
1881 if (ref
->u
.ss
.end
!= NULL
)
1883 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
1886 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
1888 gfc_error ("Substring end index at %L must be of type INTEGER",
1889 &ref
->u
.ss
.end
->where
);
1893 if (ref
->u
.ss
.end
->rank
!= 0)
1895 gfc_error ("Substring end index at %L must be scalar",
1896 &ref
->u
.ss
.end
->where
);
1900 if (ref
->u
.ss
.length
!= NULL
1901 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
)
1903 gfc_error ("Substring end index at %L is out of bounds",
1904 &ref
->u
.ss
.start
->where
);
1913 /* Resolve subtype references. */
1916 resolve_ref (gfc_expr
* expr
)
1918 int current_part_dimension
, n_components
, seen_part_dimension
;
1921 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1922 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
1924 find_array_spec (expr
);
1928 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1932 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
1940 resolve_substring (ref
);
1944 /* Check constraints on part references. */
1946 current_part_dimension
= 0;
1947 seen_part_dimension
= 0;
1950 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1955 switch (ref
->u
.ar
.type
)
1959 current_part_dimension
= 1;
1963 current_part_dimension
= 0;
1967 gfc_internal_error ("resolve_ref(): Bad array reference");
1973 if ((current_part_dimension
|| seen_part_dimension
)
1974 && ref
->u
.c
.component
->pointer
)
1977 ("Component to the right of a part reference with nonzero "
1978 "rank must not have the POINTER attribute at %L",
1990 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
1991 || ref
->next
== NULL
)
1992 && current_part_dimension
1993 && seen_part_dimension
)
1996 gfc_error ("Two or more part references with nonzero rank must "
1997 "not be specified at %L", &expr
->where
);
2001 if (ref
->type
== REF_COMPONENT
)
2003 if (current_part_dimension
)
2004 seen_part_dimension
= 1;
2006 /* reset to make sure */
2007 current_part_dimension
= 0;
2015 /* Given an expression, determine its shape. This is easier than it sounds.
2016 Leaves the shape array NULL if it is not possible to determine the shape. */
2019 expression_shape (gfc_expr
* e
)
2021 mpz_t array
[GFC_MAX_DIMENSIONS
];
2024 if (e
->rank
== 0 || e
->shape
!= NULL
)
2027 for (i
= 0; i
< e
->rank
; i
++)
2028 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2031 e
->shape
= gfc_get_shape (e
->rank
);
2033 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
2038 for (i
--; i
>= 0; i
--)
2039 mpz_clear (array
[i
]);
2043 /* Given a variable expression node, compute the rank of the expression by
2044 examining the base symbol and any reference structures it may have. */
2047 expression_rank (gfc_expr
* e
)
2054 if (e
->expr_type
== EXPR_ARRAY
)
2056 /* Constructors can have a rank different from one via RESHAPE(). */
2058 if (e
->symtree
== NULL
)
2064 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
2065 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
2071 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2073 if (ref
->type
!= REF_ARRAY
)
2076 if (ref
->u
.ar
.type
== AR_FULL
)
2078 rank
= ref
->u
.ar
.as
->rank
;
2082 if (ref
->u
.ar
.type
== AR_SECTION
)
2084 /* Figure out the rank of the section. */
2086 gfc_internal_error ("expression_rank(): Two array specs");
2088 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2089 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
2090 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2100 expression_shape (e
);
2104 /* Resolve a variable expression. */
2107 resolve_variable (gfc_expr
* e
)
2111 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
2114 sym
= e
->symtree
->n
.sym
;
2115 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2117 e
->ts
.type
= BT_PROCEDURE
;
2121 if (sym
->ts
.type
!= BT_UNKNOWN
)
2122 gfc_variable_attr (e
, &e
->ts
);
2125 /* Must be a simple variable reference. */
2126 if (gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2135 /* Resolve an expression. That is, make sure that types of operands agree
2136 with their operators, intrinsic operators are converted to function calls
2137 for overloaded types and unresolved function references are resolved. */
2140 gfc_resolve_expr (gfc_expr
* e
)
2147 switch (e
->expr_type
)
2150 t
= resolve_operator (e
);
2154 t
= resolve_function (e
);
2158 t
= resolve_variable (e
);
2160 expression_rank (e
);
2163 case EXPR_SUBSTRING
:
2164 t
= resolve_ref (e
);
2174 if (resolve_ref (e
) == FAILURE
)
2177 t
= gfc_resolve_array_constructor (e
);
2178 /* Also try to expand a constructor. */
2181 expression_rank (e
);
2182 gfc_expand_constructor (e
);
2187 case EXPR_STRUCTURE
:
2188 t
= resolve_ref (e
);
2192 t
= resolve_structure_cons (e
);
2196 t
= gfc_simplify_expr (e
, 0);
2200 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2207 /* Resolve an expression from an iterator. They must be scalar and have
2208 INTEGER or (optionally) REAL type. */
2211 gfc_resolve_iterator_expr (gfc_expr
* expr
, bool real_ok
, const char * name
)
2213 if (gfc_resolve_expr (expr
) == FAILURE
)
2216 if (expr
->rank
!= 0)
2218 gfc_error ("%s at %L must be a scalar", name
, &expr
->where
);
2222 if (!(expr
->ts
.type
== BT_INTEGER
2223 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
2225 gfc_error ("%s at %L must be INTEGER%s",
2228 real_ok
? " or REAL" : "");
2235 /* Resolve the expressions in an iterator structure. If REAL_OK is
2236 false allow only INTEGER type iterators, otherwise allow REAL types. */
2239 gfc_resolve_iterator (gfc_iterator
* iter
, bool real_ok
)
2242 if (iter
->var
->ts
.type
== BT_REAL
)
2243 gfc_notify_std (GFC_STD_F95_DEL
,
2244 "Obsolete: REAL DO loop iterator at %L",
2247 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
2251 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
2253 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2258 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
2259 "Start expression in DO loop") == FAILURE
)
2262 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
2263 "End expression in DO loop") == FAILURE
)
2266 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
2267 "Step expression in DO loop") == FAILURE
)
2270 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
2272 if ((iter
->step
->ts
.type
== BT_INTEGER
2273 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
2274 || (iter
->step
->ts
.type
== BT_REAL
2275 && mpfr_sgn (iter
->step
->value
.real
) == 0))
2277 gfc_error ("Step expression in DO loop at %L cannot be zero",
2278 &iter
->step
->where
);
2283 /* Convert start, end, and step to the same type as var. */
2284 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
2285 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
2286 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2288 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
2289 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
2290 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2292 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
2293 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
2294 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
2300 /* Resolve a list of FORALL iterators. */
2303 resolve_forall_iterators (gfc_forall_iterator
* iter
)
2308 if (gfc_resolve_expr (iter
->var
) == SUCCESS
2309 && iter
->var
->ts
.type
!= BT_INTEGER
)
2310 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2313 if (gfc_resolve_expr (iter
->start
) == SUCCESS
2314 && iter
->start
->ts
.type
!= BT_INTEGER
)
2315 gfc_error ("FORALL start expression at %L must be INTEGER",
2316 &iter
->start
->where
);
2317 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
2318 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2320 if (gfc_resolve_expr (iter
->end
) == SUCCESS
2321 && iter
->end
->ts
.type
!= BT_INTEGER
)
2322 gfc_error ("FORALL end expression at %L must be INTEGER",
2324 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
2325 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2327 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
2328 && iter
->stride
->ts
.type
!= BT_INTEGER
)
2329 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2330 &iter
->stride
->where
);
2331 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
2332 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
2339 /* Given a pointer to a symbol that is a derived type, see if any components
2340 have the POINTER attribute. The search is recursive if necessary.
2341 Returns zero if no pointer components are found, nonzero otherwise. */
2344 derived_pointer (gfc_symbol
* sym
)
2348 for (c
= sym
->components
; c
; c
= c
->next
)
2353 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
2361 /* Resolve the argument of a deallocate expression. The expression must be
2362 a pointer or a full array. */
2365 resolve_deallocate_expr (gfc_expr
* e
)
2367 symbol_attribute attr
;
2371 if (gfc_resolve_expr (e
) == FAILURE
)
2374 attr
= gfc_expr_attr (e
);
2378 if (e
->expr_type
!= EXPR_VARIABLE
)
2381 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2382 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2386 if (ref
->u
.ar
.type
!= AR_FULL
)
2391 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2392 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2400 if (allocatable
== 0)
2403 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2404 "ALLOCATABLE or a POINTER", &e
->where
);
2411 /* Resolve the expression in an ALLOCATE statement, doing the additional
2412 checks to see whether the expression is OK or not. The expression must
2413 have a trailing array reference that gives the size of the array. */
2416 resolve_allocate_expr (gfc_expr
* e
)
2418 int i
, pointer
, allocatable
, dimension
;
2419 symbol_attribute attr
;
2420 gfc_ref
*ref
, *ref2
;
2423 if (gfc_resolve_expr (e
) == FAILURE
)
2426 /* Make sure the expression is allocatable or a pointer. If it is
2427 pointer, the next-to-last reference must be a pointer. */
2431 if (e
->expr_type
!= EXPR_VARIABLE
)
2435 attr
= gfc_expr_attr (e
);
2436 pointer
= attr
.pointer
;
2437 dimension
= attr
.dimension
;
2442 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2443 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
2444 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
2446 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
2450 if (ref
->next
!= NULL
)
2455 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2456 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2458 pointer
= ref
->u
.c
.component
->pointer
;
2459 dimension
= ref
->u
.c
.component
->dimension
;
2469 if (allocatable
== 0 && pointer
== 0)
2471 gfc_error ("Expression in ALLOCATE statement at %L must be "
2472 "ALLOCATABLE or a POINTER", &e
->where
);
2476 if (pointer
&& dimension
== 0)
2479 /* Make sure the next-to-last reference node is an array specification. */
2481 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
2483 gfc_error ("Array specification required in ALLOCATE statement "
2484 "at %L", &e
->where
);
2488 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
2491 /* Make sure that the array section reference makes sense in the
2492 context of an ALLOCATE specification. */
2496 for (i
= 0; i
< ar
->dimen
; i
++)
2497 switch (ar
->dimen_type
[i
])
2503 if (ar
->start
[i
] != NULL
2504 && ar
->end
[i
] != NULL
2505 && ar
->stride
[i
] == NULL
)
2508 /* Fall Through... */
2512 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2521 /************ SELECT CASE resolution subroutines ************/
2523 /* Callback function for our mergesort variant. Determines interval
2524 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2525 op1 > op2. Assumes we're not dealing with the default case.
2526 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2527 There are nine situations to check. */
2530 compare_cases (const gfc_case
* op1
, const gfc_case
* op2
)
2534 if (op1
->low
== NULL
) /* op1 = (:L) */
2536 /* op2 = (:N), so overlap. */
2538 /* op2 = (M:) or (M:N), L < M */
2539 if (op2
->low
!= NULL
2540 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2543 else if (op1
->high
== NULL
) /* op1 = (K:) */
2545 /* op2 = (M:), so overlap. */
2547 /* op2 = (:N) or (M:N), K > N */
2548 if (op2
->high
!= NULL
2549 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2552 else /* op1 = (K:L) */
2554 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
2555 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
2556 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
2557 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
2558 else /* op2 = (M:N) */
2562 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2565 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2574 /* Merge-sort a double linked case list, detecting overlap in the
2575 process. LIST is the head of the double linked case list before it
2576 is sorted. Returns the head of the sorted list if we don't see any
2577 overlap, or NULL otherwise. */
2580 check_case_overlap (gfc_case
* list
)
2582 gfc_case
*p
, *q
, *e
, *tail
;
2583 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
2585 /* If the passed list was empty, return immediately. */
2592 /* Loop unconditionally. The only exit from this loop is a return
2593 statement, when we've finished sorting the case list. */
2600 /* Count the number of merges we do in this pass. */
2603 /* Loop while there exists a merge to be done. */
2608 /* Count this merge. */
2611 /* Cut the list in two pieces by stepping INSIZE places
2612 forward in the list, starting from P. */
2615 for (i
= 0; i
< insize
; i
++)
2624 /* Now we have two lists. Merge them! */
2625 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
2628 /* See from which the next case to merge comes from. */
2631 /* P is empty so the next case must come from Q. */
2636 else if (qsize
== 0 || q
== NULL
)
2645 cmp
= compare_cases (p
, q
);
2648 /* The whole case range for P is less than the
2656 /* The whole case range for Q is greater than
2657 the case range for P. */
2664 /* The cases overlap, or they are the same
2665 element in the list. Either way, we must
2666 issue an error and get the next case from P. */
2667 /* FIXME: Sort P and Q by line number. */
2668 gfc_error ("CASE label at %L overlaps with CASE "
2669 "label at %L", &p
->where
, &q
->where
);
2677 /* Add the next element to the merged list. */
2686 /* P has now stepped INSIZE places along, and so has Q. So
2687 they're the same. */
2692 /* If we have done only one merge or none at all, we've
2693 finished sorting the cases. */
2702 /* Otherwise repeat, merging lists twice the size. */
2708 /* Check to see if an expression is suitable for use in a CASE statement.
2709 Makes sure that all case expressions are scalar constants of the same
2710 type. Return FAILURE if anything is wrong. */
2713 validate_case_label_expr (gfc_expr
* e
, gfc_expr
* case_expr
)
2715 if (e
== NULL
) return SUCCESS
;
2717 if (e
->ts
.type
!= case_expr
->ts
.type
)
2719 gfc_error ("Expression in CASE statement at %L must be of type %s",
2720 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
2724 /* C805 (R808) For a given case-construct, each case-value shall be of
2725 the same type as case-expr. For character type, length differences
2726 are allowed, but the kind type parameters shall be the same. */
2728 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
2730 gfc_error("Expression in CASE statement at %L must be kind %d",
2731 &e
->where
, case_expr
->ts
.kind
);
2735 /* Convert the case value kind to that of case expression kind, if needed.
2736 FIXME: Should a warning be issued? */
2737 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
2738 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
2742 gfc_error ("Expression in CASE statement at %L must be scalar",
2751 /* Given a completely parsed select statement, we:
2753 - Validate all expressions and code within the SELECT.
2754 - Make sure that the selection expression is not of the wrong type.
2755 - Make sure that no case ranges overlap.
2756 - Eliminate unreachable cases and unreachable code resulting from
2757 removing case labels.
2759 The standard does allow unreachable cases, e.g. CASE (5:3). But
2760 they are a hassle for code generation, and to prevent that, we just
2761 cut them out here. This is not necessary for overlapping cases
2762 because they are illegal and we never even try to generate code.
2764 We have the additional caveat that a SELECT construct could have
2765 been a computed GOTO in the source code. Fortunately we can fairly
2766 easily work around that here: The case_expr for a "real" SELECT CASE
2767 is in code->expr1, but for a computed GOTO it is in code->expr2. All
2768 we have to do is make sure that the case_expr is a scalar integer
2772 resolve_select (gfc_code
* code
)
2775 gfc_expr
*case_expr
;
2776 gfc_case
*cp
, *default_case
, *tail
, *head
;
2777 int seen_unreachable
;
2782 if (code
->expr
== NULL
)
2784 /* This was actually a computed GOTO statement. */
2785 case_expr
= code
->expr2
;
2786 if (case_expr
->ts
.type
!= BT_INTEGER
2787 || case_expr
->rank
!= 0)
2788 gfc_error ("Selection expression in computed GOTO statement "
2789 "at %L must be a scalar integer expression",
2792 /* Further checking is not necessary because this SELECT was built
2793 by the compiler, so it should always be OK. Just move the
2794 case_expr from expr2 to expr so that we can handle computed
2795 GOTOs as normal SELECTs from here on. */
2796 code
->expr
= code
->expr2
;
2801 case_expr
= code
->expr
;
2803 type
= case_expr
->ts
.type
;
2804 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
2806 gfc_error ("Argument of SELECT statement at %L cannot be %s",
2807 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
2809 /* Punt. Going on here just produce more garbage error messages. */
2813 if (case_expr
->rank
!= 0)
2815 gfc_error ("Argument of SELECT statement at %L must be a scalar "
2816 "expression", &case_expr
->where
);
2822 /* PR 19168 has a long discussion concerning a mismatch of the kinds
2823 of the SELECT CASE expression and its CASE values. Walk the lists
2824 of case values, and if we find a mismatch, promote case_expr to
2825 the appropriate kind. */
2827 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
2829 for (body
= code
->block
; body
; body
= body
->block
)
2831 /* Walk the case label list. */
2832 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
2834 /* Intercept the DEFAULT case. It does not have a kind. */
2835 if (cp
->low
== NULL
&& cp
->high
== NULL
)
2838 /* Unreachable case ranges are discarded, so ignore. */
2839 if (cp
->low
!= NULL
&& cp
->high
!= NULL
2840 && cp
->low
!= cp
->high
2841 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
2844 /* FIXME: Should a warning be issued? */
2846 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
2847 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
2849 if (cp
->high
!= NULL
2850 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
2851 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
2856 /* Assume there is no DEFAULT case. */
2857 default_case
= NULL
;
2861 for (body
= code
->block
; body
; body
= body
->block
)
2863 /* Assume the CASE list is OK, and all CASE labels can be matched. */
2865 seen_unreachable
= 0;
2867 /* Walk the case label list, making sure that all case labels
2869 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
2871 /* Count the number of cases in the whole construct. */
2874 /* Intercept the DEFAULT case. */
2875 if (cp
->low
== NULL
&& cp
->high
== NULL
)
2877 if (default_case
!= NULL
)
2879 gfc_error ("The DEFAULT CASE at %L cannot be followed "
2880 "by a second DEFAULT CASE at %L",
2881 &default_case
->where
, &cp
->where
);
2892 /* Deal with single value cases and case ranges. Errors are
2893 issued from the validation function. */
2894 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
2895 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
2901 if (type
== BT_LOGICAL
2902 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
2903 || cp
->low
!= cp
->high
))
2906 ("Logical range in CASE statement at %L is not allowed",
2912 if (cp
->low
!= NULL
&& cp
->high
!= NULL
2913 && cp
->low
!= cp
->high
2914 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
2916 if (gfc_option
.warn_surprising
)
2917 gfc_warning ("Range specification at %L can never "
2918 "be matched", &cp
->where
);
2920 cp
->unreachable
= 1;
2921 seen_unreachable
= 1;
2925 /* If the case range can be matched, it can also overlap with
2926 other cases. To make sure it does not, we put it in a
2927 double linked list here. We sort that with a merge sort
2928 later on to detect any overlapping cases. */
2932 head
->right
= head
->left
= NULL
;
2937 tail
->right
->left
= tail
;
2944 /* It there was a failure in the previous case label, give up
2945 for this case label list. Continue with the next block. */
2949 /* See if any case labels that are unreachable have been seen.
2950 If so, we eliminate them. This is a bit of a kludge because
2951 the case lists for a single case statement (label) is a
2952 single forward linked lists. */
2953 if (seen_unreachable
)
2955 /* Advance until the first case in the list is reachable. */
2956 while (body
->ext
.case_list
!= NULL
2957 && body
->ext
.case_list
->unreachable
)
2959 gfc_case
*n
= body
->ext
.case_list
;
2960 body
->ext
.case_list
= body
->ext
.case_list
->next
;
2962 gfc_free_case_list (n
);
2965 /* Strip all other unreachable cases. */
2966 if (body
->ext
.case_list
)
2968 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
2970 if (cp
->next
->unreachable
)
2972 gfc_case
*n
= cp
->next
;
2973 cp
->next
= cp
->next
->next
;
2975 gfc_free_case_list (n
);
2982 /* See if there were overlapping cases. If the check returns NULL,
2983 there was overlap. In that case we don't do anything. If head
2984 is non-NULL, we prepend the DEFAULT case. The sorted list can
2985 then used during code generation for SELECT CASE constructs with
2986 a case expression of a CHARACTER type. */
2989 head
= check_case_overlap (head
);
2991 /* Prepend the default_case if it is there. */
2992 if (head
!= NULL
&& default_case
)
2994 default_case
->left
= NULL
;
2995 default_case
->right
= head
;
2996 head
->left
= default_case
;
3000 /* Eliminate dead blocks that may be the result if we've seen
3001 unreachable case labels for a block. */
3002 for (body
= code
; body
&& body
->block
; body
= body
->block
)
3004 if (body
->block
->ext
.case_list
== NULL
)
3006 /* Cut the unreachable block from the code chain. */
3007 gfc_code
*c
= body
->block
;
3008 body
->block
= c
->block
;
3010 /* Kill the dead block, but not the blocks below it. */
3012 gfc_free_statements (c
);
3016 /* More than two cases is legal but insane for logical selects.
3017 Issue a warning for it. */
3018 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
3020 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3025 /* Resolve a transfer statement. This is making sure that:
3026 -- a derived type being transferred has only non-pointer components
3027 -- a derived type being transferred doesn't have private components
3028 -- we're not trying to transfer a whole assumed size array. */
3031 resolve_transfer (gfc_code
* code
)
3040 if (exp
->expr_type
!= EXPR_VARIABLE
)
3043 sym
= exp
->symtree
->n
.sym
;
3046 /* Go to actual component transferred. */
3047 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
3048 if (ref
->type
== REF_COMPONENT
)
3049 ts
= &ref
->u
.c
.component
->ts
;
3051 if (ts
->type
== BT_DERIVED
)
3053 /* Check that transferred derived type doesn't contain POINTER
3055 if (derived_pointer (ts
->derived
))
3057 gfc_error ("Data transfer element at %L cannot have "
3058 "POINTER components", &code
->loc
);
3062 if (ts
->derived
->component_access
== ACCESS_PRIVATE
)
3064 gfc_error ("Data transfer element at %L cannot have "
3065 "PRIVATE components",&code
->loc
);
3070 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
3071 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
3073 gfc_error ("Data transfer element at %L cannot be a full reference to "
3074 "an assumed-size array", &code
->loc
);
3080 /*********** Toplevel code resolution subroutines ***********/
3082 /* Given a branch to a label and a namespace, if the branch is conforming.
3083 The code node described where the branch is located. */
3086 resolve_branch (gfc_st_label
* label
, gfc_code
* code
)
3088 gfc_code
*block
, *found
;
3096 /* Step one: is this a valid branching target? */
3098 if (lp
->defined
== ST_LABEL_UNKNOWN
)
3100 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
3105 if (lp
->defined
!= ST_LABEL_TARGET
)
3107 gfc_error ("Statement at %L is not a valid branch target statement "
3108 "for the branch statement at %L", &lp
->where
, &code
->loc
);
3112 /* Step two: make sure this branch is not a branch to itself ;-) */
3114 if (code
->here
== label
)
3116 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
3120 /* Step three: Try to find the label in the parse tree. To do this,
3121 we traverse the tree block-by-block: first the block that
3122 contains this GOTO, then the block that it is nested in, etc. We
3123 can ignore other blocks because branching into another block is
3128 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3130 for (block
= stack
->head
; block
; block
= block
->next
)
3132 if (block
->here
== label
)
3145 /* still nothing, so illegal. */
3146 gfc_error_now ("Label at %L is not in the same block as the "
3147 "GOTO statement at %L", &lp
->where
, &code
->loc
);
3151 /* Step four: Make sure that the branching target is legal if
3152 the statement is an END {SELECT,DO,IF}. */
3154 if (found
->op
== EXEC_NOP
)
3156 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3157 if (stack
->current
->next
== found
)
3161 gfc_notify_std (GFC_STD_F95_DEL
,
3162 "Obsolete: GOTO at %L jumps to END of construct at %L",
3163 &code
->loc
, &found
->loc
);
3168 /* Check whether EXPR1 has the same shape as EXPR2. */
3171 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
3173 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3174 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
3175 try result
= FAILURE
;
3178 /* Compare the rank. */
3179 if (expr1
->rank
!= expr2
->rank
)
3182 /* Compare the size of each dimension. */
3183 for (i
=0; i
<expr1
->rank
; i
++)
3185 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
3188 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
3191 if (mpz_cmp (shape
[i
], shape2
[i
]))
3195 /* When either of the two expression is an assumed size array, we
3196 ignore the comparison of dimension sizes. */
3201 for (i
--; i
>=0; i
--)
3203 mpz_clear (shape
[i
]);
3204 mpz_clear (shape2
[i
]);
3210 /* Check whether a WHERE assignment target or a WHERE mask expression
3211 has the same shape as the outmost WHERE mask expression. */
3214 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
3220 cblock
= code
->block
;
3222 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3223 In case of nested WHERE, only the outmost one is stored. */
3224 if (mask
== NULL
) /* outmost WHERE */
3226 else /* inner WHERE */
3233 /* Check if the mask-expr has a consistent shape with the
3234 outmost WHERE mask-expr. */
3235 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
3236 gfc_error ("WHERE mask at %L has inconsistent shape",
3237 &cblock
->expr
->where
);
3240 /* the assignment statement of a WHERE statement, or the first
3241 statement in where-body-construct of a WHERE construct */
3242 cnext
= cblock
->next
;
3247 /* WHERE assignment statement */
3250 /* Check shape consistent for WHERE assignment target. */
3251 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
3252 gfc_error ("WHERE assignment target at %L has "
3253 "inconsistent shape", &cnext
->expr
->where
);
3256 /* WHERE or WHERE construct is part of a where-body-construct */
3258 resolve_where (cnext
, e
);
3262 gfc_error ("Unsupported statement inside WHERE at %L",
3265 /* the next statement within the same where-body-construct */
3266 cnext
= cnext
->next
;
3268 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3269 cblock
= cblock
->block
;
3274 /* Check whether the FORALL index appears in the expression or not. */
3277 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
3281 gfc_actual_arglist
*args
;
3284 switch (expr
->expr_type
)
3287 gcc_assert (expr
->symtree
->n
.sym
);
3289 /* A scalar assignment */
3292 if (expr
->symtree
->n
.sym
== symbol
)
3298 /* the expr is array ref, substring or struct component. */
3305 /* Check if the symbol appears in the array subscript. */
3307 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3310 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
3314 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
3318 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
3324 if (expr
->symtree
->n
.sym
== symbol
)
3327 /* Check if the symbol appears in the substring section. */
3328 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3330 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3338 gfc_error("expresion reference type error at %L", &expr
->where
);
3344 /* If the expression is a function call, then check if the symbol
3345 appears in the actual arglist of the function. */
3347 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3349 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
3354 /* It seems not to happen. */
3355 case EXPR_SUBSTRING
:
3359 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
3360 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3362 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3367 /* It seems not to happen. */
3368 case EXPR_STRUCTURE
:
3370 gfc_error ("Unsupported statement while finding forall index in "
3375 /* Find the FORALL index in the first operand. */
3376 if (expr
->value
.op
.op1
)
3378 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
3382 /* Find the FORALL index in the second operand. */
3383 if (expr
->value
.op
.op2
)
3385 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
3398 /* Resolve assignment in FORALL construct.
3399 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3400 FORALL index variables. */
3403 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3407 for (n
= 0; n
< nvar
; n
++)
3409 gfc_symbol
*forall_index
;
3411 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
3413 /* Check whether the assignment target is one of the FORALL index
3415 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
3416 && (code
->expr
->symtree
->n
.sym
== forall_index
))
3417 gfc_error ("Assignment to a FORALL index variable at %L",
3418 &code
->expr
->where
);
3421 /* If one of the FORALL index variables doesn't appear in the
3422 assignment target, then there will be a many-to-one
3424 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
3425 gfc_error ("The FORALL with index '%s' cause more than one "
3426 "assignment to this object at %L",
3427 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
3433 /* Resolve WHERE statement in FORALL construct. */
3436 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
){
3440 cblock
= code
->block
;
3443 /* the assignment statement of a WHERE statement, or the first
3444 statement in where-body-construct of a WHERE construct */
3445 cnext
= cblock
->next
;
3450 /* WHERE assignment statement */
3452 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
3455 /* WHERE or WHERE construct is part of a where-body-construct */
3457 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
3461 gfc_error ("Unsupported statement inside WHERE at %L",
3464 /* the next statement within the same where-body-construct */
3465 cnext
= cnext
->next
;
3467 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3468 cblock
= cblock
->block
;
3473 /* Traverse the FORALL body to check whether the following errors exist:
3474 1. For assignment, check if a many-to-one assignment happens.
3475 2. For WHERE statement, check the WHERE body to see if there is any
3476 many-to-one assignment. */
3479 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3483 c
= code
->block
->next
;
3489 case EXEC_POINTER_ASSIGN
:
3490 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
3493 /* Because the resolve_blocks() will handle the nested FORALL,
3494 there is no need to handle it here. */
3498 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
3503 /* The next statement in the FORALL body. */
3509 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3510 gfc_resolve_forall_body to resolve the FORALL body. */
3512 static void resolve_blocks (gfc_code
*, gfc_namespace
*);
3515 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
3517 static gfc_expr
**var_expr
;
3518 static int total_var
= 0;
3519 static int nvar
= 0;
3520 gfc_forall_iterator
*fa
;
3521 gfc_symbol
*forall_index
;
3525 /* Start to resolve a FORALL construct */
3526 if (forall_save
== 0)
3528 /* Count the total number of FORALL index in the nested FORALL
3529 construct in order to allocate the VAR_EXPR with proper size. */
3531 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
3533 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3535 next
= next
->block
->next
;
3538 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3539 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
3542 /* The information about FORALL iterator, including FORALL index start, end
3543 and stride. The FORALL index can not appear in start, end or stride. */
3544 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3546 /* Check if any outer FORALL index name is the same as the current
3548 for (i
= 0; i
< nvar
; i
++)
3550 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
3552 gfc_error ("An outer FORALL construct already has an index "
3553 "with this name %L", &fa
->var
->where
);
3557 /* Record the current FORALL index. */
3558 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
3560 forall_index
= fa
->var
->symtree
->n
.sym
;
3562 /* Check if the FORALL index appears in start, end or stride. */
3563 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
3564 gfc_error ("A FORALL index must not appear in a limit or stride "
3565 "expression in the same FORALL at %L", &fa
->start
->where
);
3566 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
3567 gfc_error ("A FORALL index must not appear in a limit or stride "
3568 "expression in the same FORALL at %L", &fa
->end
->where
);
3569 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
3570 gfc_error ("A FORALL index must not appear in a limit or stride "
3571 "expression in the same FORALL at %L", &fa
->stride
->where
);
3575 /* Resolve the FORALL body. */
3576 gfc_resolve_forall_body (code
, nvar
, var_expr
);
3578 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3579 resolve_blocks (code
->block
, ns
);
3581 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3582 for (i
= 0; i
< total_var
; i
++)
3583 gfc_free_expr (var_expr
[i
]);
3585 /* Reset the counters. */
3591 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3594 static void resolve_code (gfc_code
*, gfc_namespace
*);
3597 resolve_blocks (gfc_code
* b
, gfc_namespace
* ns
)
3601 for (; b
; b
= b
->block
)
3603 t
= gfc_resolve_expr (b
->expr
);
3604 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
3610 if (t
== SUCCESS
&& b
->expr
!= NULL
3611 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
3613 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3620 && (b
->expr
->ts
.type
!= BT_LOGICAL
3621 || b
->expr
->rank
== 0))
3623 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3628 resolve_branch (b
->label
, b
);
3638 gfc_internal_error ("resolve_block(): Bad block type");
3641 resolve_code (b
->next
, ns
);
3646 /* Given a block of code, recursively resolve everything pointed to by this
3650 resolve_code (gfc_code
* code
, gfc_namespace
* ns
)
3652 int forall_save
= 0;
3657 frame
.prev
= cs_base
;
3661 for (; code
; code
= code
->next
)
3663 frame
.current
= code
;
3665 if (code
->op
== EXEC_FORALL
)
3667 forall_save
= forall_flag
;
3669 gfc_resolve_forall (code
, ns
, forall_save
);
3672 resolve_blocks (code
->block
, ns
);
3674 if (code
->op
== EXEC_FORALL
)
3675 forall_flag
= forall_save
;
3677 t
= gfc_resolve_expr (code
->expr
);
3678 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
3694 resolve_where (code
, NULL
);
3698 if (code
->expr
!= NULL
)
3700 if (code
->expr
->ts
.type
!= BT_INTEGER
)
3701 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3702 "variable", &code
->expr
->where
);
3703 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
3704 gfc_error ("Variable '%s' has not been assigned a target label "
3705 "at %L", code
->expr
->symtree
->n
.sym
->name
,
3706 &code
->expr
->where
);
3709 resolve_branch (code
->label
, code
);
3713 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_INTEGER
)
3714 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3715 "return specifier", &code
->expr
->where
);
3722 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
3725 if (gfc_pure (NULL
))
3727 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
3730 ("Cannot assign to variable '%s' in PURE procedure at %L",
3731 code
->expr
->symtree
->n
.sym
->name
, &code
->expr
->where
);
3735 if (code
->expr2
->ts
.type
== BT_DERIVED
3736 && derived_pointer (code
->expr2
->ts
.derived
))
3739 ("Right side of assignment at %L is a derived type "
3740 "containing a POINTER in a PURE procedure",
3741 &code
->expr2
->where
);
3746 gfc_check_assign (code
->expr
, code
->expr2
, 1);
3749 case EXEC_LABEL_ASSIGN
:
3750 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
3751 gfc_error ("Label %d referenced at %L is never defined",
3752 code
->label
->value
, &code
->label
->where
);
3754 && (code
->expr
->expr_type
!= EXPR_VARIABLE
3755 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
3756 || code
->expr
->symtree
->n
.sym
->ts
.kind
3757 != gfc_default_integer_kind
3758 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
3759 gfc_error ("ASSIGN statement at %L requires a scalar "
3760 "default INTEGER variable", &code
->expr
->where
);
3763 case EXEC_POINTER_ASSIGN
:
3767 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
3770 case EXEC_ARITHMETIC_IF
:
3772 && code
->expr
->ts
.type
!= BT_INTEGER
3773 && code
->expr
->ts
.type
!= BT_REAL
)
3774 gfc_error ("Arithmetic IF statement at %L requires a numeric "
3775 "expression", &code
->expr
->where
);
3777 resolve_branch (code
->label
, code
);
3778 resolve_branch (code
->label2
, code
);
3779 resolve_branch (code
->label3
, code
);
3783 if (t
== SUCCESS
&& code
->expr
!= NULL
3784 && (code
->expr
->ts
.type
!= BT_LOGICAL
3785 || code
->expr
->rank
!= 0))
3786 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3787 &code
->expr
->where
);
3792 resolve_call (code
);
3796 /* Select is complicated. Also, a SELECT construct could be
3797 a transformed computed GOTO. */
3798 resolve_select (code
);
3802 if (code
->ext
.iterator
!= NULL
)
3803 gfc_resolve_iterator (code
->ext
.iterator
, true);
3807 if (code
->expr
== NULL
)
3808 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
3810 && (code
->expr
->rank
!= 0
3811 || code
->expr
->ts
.type
!= BT_LOGICAL
))
3812 gfc_error ("Exit condition of DO WHILE loop at %L must be "
3813 "a scalar LOGICAL expression", &code
->expr
->where
);
3817 if (t
== SUCCESS
&& code
->expr
!= NULL
3818 && code
->expr
->ts
.type
!= BT_INTEGER
)
3819 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
3820 "of type INTEGER", &code
->expr
->where
);
3822 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3823 resolve_allocate_expr (a
->expr
);
3827 case EXEC_DEALLOCATE
:
3828 if (t
== SUCCESS
&& code
->expr
!= NULL
3829 && code
->expr
->ts
.type
!= BT_INTEGER
)
3831 ("STAT tag in DEALLOCATE statement at %L must be of type "
3832 "INTEGER", &code
->expr
->where
);
3834 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3835 resolve_deallocate_expr (a
->expr
);
3840 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
3843 resolve_branch (code
->ext
.open
->err
, code
);
3847 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
3850 resolve_branch (code
->ext
.close
->err
, code
);
3853 case EXEC_BACKSPACE
:
3856 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
3859 resolve_branch (code
->ext
.filepos
->err
, code
);
3863 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
3866 resolve_branch (code
->ext
.inquire
->err
, code
);
3870 gcc_assert (code
->ext
.inquire
!= NULL
);
3871 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
3874 resolve_branch (code
->ext
.inquire
->err
, code
);
3879 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
3882 resolve_branch (code
->ext
.dt
->err
, code
);
3883 resolve_branch (code
->ext
.dt
->end
, code
);
3884 resolve_branch (code
->ext
.dt
->eor
, code
);
3888 resolve_transfer (code
);
3892 resolve_forall_iterators (code
->ext
.forall_iterator
);
3894 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
3896 ("FORALL mask clause at %L requires a LOGICAL expression",
3897 &code
->expr
->where
);
3901 gfc_internal_error ("resolve_code(): Bad statement code");
3905 cs_base
= frame
.prev
;
3909 /* Resolve initial values and make sure they are compatible with
3913 resolve_values (gfc_symbol
* sym
)
3916 if (sym
->value
== NULL
)
3919 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
3922 gfc_check_assign_symbol (sym
, sym
->value
);
3926 /* Do anything necessary to resolve a symbol. Right now, we just
3927 assume that an otherwise unknown symbol is a variable. This sort
3928 of thing commonly happens for symbols in module. */
3931 resolve_symbol (gfc_symbol
* sym
)
3933 /* Zero if we are checking a formal namespace. */
3934 static int formal_ns_flag
= 1;
3935 int formal_ns_save
, check_constant
, mp_flag
;
3940 if (sym
->attr
.flavor
== FL_UNKNOWN
)
3942 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
3943 sym
->attr
.flavor
= FL_VARIABLE
;
3946 sym
->attr
.flavor
= FL_PROCEDURE
;
3947 if (sym
->attr
.dimension
)
3948 sym
->attr
.function
= 1;
3952 /* Symbols that are module procedures with results (functions) have
3953 the types and array specification copied for type checking in
3954 procedures that call them, as well as for saving to a module
3955 file. These symbols can't stand the scrutiny that their results
3957 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
3959 /* Assign default type to symbols that need one and don't have one. */
3960 if (sym
->ts
.type
== BT_UNKNOWN
)
3962 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
3963 gfc_set_default_type (sym
, 1, NULL
);
3965 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
3968 gfc_set_default_type (sym
, 0, NULL
);
3971 /* Result may be in another namespace. */
3972 resolve_symbol (sym
->result
);
3974 sym
->ts
= sym
->result
->ts
;
3975 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
3980 /* Assumed size arrays and assumed shape arrays must be dummy
3984 && (sym
->as
->type
== AS_ASSUMED_SIZE
3985 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
3986 && sym
->attr
.dummy
== 0)
3988 gfc_error ("Assumed %s array at %L must be a dummy argument",
3989 sym
->as
->type
== AS_ASSUMED_SIZE
? "size" : "shape",
3994 /* A parameter array's shape needs to be constant. */
3996 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->as
!= NULL
3997 && !gfc_is_compile_time_shape (sym
->as
))
3999 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4000 "or assumed shape", sym
->name
, &sym
->declared_at
);
4004 /* Make sure that character string variables with assumed length are
4007 if (sym
->attr
.flavor
== FL_VARIABLE
&& !sym
->attr
.result
4008 && sym
->ts
.type
== BT_CHARACTER
4009 && sym
->ts
.cl
->length
== NULL
&& sym
->attr
.dummy
== 0)
4011 gfc_error ("Entity with assumed character length at %L must be a "
4012 "dummy argument or a PARAMETER", &sym
->declared_at
);
4016 /* Make sure a parameter that has been implicitly typed still
4017 matches the implicit type, since PARAMETER statements can precede
4018 IMPLICIT statements. */
4020 if (sym
->attr
.flavor
== FL_PARAMETER
4021 && sym
->attr
.implicit_type
4022 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
4023 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4024 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
4026 /* Make sure the types of derived parameters are consistent. This
4027 type checking is deferred until resolution because the type may
4028 refer to a derived type from the host. */
4030 if (sym
->attr
.flavor
== FL_PARAMETER
4031 && sym
->ts
.type
== BT_DERIVED
4032 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
4033 gfc_error ("Incompatible derived type in PARAMETER at %L",
4034 &sym
->value
->where
);
4036 /* Make sure symbols with known intent or optional are really dummy
4037 variable. Because of ENTRY statement, this has to be deferred
4038 until resolution time. */
4040 if (! sym
->attr
.dummy
4041 && (sym
->attr
.optional
4042 || sym
->attr
.intent
!= INTENT_UNKNOWN
))
4044 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
4048 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
4050 if (sym
->ts
.type
== BT_CHARACTER
)
4052 gfc_charlen
*cl
= sym
->ts
.cl
;
4053 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
4055 gfc_error ("Character-valued statement function '%s' at %L must "
4056 "have constant length", sym
->name
, &sym
->declared_at
);
4062 /* Constraints on deferred shape variable. */
4063 if (sym
->attr
.flavor
== FL_VARIABLE
4064 || (sym
->attr
.flavor
== FL_PROCEDURE
4065 && sym
->attr
.function
))
4067 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
4069 if (sym
->attr
.allocatable
)
4071 if (sym
->attr
.dimension
)
4072 gfc_error ("Allocatable array at %L must have a deferred shape",
4075 gfc_error ("Object at %L may not be ALLOCATABLE",
4080 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
4082 gfc_error ("Pointer to array at %L must have a deferred shape",
4090 if (!mp_flag
&& !sym
->attr
.allocatable
4091 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
4093 gfc_error ("Array at %L cannot have a deferred shape",
4100 switch (sym
->attr
.flavor
)
4103 /* Can the sybol have an initializer? */
4105 if (sym
->attr
.allocatable
)
4106 whynot
= "Allocatable";
4107 else if (sym
->attr
.external
)
4108 whynot
= "External";
4109 else if (sym
->attr
.dummy
)
4111 else if (sym
->attr
.intrinsic
)
4112 whynot
= "Intrinsic";
4113 else if (sym
->attr
.result
)
4114 whynot
= "Function Result";
4115 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
4117 /* Don't allow initialization of automatic arrays. */
4118 for (i
= 0; i
< sym
->as
->rank
; i
++)
4120 if (sym
->as
->lower
[i
] == NULL
4121 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4122 || sym
->as
->upper
[i
] == NULL
4123 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
4125 whynot
= "Automatic array";
4131 /* Reject illegal initializers. */
4132 if (sym
->value
&& whynot
)
4134 gfc_error ("%s '%s' at %L cannot have an initializer",
4135 whynot
, sym
->name
, &sym
->declared_at
);
4139 /* Assign default initializer. */
4140 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| whynot
))
4141 sym
->value
= gfc_default_initializer (&sym
->ts
);
4145 /* Reject PRIVATE objects in a PUBLIC namelist. */
4146 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
4148 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
4150 if (!gfc_check_access(nl
->sym
->attr
.access
,
4151 nl
->sym
->ns
->default_access
))
4152 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4153 "PUBLIC namelist at %L", nl
->sym
->name
,
4164 /* Make sure that intrinsic exist */
4165 if (sym
->attr
.intrinsic
4166 && ! gfc_intrinsic_name(sym
->name
, 0)
4167 && ! gfc_intrinsic_name(sym
->name
, 1))
4168 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
4170 /* Resolve array specifier. Check as well some constraints
4171 on COMMON blocks. */
4173 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
4174 gfc_resolve_array_spec (sym
->as
, check_constant
);
4176 /* Resolve formal namespaces. */
4178 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
4180 formal_ns_save
= formal_ns_flag
;
4182 gfc_resolve (sym
->formal_ns
);
4183 formal_ns_flag
= formal_ns_save
;
4189 /************* Resolve DATA statements *************/
4193 gfc_data_value
*vnode
;
4199 /* Advance the values structure to point to the next value in the data list. */
4202 next_data_value (void)
4204 while (values
.left
== 0)
4206 if (values
.vnode
->next
== NULL
)
4209 values
.vnode
= values
.vnode
->next
;
4210 values
.left
= values
.vnode
->repeat
;
4218 check_data_variable (gfc_data_variable
* var
, locus
* where
)
4224 ar_type mark
= AR_UNKNOWN
;
4226 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
4230 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
4234 mpz_init_set_si (offset
, 0);
4237 if (e
->expr_type
!= EXPR_VARIABLE
)
4238 gfc_internal_error ("check_data_variable(): Bad expression");
4242 mpz_init_set_ui (size
, 1);
4249 /* Find the array section reference. */
4250 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4252 if (ref
->type
!= REF_ARRAY
)
4254 if (ref
->u
.ar
.type
== AR_ELEMENT
)
4260 /* Set marks according to the reference pattern. */
4261 switch (ref
->u
.ar
.type
)
4269 /* Get the start position of array section. */
4270 gfc_get_section_index (ar
, section_index
, &offset
);
4278 if (gfc_array_size (e
, &size
) == FAILURE
)
4280 gfc_error ("Nonconstant array section at %L in DATA statement",
4289 while (mpz_cmp_ui (size
, 0) > 0)
4291 if (next_data_value () == FAILURE
)
4293 gfc_error ("DATA statement at %L has more variables than values",
4299 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
4303 /* If we have more than one element left in the repeat count,
4304 and we have more than one element left in the target variable,
4305 then create a range assignment. */
4306 /* ??? Only done for full arrays for now, since array sections
4308 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
4309 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
4313 if (mpz_cmp_ui (size
, values
.left
) >= 0)
4315 mpz_init_set_ui (range
, values
.left
);
4316 mpz_sub_ui (size
, size
, values
.left
);
4321 mpz_init_set (range
, size
);
4322 values
.left
-= mpz_get_ui (size
);
4323 mpz_set_ui (size
, 0);
4326 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
4329 mpz_add (offset
, offset
, range
);
4333 /* Assign initial value to symbol. */
4337 mpz_sub_ui (size
, size
, 1);
4339 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
4341 if (mark
== AR_FULL
)
4342 mpz_add_ui (offset
, offset
, 1);
4344 /* Modify the array section indexes and recalculate the offset
4345 for next element. */
4346 else if (mark
== AR_SECTION
)
4347 gfc_advance_section (section_index
, ar
, &offset
);
4351 if (mark
== AR_SECTION
)
4353 for (i
= 0; i
< ar
->dimen
; i
++)
4354 mpz_clear (section_index
[i
]);
4364 static try traverse_data_var (gfc_data_variable
*, locus
*);
4366 /* Iterate over a list of elements in a DATA statement. */
4369 traverse_data_list (gfc_data_variable
* var
, locus
* where
)
4372 iterator_stack frame
;
4375 mpz_init (frame
.value
);
4377 mpz_init_set (trip
, var
->iter
.end
->value
.integer
);
4378 mpz_sub (trip
, trip
, var
->iter
.start
->value
.integer
);
4379 mpz_add (trip
, trip
, var
->iter
.step
->value
.integer
);
4381 mpz_div (trip
, trip
, var
->iter
.step
->value
.integer
);
4383 mpz_set (frame
.value
, var
->iter
.start
->value
.integer
);
4385 frame
.prev
= iter_stack
;
4386 frame
.variable
= var
->iter
.var
->symtree
;
4387 iter_stack
= &frame
;
4389 while (mpz_cmp_ui (trip
, 0) > 0)
4391 if (traverse_data_var (var
->list
, where
) == FAILURE
)
4397 e
= gfc_copy_expr (var
->expr
);
4398 if (gfc_simplify_expr (e
, 1) == FAILURE
)
4404 mpz_add (frame
.value
, frame
.value
, var
->iter
.step
->value
.integer
);
4406 mpz_sub_ui (trip
, trip
, 1);
4410 mpz_clear (frame
.value
);
4412 iter_stack
= frame
.prev
;
4417 /* Type resolve variables in the variable list of a DATA statement. */
4420 traverse_data_var (gfc_data_variable
* var
, locus
* where
)
4424 for (; var
; var
= var
->next
)
4426 if (var
->expr
== NULL
)
4427 t
= traverse_data_list (var
, where
);
4429 t
= check_data_variable (var
, where
);
4439 /* Resolve the expressions and iterators associated with a data statement.
4440 This is separate from the assignment checking because data lists should
4441 only be resolved once. */
4444 resolve_data_variables (gfc_data_variable
* d
)
4446 for (; d
; d
= d
->next
)
4448 if (d
->list
== NULL
)
4450 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
4455 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
4458 if (d
->iter
.start
->expr_type
!= EXPR_CONSTANT
4459 || d
->iter
.end
->expr_type
!= EXPR_CONSTANT
4460 || d
->iter
.step
->expr_type
!= EXPR_CONSTANT
)
4461 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4463 if (resolve_data_variables (d
->list
) == FAILURE
)
4472 /* Resolve a single DATA statement. We implement this by storing a pointer to
4473 the value list into static variables, and then recursively traversing the
4474 variables list, expanding iterators and such. */
4477 resolve_data (gfc_data
* d
)
4479 if (resolve_data_variables (d
->var
) == FAILURE
)
4482 values
.vnode
= d
->value
;
4483 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
4485 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
4488 /* At this point, we better not have any values left. */
4490 if (next_data_value () == SUCCESS
)
4491 gfc_error ("DATA statement at %L has more values than variables",
4496 /* Determines if a variable is not 'pure', ie not assignable within a pure
4497 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4501 gfc_impure_variable (gfc_symbol
* sym
)
4503 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
4506 if (sym
->ns
!= gfc_current_ns
)
4507 return !sym
->attr
.function
;
4509 /* TODO: Check storage association through EQUIVALENCE statements */
4515 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4516 symbol of the current procedure. */
4519 gfc_pure (gfc_symbol
* sym
)
4521 symbol_attribute attr
;
4524 sym
= gfc_current_ns
->proc_name
;
4530 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
4534 /* Test whether the current procedure is elemental or not. */
4537 gfc_elemental (gfc_symbol
* sym
)
4539 symbol_attribute attr
;
4542 sym
= gfc_current_ns
->proc_name
;
4547 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
4551 /* Warn about unused labels. */
4554 warn_unused_label (gfc_namespace
* ns
)
4565 for (; l
; l
= l
->prev
)
4567 if (l
->defined
== ST_LABEL_UNKNOWN
)
4570 switch (l
->referenced
)
4572 case ST_LABEL_UNKNOWN
:
4573 gfc_warning ("Label %d at %L defined but not used", l
->value
,
4577 case ST_LABEL_BAD_TARGET
:
4578 gfc_warning ("Label %d at %L defined but cannot be used", l
->value
,
4589 /* Resolve derived type EQUIVALENCE object. */
4592 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
4595 gfc_component
*c
= derived
->components
;
4600 /* Shall not be an object of nonsequence derived type. */
4601 if (!derived
->attr
.sequence
)
4603 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
4604 "attribute to be an EQUIVALENCE object", sym
->name
, &e
->where
);
4608 for (; c
; c
= c
->next
)
4611 if (d
&& (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
4614 /* Shall not be an object of sequence derived type containing a pointer
4615 in the structure. */
4618 gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
4619 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
4627 /* Resolve equivalence object.
4628 An EQUIVALENCE object shall not be a dummy argument, a pointer, an
4629 allocatable array, an object of nonsequence derived type, an object of
4630 sequence derived type containing a pointer at any level of component
4631 selection, an automatic object, a function name, an entry name, a result
4632 name, a named constant, a structure component, or a subobject of any of
4633 the preceding objects. */
4636 resolve_equivalence (gfc_equiv
*eq
)
4639 gfc_symbol
*derived
;
4643 for (; eq
; eq
= eq
->eq
)
4646 if (gfc_resolve_expr (e
) == FAILURE
)
4649 sym
= e
->symtree
->n
.sym
;
4651 /* Shall not be a dummy argument. */
4652 if (sym
->attr
.dummy
)
4654 gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
4655 "object", sym
->name
, &e
->where
);
4659 /* Shall not be an allocatable array. */
4660 if (sym
->attr
.allocatable
)
4662 gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
4663 "object", sym
->name
, &e
->where
);
4667 /* Shall not be a pointer. */
4668 if (sym
->attr
.pointer
)
4670 gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
4671 sym
->name
, &e
->where
);
4675 /* Shall not be a function name, ... */
4676 if (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
4677 || sym
->attr
.subroutine
)
4679 gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
4680 sym
->name
, &e
->where
);
4684 /* Shall not be a named constant. */
4685 if (e
->expr_type
== EXPR_CONSTANT
)
4687 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
4688 "object", sym
->name
, &e
->where
);
4692 derived
= e
->ts
.derived
;
4693 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
4699 /* Shall not be an automatic array. */
4700 if (e
->ref
->type
== REF_ARRAY
4701 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
4703 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
4704 "an EQUIVALENCE object", sym
->name
, &e
->where
);
4708 /* Shall not be a structure component. */
4712 if (r
->type
== REF_COMPONENT
)
4714 gfc_error ("Structure component '%s' at %L cannot be an "
4715 "EQUIVALENCE object",
4716 r
->u
.c
.component
->name
, &e
->where
);
4725 /* This function is called after a complete program unit has been compiled.
4726 Its purpose is to examine all of the expressions associated with a program
4727 unit, assign types to all intermediate expressions, make sure that all
4728 assignments are to compatible types and figure out which names refer to
4729 which functions or subroutines. */
4732 gfc_resolve (gfc_namespace
* ns
)
4734 gfc_namespace
*old_ns
, *n
;
4739 old_ns
= gfc_current_ns
;
4740 gfc_current_ns
= ns
;
4742 resolve_entries (ns
);
4744 resolve_contained_functions (ns
);
4746 gfc_traverse_ns (ns
, resolve_symbol
);
4748 for (n
= ns
->contained
; n
; n
= n
->sibling
)
4750 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
4751 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
4752 "also be PURE", n
->proc_name
->name
,
4753 &n
->proc_name
->declared_at
);
4759 gfc_check_interfaces (ns
);
4761 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
4763 if (cl
->length
== NULL
|| gfc_resolve_expr (cl
->length
) == FAILURE
)
4766 if (gfc_simplify_expr (cl
->length
, 0) == FAILURE
)
4769 if (gfc_specification_expr (cl
->length
) == FAILURE
)
4773 gfc_traverse_ns (ns
, resolve_values
);
4779 for (d
= ns
->data
; d
; d
= d
->next
)
4783 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
4785 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
4786 resolve_equivalence (eq
);
4789 resolve_code (ns
->code
, ns
);
4791 /* Warn about unused labels. */
4792 if (gfc_option
.warn_unused_labels
)
4793 warn_unused_label (ns
);
4795 gfc_current_ns
= old_ns
;