1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 59 Temple Place - Suite 330,Boston, MA
26 #include "arith.h" /* For gfc_compare_expr(). */
29 /* Stack to push the current if we descend into a block during
30 resolution. See resolve_branch() and resolve_code(). */
32 typedef struct code_stack
34 struct gfc_code
*head
, *current
;
35 struct code_stack
*prev
;
39 static code_stack
*cs_base
= NULL
;
42 /* Nonzero if we're inside a FORALL block */
44 static int forall_flag
;
46 /* Resolve types of formal argument lists. These have to be done early so that
47 the formal argument lists of module procedures can be copied to the
48 containing module before the individual procedures are resolved
49 individually. We also resolve argument lists of procedures in interface
50 blocks because they are self-contained scoping units.
52 Since a dummy argument cannot be a non-dummy procedure, the only
53 resort left for untyped names are the IMPLICIT types. */
56 resolve_formal_arglist (gfc_symbol
* proc
)
58 gfc_formal_arglist
*f
;
62 /* TODO: Procedures whose return character length parameter is not constant
63 or assumed must also have explicit interfaces. */
64 if (proc
->result
!= NULL
)
69 if (gfc_elemental (proc
)
70 || sym
->attr
.pointer
|| sym
->attr
.allocatable
71 || (sym
->as
&& sym
->as
->rank
> 0))
72 proc
->attr
.always_explicit
= 1;
74 for (f
= proc
->formal
; f
; f
= f
->next
)
80 /* Alternate return placeholder. */
81 if (gfc_elemental (proc
))
82 gfc_error ("Alternate return specifier in elemental subroutine "
83 "'%s' at %L is not allowed", proc
->name
,
85 if (proc
->attr
.function
)
86 gfc_error ("Alternate return specifier in function "
87 "'%s' at %L is not allowed", proc
->name
,
92 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
93 resolve_formal_arglist (sym
);
95 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
97 if (gfc_pure (proc
) && !gfc_pure (sym
))
100 ("Dummy procedure '%s' of PURE procedure at %L must also "
101 "be PURE", sym
->name
, &sym
->declared_at
);
105 if (gfc_elemental (proc
))
108 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
116 if (sym
->ts
.type
== BT_UNKNOWN
)
118 if (!sym
->attr
.function
|| sym
->result
== sym
)
119 gfc_set_default_type (sym
, 1, sym
->ns
);
122 /* Set the type of the RESULT, then copy. */
123 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
124 gfc_set_default_type (sym
->result
, 1, sym
->result
->ns
);
126 sym
->ts
= sym
->result
->ts
;
128 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
132 gfc_resolve_array_spec (sym
->as
, 0);
134 /* We can't tell if an array with dimension (:) is assumed or deferred
135 shape until we know if it has the pointer or allocatable attributes.
137 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
138 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
140 sym
->as
->type
= AS_ASSUMED_SHAPE
;
141 for (i
= 0; i
< sym
->as
->rank
; i
++)
142 sym
->as
->lower
[i
] = gfc_int_expr (1);
145 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
146 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
147 || sym
->attr
.optional
)
148 proc
->attr
.always_explicit
= 1;
150 /* If the flavor is unknown at this point, it has to be a variable.
151 A procedure specification would have already set the type. */
153 if (sym
->attr
.flavor
== FL_UNKNOWN
)
154 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
158 if (proc
->attr
.function
&& !sym
->attr
.pointer
159 && sym
->attr
.flavor
!= FL_PROCEDURE
160 && sym
->attr
.intent
!= INTENT_IN
)
162 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
163 "INTENT(IN)", sym
->name
, proc
->name
,
166 if (proc
->attr
.subroutine
&& !sym
->attr
.pointer
167 && sym
->attr
.intent
== INTENT_UNKNOWN
)
170 ("Argument '%s' of pure subroutine '%s' at %L must have "
171 "its INTENT specified", sym
->name
, proc
->name
,
176 if (gfc_elemental (proc
))
181 ("Argument '%s' of elemental procedure at %L must be scalar",
182 sym
->name
, &sym
->declared_at
);
186 if (sym
->attr
.pointer
)
189 ("Argument '%s' of elemental procedure at %L cannot have "
190 "the POINTER attribute", sym
->name
, &sym
->declared_at
);
195 /* Each dummy shall be specified to be scalar. */
196 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
201 ("Argument '%s' of statement function at %L must be scalar",
202 sym
->name
, &sym
->declared_at
);
206 if (sym
->ts
.type
== BT_CHARACTER
)
208 gfc_charlen
*cl
= sym
->ts
.cl
;
209 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
212 ("Character-valued argument '%s' of statement function at "
213 "%L must has constant length",
214 sym
->name
, &sym
->declared_at
);
223 /* Work function called when searching for symbols that have argument lists
224 associated with them. */
227 find_arglists (gfc_symbol
* sym
)
230 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
233 resolve_formal_arglist (sym
);
237 /* Given a namespace, resolve all formal argument lists within the namespace.
241 resolve_formal_arglists (gfc_namespace
* ns
)
247 gfc_traverse_ns (ns
, find_arglists
);
252 resolve_contained_fntype (gfc_symbol
* sym
, gfc_namespace
* ns
)
256 /* If this namespace is not a function, ignore it. */
258 || !(sym
->attr
.function
259 || sym
->attr
.flavor
== FL_VARIABLE
))
262 /* Try to find out of what the return type is. */
263 if (sym
->result
!= NULL
)
266 if (sym
->ts
.type
== BT_UNKNOWN
)
268 t
= gfc_set_default_type (sym
, 0, ns
);
271 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
272 sym
->name
, &sym
->declared_at
); /* FIXME */
277 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
278 introduce duplicates. */
281 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
283 gfc_formal_arglist
*f
, *new_arglist
;
286 for (; new_args
!= NULL
; new_args
= new_args
->next
)
288 new_sym
= new_args
->sym
;
289 /* See if ths arg is already in the formal argument list. */
290 for (f
= proc
->formal
; f
; f
= f
->next
)
292 if (new_sym
== f
->sym
)
299 /* Add a new argument. Argument order is not important. */
300 new_arglist
= gfc_get_formal_arglist ();
301 new_arglist
->sym
= new_sym
;
302 new_arglist
->next
= proc
->formal
;
303 proc
->formal
= new_arglist
;
308 /* Resolve alternate entry points. If a symbol has multiple entry points we
309 create a new master symbol for the main routine, and turn the existing
310 symbol into an entry point. */
313 resolve_entries (gfc_namespace
* ns
)
315 gfc_namespace
*old_ns
;
319 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
320 static int master_count
= 0;
322 if (ns
->proc_name
== NULL
)
325 /* No need to do anything if this procedure doesn't have alternate entry
330 /* We may already have resolved alternate entry points. */
331 if (ns
->proc_name
->attr
.entry_master
)
334 /* If this isn't a procedure something has gone horribly wrong. */
335 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
337 /* Remember the current namespace. */
338 old_ns
= gfc_current_ns
;
342 /* Add the main entry point to the list of entry points. */
343 el
= gfc_get_entry_list ();
344 el
->sym
= ns
->proc_name
;
346 el
->next
= ns
->entries
;
348 ns
->proc_name
->attr
.entry
= 1;
350 /* Add an entry statement for it. */
357 /* Create a new symbol for the master function. */
358 /* Give the internal function a unique name (within this file).
359 Also include the function name so the user has some hope of figuring
360 out what is going on. */
361 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
362 master_count
++, ns
->proc_name
->name
);
363 gfc_get_ha_symbol (name
, &proc
);
364 gcc_assert (proc
!= NULL
);
366 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
367 if (ns
->proc_name
->attr
.subroutine
)
368 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
372 gfc_typespec
*ts
, *fts
;
374 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
376 fts
= &ns
->entries
->sym
->result
->ts
;
377 if (fts
->type
== BT_UNKNOWN
)
378 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
379 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
381 ts
= &el
->sym
->result
->ts
;
382 if (ts
->type
== BT_UNKNOWN
)
383 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
384 if (! gfc_compare_types (ts
, fts
)
385 || (el
->sym
->result
->attr
.dimension
386 != ns
->entries
->sym
->result
->attr
.dimension
)
387 || (el
->sym
->result
->attr
.pointer
388 != ns
->entries
->sym
->result
->attr
.pointer
))
394 sym
= ns
->entries
->sym
->result
;
395 /* All result types the same. */
397 if (sym
->attr
.dimension
)
398 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
399 if (sym
->attr
.pointer
)
400 gfc_add_pointer (&proc
->attr
, NULL
);
404 /* Otherwise the result will be passed through an union by
406 proc
->attr
.mixed_entry_master
= 1;
407 for (el
= ns
->entries
; el
; el
= el
->next
)
409 sym
= el
->sym
->result
;
410 if (sym
->attr
.dimension
)
411 gfc_error ("%s result %s can't be an array in FUNCTION %s at %L",
412 el
== ns
->entries
? "FUNCTION" : "ENTRY", sym
->name
,
413 ns
->entries
->sym
->name
, &sym
->declared_at
);
414 else if (sym
->attr
.pointer
)
415 gfc_error ("%s result %s can't be a POINTER in FUNCTION %s at %L",
416 el
== ns
->entries
? "FUNCTION" : "ENTRY", sym
->name
,
417 ns
->entries
->sym
->name
, &sym
->declared_at
);
421 if (ts
->type
== BT_UNKNOWN
)
422 ts
= gfc_get_default_type (sym
, NULL
);
426 if (ts
->kind
== gfc_default_integer_kind
)
430 if (ts
->kind
== gfc_default_real_kind
431 || ts
->kind
== gfc_default_double_kind
)
435 if (ts
->kind
== gfc_default_complex_kind
)
439 if (ts
->kind
== gfc_default_logical_kind
)
446 gfc_error ("%s result %s can't be of type %s in FUNCTION %s at %L",
447 el
== ns
->entries
? "FUNCTION" : "ENTRY", sym
->name
,
448 gfc_typename (ts
), ns
->entries
->sym
->name
,
454 proc
->attr
.access
= ACCESS_PRIVATE
;
455 proc
->attr
.entry_master
= 1;
457 /* Merge all the entry point arguments. */
458 for (el
= ns
->entries
; el
; el
= el
->next
)
459 merge_argument_lists (proc
, el
->sym
->formal
);
461 /* Use the master function for the function body. */
462 ns
->proc_name
= proc
;
464 /* Finalize the new symbols. */
465 gfc_commit_symbols ();
467 /* Restore the original namespace. */
468 gfc_current_ns
= old_ns
;
472 /* Resolve contained function types. Because contained functions can call one
473 another, they have to be worked out before any of the contained procedures
476 The good news is that if a function doesn't already have a type, the only
477 way it can get one is through an IMPLICIT type or a RESULT variable, because
478 by definition contained functions are contained namespace they're contained
479 in, not in a sibling or parent namespace. */
482 resolve_contained_functions (gfc_namespace
* ns
)
484 gfc_namespace
*child
;
487 resolve_formal_arglists (ns
);
489 for (child
= ns
->contained
; child
; child
= child
->sibling
)
491 /* Resolve alternate entry points first. */
492 resolve_entries (child
);
494 /* Then check function return types. */
495 resolve_contained_fntype (child
->proc_name
, child
);
496 for (el
= child
->entries
; el
; el
= el
->next
)
497 resolve_contained_fntype (el
->sym
, child
);
502 /* Resolve all of the elements of a structure constructor and make sure that
503 the types are correct. */
506 resolve_structure_cons (gfc_expr
* expr
)
508 gfc_constructor
*cons
;
513 cons
= expr
->value
.constructor
;
514 /* A constructor may have references if it is the result of substituting a
515 parameter variable. In this case we just pull out the component we
518 comp
= expr
->ref
->u
.c
.sym
->components
;
520 comp
= expr
->ts
.derived
->components
;
522 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
530 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
536 /* If we don't have the right type, try to convert it. */
538 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
)
539 && gfc_convert_type (cons
->expr
, &comp
->ts
, 1) == FAILURE
)
548 /****************** Expression name resolution ******************/
550 /* Returns 0 if a symbol was not declared with a type or
551 attribute declaration statement, nonzero otherwise. */
554 was_declared (gfc_symbol
* sym
)
560 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
563 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
564 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
565 || a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
572 /* Determine if a symbol is generic or not. */
575 generic_sym (gfc_symbol
* sym
)
579 if (sym
->attr
.generic
||
580 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
583 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
586 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
588 return (s
== NULL
) ? 0 : generic_sym (s
);
592 /* Determine if a symbol is specific or not. */
595 specific_sym (gfc_symbol
* sym
)
599 if (sym
->attr
.if_source
== IFSRC_IFBODY
600 || sym
->attr
.proc
== PROC_MODULE
601 || sym
->attr
.proc
== PROC_INTERNAL
602 || sym
->attr
.proc
== PROC_ST_FUNCTION
603 || (sym
->attr
.intrinsic
&&
604 gfc_specific_intrinsic (sym
->name
))
605 || sym
->attr
.external
)
608 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
611 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
613 return (s
== NULL
) ? 0 : specific_sym (s
);
617 /* Figure out if the procedure is specific, generic or unknown. */
620 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
624 procedure_kind (gfc_symbol
* sym
)
627 if (generic_sym (sym
))
628 return PTYPE_GENERIC
;
630 if (specific_sym (sym
))
631 return PTYPE_SPECIFIC
;
633 return PTYPE_UNKNOWN
;
637 /* Resolve an actual argument list. Most of the time, this is just
638 resolving the expressions in the list.
639 The exception is that we sometimes have to decide whether arguments
640 that look like procedure arguments are really simple variable
644 resolve_actual_arglist (gfc_actual_arglist
* arg
)
647 gfc_symtree
*parent_st
;
650 for (; arg
; arg
= arg
->next
)
656 /* Check the label is a valid branching target. */
659 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
661 gfc_error ("Label %d referenced at %L is never defined",
662 arg
->label
->value
, &arg
->label
->where
);
669 if (e
->ts
.type
!= BT_PROCEDURE
)
671 if (gfc_resolve_expr (e
) != SUCCESS
)
676 /* See if the expression node should really be a variable
679 sym
= e
->symtree
->n
.sym
;
681 if (sym
->attr
.flavor
== FL_PROCEDURE
682 || sym
->attr
.intrinsic
683 || sym
->attr
.external
)
686 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
688 gfc_error ("Statement function '%s' at %L is not allowed as an "
689 "actual argument", sym
->name
, &e
->where
);
692 /* If the symbol is the function that names the current (or
693 parent) scope, then we really have a variable reference. */
695 if (sym
->attr
.function
&& sym
->result
== sym
696 && (sym
->ns
->proc_name
== sym
697 || (sym
->ns
->parent
!= NULL
698 && sym
->ns
->parent
->proc_name
== sym
)))
704 /* See if the name is a module procedure in a parent unit. */
706 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
709 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
711 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
715 if (parent_st
== NULL
)
718 sym
= parent_st
->n
.sym
;
719 e
->symtree
= parent_st
; /* Point to the right thing. */
721 if (sym
->attr
.flavor
== FL_PROCEDURE
722 || sym
->attr
.intrinsic
723 || sym
->attr
.external
)
729 e
->expr_type
= EXPR_VARIABLE
;
733 e
->rank
= sym
->as
->rank
;
734 e
->ref
= gfc_get_ref ();
735 e
->ref
->type
= REF_ARRAY
;
736 e
->ref
->u
.ar
.type
= AR_FULL
;
737 e
->ref
->u
.ar
.as
= sym
->as
;
745 /************* Function resolution *************/
747 /* Resolve a function call known to be generic.
748 Section 14.1.2.4.1. */
751 resolve_generic_f0 (gfc_expr
* expr
, gfc_symbol
* sym
)
755 if (sym
->attr
.generic
)
758 gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
761 expr
->value
.function
.name
= s
->name
;
762 expr
->value
.function
.esym
= s
;
765 expr
->rank
= s
->as
->rank
;
769 /* TODO: Need to search for elemental references in generic interface */
772 if (sym
->attr
.intrinsic
)
773 return gfc_intrinsic_func_interface (expr
, 0);
780 resolve_generic_f (gfc_expr
* expr
)
785 sym
= expr
->symtree
->n
.sym
;
789 m
= resolve_generic_f0 (expr
, sym
);
792 else if (m
== MATCH_ERROR
)
796 if (sym
->ns
->parent
== NULL
)
798 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
802 if (!generic_sym (sym
))
806 /* Last ditch attempt. */
808 if (!gfc_generic_intrinsic (expr
->symtree
->n
.sym
->name
))
810 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
811 expr
->symtree
->n
.sym
->name
, &expr
->where
);
815 m
= gfc_intrinsic_func_interface (expr
, 0);
820 ("Generic function '%s' at %L is not consistent with a specific "
821 "intrinsic interface", expr
->symtree
->n
.sym
->name
, &expr
->where
);
827 /* Resolve a function call known to be specific. */
830 resolve_specific_f0 (gfc_symbol
* sym
, gfc_expr
* expr
)
834 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
838 sym
->attr
.proc
= PROC_DUMMY
;
842 sym
->attr
.proc
= PROC_EXTERNAL
;
846 if (sym
->attr
.proc
== PROC_MODULE
847 || sym
->attr
.proc
== PROC_ST_FUNCTION
848 || sym
->attr
.proc
== PROC_INTERNAL
)
851 if (sym
->attr
.intrinsic
)
853 m
= gfc_intrinsic_func_interface (expr
, 1);
858 ("Function '%s' at %L is INTRINSIC but is not compatible with "
859 "an intrinsic", sym
->name
, &expr
->where
);
867 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
870 expr
->value
.function
.name
= sym
->name
;
871 expr
->value
.function
.esym
= sym
;
873 expr
->rank
= sym
->as
->rank
;
880 resolve_specific_f (gfc_expr
* expr
)
885 sym
= expr
->symtree
->n
.sym
;
889 m
= resolve_specific_f0 (sym
, expr
);
892 if (m
== MATCH_ERROR
)
895 if (sym
->ns
->parent
== NULL
)
898 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
904 gfc_error ("Unable to resolve the specific function '%s' at %L",
905 expr
->symtree
->n
.sym
->name
, &expr
->where
);
911 /* Resolve a procedure call not known to be generic nor specific. */
914 resolve_unknown_f (gfc_expr
* expr
)
919 sym
= expr
->symtree
->n
.sym
;
923 sym
->attr
.proc
= PROC_DUMMY
;
924 expr
->value
.function
.name
= sym
->name
;
928 /* See if we have an intrinsic function reference. */
930 if (gfc_intrinsic_name (sym
->name
, 0))
932 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
937 /* The reference is to an external name. */
939 sym
->attr
.proc
= PROC_EXTERNAL
;
940 expr
->value
.function
.name
= sym
->name
;
941 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
944 expr
->rank
= sym
->as
->rank
;
946 /* Type of the expression is either the type of the symbol or the
947 default type of the symbol. */
950 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
952 if (sym
->ts
.type
!= BT_UNKNOWN
)
956 ts
= gfc_get_default_type (sym
, sym
->ns
);
958 if (ts
->type
== BT_UNKNOWN
)
960 gfc_error ("Function '%s' at %L has no implicit type",
961 sym
->name
, &expr
->where
);
972 /* Figure out if a function reference is pure or not. Also set the name
973 of the function for a potential error message. Return nonzero if the
974 function is PURE, zero if not. */
977 pure_function (gfc_expr
* e
, const char **name
)
981 if (e
->value
.function
.esym
)
983 pure
= gfc_pure (e
->value
.function
.esym
);
984 *name
= e
->value
.function
.esym
->name
;
986 else if (e
->value
.function
.isym
)
988 pure
= e
->value
.function
.isym
->pure
989 || e
->value
.function
.isym
->elemental
;
990 *name
= e
->value
.function
.isym
->name
;
994 /* Implicit functions are not pure. */
996 *name
= e
->value
.function
.name
;
1003 /* Resolve a function call, which means resolving the arguments, then figuring
1004 out which entity the name refers to. */
1005 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1006 to INTENT(OUT) or INTENT(INOUT). */
1009 resolve_function (gfc_expr
* expr
)
1011 gfc_actual_arglist
*arg
;
1015 if (resolve_actual_arglist (expr
->value
.function
.actual
) == FAILURE
)
1018 /* See if function is already resolved. */
1020 if (expr
->value
.function
.name
!= NULL
)
1022 if (expr
->ts
.type
== BT_UNKNOWN
)
1023 expr
->ts
= expr
->symtree
->n
.sym
->ts
;
1028 /* Apply the rules of section 14.1.2. */
1030 switch (procedure_kind (expr
->symtree
->n
.sym
))
1033 t
= resolve_generic_f (expr
);
1036 case PTYPE_SPECIFIC
:
1037 t
= resolve_specific_f (expr
);
1041 t
= resolve_unknown_f (expr
);
1045 gfc_internal_error ("resolve_function(): bad function type");
1049 /* If the expression is still a function (it might have simplified),
1050 then we check to see if we are calling an elemental function. */
1052 if (expr
->expr_type
!= EXPR_FUNCTION
)
1055 if (expr
->value
.function
.actual
!= NULL
1056 && ((expr
->value
.function
.esym
!= NULL
1057 && expr
->value
.function
.esym
->attr
.elemental
)
1058 || (expr
->value
.function
.isym
!= NULL
1059 && expr
->value
.function
.isym
->elemental
)))
1062 /* The rank of an elemental is the rank of its array argument(s). */
1064 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1066 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1068 expr
->rank
= arg
->expr
->rank
;
1074 if (!pure_function (expr
, &name
))
1079 ("Function reference to '%s' at %L is inside a FORALL block",
1080 name
, &expr
->where
);
1083 else if (gfc_pure (NULL
))
1085 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1086 "procedure within a PURE procedure", name
, &expr
->where
);
1095 /************* Subroutine resolution *************/
1098 pure_subroutine (gfc_code
* c
, gfc_symbol
* sym
)
1105 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1106 sym
->name
, &c
->loc
);
1107 else if (gfc_pure (NULL
))
1108 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1114 resolve_generic_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1118 if (sym
->attr
.generic
)
1120 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1123 c
->resolved_sym
= s
;
1124 pure_subroutine (c
, s
);
1128 /* TODO: Need to search for elemental references in generic interface. */
1131 if (sym
->attr
.intrinsic
)
1132 return gfc_intrinsic_sub_interface (c
, 0);
1139 resolve_generic_s (gfc_code
* c
)
1144 sym
= c
->symtree
->n
.sym
;
1146 m
= resolve_generic_s0 (c
, sym
);
1149 if (m
== MATCH_ERROR
)
1152 if (sym
->ns
->parent
!= NULL
)
1154 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1157 m
= resolve_generic_s0 (c
, sym
);
1160 if (m
== MATCH_ERROR
)
1165 /* Last ditch attempt. */
1167 if (!gfc_generic_intrinsic (sym
->name
))
1170 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1171 sym
->name
, &c
->loc
);
1175 m
= gfc_intrinsic_sub_interface (c
, 0);
1179 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1180 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1186 /* Resolve a subroutine call known to be specific. */
1189 resolve_specific_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1193 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1195 if (sym
->attr
.dummy
)
1197 sym
->attr
.proc
= PROC_DUMMY
;
1201 sym
->attr
.proc
= PROC_EXTERNAL
;
1205 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1208 if (sym
->attr
.intrinsic
)
1210 m
= gfc_intrinsic_sub_interface (c
, 1);
1214 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1215 "with an intrinsic", sym
->name
, &c
->loc
);
1223 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1225 c
->resolved_sym
= sym
;
1226 pure_subroutine (c
, sym
);
1233 resolve_specific_s (gfc_code
* c
)
1238 sym
= c
->symtree
->n
.sym
;
1240 m
= resolve_specific_s0 (c
, sym
);
1243 if (m
== MATCH_ERROR
)
1246 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1250 m
= resolve_specific_s0 (c
, sym
);
1253 if (m
== MATCH_ERROR
)
1257 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1258 sym
->name
, &c
->loc
);
1264 /* Resolve a subroutine call not known to be generic nor specific. */
1267 resolve_unknown_s (gfc_code
* c
)
1271 sym
= c
->symtree
->n
.sym
;
1273 if (sym
->attr
.dummy
)
1275 sym
->attr
.proc
= PROC_DUMMY
;
1279 /* See if we have an intrinsic function reference. */
1281 if (gfc_intrinsic_name (sym
->name
, 1))
1283 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1288 /* The reference is to an external name. */
1291 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1293 c
->resolved_sym
= sym
;
1295 pure_subroutine (c
, sym
);
1301 /* Resolve a subroutine call. Although it was tempting to use the same code
1302 for functions, subroutines and functions are stored differently and this
1303 makes things awkward. */
1306 resolve_call (gfc_code
* c
)
1310 if (resolve_actual_arglist (c
->ext
.actual
) == FAILURE
)
1313 if (c
->resolved_sym
!= NULL
)
1316 switch (procedure_kind (c
->symtree
->n
.sym
))
1319 t
= resolve_generic_s (c
);
1322 case PTYPE_SPECIFIC
:
1323 t
= resolve_specific_s (c
);
1327 t
= resolve_unknown_s (c
);
1331 gfc_internal_error ("resolve_subroutine(): bad function type");
1337 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1338 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1339 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1340 if their shapes do not match. If either op1->shape or op2->shape is
1341 NULL, return SUCCESS. */
1344 compare_shapes (gfc_expr
* op1
, gfc_expr
* op2
)
1351 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
1353 for (i
= 0; i
< op1
->rank
; i
++)
1355 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
1357 gfc_error ("Shapes for operands at %L and %L are not conformable",
1358 &op1
->where
, &op2
->where
);
1368 /* Resolve an operator expression node. This can involve replacing the
1369 operation with a user defined function call. */
1372 resolve_operator (gfc_expr
* e
)
1374 gfc_expr
*op1
, *op2
;
1378 /* Resolve all subnodes-- give them types. */
1380 switch (e
->value
.op
.operator)
1383 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
1386 /* Fall through... */
1389 case INTRINSIC_UPLUS
:
1390 case INTRINSIC_UMINUS
:
1391 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
1396 /* Typecheck the new node. */
1398 op1
= e
->value
.op
.op1
;
1399 op2
= e
->value
.op
.op2
;
1401 switch (e
->value
.op
.operator)
1403 case INTRINSIC_UPLUS
:
1404 case INTRINSIC_UMINUS
:
1405 if (op1
->ts
.type
== BT_INTEGER
1406 || op1
->ts
.type
== BT_REAL
1407 || op1
->ts
.type
== BT_COMPLEX
)
1413 sprintf (msg
, "Operand of unary numeric operator '%s' at %%L is %s",
1414 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
1417 case INTRINSIC_PLUS
:
1418 case INTRINSIC_MINUS
:
1419 case INTRINSIC_TIMES
:
1420 case INTRINSIC_DIVIDE
:
1421 case INTRINSIC_POWER
:
1422 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1424 gfc_type_convert_binary (e
);
1429 "Operands of binary numeric operator '%s' at %%L are %s/%s",
1430 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1431 gfc_typename (&op2
->ts
));
1434 case INTRINSIC_CONCAT
:
1435 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1437 e
->ts
.type
= BT_CHARACTER
;
1438 e
->ts
.kind
= op1
->ts
.kind
;
1443 "Operands of string concatenation operator at %%L are %s/%s",
1444 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
1450 case INTRINSIC_NEQV
:
1451 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
1453 e
->ts
.type
= BT_LOGICAL
;
1454 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
1455 if (op1
->ts
.kind
< e
->ts
.kind
)
1456 gfc_convert_type (op1
, &e
->ts
, 2);
1457 else if (op2
->ts
.kind
< e
->ts
.kind
)
1458 gfc_convert_type (op2
, &e
->ts
, 2);
1462 sprintf (msg
, "Operands of logical operator '%s' at %%L are %s/%s",
1463 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1464 gfc_typename (&op2
->ts
));
1469 if (op1
->ts
.type
== BT_LOGICAL
)
1471 e
->ts
.type
= BT_LOGICAL
;
1472 e
->ts
.kind
= op1
->ts
.kind
;
1476 sprintf (msg
, "Operand of .NOT. operator at %%L is %s",
1477 gfc_typename (&op1
->ts
));
1484 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1486 strcpy (msg
, "COMPLEX quantities cannot be compared at %L");
1490 /* Fall through... */
1494 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1496 e
->ts
.type
= BT_LOGICAL
;
1497 e
->ts
.kind
= gfc_default_logical_kind
;
1501 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1503 gfc_type_convert_binary (e
);
1505 e
->ts
.type
= BT_LOGICAL
;
1506 e
->ts
.kind
= gfc_default_logical_kind
;
1510 sprintf (msg
, "Operands of comparison operator '%s' at %%L are %s/%s",
1511 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1512 gfc_typename (&op2
->ts
));
1516 case INTRINSIC_USER
:
1518 sprintf (msg
, "Operand of user operator '%s' at %%L is %s",
1519 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
1521 sprintf (msg
, "Operands of user operator '%s' at %%L are %s/%s",
1522 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
1523 gfc_typename (&op2
->ts
));
1528 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1531 /* Deal with arrayness of an operand through an operator. */
1535 switch (e
->value
.op
.operator)
1537 case INTRINSIC_PLUS
:
1538 case INTRINSIC_MINUS
:
1539 case INTRINSIC_TIMES
:
1540 case INTRINSIC_DIVIDE
:
1541 case INTRINSIC_POWER
:
1542 case INTRINSIC_CONCAT
:
1546 case INTRINSIC_NEQV
:
1554 if (op1
->rank
== 0 && op2
->rank
== 0)
1557 if (op1
->rank
== 0 && op2
->rank
!= 0)
1559 e
->rank
= op2
->rank
;
1561 if (e
->shape
== NULL
)
1562 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1565 if (op1
->rank
!= 0 && op2
->rank
== 0)
1567 e
->rank
= op1
->rank
;
1569 if (e
->shape
== NULL
)
1570 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1573 if (op1
->rank
!= 0 && op2
->rank
!= 0)
1575 if (op1
->rank
== op2
->rank
)
1577 e
->rank
= op1
->rank
;
1578 if (e
->shape
== NULL
)
1580 t
= compare_shapes(op1
, op2
);
1584 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1589 gfc_error ("Inconsistent ranks for operator at %L and %L",
1590 &op1
->where
, &op2
->where
);
1593 /* Allow higher level expressions to work. */
1601 case INTRINSIC_UPLUS
:
1602 case INTRINSIC_UMINUS
:
1603 e
->rank
= op1
->rank
;
1605 if (e
->shape
== NULL
)
1606 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1608 /* Simply copy arrayness attribute */
1615 /* Attempt to simplify the expression. */
1617 t
= gfc_simplify_expr (e
, 0);
1622 if (gfc_extend_expr (e
) == SUCCESS
)
1625 gfc_error (msg
, &e
->where
);
1631 /************** Array resolution subroutines **************/
1635 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
1638 /* Compare two integer expressions. */
1641 compare_bound (gfc_expr
* a
, gfc_expr
* b
)
1645 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
1646 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
1649 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
1650 gfc_internal_error ("compare_bound(): Bad expression");
1652 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
1662 /* Compare an integer expression with an integer. */
1665 compare_bound_int (gfc_expr
* a
, int b
)
1669 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
1672 if (a
->ts
.type
!= BT_INTEGER
)
1673 gfc_internal_error ("compare_bound_int(): Bad expression");
1675 i
= mpz_cmp_si (a
->value
.integer
, b
);
1685 /* Compare a single dimension of an array reference to the array
1689 check_dimension (int i
, gfc_array_ref
* ar
, gfc_array_spec
* as
)
1692 /* Given start, end and stride values, calculate the minimum and
1693 maximum referenced indexes. */
1701 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1703 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1709 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
1711 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
1715 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1717 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1720 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1721 it is legal (see 6.2.2.3.1). */
1726 gfc_internal_error ("check_dimension(): Bad array reference");
1732 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
1737 /* Compare an array reference with an array specification. */
1740 compare_spec_to_ref (gfc_array_ref
* ar
)
1747 /* TODO: Full array sections are only allowed as actual parameters. */
1748 if (as
->type
== AS_ASSUMED_SIZE
1749 && (/*ar->type == AR_FULL
1750 ||*/ (ar
->type
== AR_SECTION
1751 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
1753 gfc_error ("Rightmost upper bound of assumed size array section"
1754 " not specified at %L", &ar
->where
);
1758 if (ar
->type
== AR_FULL
)
1761 if (as
->rank
!= ar
->dimen
)
1763 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1764 &ar
->where
, ar
->dimen
, as
->rank
);
1768 for (i
= 0; i
< as
->rank
; i
++)
1769 if (check_dimension (i
, ar
, as
) == FAILURE
)
1776 /* Resolve one part of an array index. */
1779 gfc_resolve_index (gfc_expr
* index
, int check_scalar
)
1786 if (gfc_resolve_expr (index
) == FAILURE
)
1789 if (check_scalar
&& index
->rank
!= 0)
1791 gfc_error ("Array index at %L must be scalar", &index
->where
);
1795 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
1797 gfc_error ("Array index at %L must be of INTEGER type",
1802 if (index
->ts
.type
== BT_REAL
)
1803 if (gfc_notify_std (GFC_STD_GNU
, "Extension: REAL array index at %L",
1804 &index
->where
) == FAILURE
)
1807 if (index
->ts
.kind
!= gfc_index_integer_kind
1808 || index
->ts
.type
!= BT_INTEGER
)
1810 ts
.type
= BT_INTEGER
;
1811 ts
.kind
= gfc_index_integer_kind
;
1813 gfc_convert_type_warn (index
, &ts
, 2, 0);
1820 /* Given an expression that contains array references, update those array
1821 references to point to the right array specifications. While this is
1822 filled in during matching, this information is difficult to save and load
1823 in a module, so we take care of it here.
1825 The idea here is that the original array reference comes from the
1826 base symbol. We traverse the list of reference structures, setting
1827 the stored reference to references. Component references can
1828 provide an additional array specification. */
1831 find_array_spec (gfc_expr
* e
)
1837 as
= e
->symtree
->n
.sym
->as
;
1838 c
= e
->symtree
->n
.sym
->components
;
1840 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1845 gfc_internal_error ("find_array_spec(): Missing spec");
1852 for (; c
; c
= c
->next
)
1853 if (c
== ref
->u
.c
.component
)
1857 gfc_internal_error ("find_array_spec(): Component not found");
1862 gfc_internal_error ("find_array_spec(): unused as(1)");
1866 c
= c
->ts
.derived
->components
;
1874 gfc_internal_error ("find_array_spec(): unused as(2)");
1878 /* Resolve an array reference. */
1881 resolve_array_ref (gfc_array_ref
* ar
)
1883 int i
, check_scalar
;
1885 for (i
= 0; i
< ar
->dimen
; i
++)
1887 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
1889 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
1891 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
1893 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
1896 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
1897 switch (ar
->start
[i
]->rank
)
1900 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
1904 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
1908 gfc_error ("Array index at %L is an array of rank %d",
1909 &ar
->c_where
[i
], ar
->start
[i
]->rank
);
1914 /* If the reference type is unknown, figure out what kind it is. */
1916 if (ar
->type
== AR_UNKNOWN
)
1918 ar
->type
= AR_ELEMENT
;
1919 for (i
= 0; i
< ar
->dimen
; i
++)
1920 if (ar
->dimen_type
[i
] == DIMEN_RANGE
1921 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
1923 ar
->type
= AR_SECTION
;
1928 if (compare_spec_to_ref (ar
) == FAILURE
)
1936 resolve_substring (gfc_ref
* ref
)
1939 if (ref
->u
.ss
.start
!= NULL
)
1941 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
1944 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
1946 gfc_error ("Substring start index at %L must be of type INTEGER",
1947 &ref
->u
.ss
.start
->where
);
1951 if (ref
->u
.ss
.start
->rank
!= 0)
1953 gfc_error ("Substring start index at %L must be scalar",
1954 &ref
->u
.ss
.start
->where
);
1958 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
)
1960 gfc_error ("Substring start index at %L is less than one",
1961 &ref
->u
.ss
.start
->where
);
1966 if (ref
->u
.ss
.end
!= NULL
)
1968 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
1971 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
1973 gfc_error ("Substring end index at %L must be of type INTEGER",
1974 &ref
->u
.ss
.end
->where
);
1978 if (ref
->u
.ss
.end
->rank
!= 0)
1980 gfc_error ("Substring end index at %L must be scalar",
1981 &ref
->u
.ss
.end
->where
);
1985 if (ref
->u
.ss
.length
!= NULL
1986 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
)
1988 gfc_error ("Substring end index at %L is out of bounds",
1989 &ref
->u
.ss
.start
->where
);
1998 /* Resolve subtype references. */
2001 resolve_ref (gfc_expr
* expr
)
2003 int current_part_dimension
, n_components
, seen_part_dimension
;
2006 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2007 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
2009 find_array_spec (expr
);
2013 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2017 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
2025 resolve_substring (ref
);
2029 /* Check constraints on part references. */
2031 current_part_dimension
= 0;
2032 seen_part_dimension
= 0;
2035 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2040 switch (ref
->u
.ar
.type
)
2044 current_part_dimension
= 1;
2048 current_part_dimension
= 0;
2052 gfc_internal_error ("resolve_ref(): Bad array reference");
2058 if ((current_part_dimension
|| seen_part_dimension
)
2059 && ref
->u
.c
.component
->pointer
)
2062 ("Component to the right of a part reference with nonzero "
2063 "rank must not have the POINTER attribute at %L",
2075 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
2076 || ref
->next
== NULL
)
2077 && current_part_dimension
2078 && seen_part_dimension
)
2081 gfc_error ("Two or more part references with nonzero rank must "
2082 "not be specified at %L", &expr
->where
);
2086 if (ref
->type
== REF_COMPONENT
)
2088 if (current_part_dimension
)
2089 seen_part_dimension
= 1;
2091 /* reset to make sure */
2092 current_part_dimension
= 0;
2100 /* Given an expression, determine its shape. This is easier than it sounds.
2101 Leaves the shape array NULL if it is not possible to determine the shape. */
2104 expression_shape (gfc_expr
* e
)
2106 mpz_t array
[GFC_MAX_DIMENSIONS
];
2109 if (e
->rank
== 0 || e
->shape
!= NULL
)
2112 for (i
= 0; i
< e
->rank
; i
++)
2113 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2116 e
->shape
= gfc_get_shape (e
->rank
);
2118 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
2123 for (i
--; i
>= 0; i
--)
2124 mpz_clear (array
[i
]);
2128 /* Given a variable expression node, compute the rank of the expression by
2129 examining the base symbol and any reference structures it may have. */
2132 expression_rank (gfc_expr
* e
)
2139 if (e
->expr_type
== EXPR_ARRAY
)
2141 /* Constructors can have a rank different from one via RESHAPE(). */
2143 if (e
->symtree
== NULL
)
2149 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
2150 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
2156 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2158 if (ref
->type
!= REF_ARRAY
)
2161 if (ref
->u
.ar
.type
== AR_FULL
)
2163 rank
= ref
->u
.ar
.as
->rank
;
2167 if (ref
->u
.ar
.type
== AR_SECTION
)
2169 /* Figure out the rank of the section. */
2171 gfc_internal_error ("expression_rank(): Two array specs");
2173 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2174 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
2175 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2185 expression_shape (e
);
2189 /* Resolve a variable expression. */
2192 resolve_variable (gfc_expr
* e
)
2196 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
2199 if (e
->symtree
== NULL
)
2202 sym
= e
->symtree
->n
.sym
;
2203 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2205 e
->ts
.type
= BT_PROCEDURE
;
2209 if (sym
->ts
.type
!= BT_UNKNOWN
)
2210 gfc_variable_attr (e
, &e
->ts
);
2213 /* Must be a simple variable reference. */
2214 if (gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2223 /* Resolve an expression. That is, make sure that types of operands agree
2224 with their operators, intrinsic operators are converted to function calls
2225 for overloaded types and unresolved function references are resolved. */
2228 gfc_resolve_expr (gfc_expr
* e
)
2235 switch (e
->expr_type
)
2238 t
= resolve_operator (e
);
2242 t
= resolve_function (e
);
2246 t
= resolve_variable (e
);
2248 expression_rank (e
);
2251 case EXPR_SUBSTRING
:
2252 t
= resolve_ref (e
);
2262 if (resolve_ref (e
) == FAILURE
)
2265 t
= gfc_resolve_array_constructor (e
);
2266 /* Also try to expand a constructor. */
2269 expression_rank (e
);
2270 gfc_expand_constructor (e
);
2275 case EXPR_STRUCTURE
:
2276 t
= resolve_ref (e
);
2280 t
= resolve_structure_cons (e
);
2284 t
= gfc_simplify_expr (e
, 0);
2288 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2295 /* Resolve an expression from an iterator. They must be scalar and have
2296 INTEGER or (optionally) REAL type. */
2299 gfc_resolve_iterator_expr (gfc_expr
* expr
, bool real_ok
, const char * name
)
2301 if (gfc_resolve_expr (expr
) == FAILURE
)
2304 if (expr
->rank
!= 0)
2306 gfc_error ("%s at %L must be a scalar", name
, &expr
->where
);
2310 if (!(expr
->ts
.type
== BT_INTEGER
2311 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
2313 gfc_error ("%s at %L must be INTEGER%s",
2316 real_ok
? " or REAL" : "");
2323 /* Resolve the expressions in an iterator structure. If REAL_OK is
2324 false allow only INTEGER type iterators, otherwise allow REAL types. */
2327 gfc_resolve_iterator (gfc_iterator
* iter
, bool real_ok
)
2330 if (iter
->var
->ts
.type
== BT_REAL
)
2331 gfc_notify_std (GFC_STD_F95_DEL
,
2332 "Obsolete: REAL DO loop iterator at %L",
2335 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
2339 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
2341 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2346 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
2347 "Start expression in DO loop") == FAILURE
)
2350 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
2351 "End expression in DO loop") == FAILURE
)
2354 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
2355 "Step expression in DO loop") == FAILURE
)
2358 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
2360 if ((iter
->step
->ts
.type
== BT_INTEGER
2361 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
2362 || (iter
->step
->ts
.type
== BT_REAL
2363 && mpfr_sgn (iter
->step
->value
.real
) == 0))
2365 gfc_error ("Step expression in DO loop at %L cannot be zero",
2366 &iter
->step
->where
);
2371 /* Convert start, end, and step to the same type as var. */
2372 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
2373 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
2374 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2376 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
2377 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
2378 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2380 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
2381 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
2382 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
2388 /* Resolve a list of FORALL iterators. */
2391 resolve_forall_iterators (gfc_forall_iterator
* iter
)
2396 if (gfc_resolve_expr (iter
->var
) == SUCCESS
2397 && iter
->var
->ts
.type
!= BT_INTEGER
)
2398 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2401 if (gfc_resolve_expr (iter
->start
) == SUCCESS
2402 && iter
->start
->ts
.type
!= BT_INTEGER
)
2403 gfc_error ("FORALL start expression at %L must be INTEGER",
2404 &iter
->start
->where
);
2405 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
2406 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2408 if (gfc_resolve_expr (iter
->end
) == SUCCESS
2409 && iter
->end
->ts
.type
!= BT_INTEGER
)
2410 gfc_error ("FORALL end expression at %L must be INTEGER",
2412 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
2413 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2415 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
2416 && iter
->stride
->ts
.type
!= BT_INTEGER
)
2417 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2418 &iter
->stride
->where
);
2419 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
2420 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
2427 /* Given a pointer to a symbol that is a derived type, see if any components
2428 have the POINTER attribute. The search is recursive if necessary.
2429 Returns zero if no pointer components are found, nonzero otherwise. */
2432 derived_pointer (gfc_symbol
* sym
)
2436 for (c
= sym
->components
; c
; c
= c
->next
)
2441 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
2449 /* Resolve the argument of a deallocate expression. The expression must be
2450 a pointer or a full array. */
2453 resolve_deallocate_expr (gfc_expr
* e
)
2455 symbol_attribute attr
;
2459 if (gfc_resolve_expr (e
) == FAILURE
)
2462 attr
= gfc_expr_attr (e
);
2466 if (e
->expr_type
!= EXPR_VARIABLE
)
2469 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2470 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2474 if (ref
->u
.ar
.type
!= AR_FULL
)
2479 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2480 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2488 if (allocatable
== 0)
2491 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2492 "ALLOCATABLE or a POINTER", &e
->where
);
2499 /* Resolve the expression in an ALLOCATE statement, doing the additional
2500 checks to see whether the expression is OK or not. The expression must
2501 have a trailing array reference that gives the size of the array. */
2504 resolve_allocate_expr (gfc_expr
* e
)
2506 int i
, pointer
, allocatable
, dimension
;
2507 symbol_attribute attr
;
2508 gfc_ref
*ref
, *ref2
;
2511 if (gfc_resolve_expr (e
) == FAILURE
)
2514 /* Make sure the expression is allocatable or a pointer. If it is
2515 pointer, the next-to-last reference must be a pointer. */
2519 if (e
->expr_type
!= EXPR_VARIABLE
)
2523 attr
= gfc_expr_attr (e
);
2524 pointer
= attr
.pointer
;
2525 dimension
= attr
.dimension
;
2530 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2531 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
2532 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
2534 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
2538 if (ref
->next
!= NULL
)
2543 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2544 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2546 pointer
= ref
->u
.c
.component
->pointer
;
2547 dimension
= ref
->u
.c
.component
->dimension
;
2557 if (allocatable
== 0 && pointer
== 0)
2559 gfc_error ("Expression in ALLOCATE statement at %L must be "
2560 "ALLOCATABLE or a POINTER", &e
->where
);
2564 if (pointer
&& dimension
== 0)
2567 /* Make sure the next-to-last reference node is an array specification. */
2569 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
2571 gfc_error ("Array specification required in ALLOCATE statement "
2572 "at %L", &e
->where
);
2576 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
2579 /* Make sure that the array section reference makes sense in the
2580 context of an ALLOCATE specification. */
2584 for (i
= 0; i
< ar
->dimen
; i
++)
2585 switch (ar
->dimen_type
[i
])
2591 if (ar
->start
[i
] != NULL
2592 && ar
->end
[i
] != NULL
2593 && ar
->stride
[i
] == NULL
)
2596 /* Fall Through... */
2600 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2609 /************ SELECT CASE resolution subroutines ************/
2611 /* Callback function for our mergesort variant. Determines interval
2612 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2613 op1 > op2. Assumes we're not dealing with the default case.
2614 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2615 There are nine situations to check. */
2618 compare_cases (const gfc_case
* op1
, const gfc_case
* op2
)
2622 if (op1
->low
== NULL
) /* op1 = (:L) */
2624 /* op2 = (:N), so overlap. */
2626 /* op2 = (M:) or (M:N), L < M */
2627 if (op2
->low
!= NULL
2628 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2631 else if (op1
->high
== NULL
) /* op1 = (K:) */
2633 /* op2 = (M:), so overlap. */
2635 /* op2 = (:N) or (M:N), K > N */
2636 if (op2
->high
!= NULL
2637 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2640 else /* op1 = (K:L) */
2642 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
2643 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
2644 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
2645 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
2646 else /* op2 = (M:N) */
2650 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2653 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2662 /* Merge-sort a double linked case list, detecting overlap in the
2663 process. LIST is the head of the double linked case list before it
2664 is sorted. Returns the head of the sorted list if we don't see any
2665 overlap, or NULL otherwise. */
2668 check_case_overlap (gfc_case
* list
)
2670 gfc_case
*p
, *q
, *e
, *tail
;
2671 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
2673 /* If the passed list was empty, return immediately. */
2680 /* Loop unconditionally. The only exit from this loop is a return
2681 statement, when we've finished sorting the case list. */
2688 /* Count the number of merges we do in this pass. */
2691 /* Loop while there exists a merge to be done. */
2696 /* Count this merge. */
2699 /* Cut the list in two pieces by stepping INSIZE places
2700 forward in the list, starting from P. */
2703 for (i
= 0; i
< insize
; i
++)
2712 /* Now we have two lists. Merge them! */
2713 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
2716 /* See from which the next case to merge comes from. */
2719 /* P is empty so the next case must come from Q. */
2724 else if (qsize
== 0 || q
== NULL
)
2733 cmp
= compare_cases (p
, q
);
2736 /* The whole case range for P is less than the
2744 /* The whole case range for Q is greater than
2745 the case range for P. */
2752 /* The cases overlap, or they are the same
2753 element in the list. Either way, we must
2754 issue an error and get the next case from P. */
2755 /* FIXME: Sort P and Q by line number. */
2756 gfc_error ("CASE label at %L overlaps with CASE "
2757 "label at %L", &p
->where
, &q
->where
);
2765 /* Add the next element to the merged list. */
2774 /* P has now stepped INSIZE places along, and so has Q. So
2775 they're the same. */
2780 /* If we have done only one merge or none at all, we've
2781 finished sorting the cases. */
2790 /* Otherwise repeat, merging lists twice the size. */
2796 /* Check to see if an expression is suitable for use in a CASE statement.
2797 Makes sure that all case expressions are scalar constants of the same
2798 type. Return FAILURE if anything is wrong. */
2801 validate_case_label_expr (gfc_expr
* e
, gfc_expr
* case_expr
)
2803 if (e
== NULL
) return SUCCESS
;
2805 if (e
->ts
.type
!= case_expr
->ts
.type
)
2807 gfc_error ("Expression in CASE statement at %L must be of type %s",
2808 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
2812 /* C805 (R808) For a given case-construct, each case-value shall be of
2813 the same type as case-expr. For character type, length differences
2814 are allowed, but the kind type parameters shall be the same. */
2816 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
2818 gfc_error("Expression in CASE statement at %L must be kind %d",
2819 &e
->where
, case_expr
->ts
.kind
);
2823 /* Convert the case value kind to that of case expression kind, if needed.
2824 FIXME: Should a warning be issued? */
2825 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
2826 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
2830 gfc_error ("Expression in CASE statement at %L must be scalar",
2839 /* Given a completely parsed select statement, we:
2841 - Validate all expressions and code within the SELECT.
2842 - Make sure that the selection expression is not of the wrong type.
2843 - Make sure that no case ranges overlap.
2844 - Eliminate unreachable cases and unreachable code resulting from
2845 removing case labels.
2847 The standard does allow unreachable cases, e.g. CASE (5:3). But
2848 they are a hassle for code generation, and to prevent that, we just
2849 cut them out here. This is not necessary for overlapping cases
2850 because they are illegal and we never even try to generate code.
2852 We have the additional caveat that a SELECT construct could have
2853 been a computed GOTO in the source code. Fortunately we can fairly
2854 easily work around that here: The case_expr for a "real" SELECT CASE
2855 is in code->expr1, but for a computed GOTO it is in code->expr2. All
2856 we have to do is make sure that the case_expr is a scalar integer
2860 resolve_select (gfc_code
* code
)
2863 gfc_expr
*case_expr
;
2864 gfc_case
*cp
, *default_case
, *tail
, *head
;
2865 int seen_unreachable
;
2870 if (code
->expr
== NULL
)
2872 /* This was actually a computed GOTO statement. */
2873 case_expr
= code
->expr2
;
2874 if (case_expr
->ts
.type
!= BT_INTEGER
2875 || case_expr
->rank
!= 0)
2876 gfc_error ("Selection expression in computed GOTO statement "
2877 "at %L must be a scalar integer expression",
2880 /* Further checking is not necessary because this SELECT was built
2881 by the compiler, so it should always be OK. Just move the
2882 case_expr from expr2 to expr so that we can handle computed
2883 GOTOs as normal SELECTs from here on. */
2884 code
->expr
= code
->expr2
;
2889 case_expr
= code
->expr
;
2891 type
= case_expr
->ts
.type
;
2892 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
2894 gfc_error ("Argument of SELECT statement at %L cannot be %s",
2895 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
2897 /* Punt. Going on here just produce more garbage error messages. */
2901 if (case_expr
->rank
!= 0)
2903 gfc_error ("Argument of SELECT statement at %L must be a scalar "
2904 "expression", &case_expr
->where
);
2910 /* PR 19168 has a long discussion concerning a mismatch of the kinds
2911 of the SELECT CASE expression and its CASE values. Walk the lists
2912 of case values, and if we find a mismatch, promote case_expr to
2913 the appropriate kind. */
2915 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
2917 for (body
= code
->block
; body
; body
= body
->block
)
2919 /* Walk the case label list. */
2920 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
2922 /* Intercept the DEFAULT case. It does not have a kind. */
2923 if (cp
->low
== NULL
&& cp
->high
== NULL
)
2926 /* Unreachable case ranges are discarded, so ignore. */
2927 if (cp
->low
!= NULL
&& cp
->high
!= NULL
2928 && cp
->low
!= cp
->high
2929 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
2932 /* FIXME: Should a warning be issued? */
2934 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
2935 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
2937 if (cp
->high
!= NULL
2938 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
2939 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
2944 /* Assume there is no DEFAULT case. */
2945 default_case
= NULL
;
2949 for (body
= code
->block
; body
; body
= body
->block
)
2951 /* Assume the CASE list is OK, and all CASE labels can be matched. */
2953 seen_unreachable
= 0;
2955 /* Walk the case label list, making sure that all case labels
2957 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
2959 /* Count the number of cases in the whole construct. */
2962 /* Intercept the DEFAULT case. */
2963 if (cp
->low
== NULL
&& cp
->high
== NULL
)
2965 if (default_case
!= NULL
)
2967 gfc_error ("The DEFAULT CASE at %L cannot be followed "
2968 "by a second DEFAULT CASE at %L",
2969 &default_case
->where
, &cp
->where
);
2980 /* Deal with single value cases and case ranges. Errors are
2981 issued from the validation function. */
2982 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
2983 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
2989 if (type
== BT_LOGICAL
2990 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
2991 || cp
->low
!= cp
->high
))
2994 ("Logical range in CASE statement at %L is not allowed",
3000 if (cp
->low
!= NULL
&& cp
->high
!= NULL
3001 && cp
->low
!= cp
->high
3002 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
3004 if (gfc_option
.warn_surprising
)
3005 gfc_warning ("Range specification at %L can never "
3006 "be matched", &cp
->where
);
3008 cp
->unreachable
= 1;
3009 seen_unreachable
= 1;
3013 /* If the case range can be matched, it can also overlap with
3014 other cases. To make sure it does not, we put it in a
3015 double linked list here. We sort that with a merge sort
3016 later on to detect any overlapping cases. */
3020 head
->right
= head
->left
= NULL
;
3025 tail
->right
->left
= tail
;
3032 /* It there was a failure in the previous case label, give up
3033 for this case label list. Continue with the next block. */
3037 /* See if any case labels that are unreachable have been seen.
3038 If so, we eliminate them. This is a bit of a kludge because
3039 the case lists for a single case statement (label) is a
3040 single forward linked lists. */
3041 if (seen_unreachable
)
3043 /* Advance until the first case in the list is reachable. */
3044 while (body
->ext
.case_list
!= NULL
3045 && body
->ext
.case_list
->unreachable
)
3047 gfc_case
*n
= body
->ext
.case_list
;
3048 body
->ext
.case_list
= body
->ext
.case_list
->next
;
3050 gfc_free_case_list (n
);
3053 /* Strip all other unreachable cases. */
3054 if (body
->ext
.case_list
)
3056 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
3058 if (cp
->next
->unreachable
)
3060 gfc_case
*n
= cp
->next
;
3061 cp
->next
= cp
->next
->next
;
3063 gfc_free_case_list (n
);
3070 /* See if there were overlapping cases. If the check returns NULL,
3071 there was overlap. In that case we don't do anything. If head
3072 is non-NULL, we prepend the DEFAULT case. The sorted list can
3073 then used during code generation for SELECT CASE constructs with
3074 a case expression of a CHARACTER type. */
3077 head
= check_case_overlap (head
);
3079 /* Prepend the default_case if it is there. */
3080 if (head
!= NULL
&& default_case
)
3082 default_case
->left
= NULL
;
3083 default_case
->right
= head
;
3084 head
->left
= default_case
;
3088 /* Eliminate dead blocks that may be the result if we've seen
3089 unreachable case labels for a block. */
3090 for (body
= code
; body
&& body
->block
; body
= body
->block
)
3092 if (body
->block
->ext
.case_list
== NULL
)
3094 /* Cut the unreachable block from the code chain. */
3095 gfc_code
*c
= body
->block
;
3096 body
->block
= c
->block
;
3098 /* Kill the dead block, but not the blocks below it. */
3100 gfc_free_statements (c
);
3104 /* More than two cases is legal but insane for logical selects.
3105 Issue a warning for it. */
3106 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
3108 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3113 /* Resolve a transfer statement. This is making sure that:
3114 -- a derived type being transferred has only non-pointer components
3115 -- a derived type being transferred doesn't have private components
3116 -- we're not trying to transfer a whole assumed size array. */
3119 resolve_transfer (gfc_code
* code
)
3128 if (exp
->expr_type
!= EXPR_VARIABLE
)
3131 sym
= exp
->symtree
->n
.sym
;
3134 /* Go to actual component transferred. */
3135 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
3136 if (ref
->type
== REF_COMPONENT
)
3137 ts
= &ref
->u
.c
.component
->ts
;
3139 if (ts
->type
== BT_DERIVED
)
3141 /* Check that transferred derived type doesn't contain POINTER
3143 if (derived_pointer (ts
->derived
))
3145 gfc_error ("Data transfer element at %L cannot have "
3146 "POINTER components", &code
->loc
);
3150 if (ts
->derived
->component_access
== ACCESS_PRIVATE
)
3152 gfc_error ("Data transfer element at %L cannot have "
3153 "PRIVATE components",&code
->loc
);
3158 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
3159 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
3161 gfc_error ("Data transfer element at %L cannot be a full reference to "
3162 "an assumed-size array", &code
->loc
);
3168 /*********** Toplevel code resolution subroutines ***********/
3170 /* Given a branch to a label and a namespace, if the branch is conforming.
3171 The code node described where the branch is located. */
3174 resolve_branch (gfc_st_label
* label
, gfc_code
* code
)
3176 gfc_code
*block
, *found
;
3184 /* Step one: is this a valid branching target? */
3186 if (lp
->defined
== ST_LABEL_UNKNOWN
)
3188 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
3193 if (lp
->defined
!= ST_LABEL_TARGET
)
3195 gfc_error ("Statement at %L is not a valid branch target statement "
3196 "for the branch statement at %L", &lp
->where
, &code
->loc
);
3200 /* Step two: make sure this branch is not a branch to itself ;-) */
3202 if (code
->here
== label
)
3204 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
3208 /* Step three: Try to find the label in the parse tree. To do this,
3209 we traverse the tree block-by-block: first the block that
3210 contains this GOTO, then the block that it is nested in, etc. We
3211 can ignore other blocks because branching into another block is
3216 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3218 for (block
= stack
->head
; block
; block
= block
->next
)
3220 if (block
->here
== label
)
3233 /* still nothing, so illegal. */
3234 gfc_error_now ("Label at %L is not in the same block as the "
3235 "GOTO statement at %L", &lp
->where
, &code
->loc
);
3239 /* Step four: Make sure that the branching target is legal if
3240 the statement is an END {SELECT,DO,IF}. */
3242 if (found
->op
== EXEC_NOP
)
3244 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3245 if (stack
->current
->next
== found
)
3249 gfc_notify_std (GFC_STD_F95_DEL
,
3250 "Obsolete: GOTO at %L jumps to END of construct at %L",
3251 &code
->loc
, &found
->loc
);
3256 /* Check whether EXPR1 has the same shape as EXPR2. */
3259 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
3261 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3262 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
3263 try result
= FAILURE
;
3266 /* Compare the rank. */
3267 if (expr1
->rank
!= expr2
->rank
)
3270 /* Compare the size of each dimension. */
3271 for (i
=0; i
<expr1
->rank
; i
++)
3273 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
3276 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
3279 if (mpz_cmp (shape
[i
], shape2
[i
]))
3283 /* When either of the two expression is an assumed size array, we
3284 ignore the comparison of dimension sizes. */
3289 for (i
--; i
>=0; i
--)
3291 mpz_clear (shape
[i
]);
3292 mpz_clear (shape2
[i
]);
3298 /* Check whether a WHERE assignment target or a WHERE mask expression
3299 has the same shape as the outmost WHERE mask expression. */
3302 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
3308 cblock
= code
->block
;
3310 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3311 In case of nested WHERE, only the outmost one is stored. */
3312 if (mask
== NULL
) /* outmost WHERE */
3314 else /* inner WHERE */
3321 /* Check if the mask-expr has a consistent shape with the
3322 outmost WHERE mask-expr. */
3323 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
3324 gfc_error ("WHERE mask at %L has inconsistent shape",
3325 &cblock
->expr
->where
);
3328 /* the assignment statement of a WHERE statement, or the first
3329 statement in where-body-construct of a WHERE construct */
3330 cnext
= cblock
->next
;
3335 /* WHERE assignment statement */
3338 /* Check shape consistent for WHERE assignment target. */
3339 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
3340 gfc_error ("WHERE assignment target at %L has "
3341 "inconsistent shape", &cnext
->expr
->where
);
3344 /* WHERE or WHERE construct is part of a where-body-construct */
3346 resolve_where (cnext
, e
);
3350 gfc_error ("Unsupported statement inside WHERE at %L",
3353 /* the next statement within the same where-body-construct */
3354 cnext
= cnext
->next
;
3356 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3357 cblock
= cblock
->block
;
3362 /* Check whether the FORALL index appears in the expression or not. */
3365 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
3369 gfc_actual_arglist
*args
;
3372 switch (expr
->expr_type
)
3375 gcc_assert (expr
->symtree
->n
.sym
);
3377 /* A scalar assignment */
3380 if (expr
->symtree
->n
.sym
== symbol
)
3386 /* the expr is array ref, substring or struct component. */
3393 /* Check if the symbol appears in the array subscript. */
3395 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3398 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
3402 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
3406 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
3412 if (expr
->symtree
->n
.sym
== symbol
)
3415 /* Check if the symbol appears in the substring section. */
3416 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3418 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3426 gfc_error("expresion reference type error at %L", &expr
->where
);
3432 /* If the expression is a function call, then check if the symbol
3433 appears in the actual arglist of the function. */
3435 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3437 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
3442 /* It seems not to happen. */
3443 case EXPR_SUBSTRING
:
3447 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
3448 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3450 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3455 /* It seems not to happen. */
3456 case EXPR_STRUCTURE
:
3458 gfc_error ("Unsupported statement while finding forall index in "
3463 /* Find the FORALL index in the first operand. */
3464 if (expr
->value
.op
.op1
)
3466 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
3470 /* Find the FORALL index in the second operand. */
3471 if (expr
->value
.op
.op2
)
3473 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
3486 /* Resolve assignment in FORALL construct.
3487 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3488 FORALL index variables. */
3491 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3495 for (n
= 0; n
< nvar
; n
++)
3497 gfc_symbol
*forall_index
;
3499 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
3501 /* Check whether the assignment target is one of the FORALL index
3503 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
3504 && (code
->expr
->symtree
->n
.sym
== forall_index
))
3505 gfc_error ("Assignment to a FORALL index variable at %L",
3506 &code
->expr
->where
);
3509 /* If one of the FORALL index variables doesn't appear in the
3510 assignment target, then there will be a many-to-one
3512 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
3513 gfc_error ("The FORALL with index '%s' cause more than one "
3514 "assignment to this object at %L",
3515 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
3521 /* Resolve WHERE statement in FORALL construct. */
3524 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
){
3528 cblock
= code
->block
;
3531 /* the assignment statement of a WHERE statement, or the first
3532 statement in where-body-construct of a WHERE construct */
3533 cnext
= cblock
->next
;
3538 /* WHERE assignment statement */
3540 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
3543 /* WHERE or WHERE construct is part of a where-body-construct */
3545 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
3549 gfc_error ("Unsupported statement inside WHERE at %L",
3552 /* the next statement within the same where-body-construct */
3553 cnext
= cnext
->next
;
3555 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3556 cblock
= cblock
->block
;
3561 /* Traverse the FORALL body to check whether the following errors exist:
3562 1. For assignment, check if a many-to-one assignment happens.
3563 2. For WHERE statement, check the WHERE body to see if there is any
3564 many-to-one assignment. */
3567 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3571 c
= code
->block
->next
;
3577 case EXEC_POINTER_ASSIGN
:
3578 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
3581 /* Because the resolve_blocks() will handle the nested FORALL,
3582 there is no need to handle it here. */
3586 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
3591 /* The next statement in the FORALL body. */
3597 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3598 gfc_resolve_forall_body to resolve the FORALL body. */
3600 static void resolve_blocks (gfc_code
*, gfc_namespace
*);
3603 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
3605 static gfc_expr
**var_expr
;
3606 static int total_var
= 0;
3607 static int nvar
= 0;
3608 gfc_forall_iterator
*fa
;
3609 gfc_symbol
*forall_index
;
3613 /* Start to resolve a FORALL construct */
3614 if (forall_save
== 0)
3616 /* Count the total number of FORALL index in the nested FORALL
3617 construct in order to allocate the VAR_EXPR with proper size. */
3619 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
3621 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3623 next
= next
->block
->next
;
3626 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3627 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
3630 /* The information about FORALL iterator, including FORALL index start, end
3631 and stride. The FORALL index can not appear in start, end or stride. */
3632 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3634 /* Check if any outer FORALL index name is the same as the current
3636 for (i
= 0; i
< nvar
; i
++)
3638 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
3640 gfc_error ("An outer FORALL construct already has an index "
3641 "with this name %L", &fa
->var
->where
);
3645 /* Record the current FORALL index. */
3646 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
3648 forall_index
= fa
->var
->symtree
->n
.sym
;
3650 /* Check if the FORALL index appears in start, end or stride. */
3651 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
3652 gfc_error ("A FORALL index must not appear in a limit or stride "
3653 "expression in the same FORALL at %L", &fa
->start
->where
);
3654 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
3655 gfc_error ("A FORALL index must not appear in a limit or stride "
3656 "expression in the same FORALL at %L", &fa
->end
->where
);
3657 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
3658 gfc_error ("A FORALL index must not appear in a limit or stride "
3659 "expression in the same FORALL at %L", &fa
->stride
->where
);
3663 /* Resolve the FORALL body. */
3664 gfc_resolve_forall_body (code
, nvar
, var_expr
);
3666 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3667 resolve_blocks (code
->block
, ns
);
3669 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3670 for (i
= 0; i
< total_var
; i
++)
3671 gfc_free_expr (var_expr
[i
]);
3673 /* Reset the counters. */
3679 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3682 static void resolve_code (gfc_code
*, gfc_namespace
*);
3685 resolve_blocks (gfc_code
* b
, gfc_namespace
* ns
)
3689 for (; b
; b
= b
->block
)
3691 t
= gfc_resolve_expr (b
->expr
);
3692 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
3698 if (t
== SUCCESS
&& b
->expr
!= NULL
3699 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
3701 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3708 && (b
->expr
->ts
.type
!= BT_LOGICAL
3709 || b
->expr
->rank
== 0))
3711 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3716 resolve_branch (b
->label
, b
);
3726 gfc_internal_error ("resolve_block(): Bad block type");
3729 resolve_code (b
->next
, ns
);
3734 /* Given a block of code, recursively resolve everything pointed to by this
3738 resolve_code (gfc_code
* code
, gfc_namespace
* ns
)
3740 int forall_save
= 0;
3745 frame
.prev
= cs_base
;
3749 for (; code
; code
= code
->next
)
3751 frame
.current
= code
;
3753 if (code
->op
== EXEC_FORALL
)
3755 forall_save
= forall_flag
;
3757 gfc_resolve_forall (code
, ns
, forall_save
);
3760 resolve_blocks (code
->block
, ns
);
3762 if (code
->op
== EXEC_FORALL
)
3763 forall_flag
= forall_save
;
3765 t
= gfc_resolve_expr (code
->expr
);
3766 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
3782 resolve_where (code
, NULL
);
3786 if (code
->expr
!= NULL
)
3788 if (code
->expr
->ts
.type
!= BT_INTEGER
)
3789 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3790 "variable", &code
->expr
->where
);
3791 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
3792 gfc_error ("Variable '%s' has not been assigned a target label "
3793 "at %L", code
->expr
->symtree
->n
.sym
->name
,
3794 &code
->expr
->where
);
3797 resolve_branch (code
->label
, code
);
3801 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_INTEGER
)
3802 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3803 "return specifier", &code
->expr
->where
);
3810 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
3813 if (gfc_pure (NULL
))
3815 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
3818 ("Cannot assign to variable '%s' in PURE procedure at %L",
3819 code
->expr
->symtree
->n
.sym
->name
, &code
->expr
->where
);
3823 if (code
->expr2
->ts
.type
== BT_DERIVED
3824 && derived_pointer (code
->expr2
->ts
.derived
))
3827 ("Right side of assignment at %L is a derived type "
3828 "containing a POINTER in a PURE procedure",
3829 &code
->expr2
->where
);
3834 gfc_check_assign (code
->expr
, code
->expr2
, 1);
3837 case EXEC_LABEL_ASSIGN
:
3838 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
3839 gfc_error ("Label %d referenced at %L is never defined",
3840 code
->label
->value
, &code
->label
->where
);
3842 && (code
->expr
->expr_type
!= EXPR_VARIABLE
3843 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
3844 || code
->expr
->symtree
->n
.sym
->ts
.kind
3845 != gfc_default_integer_kind
3846 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
3847 gfc_error ("ASSIGN statement at %L requires a scalar "
3848 "default INTEGER variable", &code
->expr
->where
);
3851 case EXEC_POINTER_ASSIGN
:
3855 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
3858 case EXEC_ARITHMETIC_IF
:
3860 && code
->expr
->ts
.type
!= BT_INTEGER
3861 && code
->expr
->ts
.type
!= BT_REAL
)
3862 gfc_error ("Arithmetic IF statement at %L requires a numeric "
3863 "expression", &code
->expr
->where
);
3865 resolve_branch (code
->label
, code
);
3866 resolve_branch (code
->label2
, code
);
3867 resolve_branch (code
->label3
, code
);
3871 if (t
== SUCCESS
&& code
->expr
!= NULL
3872 && (code
->expr
->ts
.type
!= BT_LOGICAL
3873 || code
->expr
->rank
!= 0))
3874 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3875 &code
->expr
->where
);
3880 resolve_call (code
);
3884 /* Select is complicated. Also, a SELECT construct could be
3885 a transformed computed GOTO. */
3886 resolve_select (code
);
3890 if (code
->ext
.iterator
!= NULL
)
3891 gfc_resolve_iterator (code
->ext
.iterator
, true);
3895 if (code
->expr
== NULL
)
3896 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
3898 && (code
->expr
->rank
!= 0
3899 || code
->expr
->ts
.type
!= BT_LOGICAL
))
3900 gfc_error ("Exit condition of DO WHILE loop at %L must be "
3901 "a scalar LOGICAL expression", &code
->expr
->where
);
3905 if (t
== SUCCESS
&& code
->expr
!= NULL
3906 && code
->expr
->ts
.type
!= BT_INTEGER
)
3907 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
3908 "of type INTEGER", &code
->expr
->where
);
3910 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3911 resolve_allocate_expr (a
->expr
);
3915 case EXEC_DEALLOCATE
:
3916 if (t
== SUCCESS
&& code
->expr
!= NULL
3917 && code
->expr
->ts
.type
!= BT_INTEGER
)
3919 ("STAT tag in DEALLOCATE statement at %L must be of type "
3920 "INTEGER", &code
->expr
->where
);
3922 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3923 resolve_deallocate_expr (a
->expr
);
3928 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
3931 resolve_branch (code
->ext
.open
->err
, code
);
3935 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
3938 resolve_branch (code
->ext
.close
->err
, code
);
3941 case EXEC_BACKSPACE
:
3944 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
3947 resolve_branch (code
->ext
.filepos
->err
, code
);
3951 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
3954 resolve_branch (code
->ext
.inquire
->err
, code
);
3958 gcc_assert (code
->ext
.inquire
!= NULL
);
3959 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
3962 resolve_branch (code
->ext
.inquire
->err
, code
);
3967 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
3970 resolve_branch (code
->ext
.dt
->err
, code
);
3971 resolve_branch (code
->ext
.dt
->end
, code
);
3972 resolve_branch (code
->ext
.dt
->eor
, code
);
3976 resolve_transfer (code
);
3980 resolve_forall_iterators (code
->ext
.forall_iterator
);
3982 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
3984 ("FORALL mask clause at %L requires a LOGICAL expression",
3985 &code
->expr
->where
);
3989 gfc_internal_error ("resolve_code(): Bad statement code");
3993 cs_base
= frame
.prev
;
3997 /* Resolve initial values and make sure they are compatible with
4001 resolve_values (gfc_symbol
* sym
)
4004 if (sym
->value
== NULL
)
4007 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
4010 gfc_check_assign_symbol (sym
, sym
->value
);
4014 /* Do anything necessary to resolve a symbol. Right now, we just
4015 assume that an otherwise unknown symbol is a variable. This sort
4016 of thing commonly happens for symbols in module. */
4019 resolve_symbol (gfc_symbol
* sym
)
4021 /* Zero if we are checking a formal namespace. */
4022 static int formal_ns_flag
= 1;
4023 int formal_ns_save
, check_constant
, mp_flag
;
4028 if (sym
->attr
.flavor
== FL_UNKNOWN
)
4030 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
4031 sym
->attr
.flavor
= FL_VARIABLE
;
4034 sym
->attr
.flavor
= FL_PROCEDURE
;
4035 if (sym
->attr
.dimension
)
4036 sym
->attr
.function
= 1;
4040 /* Symbols that are module procedures with results (functions) have
4041 the types and array specification copied for type checking in
4042 procedures that call them, as well as for saving to a module
4043 file. These symbols can't stand the scrutiny that their results
4045 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
4047 /* Assign default type to symbols that need one and don't have one. */
4048 if (sym
->ts
.type
== BT_UNKNOWN
)
4050 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
4051 gfc_set_default_type (sym
, 1, NULL
);
4053 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
4056 gfc_set_default_type (sym
, 0, NULL
);
4059 /* Result may be in another namespace. */
4060 resolve_symbol (sym
->result
);
4062 sym
->ts
= sym
->result
->ts
;
4063 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
4064 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
4065 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
4070 /* Assumed size arrays and assumed shape arrays must be dummy
4074 && (sym
->as
->type
== AS_ASSUMED_SIZE
4075 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
4076 && sym
->attr
.dummy
== 0)
4078 gfc_error ("Assumed %s array at %L must be a dummy argument",
4079 sym
->as
->type
== AS_ASSUMED_SIZE
? "size" : "shape",
4084 /* A parameter array's shape needs to be constant. */
4086 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->as
!= NULL
4087 && !gfc_is_compile_time_shape (sym
->as
))
4089 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4090 "or assumed shape", sym
->name
, &sym
->declared_at
);
4094 /* Make sure that character string variables with assumed length are
4097 if (sym
->attr
.flavor
== FL_VARIABLE
&& !sym
->attr
.result
4098 && sym
->ts
.type
== BT_CHARACTER
4099 && sym
->ts
.cl
->length
== NULL
&& sym
->attr
.dummy
== 0)
4101 gfc_error ("Entity with assumed character length at %L must be a "
4102 "dummy argument or a PARAMETER", &sym
->declared_at
);
4106 /* Make sure a parameter that has been implicitly typed still
4107 matches the implicit type, since PARAMETER statements can precede
4108 IMPLICIT statements. */
4110 if (sym
->attr
.flavor
== FL_PARAMETER
4111 && sym
->attr
.implicit_type
4112 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
4113 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4114 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
4116 /* Make sure the types of derived parameters are consistent. This
4117 type checking is deferred until resolution because the type may
4118 refer to a derived type from the host. */
4120 if (sym
->attr
.flavor
== FL_PARAMETER
4121 && sym
->ts
.type
== BT_DERIVED
4122 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
4123 gfc_error ("Incompatible derived type in PARAMETER at %L",
4124 &sym
->value
->where
);
4126 /* Make sure symbols with known intent or optional are really dummy
4127 variable. Because of ENTRY statement, this has to be deferred
4128 until resolution time. */
4130 if (! sym
->attr
.dummy
4131 && (sym
->attr
.optional
4132 || sym
->attr
.intent
!= INTENT_UNKNOWN
))
4134 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
4138 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
4140 if (sym
->ts
.type
== BT_CHARACTER
)
4142 gfc_charlen
*cl
= sym
->ts
.cl
;
4143 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
4145 gfc_error ("Character-valued statement function '%s' at %L must "
4146 "have constant length", sym
->name
, &sym
->declared_at
);
4152 /* Constraints on deferred shape variable. */
4153 if (sym
->attr
.flavor
== FL_VARIABLE
4154 || (sym
->attr
.flavor
== FL_PROCEDURE
4155 && sym
->attr
.function
))
4157 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
4159 if (sym
->attr
.allocatable
)
4161 if (sym
->attr
.dimension
)
4162 gfc_error ("Allocatable array at %L must have a deferred shape",
4165 gfc_error ("Object at %L may not be ALLOCATABLE",
4170 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
4172 gfc_error ("Pointer to array at %L must have a deferred shape",
4180 if (!mp_flag
&& !sym
->attr
.allocatable
4181 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
4183 gfc_error ("Array at %L cannot have a deferred shape",
4190 switch (sym
->attr
.flavor
)
4193 /* Can the sybol have an initializer? */
4195 if (sym
->attr
.allocatable
)
4196 whynot
= "Allocatable";
4197 else if (sym
->attr
.external
)
4198 whynot
= "External";
4199 else if (sym
->attr
.dummy
)
4201 else if (sym
->attr
.intrinsic
)
4202 whynot
= "Intrinsic";
4203 else if (sym
->attr
.result
)
4204 whynot
= "Function Result";
4205 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
4207 /* Don't allow initialization of automatic arrays. */
4208 for (i
= 0; i
< sym
->as
->rank
; i
++)
4210 if (sym
->as
->lower
[i
] == NULL
4211 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4212 || sym
->as
->upper
[i
] == NULL
4213 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
4215 whynot
= "Automatic array";
4221 /* Reject illegal initializers. */
4222 if (sym
->value
&& whynot
)
4224 gfc_error ("%s '%s' at %L cannot have an initializer",
4225 whynot
, sym
->name
, &sym
->declared_at
);
4229 /* Assign default initializer. */
4230 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| whynot
))
4231 sym
->value
= gfc_default_initializer (&sym
->ts
);
4235 /* Reject PRIVATE objects in a PUBLIC namelist. */
4236 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
4238 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
4240 if (!gfc_check_access(nl
->sym
->attr
.access
,
4241 nl
->sym
->ns
->default_access
))
4242 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4243 "PUBLIC namelist at %L", nl
->sym
->name
,
4254 /* Make sure that intrinsic exist */
4255 if (sym
->attr
.intrinsic
4256 && ! gfc_intrinsic_name(sym
->name
, 0)
4257 && ! gfc_intrinsic_name(sym
->name
, 1))
4258 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
4260 /* Resolve array specifier. Check as well some constraints
4261 on COMMON blocks. */
4263 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
4264 gfc_resolve_array_spec (sym
->as
, check_constant
);
4266 /* Resolve formal namespaces. */
4268 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
4270 formal_ns_save
= formal_ns_flag
;
4272 gfc_resolve (sym
->formal_ns
);
4273 formal_ns_flag
= formal_ns_save
;
4279 /************* Resolve DATA statements *************/
4283 gfc_data_value
*vnode
;
4289 /* Advance the values structure to point to the next value in the data list. */
4292 next_data_value (void)
4294 while (values
.left
== 0)
4296 if (values
.vnode
->next
== NULL
)
4299 values
.vnode
= values
.vnode
->next
;
4300 values
.left
= values
.vnode
->repeat
;
4308 check_data_variable (gfc_data_variable
* var
, locus
* where
)
4314 ar_type mark
= AR_UNKNOWN
;
4316 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
4320 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
4324 mpz_init_set_si (offset
, 0);
4327 if (e
->expr_type
!= EXPR_VARIABLE
)
4328 gfc_internal_error ("check_data_variable(): Bad expression");
4332 mpz_init_set_ui (size
, 1);
4339 /* Find the array section reference. */
4340 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4342 if (ref
->type
!= REF_ARRAY
)
4344 if (ref
->u
.ar
.type
== AR_ELEMENT
)
4350 /* Set marks according to the reference pattern. */
4351 switch (ref
->u
.ar
.type
)
4359 /* Get the start position of array section. */
4360 gfc_get_section_index (ar
, section_index
, &offset
);
4368 if (gfc_array_size (e
, &size
) == FAILURE
)
4370 gfc_error ("Nonconstant array section at %L in DATA statement",
4379 while (mpz_cmp_ui (size
, 0) > 0)
4381 if (next_data_value () == FAILURE
)
4383 gfc_error ("DATA statement at %L has more variables than values",
4389 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
4393 /* If we have more than one element left in the repeat count,
4394 and we have more than one element left in the target variable,
4395 then create a range assignment. */
4396 /* ??? Only done for full arrays for now, since array sections
4398 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
4399 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
4403 if (mpz_cmp_ui (size
, values
.left
) >= 0)
4405 mpz_init_set_ui (range
, values
.left
);
4406 mpz_sub_ui (size
, size
, values
.left
);
4411 mpz_init_set (range
, size
);
4412 values
.left
-= mpz_get_ui (size
);
4413 mpz_set_ui (size
, 0);
4416 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
4419 mpz_add (offset
, offset
, range
);
4423 /* Assign initial value to symbol. */
4427 mpz_sub_ui (size
, size
, 1);
4429 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
4431 if (mark
== AR_FULL
)
4432 mpz_add_ui (offset
, offset
, 1);
4434 /* Modify the array section indexes and recalculate the offset
4435 for next element. */
4436 else if (mark
== AR_SECTION
)
4437 gfc_advance_section (section_index
, ar
, &offset
);
4441 if (mark
== AR_SECTION
)
4443 for (i
= 0; i
< ar
->dimen
; i
++)
4444 mpz_clear (section_index
[i
]);
4454 static try traverse_data_var (gfc_data_variable
*, locus
*);
4456 /* Iterate over a list of elements in a DATA statement. */
4459 traverse_data_list (gfc_data_variable
* var
, locus
* where
)
4462 iterator_stack frame
;
4465 mpz_init (frame
.value
);
4467 mpz_init_set (trip
, var
->iter
.end
->value
.integer
);
4468 mpz_sub (trip
, trip
, var
->iter
.start
->value
.integer
);
4469 mpz_add (trip
, trip
, var
->iter
.step
->value
.integer
);
4471 mpz_div (trip
, trip
, var
->iter
.step
->value
.integer
);
4473 mpz_set (frame
.value
, var
->iter
.start
->value
.integer
);
4475 frame
.prev
= iter_stack
;
4476 frame
.variable
= var
->iter
.var
->symtree
;
4477 iter_stack
= &frame
;
4479 while (mpz_cmp_ui (trip
, 0) > 0)
4481 if (traverse_data_var (var
->list
, where
) == FAILURE
)
4487 e
= gfc_copy_expr (var
->expr
);
4488 if (gfc_simplify_expr (e
, 1) == FAILURE
)
4494 mpz_add (frame
.value
, frame
.value
, var
->iter
.step
->value
.integer
);
4496 mpz_sub_ui (trip
, trip
, 1);
4500 mpz_clear (frame
.value
);
4502 iter_stack
= frame
.prev
;
4507 /* Type resolve variables in the variable list of a DATA statement. */
4510 traverse_data_var (gfc_data_variable
* var
, locus
* where
)
4514 for (; var
; var
= var
->next
)
4516 if (var
->expr
== NULL
)
4517 t
= traverse_data_list (var
, where
);
4519 t
= check_data_variable (var
, where
);
4529 /* Resolve the expressions and iterators associated with a data statement.
4530 This is separate from the assignment checking because data lists should
4531 only be resolved once. */
4534 resolve_data_variables (gfc_data_variable
* d
)
4536 for (; d
; d
= d
->next
)
4538 if (d
->list
== NULL
)
4540 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
4545 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
4548 if (d
->iter
.start
->expr_type
!= EXPR_CONSTANT
4549 || d
->iter
.end
->expr_type
!= EXPR_CONSTANT
4550 || d
->iter
.step
->expr_type
!= EXPR_CONSTANT
)
4551 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4553 if (resolve_data_variables (d
->list
) == FAILURE
)
4562 /* Resolve a single DATA statement. We implement this by storing a pointer to
4563 the value list into static variables, and then recursively traversing the
4564 variables list, expanding iterators and such. */
4567 resolve_data (gfc_data
* d
)
4569 if (resolve_data_variables (d
->var
) == FAILURE
)
4572 values
.vnode
= d
->value
;
4573 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
4575 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
4578 /* At this point, we better not have any values left. */
4580 if (next_data_value () == SUCCESS
)
4581 gfc_error ("DATA statement at %L has more values than variables",
4586 /* Determines if a variable is not 'pure', ie not assignable within a pure
4587 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4591 gfc_impure_variable (gfc_symbol
* sym
)
4593 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
4596 if (sym
->ns
!= gfc_current_ns
)
4597 return !sym
->attr
.function
;
4599 /* TODO: Check storage association through EQUIVALENCE statements */
4605 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4606 symbol of the current procedure. */
4609 gfc_pure (gfc_symbol
* sym
)
4611 symbol_attribute attr
;
4614 sym
= gfc_current_ns
->proc_name
;
4620 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
4624 /* Test whether the current procedure is elemental or not. */
4627 gfc_elemental (gfc_symbol
* sym
)
4629 symbol_attribute attr
;
4632 sym
= gfc_current_ns
->proc_name
;
4637 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
4641 /* Warn about unused labels. */
4644 warn_unused_label (gfc_namespace
* ns
)
4655 for (; l
; l
= l
->prev
)
4657 if (l
->defined
== ST_LABEL_UNKNOWN
)
4660 switch (l
->referenced
)
4662 case ST_LABEL_UNKNOWN
:
4663 gfc_warning ("Label %d at %L defined but not used", l
->value
,
4667 case ST_LABEL_BAD_TARGET
:
4668 gfc_warning ("Label %d at %L defined but cannot be used", l
->value
,
4679 /* Resolve derived type EQUIVALENCE object. */
4682 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
4685 gfc_component
*c
= derived
->components
;
4690 /* Shall not be an object of nonsequence derived type. */
4691 if (!derived
->attr
.sequence
)
4693 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
4694 "attribute to be an EQUIVALENCE object", sym
->name
, &e
->where
);
4698 for (; c
; c
= c
->next
)
4701 if (d
&& (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
4704 /* Shall not be an object of sequence derived type containing a pointer
4705 in the structure. */
4708 gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
4709 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
4717 /* Resolve equivalence object.
4718 An EQUIVALENCE object shall not be a dummy argument, a pointer, an
4719 allocatable array, an object of nonsequence derived type, an object of
4720 sequence derived type containing a pointer at any level of component
4721 selection, an automatic object, a function name, an entry name, a result
4722 name, a named constant, a structure component, or a subobject of any of
4723 the preceding objects. */
4726 resolve_equivalence (gfc_equiv
*eq
)
4729 gfc_symbol
*derived
;
4733 for (; eq
; eq
= eq
->eq
)
4736 if (gfc_resolve_expr (e
) == FAILURE
)
4739 sym
= e
->symtree
->n
.sym
;
4741 /* Shall not be a dummy argument. */
4742 if (sym
->attr
.dummy
)
4744 gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
4745 "object", sym
->name
, &e
->where
);
4749 /* Shall not be an allocatable array. */
4750 if (sym
->attr
.allocatable
)
4752 gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
4753 "object", sym
->name
, &e
->where
);
4757 /* Shall not be a pointer. */
4758 if (sym
->attr
.pointer
)
4760 gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
4761 sym
->name
, &e
->where
);
4765 /* Shall not be a function name, ... */
4766 if (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
4767 || sym
->attr
.subroutine
)
4769 gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
4770 sym
->name
, &e
->where
);
4774 /* Shall not be a named constant. */
4775 if (e
->expr_type
== EXPR_CONSTANT
)
4777 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
4778 "object", sym
->name
, &e
->where
);
4782 derived
= e
->ts
.derived
;
4783 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
4789 /* Shall not be an automatic array. */
4790 if (e
->ref
->type
== REF_ARRAY
4791 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
4793 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
4794 "an EQUIVALENCE object", sym
->name
, &e
->where
);
4798 /* Shall not be a structure component. */
4802 if (r
->type
== REF_COMPONENT
)
4804 gfc_error ("Structure component '%s' at %L cannot be an "
4805 "EQUIVALENCE object",
4806 r
->u
.c
.component
->name
, &e
->where
);
4815 /* This function is called after a complete program unit has been compiled.
4816 Its purpose is to examine all of the expressions associated with a program
4817 unit, assign types to all intermediate expressions, make sure that all
4818 assignments are to compatible types and figure out which names refer to
4819 which functions or subroutines. */
4822 gfc_resolve (gfc_namespace
* ns
)
4824 gfc_namespace
*old_ns
, *n
;
4829 old_ns
= gfc_current_ns
;
4830 gfc_current_ns
= ns
;
4832 resolve_entries (ns
);
4834 resolve_contained_functions (ns
);
4836 gfc_traverse_ns (ns
, resolve_symbol
);
4838 for (n
= ns
->contained
; n
; n
= n
->sibling
)
4840 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
4841 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
4842 "also be PURE", n
->proc_name
->name
,
4843 &n
->proc_name
->declared_at
);
4849 gfc_check_interfaces (ns
);
4851 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
4853 if (cl
->length
== NULL
|| gfc_resolve_expr (cl
->length
) == FAILURE
)
4856 if (gfc_simplify_expr (cl
->length
, 0) == FAILURE
)
4859 if (gfc_specification_expr (cl
->length
) == FAILURE
)
4863 gfc_traverse_ns (ns
, resolve_values
);
4869 for (d
= ns
->data
; d
; d
= d
->next
)
4873 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
4875 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
4876 resolve_equivalence (eq
);
4879 resolve_code (ns
->code
, ns
);
4881 /* Warn about unused labels. */
4882 if (gfc_option
.warn_unused_labels
)
4883 warn_unused_label (ns
);
4885 gfc_current_ns
= old_ns
;