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
->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 type the function is. If there was an
263 explicit RESULT clause, try to get the type from it. If the
264 function is never defined, set it to the implicit type. If
265 even that fails, give up. */
266 if (sym
->result
!= NULL
)
269 if (sym
->ts
.type
== BT_UNKNOWN
)
271 /* Assume we can find an implicit type. */
274 if (sym
->result
== NULL
)
275 t
= gfc_set_default_type (sym
, 0, ns
);
278 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
279 t
= gfc_set_default_type (sym
->result
, 0, NULL
);
281 sym
->ts
= sym
->result
->ts
;
285 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
286 sym
->name
, &sym
->declared_at
); /* FIXME */
291 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
292 introduce duplicates. */
295 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
297 gfc_formal_arglist
*f
, *new_arglist
;
300 for (; new_args
!= NULL
; new_args
= new_args
->next
)
302 new_sym
= new_args
->sym
;
303 /* See if ths arg is already in the formal argument list. */
304 for (f
= proc
->formal
; f
; f
= f
->next
)
306 if (new_sym
== f
->sym
)
313 /* Add a new argument. Argument order is not important. */
314 new_arglist
= gfc_get_formal_arglist ();
315 new_arglist
->sym
= new_sym
;
316 new_arglist
->next
= proc
->formal
;
317 proc
->formal
= new_arglist
;
322 /* Resolve alternate entry points. If a symbol has multiple entry points we
323 create a new master symbol for the main routine, and turn the existing
324 symbol into an entry point. */
327 resolve_entries (gfc_namespace
* ns
)
329 gfc_namespace
*old_ns
;
333 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
334 static int master_count
= 0;
336 if (ns
->proc_name
== NULL
)
339 /* No need to do anything if this procedure doesn't have alternate entry
344 /* We may already have resolved alternate entry points. */
345 if (ns
->proc_name
->attr
.entry_master
)
348 /* If this isn't a procedure something has gone horribly wrong. */
349 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
351 /* Remember the current namespace. */
352 old_ns
= gfc_current_ns
;
356 /* Add the main entry point to the list of entry points. */
357 el
= gfc_get_entry_list ();
358 el
->sym
= ns
->proc_name
;
360 el
->next
= ns
->entries
;
362 ns
->proc_name
->attr
.entry
= 1;
364 /* Add an entry statement for it. */
371 /* Create a new symbol for the master function. */
372 /* Give the internal function a unique name (within this file).
373 Also include the function name so the user has some hope of figuring
374 out what is going on. */
375 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
376 master_count
++, ns
->proc_name
->name
);
377 name
[GFC_MAX_SYMBOL_LEN
] = '\0';
378 gfc_get_ha_symbol (name
, &proc
);
379 gcc_assert (proc
!= NULL
);
381 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, NULL
);
382 if (ns
->proc_name
->attr
.subroutine
)
383 gfc_add_subroutine (&proc
->attr
, NULL
);
386 gfc_add_function (&proc
->attr
, NULL
);
387 gfc_internal_error ("TODO: Functions with alternate entry points");
389 proc
->attr
.access
= ACCESS_PRIVATE
;
390 proc
->attr
.entry_master
= 1;
392 /* Merge all the entry point arguments. */
393 for (el
= ns
->entries
; el
; el
= el
->next
)
394 merge_argument_lists (proc
, el
->sym
->formal
);
396 /* Use the master function for the function body. */
397 ns
->proc_name
= proc
;
399 /* Finalize the new symbols. */
400 gfc_commit_symbols ();
402 /* Restore the original namespace. */
403 gfc_current_ns
= old_ns
;
407 /* Resolve contained function types. Because contained functions can call one
408 another, they have to be worked out before any of the contained procedures
411 The good news is that if a function doesn't already have a type, the only
412 way it can get one is through an IMPLICIT type or a RESULT variable, because
413 by definition contained functions are contained namespace they're contained
414 in, not in a sibling or parent namespace. */
417 resolve_contained_functions (gfc_namespace
* ns
)
419 gfc_namespace
*child
;
422 resolve_formal_arglists (ns
);
424 for (child
= ns
->contained
; child
; child
= child
->sibling
)
426 /* Resolve alternate entry points first. */
427 resolve_entries (child
);
429 /* Then check function return types. */
430 resolve_contained_fntype (child
->proc_name
, child
);
431 for (el
= child
->entries
; el
; el
= el
->next
)
432 resolve_contained_fntype (el
->sym
, child
);
437 /* Resolve all of the elements of a structure constructor and make sure that
438 the types are correct. */
441 resolve_structure_cons (gfc_expr
* expr
)
443 gfc_constructor
*cons
;
448 cons
= expr
->value
.constructor
;
449 /* A constructor may have references if it is the result of substituting a
450 parameter variable. In this case we just pull out the component we
453 comp
= expr
->ref
->u
.c
.sym
->components
;
455 comp
= expr
->ts
.derived
->components
;
457 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
465 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
471 /* If we don't have the right type, try to convert it. */
473 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
)
474 && gfc_convert_type (cons
->expr
, &comp
->ts
, 1) == FAILURE
)
483 /****************** Expression name resolution ******************/
485 /* Returns 0 if a symbol was not declared with a type or
486 attribute declaration statement, nonzero otherwise. */
489 was_declared (gfc_symbol
* sym
)
495 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
498 if (a
.allocatable
|| a
.dimension
|| a
.external
|| a
.intrinsic
499 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
500 || a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
507 /* Determine if a symbol is generic or not. */
510 generic_sym (gfc_symbol
* sym
)
514 if (sym
->attr
.generic
||
515 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
518 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
521 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
523 return (s
== NULL
) ? 0 : generic_sym (s
);
527 /* Determine if a symbol is specific or not. */
530 specific_sym (gfc_symbol
* sym
)
534 if (sym
->attr
.if_source
== IFSRC_IFBODY
535 || sym
->attr
.proc
== PROC_MODULE
536 || sym
->attr
.proc
== PROC_INTERNAL
537 || sym
->attr
.proc
== PROC_ST_FUNCTION
538 || (sym
->attr
.intrinsic
&&
539 gfc_specific_intrinsic (sym
->name
))
540 || sym
->attr
.external
)
543 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
546 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
548 return (s
== NULL
) ? 0 : specific_sym (s
);
552 /* Figure out if the procedure is specific, generic or unknown. */
555 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
559 procedure_kind (gfc_symbol
* sym
)
562 if (generic_sym (sym
))
563 return PTYPE_GENERIC
;
565 if (specific_sym (sym
))
566 return PTYPE_SPECIFIC
;
568 return PTYPE_UNKNOWN
;
572 /* Resolve an actual argument list. Most of the time, this is just
573 resolving the expressions in the list.
574 The exception is that we sometimes have to decide whether arguments
575 that look like procedure arguments are really simple variable
579 resolve_actual_arglist (gfc_actual_arglist
* arg
)
582 gfc_symtree
*parent_st
;
585 for (; arg
; arg
= arg
->next
)
591 /* Check the label is a valid branching target. */
594 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
596 gfc_error ("Label %d referenced at %L is never defined",
597 arg
->label
->value
, &arg
->label
->where
);
604 if (e
->ts
.type
!= BT_PROCEDURE
)
606 if (gfc_resolve_expr (e
) != SUCCESS
)
611 /* See if the expression node should really be a variable
614 sym
= e
->symtree
->n
.sym
;
616 if (sym
->attr
.flavor
== FL_PROCEDURE
617 || sym
->attr
.intrinsic
618 || sym
->attr
.external
)
621 /* If the symbol is the function that names the current (or
622 parent) scope, then we really have a variable reference. */
624 if (sym
->attr
.function
&& sym
->result
== sym
625 && (sym
->ns
->proc_name
== sym
626 || (sym
->ns
->parent
!= NULL
627 && sym
->ns
->parent
->proc_name
== sym
)))
633 /* See if the name is a module procedure in a parent unit. */
635 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
638 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
640 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
644 if (parent_st
== NULL
)
647 sym
= parent_st
->n
.sym
;
648 e
->symtree
= parent_st
; /* Point to the right thing. */
650 if (sym
->attr
.flavor
== FL_PROCEDURE
651 || sym
->attr
.intrinsic
652 || sym
->attr
.external
)
658 e
->expr_type
= EXPR_VARIABLE
;
662 e
->rank
= sym
->as
->rank
;
663 e
->ref
= gfc_get_ref ();
664 e
->ref
->type
= REF_ARRAY
;
665 e
->ref
->u
.ar
.type
= AR_FULL
;
666 e
->ref
->u
.ar
.as
= sym
->as
;
674 /************* Function resolution *************/
676 /* Resolve a function call known to be generic.
677 Section 14.1.2.4.1. */
680 resolve_generic_f0 (gfc_expr
* expr
, gfc_symbol
* sym
)
684 if (sym
->attr
.generic
)
687 gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
690 expr
->value
.function
.name
= s
->name
;
691 expr
->value
.function
.esym
= s
;
694 expr
->rank
= s
->as
->rank
;
698 /* TODO: Need to search for elemental references in generic interface */
701 if (sym
->attr
.intrinsic
)
702 return gfc_intrinsic_func_interface (expr
, 0);
709 resolve_generic_f (gfc_expr
* expr
)
714 sym
= expr
->symtree
->n
.sym
;
718 m
= resolve_generic_f0 (expr
, sym
);
721 else if (m
== MATCH_ERROR
)
725 if (sym
->ns
->parent
== NULL
)
727 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
731 if (!generic_sym (sym
))
735 /* Last ditch attempt. */
737 if (!gfc_generic_intrinsic (expr
->symtree
->n
.sym
->name
))
739 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
740 expr
->symtree
->n
.sym
->name
, &expr
->where
);
744 m
= gfc_intrinsic_func_interface (expr
, 0);
749 ("Generic function '%s' at %L is not consistent with a specific "
750 "intrinsic interface", expr
->symtree
->n
.sym
->name
, &expr
->where
);
756 /* Resolve a function call known to be specific. */
759 resolve_specific_f0 (gfc_symbol
* sym
, gfc_expr
* expr
)
763 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
767 sym
->attr
.proc
= PROC_DUMMY
;
771 sym
->attr
.proc
= PROC_EXTERNAL
;
775 if (sym
->attr
.proc
== PROC_MODULE
776 || sym
->attr
.proc
== PROC_ST_FUNCTION
777 || sym
->attr
.proc
== PROC_INTERNAL
)
780 if (sym
->attr
.intrinsic
)
782 m
= gfc_intrinsic_func_interface (expr
, 1);
787 ("Function '%s' at %L is INTRINSIC but is not compatible with "
788 "an intrinsic", sym
->name
, &expr
->where
);
796 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
799 expr
->value
.function
.name
= sym
->name
;
800 expr
->value
.function
.esym
= sym
;
802 expr
->rank
= sym
->as
->rank
;
809 resolve_specific_f (gfc_expr
* expr
)
814 sym
= expr
->symtree
->n
.sym
;
818 m
= resolve_specific_f0 (sym
, expr
);
821 if (m
== MATCH_ERROR
)
824 if (sym
->ns
->parent
== NULL
)
827 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
833 gfc_error ("Unable to resolve the specific function '%s' at %L",
834 expr
->symtree
->n
.sym
->name
, &expr
->where
);
840 /* Resolve a procedure call not known to be generic nor specific. */
843 resolve_unknown_f (gfc_expr
* expr
)
848 sym
= expr
->symtree
->n
.sym
;
852 sym
->attr
.proc
= PROC_DUMMY
;
853 expr
->value
.function
.name
= sym
->name
;
857 /* See if we have an intrinsic function reference. */
859 if (gfc_intrinsic_name (sym
->name
, 0))
861 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
866 /* The reference is to an external name. */
868 sym
->attr
.proc
= PROC_EXTERNAL
;
869 expr
->value
.function
.name
= sym
->name
;
870 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
873 expr
->rank
= sym
->as
->rank
;
875 /* Type of the expression is either the type of the symbol or the
876 default type of the symbol. */
879 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
881 if (sym
->ts
.type
!= BT_UNKNOWN
)
885 ts
= gfc_get_default_type (sym
, sym
->ns
);
887 if (ts
->type
== BT_UNKNOWN
)
889 gfc_error ("Function '%s' at %L has no implicit type",
890 sym
->name
, &expr
->where
);
901 /* Figure out if if a function reference is pure or not. Also sets the name
902 of the function for a potential error message. Returns nonzero if the
903 function is PURE, zero if not. */
906 pure_function (gfc_expr
* e
, const char **name
)
910 if (e
->value
.function
.esym
)
912 pure
= gfc_pure (e
->value
.function
.esym
);
913 *name
= e
->value
.function
.esym
->name
;
915 else if (e
->value
.function
.isym
)
917 pure
= e
->value
.function
.isym
->pure
918 || e
->value
.function
.isym
->elemental
;
919 *name
= e
->value
.function
.isym
->name
;
923 /* Implicit functions are not pure. */
925 *name
= e
->value
.function
.name
;
932 /* Resolve a function call, which means resolving the arguments, then figuring
933 out which entity the name refers to. */
934 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
935 to INTENT(OUT) or INTENT(INOUT). */
938 resolve_function (gfc_expr
* expr
)
940 gfc_actual_arglist
*arg
;
944 if (resolve_actual_arglist (expr
->value
.function
.actual
) == FAILURE
)
947 /* See if function is already resolved. */
949 if (expr
->value
.function
.name
!= NULL
)
951 if (expr
->ts
.type
== BT_UNKNOWN
)
952 expr
->ts
= expr
->symtree
->n
.sym
->ts
;
957 /* Apply the rules of section 14.1.2. */
959 switch (procedure_kind (expr
->symtree
->n
.sym
))
962 t
= resolve_generic_f (expr
);
966 t
= resolve_specific_f (expr
);
970 t
= resolve_unknown_f (expr
);
974 gfc_internal_error ("resolve_function(): bad function type");
978 /* If the expression is still a function (it might have simplified),
979 then we check to see if we are calling an elemental function. */
981 if (expr
->expr_type
!= EXPR_FUNCTION
)
984 if (expr
->value
.function
.actual
!= NULL
985 && ((expr
->value
.function
.esym
!= NULL
986 && expr
->value
.function
.esym
->attr
.elemental
)
987 || (expr
->value
.function
.isym
!= NULL
988 && expr
->value
.function
.isym
->elemental
)))
991 /* The rank of an elemental is the rank of its array argument(s). */
993 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
995 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
997 expr
->rank
= arg
->expr
->rank
;
1003 if (!pure_function (expr
, &name
))
1008 ("Function reference to '%s' at %L is inside a FORALL block",
1009 name
, &expr
->where
);
1012 else if (gfc_pure (NULL
))
1014 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1015 "procedure within a PURE procedure", name
, &expr
->where
);
1024 /************* Subroutine resolution *************/
1027 pure_subroutine (gfc_code
* c
, gfc_symbol
* sym
)
1034 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1035 sym
->name
, &c
->loc
);
1036 else if (gfc_pure (NULL
))
1037 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1043 resolve_generic_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1047 if (sym
->attr
.generic
)
1049 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1052 c
->resolved_sym
= s
;
1053 pure_subroutine (c
, s
);
1057 /* TODO: Need to search for elemental references in generic interface. */
1060 if (sym
->attr
.intrinsic
)
1061 return gfc_intrinsic_sub_interface (c
, 0);
1068 resolve_generic_s (gfc_code
* c
)
1073 sym
= c
->symtree
->n
.sym
;
1075 m
= resolve_generic_s0 (c
, sym
);
1078 if (m
== MATCH_ERROR
)
1081 if (sym
->ns
->parent
!= NULL
)
1083 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1086 m
= resolve_generic_s0 (c
, sym
);
1089 if (m
== MATCH_ERROR
)
1094 /* Last ditch attempt. */
1096 if (!gfc_generic_intrinsic (sym
->name
))
1099 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1100 sym
->name
, &c
->loc
);
1104 m
= gfc_intrinsic_sub_interface (c
, 0);
1108 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1109 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1115 /* Resolve a subroutine call known to be specific. */
1118 resolve_specific_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1122 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1124 if (sym
->attr
.dummy
)
1126 sym
->attr
.proc
= PROC_DUMMY
;
1130 sym
->attr
.proc
= PROC_EXTERNAL
;
1134 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1137 if (sym
->attr
.intrinsic
)
1139 m
= gfc_intrinsic_sub_interface (c
, 1);
1143 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1144 "with an intrinsic", sym
->name
, &c
->loc
);
1152 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1154 c
->resolved_sym
= sym
;
1155 pure_subroutine (c
, sym
);
1162 resolve_specific_s (gfc_code
* c
)
1167 sym
= c
->symtree
->n
.sym
;
1169 m
= resolve_specific_s0 (c
, sym
);
1172 if (m
== MATCH_ERROR
)
1175 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1179 m
= resolve_specific_s0 (c
, sym
);
1182 if (m
== MATCH_ERROR
)
1186 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1187 sym
->name
, &c
->loc
);
1193 /* Resolve a subroutine call not known to be generic nor specific. */
1196 resolve_unknown_s (gfc_code
* c
)
1200 sym
= c
->symtree
->n
.sym
;
1202 if (sym
->attr
.dummy
)
1204 sym
->attr
.proc
= PROC_DUMMY
;
1208 /* See if we have an intrinsic function reference. */
1210 if (gfc_intrinsic_name (sym
->name
, 1))
1212 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1217 /* The reference is to an external name. */
1220 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1222 c
->resolved_sym
= sym
;
1224 pure_subroutine (c
, sym
);
1230 /* Resolve a subroutine call. Although it was tempting to use the same code
1231 for functions, subroutines and functions are stored differently and this
1232 makes things awkward. */
1235 resolve_call (gfc_code
* c
)
1239 if (resolve_actual_arglist (c
->ext
.actual
) == FAILURE
)
1242 if (c
->resolved_sym
!= NULL
)
1245 switch (procedure_kind (c
->symtree
->n
.sym
))
1248 t
= resolve_generic_s (c
);
1251 case PTYPE_SPECIFIC
:
1252 t
= resolve_specific_s (c
);
1256 t
= resolve_unknown_s (c
);
1260 gfc_internal_error ("resolve_subroutine(): bad function type");
1267 /* Resolve an operator expression node. This can involve replacing the
1268 operation with a user defined function call. */
1271 resolve_operator (gfc_expr
* e
)
1273 gfc_expr
*op1
, *op2
;
1277 /* Resolve all subnodes-- give them types. */
1279 switch (e
->operator)
1282 if (gfc_resolve_expr (e
->op2
) == FAILURE
)
1285 /* Fall through... */
1288 case INTRINSIC_UPLUS
:
1289 case INTRINSIC_UMINUS
:
1290 if (gfc_resolve_expr (e
->op1
) == FAILURE
)
1295 /* Typecheck the new node. */
1300 switch (e
->operator)
1302 case INTRINSIC_UPLUS
:
1303 case INTRINSIC_UMINUS
:
1304 if (op1
->ts
.type
== BT_INTEGER
1305 || op1
->ts
.type
== BT_REAL
1306 || op1
->ts
.type
== BT_COMPLEX
)
1312 sprintf (msg
, "Operand of unary numeric operator '%s' at %%L is %s",
1313 gfc_op2string (e
->operator), gfc_typename (&e
->ts
));
1316 case INTRINSIC_PLUS
:
1317 case INTRINSIC_MINUS
:
1318 case INTRINSIC_TIMES
:
1319 case INTRINSIC_DIVIDE
:
1320 case INTRINSIC_POWER
:
1321 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1323 gfc_type_convert_binary (e
);
1328 "Operands of binary numeric operator '%s' at %%L are %s/%s",
1329 gfc_op2string (e
->operator), gfc_typename (&op1
->ts
),
1330 gfc_typename (&op2
->ts
));
1333 case INTRINSIC_CONCAT
:
1334 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1336 e
->ts
.type
= BT_CHARACTER
;
1337 e
->ts
.kind
= op1
->ts
.kind
;
1342 "Operands of string concatenation operator at %%L are %s/%s",
1343 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
1349 case INTRINSIC_NEQV
:
1350 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
1352 e
->ts
.type
= BT_LOGICAL
;
1353 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
1354 if (op1
->ts
.kind
< e
->ts
.kind
)
1355 gfc_convert_type (op1
, &e
->ts
, 2);
1356 else if (op2
->ts
.kind
< e
->ts
.kind
)
1357 gfc_convert_type (op2
, &e
->ts
, 2);
1361 sprintf (msg
, "Operands of logical operator '%s' at %%L are %s/%s",
1362 gfc_op2string (e
->operator), gfc_typename (&op1
->ts
),
1363 gfc_typename (&op2
->ts
));
1368 if (op1
->ts
.type
== BT_LOGICAL
)
1370 e
->ts
.type
= BT_LOGICAL
;
1371 e
->ts
.kind
= op1
->ts
.kind
;
1375 sprintf (msg
, "Operand of .NOT. operator at %%L is %s",
1376 gfc_typename (&op1
->ts
));
1383 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1385 strcpy (msg
, "COMPLEX quantities cannot be compared at %L");
1389 /* Fall through... */
1393 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1395 e
->ts
.type
= BT_LOGICAL
;
1396 e
->ts
.kind
= gfc_default_logical_kind
;
1400 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1402 gfc_type_convert_binary (e
);
1404 e
->ts
.type
= BT_LOGICAL
;
1405 e
->ts
.kind
= gfc_default_logical_kind
;
1409 sprintf (msg
, "Operands of comparison operator '%s' at %%L are %s/%s",
1410 gfc_op2string (e
->operator), gfc_typename (&op1
->ts
),
1411 gfc_typename (&op2
->ts
));
1415 case INTRINSIC_USER
:
1417 sprintf (msg
, "Operand of user operator '%s' at %%L is %s",
1418 e
->uop
->name
, gfc_typename (&op1
->ts
));
1420 sprintf (msg
, "Operands of user operator '%s' at %%L are %s/%s",
1421 e
->uop
->name
, gfc_typename (&op1
->ts
),
1422 gfc_typename (&op2
->ts
));
1427 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1430 /* Deal with arrayness of an operand through an operator. */
1434 switch (e
->operator)
1436 case INTRINSIC_PLUS
:
1437 case INTRINSIC_MINUS
:
1438 case INTRINSIC_TIMES
:
1439 case INTRINSIC_DIVIDE
:
1440 case INTRINSIC_POWER
:
1441 case INTRINSIC_CONCAT
:
1445 case INTRINSIC_NEQV
:
1453 if (op1
->rank
== 0 && op2
->rank
== 0)
1456 if (op1
->rank
== 0 && op2
->rank
!= 0)
1458 e
->rank
= op2
->rank
;
1460 if (e
->shape
== NULL
)
1461 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1464 if (op1
->rank
!= 0 && op2
->rank
== 0)
1466 e
->rank
= op1
->rank
;
1468 if (e
->shape
== NULL
)
1469 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1472 if (op1
->rank
!= 0 && op2
->rank
!= 0)
1474 if (op1
->rank
== op2
->rank
)
1476 e
->rank
= op1
->rank
;
1478 if (e
->shape
== NULL
)
1479 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1484 gfc_error ("Inconsistent ranks for operator at %L and %L",
1485 &op1
->where
, &op2
->where
);
1488 /* Allow higher level expressions to work. */
1496 case INTRINSIC_UPLUS
:
1497 case INTRINSIC_UMINUS
:
1498 e
->rank
= op1
->rank
;
1500 if (e
->shape
== NULL
)
1501 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1503 /* Simply copy arrayness attribute */
1510 /* Attempt to simplify the expression. */
1512 t
= gfc_simplify_expr (e
, 0);
1516 if (gfc_extend_expr (e
) == SUCCESS
)
1519 gfc_error (msg
, &e
->where
);
1524 /************** Array resolution subroutines **************/
1528 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
1531 /* Compare two integer expressions. */
1534 compare_bound (gfc_expr
* a
, gfc_expr
* b
)
1538 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
1539 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
1542 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
1543 gfc_internal_error ("compare_bound(): Bad expression");
1545 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
1555 /* Compare an integer expression with an integer. */
1558 compare_bound_int (gfc_expr
* a
, int b
)
1562 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
1565 if (a
->ts
.type
!= BT_INTEGER
)
1566 gfc_internal_error ("compare_bound_int(): Bad expression");
1568 i
= mpz_cmp_si (a
->value
.integer
, b
);
1578 /* Compare a single dimension of an array reference to the array
1582 check_dimension (int i
, gfc_array_ref
* ar
, gfc_array_spec
* as
)
1585 /* Given start, end and stride values, calculate the minimum and
1586 maximum referenced indexes. */
1594 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1596 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1602 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
1604 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
1608 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1610 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1613 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1614 it is legal (see 6.2.2.3.1). */
1619 gfc_internal_error ("check_dimension(): Bad array reference");
1625 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
1630 /* Compare an array reference with an array specification. */
1633 compare_spec_to_ref (gfc_array_ref
* ar
)
1640 /* TODO: Full array sections are only allowed as actual parameters. */
1641 if (as
->type
== AS_ASSUMED_SIZE
1642 && (/*ar->type == AR_FULL
1643 ||*/ (ar
->type
== AR_SECTION
1644 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
1646 gfc_error ("Rightmost upper bound of assumed size array section"
1647 " not specified at %L", &ar
->where
);
1651 if (ar
->type
== AR_FULL
)
1654 if (as
->rank
!= ar
->dimen
)
1656 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1657 &ar
->where
, ar
->dimen
, as
->rank
);
1661 for (i
= 0; i
< as
->rank
; i
++)
1662 if (check_dimension (i
, ar
, as
) == FAILURE
)
1669 /* Resolve one part of an array index. */
1672 gfc_resolve_index (gfc_expr
* index
, int check_scalar
)
1679 if (gfc_resolve_expr (index
) == FAILURE
)
1682 if (index
->ts
.type
!= BT_INTEGER
)
1684 gfc_error ("Array index at %L must be of INTEGER type", &index
->where
);
1688 if (check_scalar
&& index
->rank
!= 0)
1690 gfc_error ("Array index at %L must be scalar", &index
->where
);
1694 if (index
->ts
.kind
!= gfc_index_integer_kind
)
1696 ts
.type
= BT_INTEGER
;
1697 ts
.kind
= gfc_index_integer_kind
;
1699 gfc_convert_type_warn (index
, &ts
, 2, 0);
1706 /* Given an expression that contains array references, update those array
1707 references to point to the right array specifications. While this is
1708 filled in during matching, this information is difficult to save and load
1709 in a module, so we take care of it here.
1711 The idea here is that the original array reference comes from the
1712 base symbol. We traverse the list of reference structures, setting
1713 the stored reference to references. Component references can
1714 provide an additional array specification. */
1717 find_array_spec (gfc_expr
* e
)
1723 as
= e
->symtree
->n
.sym
->as
;
1724 c
= e
->symtree
->n
.sym
->components
;
1726 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1731 gfc_internal_error ("find_array_spec(): Missing spec");
1738 for (; c
; c
= c
->next
)
1739 if (c
== ref
->u
.c
.component
)
1743 gfc_internal_error ("find_array_spec(): Component not found");
1748 gfc_internal_error ("find_array_spec(): unused as(1)");
1752 c
= c
->ts
.derived
->components
;
1760 gfc_internal_error ("find_array_spec(): unused as(2)");
1764 /* Resolve an array reference. */
1767 resolve_array_ref (gfc_array_ref
* ar
)
1769 int i
, check_scalar
;
1771 for (i
= 0; i
< ar
->dimen
; i
++)
1773 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
1775 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
1777 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
1779 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
1782 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
1783 switch (ar
->start
[i
]->rank
)
1786 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
1790 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
1794 gfc_error ("Array index at %L is an array of rank %d",
1795 &ar
->c_where
[i
], ar
->start
[i
]->rank
);
1800 /* If the reference type is unknown, figure out what kind it is. */
1802 if (ar
->type
== AR_UNKNOWN
)
1804 ar
->type
= AR_ELEMENT
;
1805 for (i
= 0; i
< ar
->dimen
; i
++)
1806 if (ar
->dimen_type
[i
] == DIMEN_RANGE
1807 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
1809 ar
->type
= AR_SECTION
;
1814 if (compare_spec_to_ref (ar
) == FAILURE
)
1822 resolve_substring (gfc_ref
* ref
)
1825 if (ref
->u
.ss
.start
!= NULL
)
1827 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
1830 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
1832 gfc_error ("Substring start index at %L must be of type INTEGER",
1833 &ref
->u
.ss
.start
->where
);
1837 if (ref
->u
.ss
.start
->rank
!= 0)
1839 gfc_error ("Substring start index at %L must be scalar",
1840 &ref
->u
.ss
.start
->where
);
1844 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
)
1846 gfc_error ("Substring start index at %L is less than one",
1847 &ref
->u
.ss
.start
->where
);
1852 if (ref
->u
.ss
.end
!= NULL
)
1854 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
1857 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
1859 gfc_error ("Substring end index at %L must be of type INTEGER",
1860 &ref
->u
.ss
.end
->where
);
1864 if (ref
->u
.ss
.end
->rank
!= 0)
1866 gfc_error ("Substring end index at %L must be scalar",
1867 &ref
->u
.ss
.end
->where
);
1871 if (ref
->u
.ss
.length
!= NULL
1872 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
)
1874 gfc_error ("Substring end index at %L is out of bounds",
1875 &ref
->u
.ss
.start
->where
);
1884 /* Resolve subtype references. */
1887 resolve_ref (gfc_expr
* expr
)
1889 int current_part_dimension
, n_components
, seen_part_dimension
;
1892 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1893 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
1895 find_array_spec (expr
);
1899 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1903 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
1911 resolve_substring (ref
);
1915 /* Check constraints on part references. */
1917 current_part_dimension
= 0;
1918 seen_part_dimension
= 0;
1921 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1926 switch (ref
->u
.ar
.type
)
1930 current_part_dimension
= 1;
1934 current_part_dimension
= 0;
1938 gfc_internal_error ("resolve_ref(): Bad array reference");
1944 if ((current_part_dimension
|| seen_part_dimension
)
1945 && ref
->u
.c
.component
->pointer
)
1948 ("Component to the right of a part reference with nonzero "
1949 "rank must not have the POINTER attribute at %L",
1961 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
1962 || ref
->next
== NULL
)
1963 && current_part_dimension
1964 && seen_part_dimension
)
1967 gfc_error ("Two or more part references with nonzero rank must "
1968 "not be specified at %L", &expr
->where
);
1972 if (ref
->type
== REF_COMPONENT
)
1974 if (current_part_dimension
)
1975 seen_part_dimension
= 1;
1977 /* reset to make sure */
1978 current_part_dimension
= 0;
1986 /* Given an expression, determine its shape. This is easier than it sounds.
1987 Leaves the shape array NULL if it is not possible to determine the shape. */
1990 expression_shape (gfc_expr
* e
)
1992 mpz_t array
[GFC_MAX_DIMENSIONS
];
1995 if (e
->rank
== 0 || e
->shape
!= NULL
)
1998 for (i
= 0; i
< e
->rank
; i
++)
1999 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2002 e
->shape
= gfc_get_shape (e
->rank
);
2004 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
2009 for (i
--; i
>= 0; i
--)
2010 mpz_clear (array
[i
]);
2014 /* Given a variable expression node, compute the rank of the expression by
2015 examining the base symbol and any reference structures it may have. */
2018 expression_rank (gfc_expr
* e
)
2025 if (e
->expr_type
== EXPR_ARRAY
)
2027 /* Constructors can have a rank different from one via RESHAPE(). */
2029 if (e
->symtree
== NULL
)
2035 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
2036 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
2042 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2044 if (ref
->type
!= REF_ARRAY
)
2047 if (ref
->u
.ar
.type
== AR_FULL
)
2049 rank
= ref
->u
.ar
.as
->rank
;
2053 if (ref
->u
.ar
.type
== AR_SECTION
)
2055 /* Figure out the rank of the section. */
2057 gfc_internal_error ("expression_rank(): Two array specs");
2059 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2060 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
2061 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2071 expression_shape (e
);
2075 /* Resolve a variable expression. */
2078 resolve_variable (gfc_expr
* e
)
2082 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
2085 sym
= e
->symtree
->n
.sym
;
2086 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2088 e
->ts
.type
= BT_PROCEDURE
;
2092 if (sym
->ts
.type
!= BT_UNKNOWN
)
2093 gfc_variable_attr (e
, &e
->ts
);
2096 /* Must be a simple variable reference. */
2097 if (gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2106 /* Resolve an expression. That is, make sure that types of operands agree
2107 with their operators, intrinsic operators are converted to function calls
2108 for overloaded types and unresolved function references are resolved. */
2111 gfc_resolve_expr (gfc_expr
* e
)
2118 switch (e
->expr_type
)
2121 t
= resolve_operator (e
);
2125 t
= resolve_function (e
);
2129 t
= resolve_variable (e
);
2131 expression_rank (e
);
2134 case EXPR_SUBSTRING
:
2135 t
= resolve_ref (e
);
2145 if (resolve_ref (e
) == FAILURE
)
2148 t
= gfc_resolve_array_constructor (e
);
2149 /* Also try to expand a constructor. */
2152 expression_rank (e
);
2153 gfc_expand_constructor (e
);
2158 case EXPR_STRUCTURE
:
2159 t
= resolve_ref (e
);
2163 t
= resolve_structure_cons (e
);
2167 t
= gfc_simplify_expr (e
, 0);
2171 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2178 /* Resolve an expression from an iterator. They must be scalar and have
2179 INTEGER or (optionally) REAL type. */
2182 gfc_resolve_iterator_expr (gfc_expr
* expr
, bool real_ok
, const char * name
)
2184 if (gfc_resolve_expr (expr
) == FAILURE
)
2187 if (expr
->rank
!= 0)
2189 gfc_error ("%s at %L must be a scalar", name
, &expr
->where
);
2193 if (!(expr
->ts
.type
== BT_INTEGER
2194 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
2196 gfc_error ("%s at %L must be INTEGER%s",
2199 real_ok
? " or REAL" : "");
2206 /* Resolve the expressions in an iterator structure. If REAL_OK is
2207 false allow only INTEGER type iterators, otherwise allow REAL types. */
2210 gfc_resolve_iterator (gfc_iterator
* iter
, bool real_ok
)
2213 if (iter
->var
->ts
.type
== BT_REAL
)
2214 gfc_notify_std (GFC_STD_F95_DEL
,
2215 "Obsolete: REAL DO loop iterator at %L",
2218 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
2222 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
2224 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2229 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
2230 "Start expression in DO loop") == FAILURE
)
2233 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
2234 "End expression in DO loop") == FAILURE
)
2237 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
2238 "Step expression in DO loop") == FAILURE
)
2241 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
2243 if ((iter
->step
->ts
.type
== BT_INTEGER
2244 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
2245 || (iter
->step
->ts
.type
== BT_REAL
2246 && mpfr_sgn (iter
->step
->value
.real
) == 0))
2248 gfc_error ("Step expression in DO loop at %L cannot be zero",
2249 &iter
->step
->where
);
2254 /* Convert start, end, and step to the same type as var. */
2255 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
2256 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
2257 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2259 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
2260 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
2261 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2263 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
2264 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
2265 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
2271 /* Resolve a list of FORALL iterators. */
2274 resolve_forall_iterators (gfc_forall_iterator
* iter
)
2279 if (gfc_resolve_expr (iter
->var
) == SUCCESS
2280 && iter
->var
->ts
.type
!= BT_INTEGER
)
2281 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2284 if (gfc_resolve_expr (iter
->start
) == SUCCESS
2285 && iter
->start
->ts
.type
!= BT_INTEGER
)
2286 gfc_error ("FORALL start expression at %L must be INTEGER",
2287 &iter
->start
->where
);
2288 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
2289 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2291 if (gfc_resolve_expr (iter
->end
) == SUCCESS
2292 && iter
->end
->ts
.type
!= BT_INTEGER
)
2293 gfc_error ("FORALL end expression at %L must be INTEGER",
2295 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
2296 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2298 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
2299 && iter
->stride
->ts
.type
!= BT_INTEGER
)
2300 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2301 &iter
->stride
->where
);
2302 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
2303 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
2310 /* Given a pointer to a symbol that is a derived type, see if any components
2311 have the POINTER attribute. The search is recursive if necessary.
2312 Returns zero if no pointer components are found, nonzero otherwise. */
2315 derived_pointer (gfc_symbol
* sym
)
2319 for (c
= sym
->components
; c
; c
= c
->next
)
2324 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
2332 /* Resolve the argument of a deallocate expression. The expression must be
2333 a pointer or a full array. */
2336 resolve_deallocate_expr (gfc_expr
* e
)
2338 symbol_attribute attr
;
2342 if (gfc_resolve_expr (e
) == FAILURE
)
2345 attr
= gfc_expr_attr (e
);
2349 if (e
->expr_type
!= EXPR_VARIABLE
)
2352 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2353 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2357 if (ref
->u
.ar
.type
!= AR_FULL
)
2362 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2363 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2371 if (allocatable
== 0)
2374 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2375 "ALLOCATABLE or a POINTER", &e
->where
);
2382 /* Resolve the expression in an ALLOCATE statement, doing the additional
2383 checks to see whether the expression is OK or not. The expression must
2384 have a trailing array reference that gives the size of the array. */
2387 resolve_allocate_expr (gfc_expr
* e
)
2389 int i
, pointer
, allocatable
, dimension
;
2390 symbol_attribute attr
;
2391 gfc_ref
*ref
, *ref2
;
2394 if (gfc_resolve_expr (e
) == FAILURE
)
2397 /* Make sure the expression is allocatable or a pointer. If it is
2398 pointer, the next-to-last reference must be a pointer. */
2402 if (e
->expr_type
!= EXPR_VARIABLE
)
2406 attr
= gfc_expr_attr (e
);
2407 pointer
= attr
.pointer
;
2408 dimension
= attr
.dimension
;
2413 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2414 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
2415 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
2417 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
2421 if (ref
->next
!= NULL
)
2426 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2427 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2429 pointer
= ref
->u
.c
.component
->pointer
;
2430 dimension
= ref
->u
.c
.component
->dimension
;
2440 if (allocatable
== 0 && pointer
== 0)
2442 gfc_error ("Expression in ALLOCATE statement at %L must be "
2443 "ALLOCATABLE or a POINTER", &e
->where
);
2447 if (pointer
&& dimension
== 0)
2450 /* Make sure the next-to-last reference node is an array specification. */
2452 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
2454 gfc_error ("Array specification required in ALLOCATE statement "
2455 "at %L", &e
->where
);
2459 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
2462 /* Make sure that the array section reference makes sense in the
2463 context of an ALLOCATE specification. */
2467 for (i
= 0; i
< ar
->dimen
; i
++)
2468 switch (ar
->dimen_type
[i
])
2474 if (ar
->start
[i
] != NULL
2475 && ar
->end
[i
] != NULL
2476 && ar
->stride
[i
] == NULL
)
2479 /* Fall Through... */
2483 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2492 /************ SELECT CASE resolution subroutines ************/
2494 /* Callback function for our mergesort variant. Determines interval
2495 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2496 op1 > op2. Assumes we're not dealing with the default case.
2497 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2498 There are nine situations to check. */
2501 compare_cases (const gfc_case
* op1
, const gfc_case
* op2
)
2505 if (op1
->low
== NULL
) /* op1 = (:L) */
2507 /* op2 = (:N), so overlap. */
2509 /* op2 = (M:) or (M:N), L < M */
2510 if (op2
->low
!= NULL
2511 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2514 else if (op1
->high
== NULL
) /* op1 = (K:) */
2516 /* op2 = (M:), so overlap. */
2518 /* op2 = (:N) or (M:N), K > N */
2519 if (op2
->high
!= NULL
2520 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2523 else /* op1 = (K:L) */
2525 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
2526 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
2527 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
2528 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
2529 else /* op2 = (M:N) */
2533 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2536 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2545 /* Merge-sort a double linked case list, detecting overlap in the
2546 process. LIST is the head of the double linked case list before it
2547 is sorted. Returns the head of the sorted list if we don't see any
2548 overlap, or NULL otherwise. */
2551 check_case_overlap (gfc_case
* list
)
2553 gfc_case
*p
, *q
, *e
, *tail
;
2554 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
2556 /* If the passed list was empty, return immediately. */
2563 /* Loop unconditionally. The only exit from this loop is a return
2564 statement, when we've finished sorting the case list. */
2571 /* Count the number of merges we do in this pass. */
2574 /* Loop while there exists a merge to be done. */
2579 /* Count this merge. */
2582 /* Cut the list in two pieces by stepping INSIZE places
2583 forward in the list, starting from P. */
2586 for (i
= 0; i
< insize
; i
++)
2595 /* Now we have two lists. Merge them! */
2596 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
2599 /* See from which the next case to merge comes from. */
2602 /* P is empty so the next case must come from Q. */
2607 else if (qsize
== 0 || q
== NULL
)
2616 cmp
= compare_cases (p
, q
);
2619 /* The whole case range for P is less than the
2627 /* The whole case range for Q is greater than
2628 the case range for P. */
2635 /* The cases overlap, or they are the same
2636 element in the list. Either way, we must
2637 issue an error and get the next case from P. */
2638 /* FIXME: Sort P and Q by line number. */
2639 gfc_error ("CASE label at %L overlaps with CASE "
2640 "label at %L", &p
->where
, &q
->where
);
2648 /* Add the next element to the merged list. */
2657 /* P has now stepped INSIZE places along, and so has Q. So
2658 they're the same. */
2663 /* If we have done only one merge or none at all, we've
2664 finished sorting the cases. */
2673 /* Otherwise repeat, merging lists twice the size. */
2679 /* Check to see if an expression is suitable for use in a CASE statement.
2680 Makes sure that all case expressions are scalar constants of the same
2681 type. Return FAILURE if anything is wrong. */
2684 validate_case_label_expr (gfc_expr
* e
, gfc_expr
* case_expr
)
2686 if (e
== NULL
) return SUCCESS
;
2688 if (e
->ts
.type
!= case_expr
->ts
.type
)
2690 gfc_error ("Expression in CASE statement at %L must be of type %s",
2691 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
2695 /* C805 (R808) For a given case-construct, each case-value shall be of
2696 the same type as case-expr. For character type, length differences
2697 are allowed, but the kind type parameters shall be the same. */
2699 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
2701 gfc_error("Expression in CASE statement at %L must be kind %d",
2702 &e
->where
, case_expr
->ts
.kind
);
2706 /* Convert the case value kind to that of case expression kind, if needed.
2707 FIXME: Should a warning be issued? */
2708 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
2709 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
2713 gfc_error ("Expression in CASE statement at %L must be scalar",
2722 /* Given a completely parsed select statement, we:
2724 - Validate all expressions and code within the SELECT.
2725 - Make sure that the selection expression is not of the wrong type.
2726 - Make sure that no case ranges overlap.
2727 - Eliminate unreachable cases and unreachable code resulting from
2728 removing case labels.
2730 The standard does allow unreachable cases, e.g. CASE (5:3). But
2731 they are a hassle for code generation, and to prevent that, we just
2732 cut them out here. This is not necessary for overlapping cases
2733 because they are illegal and we never even try to generate code.
2735 We have the additional caveat that a SELECT construct could have
2736 been a computed GOTO in the source code. Fortunately we can fairly
2737 easily work around that here: The case_expr for a "real" SELECT CASE
2738 is in code->expr1, but for a computed GOTO it is in code->expr2. All
2739 we have to do is make sure that the case_expr is a scalar integer
2743 resolve_select (gfc_code
* code
)
2746 gfc_expr
*case_expr
;
2747 gfc_case
*cp
, *default_case
, *tail
, *head
;
2748 int seen_unreachable
;
2753 if (code
->expr
== NULL
)
2755 /* This was actually a computed GOTO statement. */
2756 case_expr
= code
->expr2
;
2757 if (case_expr
->ts
.type
!= BT_INTEGER
2758 || case_expr
->rank
!= 0)
2759 gfc_error ("Selection expression in computed GOTO statement "
2760 "at %L must be a scalar integer expression",
2763 /* Further checking is not necessary because this SELECT was built
2764 by the compiler, so it should always be OK. Just move the
2765 case_expr from expr2 to expr so that we can handle computed
2766 GOTOs as normal SELECTs from here on. */
2767 code
->expr
= code
->expr2
;
2772 case_expr
= code
->expr
;
2774 type
= case_expr
->ts
.type
;
2775 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
2777 gfc_error ("Argument of SELECT statement at %L cannot be %s",
2778 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
2780 /* Punt. Going on here just produce more garbage error messages. */
2784 if (case_expr
->rank
!= 0)
2786 gfc_error ("Argument of SELECT statement at %L must be a scalar "
2787 "expression", &case_expr
->where
);
2793 /* PR 19168 has a long discussion concerning a mismatch of the kinds
2794 of the SELECT CASE expression and its CASE values. Walk the lists
2795 of case values, and if we find a mismatch, promote case_expr to
2796 the appropriate kind. */
2798 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
2800 for (body
= code
->block
; body
; body
= body
->block
)
2802 /* Walk the case label list. */
2803 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
2805 /* Intercept the DEFAULT case. It does not have a kind. */
2806 if (cp
->low
== NULL
&& cp
->high
== NULL
)
2809 /* Unreachable case ranges are discarded, so ignore. */
2810 if (cp
->low
!= NULL
&& cp
->high
!= NULL
2811 && cp
->low
!= cp
->high
2812 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
2815 /* FIXME: Should a warning be issued? */
2817 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
2818 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
2820 if (cp
->high
!= NULL
2821 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
2822 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
2827 /* Assume there is no DEFAULT case. */
2828 default_case
= NULL
;
2832 for (body
= code
->block
; body
; body
= body
->block
)
2834 /* Assume the CASE list is OK, and all CASE labels can be matched. */
2836 seen_unreachable
= 0;
2838 /* Walk the case label list, making sure that all case labels
2840 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
2842 /* Count the number of cases in the whole construct. */
2845 /* Intercept the DEFAULT case. */
2846 if (cp
->low
== NULL
&& cp
->high
== NULL
)
2848 if (default_case
!= NULL
)
2850 gfc_error ("The DEFAULT CASE at %L cannot be followed "
2851 "by a second DEFAULT CASE at %L",
2852 &default_case
->where
, &cp
->where
);
2863 /* Deal with single value cases and case ranges. Errors are
2864 issued from the validation function. */
2865 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
2866 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
2872 if (type
== BT_LOGICAL
2873 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
2874 || cp
->low
!= cp
->high
))
2877 ("Logical range in CASE statement at %L is not allowed",
2883 if (cp
->low
!= NULL
&& cp
->high
!= NULL
2884 && cp
->low
!= cp
->high
2885 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
2887 if (gfc_option
.warn_surprising
)
2888 gfc_warning ("Range specification at %L can never "
2889 "be matched", &cp
->where
);
2891 cp
->unreachable
= 1;
2892 seen_unreachable
= 1;
2896 /* If the case range can be matched, it can also overlap with
2897 other cases. To make sure it does not, we put it in a
2898 double linked list here. We sort that with a merge sort
2899 later on to detect any overlapping cases. */
2903 head
->right
= head
->left
= NULL
;
2908 tail
->right
->left
= tail
;
2915 /* It there was a failure in the previous case label, give up
2916 for this case label list. Continue with the next block. */
2920 /* See if any case labels that are unreachable have been seen.
2921 If so, we eliminate them. This is a bit of a kludge because
2922 the case lists for a single case statement (label) is a
2923 single forward linked lists. */
2924 if (seen_unreachable
)
2926 /* Advance until the first case in the list is reachable. */
2927 while (body
->ext
.case_list
!= NULL
2928 && body
->ext
.case_list
->unreachable
)
2930 gfc_case
*n
= body
->ext
.case_list
;
2931 body
->ext
.case_list
= body
->ext
.case_list
->next
;
2933 gfc_free_case_list (n
);
2936 /* Strip all other unreachable cases. */
2937 if (body
->ext
.case_list
)
2939 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
2941 if (cp
->next
->unreachable
)
2943 gfc_case
*n
= cp
->next
;
2944 cp
->next
= cp
->next
->next
;
2946 gfc_free_case_list (n
);
2953 /* See if there were overlapping cases. If the check returns NULL,
2954 there was overlap. In that case we don't do anything. If head
2955 is non-NULL, we prepend the DEFAULT case. The sorted list can
2956 then used during code generation for SELECT CASE constructs with
2957 a case expression of a CHARACTER type. */
2960 head
= check_case_overlap (head
);
2962 /* Prepend the default_case if it is there. */
2963 if (head
!= NULL
&& default_case
)
2965 default_case
->left
= NULL
;
2966 default_case
->right
= head
;
2967 head
->left
= default_case
;
2971 /* Eliminate dead blocks that may be the result if we've seen
2972 unreachable case labels for a block. */
2973 for (body
= code
; body
&& body
->block
; body
= body
->block
)
2975 if (body
->block
->ext
.case_list
== NULL
)
2977 /* Cut the unreachable block from the code chain. */
2978 gfc_code
*c
= body
->block
;
2979 body
->block
= c
->block
;
2981 /* Kill the dead block, but not the blocks below it. */
2983 gfc_free_statements (c
);
2987 /* More than two cases is legal but insane for logical selects.
2988 Issue a warning for it. */
2989 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
2991 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
2996 /* Resolve a transfer statement. This is making sure that:
2997 -- a derived type being transferred has only non-pointer components
2998 -- a derived type being transferred doesn't have private components
2999 -- we're not trying to transfer a whole assumed size array. */
3002 resolve_transfer (gfc_code
* code
)
3011 if (exp
->expr_type
!= EXPR_VARIABLE
)
3014 sym
= exp
->symtree
->n
.sym
;
3017 /* Go to actual component transferred. */
3018 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
3019 if (ref
->type
== REF_COMPONENT
)
3020 ts
= &ref
->u
.c
.component
->ts
;
3022 if (ts
->type
== BT_DERIVED
)
3024 /* Check that transferred derived type doesn't contain POINTER
3026 if (derived_pointer (ts
->derived
))
3028 gfc_error ("Data transfer element at %L cannot have "
3029 "POINTER components", &code
->loc
);
3033 if (ts
->derived
->component_access
== ACCESS_PRIVATE
)
3035 gfc_error ("Data transfer element at %L cannot have "
3036 "PRIVATE components",&code
->loc
);
3041 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
3042 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
3044 gfc_error ("Data transfer element at %L cannot be a full reference to "
3045 "an assumed-size array", &code
->loc
);
3051 /*********** Toplevel code resolution subroutines ***********/
3053 /* Given a branch to a label and a namespace, if the branch is conforming.
3054 The code node described where the branch is located. */
3057 resolve_branch (gfc_st_label
* label
, gfc_code
* code
)
3059 gfc_code
*block
, *found
;
3067 /* Step one: is this a valid branching target? */
3069 if (lp
->defined
== ST_LABEL_UNKNOWN
)
3071 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
3076 if (lp
->defined
!= ST_LABEL_TARGET
)
3078 gfc_error ("Statement at %L is not a valid branch target statement "
3079 "for the branch statement at %L", &lp
->where
, &code
->loc
);
3083 /* Step two: make sure this branch is not a branch to itself ;-) */
3085 if (code
->here
== label
)
3087 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
3091 /* Step three: Try to find the label in the parse tree. To do this,
3092 we traverse the tree block-by-block: first the block that
3093 contains this GOTO, then the block that it is nested in, etc. We
3094 can ignore other blocks because branching into another block is
3099 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3101 for (block
= stack
->head
; block
; block
= block
->next
)
3103 if (block
->here
== label
)
3116 /* still nothing, so illegal. */
3117 gfc_error_now ("Label at %L is not in the same block as the "
3118 "GOTO statement at %L", &lp
->where
, &code
->loc
);
3122 /* Step four: Make sure that the branching target is legal if
3123 the statement is an END {SELECT,DO,IF}. */
3125 if (found
->op
== EXEC_NOP
)
3127 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3128 if (stack
->current
->next
== found
)
3132 gfc_notify_std (GFC_STD_F95_DEL
,
3133 "Obsolete: GOTO at %L jumps to END of construct at %L",
3134 &code
->loc
, &found
->loc
);
3139 /* Check whether EXPR1 has the same shape as EXPR2. */
3142 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
3144 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3145 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
3146 try result
= FAILURE
;
3149 /* Compare the rank. */
3150 if (expr1
->rank
!= expr2
->rank
)
3153 /* Compare the size of each dimension. */
3154 for (i
=0; i
<expr1
->rank
; i
++)
3156 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
3159 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
3162 if (mpz_cmp (shape
[i
], shape2
[i
]))
3166 /* When either of the two expression is an assumed size array, we
3167 ignore the comparison of dimension sizes. */
3172 for (i
--; i
>=0; i
--)
3174 mpz_clear (shape
[i
]);
3175 mpz_clear (shape2
[i
]);
3181 /* Check whether a WHERE assignment target or a WHERE mask expression
3182 has the same shape as the outmost WHERE mask expression. */
3185 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
3191 cblock
= code
->block
;
3193 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3194 In case of nested WHERE, only the outmost one is stored. */
3195 if (mask
== NULL
) /* outmost WHERE */
3197 else /* inner WHERE */
3204 /* Check if the mask-expr has a consistent shape with the
3205 outmost WHERE mask-expr. */
3206 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
3207 gfc_error ("WHERE mask at %L has inconsistent shape",
3208 &cblock
->expr
->where
);
3211 /* the assignment statement of a WHERE statement, or the first
3212 statement in where-body-construct of a WHERE construct */
3213 cnext
= cblock
->next
;
3218 /* WHERE assignment statement */
3221 /* Check shape consistent for WHERE assignment target. */
3222 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
3223 gfc_error ("WHERE assignment target at %L has "
3224 "inconsistent shape", &cnext
->expr
->where
);
3227 /* WHERE or WHERE construct is part of a where-body-construct */
3229 resolve_where (cnext
, e
);
3233 gfc_error ("Unsupported statement inside WHERE at %L",
3236 /* the next statement within the same where-body-construct */
3237 cnext
= cnext
->next
;
3239 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3240 cblock
= cblock
->block
;
3245 /* Check whether the FORALL index appears in the expression or not. */
3248 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
3252 gfc_actual_arglist
*args
;
3255 switch (expr
->expr_type
)
3258 gcc_assert (expr
->symtree
->n
.sym
);
3260 /* A scalar assignment */
3263 if (expr
->symtree
->n
.sym
== symbol
)
3269 /* the expr is array ref, substring or struct component. */
3276 /* Check if the symbol appears in the array subscript. */
3278 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3281 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
3285 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
3289 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
3295 if (expr
->symtree
->n
.sym
== symbol
)
3298 /* Check if the symbol appears in the substring section. */
3299 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3301 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3309 gfc_error("expresion reference type error at %L", &expr
->where
);
3315 /* If the expression is a function call, then check if the symbol
3316 appears in the actual arglist of the function. */
3318 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3320 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
3325 /* It seems not to happen. */
3326 case EXPR_SUBSTRING
:
3330 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
3331 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3333 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3338 /* It seems not to happen. */
3339 case EXPR_STRUCTURE
:
3341 gfc_error ("Unsupported statement while finding forall index in "
3348 /* Find the FORALL index in the first operand. */
3351 if (gfc_find_forall_index (expr
->op1
, symbol
) == SUCCESS
)
3355 /* Find the FORALL index in the second operand. */
3358 if (gfc_find_forall_index (expr
->op2
, symbol
) == SUCCESS
)
3365 /* Resolve assignment in FORALL construct.
3366 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3367 FORALL index variables. */
3370 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3374 for (n
= 0; n
< nvar
; n
++)
3376 gfc_symbol
*forall_index
;
3378 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
3380 /* Check whether the assignment target is one of the FORALL index
3382 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
3383 && (code
->expr
->symtree
->n
.sym
== forall_index
))
3384 gfc_error ("Assignment to a FORALL index variable at %L",
3385 &code
->expr
->where
);
3388 /* If one of the FORALL index variables doesn't appear in the
3389 assignment target, then there will be a many-to-one
3391 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
3392 gfc_error ("The FORALL with index '%s' cause more than one "
3393 "assignment to this object at %L",
3394 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
3400 /* Resolve WHERE statement in FORALL construct. */
3403 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
){
3407 cblock
= code
->block
;
3410 /* the assignment statement of a WHERE statement, or the first
3411 statement in where-body-construct of a WHERE construct */
3412 cnext
= cblock
->next
;
3417 /* WHERE assignment statement */
3419 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
3422 /* WHERE or WHERE construct is part of a where-body-construct */
3424 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
3428 gfc_error ("Unsupported statement inside WHERE at %L",
3431 /* the next statement within the same where-body-construct */
3432 cnext
= cnext
->next
;
3434 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3435 cblock
= cblock
->block
;
3440 /* Traverse the FORALL body to check whether the following errors exist:
3441 1. For assignment, check if a many-to-one assignment happens.
3442 2. For WHERE statement, check the WHERE body to see if there is any
3443 many-to-one assignment. */
3446 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3450 c
= code
->block
->next
;
3456 case EXEC_POINTER_ASSIGN
:
3457 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
3460 /* Because the resolve_blocks() will handle the nested FORALL,
3461 there is no need to handle it here. */
3465 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
3470 /* The next statement in the FORALL body. */
3476 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3477 gfc_resolve_forall_body to resolve the FORALL body. */
3479 static void resolve_blocks (gfc_code
*, gfc_namespace
*);
3482 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
3484 static gfc_expr
**var_expr
;
3485 static int total_var
= 0;
3486 static int nvar
= 0;
3487 gfc_forall_iterator
*fa
;
3488 gfc_symbol
*forall_index
;
3492 /* Start to resolve a FORALL construct */
3493 if (forall_save
== 0)
3495 /* Count the total number of FORALL index in the nested FORALL
3496 construct in order to allocate the VAR_EXPR with proper size. */
3498 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
3500 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3502 next
= next
->block
->next
;
3505 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3506 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
3509 /* The information about FORALL iterator, including FORALL index start, end
3510 and stride. The FORALL index can not appear in start, end or stride. */
3511 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3513 /* Check if any outer FORALL index name is the same as the current
3515 for (i
= 0; i
< nvar
; i
++)
3517 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
3519 gfc_error ("An outer FORALL construct already has an index "
3520 "with this name %L", &fa
->var
->where
);
3524 /* Record the current FORALL index. */
3525 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
3527 forall_index
= fa
->var
->symtree
->n
.sym
;
3529 /* Check if the FORALL index appears in start, end or stride. */
3530 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
3531 gfc_error ("A FORALL index must not appear in a limit or stride "
3532 "expression in the same FORALL at %L", &fa
->start
->where
);
3533 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
3534 gfc_error ("A FORALL index must not appear in a limit or stride "
3535 "expression in the same FORALL at %L", &fa
->end
->where
);
3536 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
3537 gfc_error ("A FORALL index must not appear in a limit or stride "
3538 "expression in the same FORALL at %L", &fa
->stride
->where
);
3542 /* Resolve the FORALL body. */
3543 gfc_resolve_forall_body (code
, nvar
, var_expr
);
3545 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3546 resolve_blocks (code
->block
, ns
);
3548 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3549 for (i
= 0; i
< total_var
; i
++)
3550 gfc_free_expr (var_expr
[i
]);
3552 /* Reset the counters. */
3558 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3561 static void resolve_code (gfc_code
*, gfc_namespace
*);
3564 resolve_blocks (gfc_code
* b
, gfc_namespace
* ns
)
3568 for (; b
; b
= b
->block
)
3570 t
= gfc_resolve_expr (b
->expr
);
3571 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
3577 if (t
== SUCCESS
&& b
->expr
!= NULL
3578 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
3580 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3587 && (b
->expr
->ts
.type
!= BT_LOGICAL
3588 || b
->expr
->rank
== 0))
3590 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3595 resolve_branch (b
->label
, b
);
3605 gfc_internal_error ("resolve_block(): Bad block type");
3608 resolve_code (b
->next
, ns
);
3613 /* Given a block of code, recursively resolve everything pointed to by this
3617 resolve_code (gfc_code
* code
, gfc_namespace
* ns
)
3619 int forall_save
= 0;
3624 frame
.prev
= cs_base
;
3628 for (; code
; code
= code
->next
)
3630 frame
.current
= code
;
3632 if (code
->op
== EXEC_FORALL
)
3634 forall_save
= forall_flag
;
3636 gfc_resolve_forall (code
, ns
, forall_save
);
3639 resolve_blocks (code
->block
, ns
);
3641 if (code
->op
== EXEC_FORALL
)
3642 forall_flag
= forall_save
;
3644 t
= gfc_resolve_expr (code
->expr
);
3645 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
3661 resolve_where (code
, NULL
);
3665 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_INTEGER
)
3666 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3667 "variable", &code
->expr
->where
);
3669 resolve_branch (code
->label
, code
);
3673 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_INTEGER
)
3674 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3675 "return specifier", &code
->expr
->where
);
3682 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
3685 if (gfc_pure (NULL
))
3687 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
3690 ("Cannot assign to variable '%s' in PURE procedure at %L",
3691 code
->expr
->symtree
->n
.sym
->name
, &code
->expr
->where
);
3695 if (code
->expr2
->ts
.type
== BT_DERIVED
3696 && derived_pointer (code
->expr2
->ts
.derived
))
3699 ("Right side of assignment at %L is a derived type "
3700 "containing a POINTER in a PURE procedure",
3701 &code
->expr2
->where
);
3706 gfc_check_assign (code
->expr
, code
->expr2
, 1);
3709 case EXEC_LABEL_ASSIGN
:
3710 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
3711 gfc_error ("Label %d referenced at %L is never defined",
3712 code
->label
->value
, &code
->label
->where
);
3714 && (code
->expr
->expr_type
!= EXPR_VARIABLE
3715 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
3716 || code
->expr
->symtree
->n
.sym
->ts
.kind
3717 != gfc_default_integer_kind
3718 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
3719 gfc_error ("ASSIGN statement at %L requires a scalar "
3720 "default INTEGER variable", &code
->expr
->where
);
3723 case EXEC_POINTER_ASSIGN
:
3727 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
3730 case EXEC_ARITHMETIC_IF
:
3732 && code
->expr
->ts
.type
!= BT_INTEGER
3733 && code
->expr
->ts
.type
!= BT_REAL
)
3734 gfc_error ("Arithmetic IF statement at %L requires a numeric "
3735 "expression", &code
->expr
->where
);
3737 resolve_branch (code
->label
, code
);
3738 resolve_branch (code
->label2
, code
);
3739 resolve_branch (code
->label3
, code
);
3743 if (t
== SUCCESS
&& code
->expr
!= NULL
3744 && (code
->expr
->ts
.type
!= BT_LOGICAL
3745 || code
->expr
->rank
!= 0))
3746 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3747 &code
->expr
->where
);
3752 resolve_call (code
);
3756 /* Select is complicated. Also, a SELECT construct could be
3757 a transformed computed GOTO. */
3758 resolve_select (code
);
3762 if (code
->ext
.iterator
!= NULL
)
3763 gfc_resolve_iterator (code
->ext
.iterator
, true);
3767 if (code
->expr
== NULL
)
3768 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
3770 && (code
->expr
->rank
!= 0
3771 || code
->expr
->ts
.type
!= BT_LOGICAL
))
3772 gfc_error ("Exit condition of DO WHILE loop at %L must be "
3773 "a scalar LOGICAL expression", &code
->expr
->where
);
3777 if (t
== SUCCESS
&& code
->expr
!= NULL
3778 && code
->expr
->ts
.type
!= BT_INTEGER
)
3779 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
3780 "of type INTEGER", &code
->expr
->where
);
3782 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3783 resolve_allocate_expr (a
->expr
);
3787 case EXEC_DEALLOCATE
:
3788 if (t
== SUCCESS
&& code
->expr
!= NULL
3789 && code
->expr
->ts
.type
!= BT_INTEGER
)
3791 ("STAT tag in DEALLOCATE statement at %L must be of type "
3792 "INTEGER", &code
->expr
->where
);
3794 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3795 resolve_deallocate_expr (a
->expr
);
3800 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
3803 resolve_branch (code
->ext
.open
->err
, code
);
3807 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
3810 resolve_branch (code
->ext
.close
->err
, code
);
3813 case EXEC_BACKSPACE
:
3816 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
3819 resolve_branch (code
->ext
.filepos
->err
, code
);
3823 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
3826 resolve_branch (code
->ext
.inquire
->err
, code
);
3830 gcc_assert (code
->ext
.inquire
!= NULL
);
3831 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
3834 resolve_branch (code
->ext
.inquire
->err
, code
);
3839 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
3842 resolve_branch (code
->ext
.dt
->err
, code
);
3843 resolve_branch (code
->ext
.dt
->end
, code
);
3844 resolve_branch (code
->ext
.dt
->eor
, code
);
3848 resolve_transfer (code
);
3852 resolve_forall_iterators (code
->ext
.forall_iterator
);
3854 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
3856 ("FORALL mask clause at %L requires a LOGICAL expression",
3857 &code
->expr
->where
);
3861 gfc_internal_error ("resolve_code(): Bad statement code");
3865 cs_base
= frame
.prev
;
3869 /* Resolve initial values and make sure they are compatible with
3873 resolve_values (gfc_symbol
* sym
)
3876 if (sym
->value
== NULL
)
3879 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
3882 gfc_check_assign_symbol (sym
, sym
->value
);
3886 /* Do anything necessary to resolve a symbol. Right now, we just
3887 assume that an otherwise unknown symbol is a variable. This sort
3888 of thing commonly happens for symbols in module. */
3891 resolve_symbol (gfc_symbol
* sym
)
3893 /* Zero if we are checking a formal namespace. */
3894 static int formal_ns_flag
= 1;
3895 int formal_ns_save
, check_constant
, mp_flag
;
3900 if (sym
->attr
.flavor
== FL_UNKNOWN
)
3902 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
3903 sym
->attr
.flavor
= FL_VARIABLE
;
3906 sym
->attr
.flavor
= FL_PROCEDURE
;
3907 if (sym
->attr
.dimension
)
3908 sym
->attr
.function
= 1;
3912 /* Symbols that are module procedures with results (functions) have
3913 the types and array specification copied for type checking in
3914 procedures that call them, as well as for saving to a module
3915 file. These symbols can't stand the scrutiny that their results
3917 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
3919 /* Assign default type to symbols that need one and don't have one. */
3920 if (sym
->ts
.type
== BT_UNKNOWN
)
3922 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
3923 gfc_set_default_type (sym
, 1, NULL
);
3925 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
3928 gfc_set_default_type (sym
, 0, NULL
);
3931 /* Result may be in another namespace. */
3932 resolve_symbol (sym
->result
);
3934 sym
->ts
= sym
->result
->ts
;
3935 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
3940 /* Assumed size arrays and assumed shape arrays must be dummy
3944 && (sym
->as
->type
== AS_ASSUMED_SIZE
3945 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
3946 && sym
->attr
.dummy
== 0)
3948 gfc_error ("Assumed %s array at %L must be a dummy argument",
3949 sym
->as
->type
== AS_ASSUMED_SIZE
? "size" : "shape",
3954 /* A parameter array's shape needs to be constant. */
3956 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->as
!= NULL
3957 && !gfc_is_compile_time_shape (sym
->as
))
3959 gfc_error ("Parameter array '%s' at %L cannot be automatic "
3960 "or assumed shape", sym
->name
, &sym
->declared_at
);
3964 /* Make sure that character string variables with assumed length are
3967 if (sym
->attr
.flavor
== FL_VARIABLE
&& !sym
->attr
.result
3968 && sym
->ts
.type
== BT_CHARACTER
3969 && sym
->ts
.cl
->length
== NULL
&& sym
->attr
.dummy
== 0)
3971 gfc_error ("Entity with assumed character length at %L must be a "
3972 "dummy argument or a PARAMETER", &sym
->declared_at
);
3976 /* Make sure a parameter that has been implicitly typed still
3977 matches the implicit type, since PARAMETER statements can precede
3978 IMPLICIT statements. */
3980 if (sym
->attr
.flavor
== FL_PARAMETER
3981 && sym
->attr
.implicit_type
3982 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
3983 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
3984 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
3986 /* Make sure the types of derived parameters are consistent. This
3987 type checking is deferred until resolution because the type may
3988 refer to a derived type from the host. */
3990 if (sym
->attr
.flavor
== FL_PARAMETER
3991 && sym
->ts
.type
== BT_DERIVED
3992 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
3993 gfc_error ("Incompatible derived type in PARAMETER at %L",
3994 &sym
->value
->where
);
3996 /* Make sure symbols with known intent or optional are really dummy
3997 variable. Because of ENTRY statement, this has to be deferred
3998 until resolution time. */
4000 if (! sym
->attr
.dummy
4001 && (sym
->attr
.optional
4002 || sym
->attr
.intent
!= INTENT_UNKNOWN
))
4004 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
4008 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
4010 if (sym
->ts
.type
== BT_CHARACTER
)
4012 gfc_charlen
*cl
= sym
->ts
.cl
;
4013 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
4015 gfc_error ("Character-valued statement function '%s' at %L must "
4016 "have constant length", sym
->name
, &sym
->declared_at
);
4022 /* Constraints on deferred shape variable. */
4023 if (sym
->attr
.flavor
== FL_VARIABLE
4024 || (sym
->attr
.flavor
== FL_PROCEDURE
4025 && sym
->attr
.function
))
4027 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
4029 if (sym
->attr
.allocatable
)
4031 if (sym
->attr
.dimension
)
4032 gfc_error ("Allocatable array at %L must have a deferred shape",
4035 gfc_error ("Object at %L may not be ALLOCATABLE",
4040 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
4042 gfc_error ("Pointer to array at %L must have a deferred shape",
4050 if (!mp_flag
&& !sym
->attr
.allocatable
4051 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
4053 gfc_error ("Array at %L cannot have a deferred shape",
4060 if (sym
->attr
.flavor
== FL_VARIABLE
)
4062 /* Can the sybol have an initializer? */
4064 if (sym
->attr
.allocatable
)
4065 whynot
= "Allocatable";
4066 else if (sym
->attr
.external
)
4067 whynot
= "External";
4068 else if (sym
->attr
.dummy
)
4070 else if (sym
->attr
.intrinsic
)
4071 whynot
= "Intrinsic";
4072 else if (sym
->attr
.result
)
4073 whynot
= "Function Result";
4074 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
4076 /* Don't allow initialization of automatic arrays. */
4077 for (i
= 0; i
< sym
->as
->rank
; i
++)
4079 if (sym
->as
->lower
[i
] == NULL
4080 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4081 || sym
->as
->upper
[i
] == NULL
4082 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
4084 whynot
= "Automatic array";
4090 /* Reject illegal initializers. */
4091 if (sym
->value
&& whynot
)
4093 gfc_error ("%s '%s' at %L cannot have an initializer",
4094 whynot
, sym
->name
, &sym
->declared_at
);
4098 /* Assign default initializer. */
4099 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| whynot
))
4100 sym
->value
= gfc_default_initializer (&sym
->ts
);
4104 /* Make sure that intrinsic exist */
4105 if (sym
->attr
.intrinsic
4106 && ! gfc_intrinsic_name(sym
->name
, 0)
4107 && ! gfc_intrinsic_name(sym
->name
, 1))
4108 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
4110 /* Resolve array specifier. Check as well some constraints
4111 on COMMON blocks. */
4113 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
4114 gfc_resolve_array_spec (sym
->as
, check_constant
);
4116 /* Resolve formal namespaces. */
4118 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
4120 formal_ns_save
= formal_ns_flag
;
4122 gfc_resolve (sym
->formal_ns
);
4123 formal_ns_flag
= formal_ns_save
;
4129 /************* Resolve DATA statements *************/
4133 gfc_data_value
*vnode
;
4139 /* Advance the values structure to point to the next value in the data list. */
4142 next_data_value (void)
4144 while (values
.left
== 0)
4146 if (values
.vnode
->next
== NULL
)
4149 values
.vnode
= values
.vnode
->next
;
4150 values
.left
= values
.vnode
->repeat
;
4158 check_data_variable (gfc_data_variable
* var
, locus
* where
)
4164 ar_type mark
= AR_UNKNOWN
;
4166 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
4170 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
4174 mpz_init_set_si (offset
, 0);
4177 if (e
->expr_type
!= EXPR_VARIABLE
)
4178 gfc_internal_error ("check_data_variable(): Bad expression");
4182 mpz_init_set_ui (size
, 1);
4189 /* Find the array section reference. */
4190 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4192 if (ref
->type
!= REF_ARRAY
)
4194 if (ref
->u
.ar
.type
== AR_ELEMENT
)
4200 /* Set marks according to the reference pattern. */
4201 switch (ref
->u
.ar
.type
)
4209 /* Get the start position of array section. */
4210 gfc_get_section_index (ar
, section_index
, &offset
);
4218 if (gfc_array_size (e
, &size
) == FAILURE
)
4220 gfc_error ("Nonconstant array section at %L in DATA statement",
4229 while (mpz_cmp_ui (size
, 0) > 0)
4231 if (next_data_value () == FAILURE
)
4233 gfc_error ("DATA statement at %L has more variables than values",
4239 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
4243 /* If we have more than one element left in the repeat count,
4244 and we have more than one element left in the target variable,
4245 then create a range assignment. */
4246 /* ??? Only done for full arrays for now, since array sections
4248 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
4249 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
4253 if (mpz_cmp_ui (size
, values
.left
) >= 0)
4255 mpz_init_set_ui (range
, values
.left
);
4256 mpz_sub_ui (size
, size
, values
.left
);
4261 mpz_init_set (range
, size
);
4262 values
.left
-= mpz_get_ui (size
);
4263 mpz_set_ui (size
, 0);
4266 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
4269 mpz_add (offset
, offset
, range
);
4273 /* Assign initial value to symbol. */
4277 mpz_sub_ui (size
, size
, 1);
4279 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
4281 if (mark
== AR_FULL
)
4282 mpz_add_ui (offset
, offset
, 1);
4284 /* Modify the array section indexes and recalculate the offset
4285 for next element. */
4286 else if (mark
== AR_SECTION
)
4287 gfc_advance_section (section_index
, ar
, &offset
);
4291 if (mark
== AR_SECTION
)
4293 for (i
= 0; i
< ar
->dimen
; i
++)
4294 mpz_clear (section_index
[i
]);
4304 static try traverse_data_var (gfc_data_variable
*, locus
*);
4306 /* Iterate over a list of elements in a DATA statement. */
4309 traverse_data_list (gfc_data_variable
* var
, locus
* where
)
4312 iterator_stack frame
;
4315 mpz_init (frame
.value
);
4317 mpz_init_set (trip
, var
->iter
.end
->value
.integer
);
4318 mpz_sub (trip
, trip
, var
->iter
.start
->value
.integer
);
4319 mpz_add (trip
, trip
, var
->iter
.step
->value
.integer
);
4321 mpz_div (trip
, trip
, var
->iter
.step
->value
.integer
);
4323 mpz_set (frame
.value
, var
->iter
.start
->value
.integer
);
4325 frame
.prev
= iter_stack
;
4326 frame
.variable
= var
->iter
.var
->symtree
;
4327 iter_stack
= &frame
;
4329 while (mpz_cmp_ui (trip
, 0) > 0)
4331 if (traverse_data_var (var
->list
, where
) == FAILURE
)
4337 e
= gfc_copy_expr (var
->expr
);
4338 if (gfc_simplify_expr (e
, 1) == FAILURE
)
4344 mpz_add (frame
.value
, frame
.value
, var
->iter
.step
->value
.integer
);
4346 mpz_sub_ui (trip
, trip
, 1);
4350 mpz_clear (frame
.value
);
4352 iter_stack
= frame
.prev
;
4357 /* Type resolve variables in the variable list of a DATA statement. */
4360 traverse_data_var (gfc_data_variable
* var
, locus
* where
)
4364 for (; var
; var
= var
->next
)
4366 if (var
->expr
== NULL
)
4367 t
= traverse_data_list (var
, where
);
4369 t
= check_data_variable (var
, where
);
4379 /* Resolve the expressions and iterators associated with a data statement.
4380 This is separate from the assignment checking because data lists should
4381 only be resolved once. */
4384 resolve_data_variables (gfc_data_variable
* d
)
4386 for (; d
; d
= d
->next
)
4388 if (d
->list
== NULL
)
4390 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
4395 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
4398 if (d
->iter
.start
->expr_type
!= EXPR_CONSTANT
4399 || d
->iter
.end
->expr_type
!= EXPR_CONSTANT
4400 || d
->iter
.step
->expr_type
!= EXPR_CONSTANT
)
4401 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4403 if (resolve_data_variables (d
->list
) == FAILURE
)
4412 /* Resolve a single DATA statement. We implement this by storing a pointer to
4413 the value list into static variables, and then recursively traversing the
4414 variables list, expanding iterators and such. */
4417 resolve_data (gfc_data
* d
)
4419 if (resolve_data_variables (d
->var
) == FAILURE
)
4422 values
.vnode
= d
->value
;
4423 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
4425 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
4428 /* At this point, we better not have any values left. */
4430 if (next_data_value () == SUCCESS
)
4431 gfc_error ("DATA statement at %L has more values than variables",
4436 /* Determines if a variable is not 'pure', ie not assignable within a pure
4437 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4441 gfc_impure_variable (gfc_symbol
* sym
)
4443 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
4446 if (sym
->ns
!= gfc_current_ns
)
4447 return !sym
->attr
.function
;
4449 /* TODO: Check storage association through EQUIVALENCE statements */
4455 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4456 symbol of the current procedure. */
4459 gfc_pure (gfc_symbol
* sym
)
4461 symbol_attribute attr
;
4464 sym
= gfc_current_ns
->proc_name
;
4470 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
4474 /* Test whether the current procedure is elemental or not. */
4477 gfc_elemental (gfc_symbol
* sym
)
4479 symbol_attribute attr
;
4482 sym
= gfc_current_ns
->proc_name
;
4487 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
4491 /* Warn about unused labels. */
4494 warn_unused_label (gfc_namespace
* ns
)
4505 for (; l
; l
= l
->prev
)
4507 if (l
->defined
== ST_LABEL_UNKNOWN
)
4510 switch (l
->referenced
)
4512 case ST_LABEL_UNKNOWN
:
4513 gfc_warning ("Label %d at %L defined but not used", l
->value
,
4517 case ST_LABEL_BAD_TARGET
:
4518 gfc_warning ("Label %d at %L defined but cannot be used", l
->value
,
4529 /* Resolve derived type EQUIVALENCE object. */
4532 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
4535 gfc_component
*c
= derived
->components
;
4540 /* Shall not be an object of nonsequence derived type. */
4541 if (!derived
->attr
.sequence
)
4543 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
4544 "attribute to be an EQUIVALENCE object", sym
->name
, &e
->where
);
4548 for (; c
; c
= c
->next
)
4551 if (d
&& (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
4554 /* Shall not be an object of sequence derived type containing a pointer
4555 in the structure. */
4558 gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
4559 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
4567 /* Resolve equivalence object.
4568 An EQUIVALENCE object shall not be a dummy argument, a pointer, an
4569 allocatable array, an object of nonsequence derived type, an object of
4570 sequence derived type containing a pointer at any level of component
4571 selection, an automatic object, a function name, an entry name, a result
4572 name, a named constant, a structure component, or a subobject of any of
4573 the preceding objects. */
4576 resolve_equivalence (gfc_equiv
*eq
)
4579 gfc_symbol
*derived
;
4583 for (; eq
; eq
= eq
->eq
)
4586 if (gfc_resolve_expr (e
) == FAILURE
)
4589 sym
= e
->symtree
->n
.sym
;
4591 /* Shall not be a dummy argument. */
4592 if (sym
->attr
.dummy
)
4594 gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
4595 "object", sym
->name
, &e
->where
);
4599 /* Shall not be an allocatable array. */
4600 if (sym
->attr
.allocatable
)
4602 gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
4603 "object", sym
->name
, &e
->where
);
4607 /* Shall not be a pointer. */
4608 if (sym
->attr
.pointer
)
4610 gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
4611 sym
->name
, &e
->where
);
4615 /* Shall not be a function name, ... */
4616 if (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
4617 || sym
->attr
.subroutine
)
4619 gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
4620 sym
->name
, &e
->where
);
4624 /* Shall not be a named constant. */
4625 if (e
->expr_type
== EXPR_CONSTANT
)
4627 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
4628 "object", sym
->name
, &e
->where
);
4632 derived
= e
->ts
.derived
;
4633 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
4639 /* Shall not be an automatic array. */
4640 if (e
->ref
->type
== REF_ARRAY
4641 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
4643 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
4644 "an EQUIVALENCE object", sym
->name
, &e
->where
);
4648 /* Shall not be a structure component. */
4652 if (r
->type
== REF_COMPONENT
)
4654 gfc_error ("Structure component '%s' at %L cannot be an "
4655 "EQUIVALENCE object",
4656 r
->u
.c
.component
->name
, &e
->where
);
4665 /* This function is called after a complete program unit has been compiled.
4666 Its purpose is to examine all of the expressions associated with a program
4667 unit, assign types to all intermediate expressions, make sure that all
4668 assignments are to compatible types and figure out which names refer to
4669 which functions or subroutines. */
4672 gfc_resolve (gfc_namespace
* ns
)
4674 gfc_namespace
*old_ns
, *n
;
4679 old_ns
= gfc_current_ns
;
4680 gfc_current_ns
= ns
;
4682 resolve_entries (ns
);
4684 resolve_contained_functions (ns
);
4686 gfc_traverse_ns (ns
, resolve_symbol
);
4688 for (n
= ns
->contained
; n
; n
= n
->sibling
)
4690 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
4691 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
4692 "also be PURE", n
->proc_name
->name
,
4693 &n
->proc_name
->declared_at
);
4699 gfc_check_interfaces (ns
);
4701 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
4703 if (cl
->length
== NULL
|| gfc_resolve_expr (cl
->length
) == FAILURE
)
4706 if (cl
->length
->ts
.type
!= BT_INTEGER
)
4708 ("Character length specification at %L must be of type INTEGER",
4709 &cl
->length
->where
);
4712 gfc_traverse_ns (ns
, resolve_values
);
4718 for (d
= ns
->data
; d
; d
= d
->next
)
4722 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
4724 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
4725 resolve_equivalence (eq
);
4728 resolve_code (ns
->code
, ns
);
4730 /* Warn about unused labels. */
4731 if (gfc_option
.warn_unused_labels
)
4732 warn_unused_label (ns
);
4734 gfc_current_ns
= old_ns
;