1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
26 #include "arith.h" /* For gfc_compare_expr(). */
27 #include "dependency.h"
29 /* Types used in equivalence statements. */
33 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
37 /* Stack to push the current if we descend into a block during
38 resolution. See resolve_branch() and resolve_code(). */
40 typedef struct code_stack
42 struct gfc_code
*head
, *current
;
43 struct code_stack
*prev
;
47 static code_stack
*cs_base
= NULL
;
50 /* Nonzero if we're inside a FORALL block */
52 static int forall_flag
;
54 /* Nonzero if we are processing a formal arglist. The corresponding function
55 resets the flag each time that it is read. */
56 static int formal_arg_flag
= 0;
59 gfc_is_formal_arg (void)
61 return formal_arg_flag
;
64 /* Resolve types of formal argument lists. These have to be done early so that
65 the formal argument lists of module procedures can be copied to the
66 containing module before the individual procedures are resolved
67 individually. We also resolve argument lists of procedures in interface
68 blocks because they are self-contained scoping units.
70 Since a dummy argument cannot be a non-dummy procedure, the only
71 resort left for untyped names are the IMPLICIT types. */
74 resolve_formal_arglist (gfc_symbol
* proc
)
76 gfc_formal_arglist
*f
;
80 /* TODO: Procedures whose return character length parameter is not constant
81 or assumed must also have explicit interfaces. */
82 if (proc
->result
!= NULL
)
87 if (gfc_elemental (proc
)
88 || sym
->attr
.pointer
|| sym
->attr
.allocatable
89 || (sym
->as
&& sym
->as
->rank
> 0))
90 proc
->attr
.always_explicit
= 1;
94 for (f
= proc
->formal
; f
; f
= f
->next
)
100 /* Alternate return placeholder. */
101 if (gfc_elemental (proc
))
102 gfc_error ("Alternate return specifier in elemental subroutine "
103 "'%s' at %L is not allowed", proc
->name
,
105 if (proc
->attr
.function
)
106 gfc_error ("Alternate return specifier in function "
107 "'%s' at %L is not allowed", proc
->name
,
112 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
113 resolve_formal_arglist (sym
);
115 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
117 if (gfc_pure (proc
) && !gfc_pure (sym
))
120 ("Dummy procedure '%s' of PURE procedure at %L must also "
121 "be PURE", sym
->name
, &sym
->declared_at
);
125 if (gfc_elemental (proc
))
128 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
136 if (sym
->ts
.type
== BT_UNKNOWN
)
138 if (!sym
->attr
.function
|| sym
->result
== sym
)
139 gfc_set_default_type (sym
, 1, sym
->ns
);
142 gfc_resolve_array_spec (sym
->as
, 0);
144 /* We can't tell if an array with dimension (:) is assumed or deferred
145 shape until we know if it has the pointer or allocatable attributes.
147 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
148 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
150 sym
->as
->type
= AS_ASSUMED_SHAPE
;
151 for (i
= 0; i
< sym
->as
->rank
; i
++)
152 sym
->as
->lower
[i
] = gfc_int_expr (1);
155 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
156 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
157 || sym
->attr
.optional
)
158 proc
->attr
.always_explicit
= 1;
160 /* If the flavor is unknown at this point, it has to be a variable.
161 A procedure specification would have already set the type. */
163 if (sym
->attr
.flavor
== FL_UNKNOWN
)
164 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
168 if (proc
->attr
.function
&& !sym
->attr
.pointer
169 && sym
->attr
.flavor
!= FL_PROCEDURE
170 && sym
->attr
.intent
!= INTENT_IN
)
172 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
173 "INTENT(IN)", sym
->name
, proc
->name
,
176 if (proc
->attr
.subroutine
&& !sym
->attr
.pointer
177 && sym
->attr
.intent
== INTENT_UNKNOWN
)
180 ("Argument '%s' of pure subroutine '%s' at %L must have "
181 "its INTENT specified", sym
->name
, proc
->name
,
186 if (gfc_elemental (proc
))
191 ("Argument '%s' of elemental procedure at %L must be scalar",
192 sym
->name
, &sym
->declared_at
);
196 if (sym
->attr
.pointer
)
199 ("Argument '%s' of elemental procedure at %L cannot have "
200 "the POINTER attribute", sym
->name
, &sym
->declared_at
);
205 /* Each dummy shall be specified to be scalar. */
206 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
211 ("Argument '%s' of statement function at %L must be scalar",
212 sym
->name
, &sym
->declared_at
);
216 if (sym
->ts
.type
== BT_CHARACTER
)
218 gfc_charlen
*cl
= sym
->ts
.cl
;
219 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
222 ("Character-valued argument '%s' of statement function at "
223 "%L must has constant length",
224 sym
->name
, &sym
->declared_at
);
234 /* Work function called when searching for symbols that have argument lists
235 associated with them. */
238 find_arglists (gfc_symbol
* sym
)
241 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
244 resolve_formal_arglist (sym
);
248 /* Given a namespace, resolve all formal argument lists within the namespace.
252 resolve_formal_arglists (gfc_namespace
* ns
)
258 gfc_traverse_ns (ns
, find_arglists
);
263 resolve_contained_fntype (gfc_symbol
* sym
, gfc_namespace
* ns
)
267 /* If this namespace is not a function, ignore it. */
269 || !(sym
->attr
.function
270 || sym
->attr
.flavor
== FL_VARIABLE
))
273 /* Try to find out of what the return type is. */
274 if (sym
->result
!= NULL
)
277 if (sym
->ts
.type
== BT_UNKNOWN
)
279 t
= gfc_set_default_type (sym
, 0, ns
);
281 if (t
== FAILURE
&& !sym
->attr
.untyped
)
283 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
284 sym
->name
, &sym
->declared_at
); /* FIXME */
285 sym
->attr
.untyped
= 1;
289 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
290 lists the only ways a character length value of * can be used: dummy arguments
291 of procedures, named constants, and function results in external functions.
292 Internal function results are not on that list; ergo, not permitted. */
294 if (sym
->ts
.type
== BT_CHARACTER
)
296 gfc_charlen
*cl
= sym
->ts
.cl
;
297 if (!cl
|| !cl
->length
)
298 gfc_error ("Character-valued internal function '%s' at %L must "
299 "not be assumed length", sym
->name
, &sym
->declared_at
);
304 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
305 introduce duplicates. */
308 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
310 gfc_formal_arglist
*f
, *new_arglist
;
313 for (; new_args
!= NULL
; new_args
= new_args
->next
)
315 new_sym
= new_args
->sym
;
316 /* See if ths arg is already in the formal argument list. */
317 for (f
= proc
->formal
; f
; f
= f
->next
)
319 if (new_sym
== f
->sym
)
326 /* Add a new argument. Argument order is not important. */
327 new_arglist
= gfc_get_formal_arglist ();
328 new_arglist
->sym
= new_sym
;
329 new_arglist
->next
= proc
->formal
;
330 proc
->formal
= new_arglist
;
335 /* Resolve alternate entry points. If a symbol has multiple entry points we
336 create a new master symbol for the main routine, and turn the existing
337 symbol into an entry point. */
340 resolve_entries (gfc_namespace
* ns
)
342 gfc_namespace
*old_ns
;
346 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
347 static int master_count
= 0;
349 if (ns
->proc_name
== NULL
)
352 /* No need to do anything if this procedure doesn't have alternate entry
357 /* We may already have resolved alternate entry points. */
358 if (ns
->proc_name
->attr
.entry_master
)
361 /* If this isn't a procedure something has gone horribly wrong. */
362 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
364 /* Remember the current namespace. */
365 old_ns
= gfc_current_ns
;
369 /* Add the main entry point to the list of entry points. */
370 el
= gfc_get_entry_list ();
371 el
->sym
= ns
->proc_name
;
373 el
->next
= ns
->entries
;
375 ns
->proc_name
->attr
.entry
= 1;
377 /* Add an entry statement for it. */
384 /* Create a new symbol for the master function. */
385 /* Give the internal function a unique name (within this file).
386 Also include the function name so the user has some hope of figuring
387 out what is going on. */
388 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
389 master_count
++, ns
->proc_name
->name
);
390 gfc_get_ha_symbol (name
, &proc
);
391 gcc_assert (proc
!= NULL
);
393 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
394 if (ns
->proc_name
->attr
.subroutine
)
395 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
399 gfc_typespec
*ts
, *fts
;
401 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
403 fts
= &ns
->entries
->sym
->result
->ts
;
404 if (fts
->type
== BT_UNKNOWN
)
405 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
406 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
408 ts
= &el
->sym
->result
->ts
;
409 if (ts
->type
== BT_UNKNOWN
)
410 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
411 if (! gfc_compare_types (ts
, fts
)
412 || (el
->sym
->result
->attr
.dimension
413 != ns
->entries
->sym
->result
->attr
.dimension
)
414 || (el
->sym
->result
->attr
.pointer
415 != ns
->entries
->sym
->result
->attr
.pointer
))
421 sym
= ns
->entries
->sym
->result
;
422 /* All result types the same. */
424 if (sym
->attr
.dimension
)
425 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
426 if (sym
->attr
.pointer
)
427 gfc_add_pointer (&proc
->attr
, NULL
);
431 /* Otherwise the result will be passed through a union by
433 proc
->attr
.mixed_entry_master
= 1;
434 for (el
= ns
->entries
; el
; el
= el
->next
)
436 sym
= el
->sym
->result
;
437 if (sym
->attr
.dimension
)
439 if (el
== ns
->entries
)
441 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
442 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
445 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
446 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
448 else if (sym
->attr
.pointer
)
450 if (el
== ns
->entries
)
452 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
453 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
456 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
457 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
462 if (ts
->type
== BT_UNKNOWN
)
463 ts
= gfc_get_default_type (sym
, NULL
);
467 if (ts
->kind
== gfc_default_integer_kind
)
471 if (ts
->kind
== gfc_default_real_kind
472 || ts
->kind
== gfc_default_double_kind
)
476 if (ts
->kind
== gfc_default_complex_kind
)
480 if (ts
->kind
== gfc_default_logical_kind
)
484 /* We will issue error elsewhere. */
492 if (el
== ns
->entries
)
494 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
495 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
499 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
500 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
507 proc
->attr
.access
= ACCESS_PRIVATE
;
508 proc
->attr
.entry_master
= 1;
510 /* Merge all the entry point arguments. */
511 for (el
= ns
->entries
; el
; el
= el
->next
)
512 merge_argument_lists (proc
, el
->sym
->formal
);
514 /* Use the master function for the function body. */
515 ns
->proc_name
= proc
;
517 /* Finalize the new symbols. */
518 gfc_commit_symbols ();
520 /* Restore the original namespace. */
521 gfc_current_ns
= old_ns
;
525 /* Resolve contained function types. Because contained functions can call one
526 another, they have to be worked out before any of the contained procedures
529 The good news is that if a function doesn't already have a type, the only
530 way it can get one is through an IMPLICIT type or a RESULT variable, because
531 by definition contained functions are contained namespace they're contained
532 in, not in a sibling or parent namespace. */
535 resolve_contained_functions (gfc_namespace
* ns
)
537 gfc_namespace
*child
;
540 resolve_formal_arglists (ns
);
542 for (child
= ns
->contained
; child
; child
= child
->sibling
)
544 /* Resolve alternate entry points first. */
545 resolve_entries (child
);
547 /* Then check function return types. */
548 resolve_contained_fntype (child
->proc_name
, child
);
549 for (el
= child
->entries
; el
; el
= el
->next
)
550 resolve_contained_fntype (el
->sym
, child
);
555 /* Resolve all of the elements of a structure constructor and make sure that
556 the types are correct. */
559 resolve_structure_cons (gfc_expr
* expr
)
561 gfc_constructor
*cons
;
566 cons
= expr
->value
.constructor
;
567 /* A constructor may have references if it is the result of substituting a
568 parameter variable. In this case we just pull out the component we
571 comp
= expr
->ref
->u
.c
.sym
->components
;
573 comp
= expr
->ts
.derived
->components
;
575 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
583 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
589 /* If we don't have the right type, try to convert it. */
591 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
)
592 && gfc_convert_type (cons
->expr
, &comp
->ts
, 1) == FAILURE
)
601 /****************** Expression name resolution ******************/
603 /* Returns 0 if a symbol was not declared with a type or
604 attribute declaration statement, nonzero otherwise. */
607 was_declared (gfc_symbol
* sym
)
613 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
616 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
617 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
618 || a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
625 /* Determine if a symbol is generic or not. */
628 generic_sym (gfc_symbol
* sym
)
632 if (sym
->attr
.generic
||
633 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
636 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
639 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
641 return (s
== NULL
) ? 0 : generic_sym (s
);
645 /* Determine if a symbol is specific or not. */
648 specific_sym (gfc_symbol
* sym
)
652 if (sym
->attr
.if_source
== IFSRC_IFBODY
653 || sym
->attr
.proc
== PROC_MODULE
654 || sym
->attr
.proc
== PROC_INTERNAL
655 || sym
->attr
.proc
== PROC_ST_FUNCTION
656 || (sym
->attr
.intrinsic
&&
657 gfc_specific_intrinsic (sym
->name
))
658 || sym
->attr
.external
)
661 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
664 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
666 return (s
== NULL
) ? 0 : specific_sym (s
);
670 /* Figure out if the procedure is specific, generic or unknown. */
673 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
677 procedure_kind (gfc_symbol
* sym
)
680 if (generic_sym (sym
))
681 return PTYPE_GENERIC
;
683 if (specific_sym (sym
))
684 return PTYPE_SPECIFIC
;
686 return PTYPE_UNKNOWN
;
690 /* Resolve an actual argument list. Most of the time, this is just
691 resolving the expressions in the list.
692 The exception is that we sometimes have to decide whether arguments
693 that look like procedure arguments are really simple variable
697 resolve_actual_arglist (gfc_actual_arglist
* arg
)
700 gfc_symtree
*parent_st
;
703 for (; arg
; arg
= arg
->next
)
709 /* Check the label is a valid branching target. */
712 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
714 gfc_error ("Label %d referenced at %L is never defined",
715 arg
->label
->value
, &arg
->label
->where
);
722 if (e
->ts
.type
!= BT_PROCEDURE
)
724 if (gfc_resolve_expr (e
) != SUCCESS
)
729 /* See if the expression node should really be a variable
732 sym
= e
->symtree
->n
.sym
;
734 if (sym
->attr
.flavor
== FL_PROCEDURE
735 || sym
->attr
.intrinsic
736 || sym
->attr
.external
)
739 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
741 gfc_error ("Statement function '%s' at %L is not allowed as an "
742 "actual argument", sym
->name
, &e
->where
);
745 /* If the symbol is the function that names the current (or
746 parent) scope, then we really have a variable reference. */
748 if (sym
->attr
.function
&& sym
->result
== sym
749 && (sym
->ns
->proc_name
== sym
750 || (sym
->ns
->parent
!= NULL
751 && sym
->ns
->parent
->proc_name
== sym
)))
757 /* See if the name is a module procedure in a parent unit. */
759 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
762 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
764 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
768 if (parent_st
== NULL
)
771 sym
= parent_st
->n
.sym
;
772 e
->symtree
= parent_st
; /* Point to the right thing. */
774 if (sym
->attr
.flavor
== FL_PROCEDURE
775 || sym
->attr
.intrinsic
776 || sym
->attr
.external
)
782 e
->expr_type
= EXPR_VARIABLE
;
786 e
->rank
= sym
->as
->rank
;
787 e
->ref
= gfc_get_ref ();
788 e
->ref
->type
= REF_ARRAY
;
789 e
->ref
->u
.ar
.type
= AR_FULL
;
790 e
->ref
->u
.ar
.as
= sym
->as
;
798 /* Go through each actual argument in ACTUAL and see if it can be
799 implemented as an inlined, non-copying intrinsic. FNSYM is the
800 function being called, or NULL if not known. */
803 find_noncopying_intrinsics (gfc_symbol
* fnsym
, gfc_actual_arglist
* actual
)
805 gfc_actual_arglist
*ap
;
808 for (ap
= actual
; ap
; ap
= ap
->next
)
810 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
811 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
812 ap
->expr
->inline_noncopying_intrinsic
= 1;
816 /************* Function resolution *************/
818 /* Resolve a function call known to be generic.
819 Section 14.1.2.4.1. */
822 resolve_generic_f0 (gfc_expr
* expr
, gfc_symbol
* sym
)
826 if (sym
->attr
.generic
)
829 gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
832 expr
->value
.function
.name
= s
->name
;
833 expr
->value
.function
.esym
= s
;
836 expr
->rank
= s
->as
->rank
;
840 /* TODO: Need to search for elemental references in generic interface */
843 if (sym
->attr
.intrinsic
)
844 return gfc_intrinsic_func_interface (expr
, 0);
851 resolve_generic_f (gfc_expr
* expr
)
856 sym
= expr
->symtree
->n
.sym
;
860 m
= resolve_generic_f0 (expr
, sym
);
863 else if (m
== MATCH_ERROR
)
867 if (sym
->ns
->parent
== NULL
)
869 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
873 if (!generic_sym (sym
))
877 /* Last ditch attempt. */
879 if (!gfc_generic_intrinsic (expr
->symtree
->n
.sym
->name
))
881 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
882 expr
->symtree
->n
.sym
->name
, &expr
->where
);
886 m
= gfc_intrinsic_func_interface (expr
, 0);
891 ("Generic function '%s' at %L is not consistent with a specific "
892 "intrinsic interface", expr
->symtree
->n
.sym
->name
, &expr
->where
);
898 /* Resolve a function call known to be specific. */
901 resolve_specific_f0 (gfc_symbol
* sym
, gfc_expr
* expr
)
905 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
909 sym
->attr
.proc
= PROC_DUMMY
;
913 sym
->attr
.proc
= PROC_EXTERNAL
;
917 if (sym
->attr
.proc
== PROC_MODULE
918 || sym
->attr
.proc
== PROC_ST_FUNCTION
919 || sym
->attr
.proc
== PROC_INTERNAL
)
922 if (sym
->attr
.intrinsic
)
924 m
= gfc_intrinsic_func_interface (expr
, 1);
929 ("Function '%s' at %L is INTRINSIC but is not compatible with "
930 "an intrinsic", sym
->name
, &expr
->where
);
938 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
941 expr
->value
.function
.name
= sym
->name
;
942 expr
->value
.function
.esym
= sym
;
944 expr
->rank
= sym
->as
->rank
;
951 resolve_specific_f (gfc_expr
* expr
)
956 sym
= expr
->symtree
->n
.sym
;
960 m
= resolve_specific_f0 (sym
, expr
);
963 if (m
== MATCH_ERROR
)
966 if (sym
->ns
->parent
== NULL
)
969 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
975 gfc_error ("Unable to resolve the specific function '%s' at %L",
976 expr
->symtree
->n
.sym
->name
, &expr
->where
);
982 /* Resolve a procedure call not known to be generic nor specific. */
985 resolve_unknown_f (gfc_expr
* expr
)
990 sym
= expr
->symtree
->n
.sym
;
994 sym
->attr
.proc
= PROC_DUMMY
;
995 expr
->value
.function
.name
= sym
->name
;
999 /* See if we have an intrinsic function reference. */
1001 if (gfc_intrinsic_name (sym
->name
, 0))
1003 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1008 /* The reference is to an external name. */
1010 sym
->attr
.proc
= PROC_EXTERNAL
;
1011 expr
->value
.function
.name
= sym
->name
;
1012 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1014 if (sym
->as
!= NULL
)
1015 expr
->rank
= sym
->as
->rank
;
1017 /* Type of the expression is either the type of the symbol or the
1018 default type of the symbol. */
1021 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1023 if (sym
->ts
.type
!= BT_UNKNOWN
)
1027 ts
= gfc_get_default_type (sym
, sym
->ns
);
1029 if (ts
->type
== BT_UNKNOWN
)
1031 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1032 sym
->name
, &expr
->where
);
1043 /* Figure out if a function reference is pure or not. Also set the name
1044 of the function for a potential error message. Return nonzero if the
1045 function is PURE, zero if not. */
1048 pure_function (gfc_expr
* e
, const char **name
)
1052 if (e
->value
.function
.esym
)
1054 pure
= gfc_pure (e
->value
.function
.esym
);
1055 *name
= e
->value
.function
.esym
->name
;
1057 else if (e
->value
.function
.isym
)
1059 pure
= e
->value
.function
.isym
->pure
1060 || e
->value
.function
.isym
->elemental
;
1061 *name
= e
->value
.function
.isym
->name
;
1065 /* Implicit functions are not pure. */
1067 *name
= e
->value
.function
.name
;
1074 /* Resolve a function call, which means resolving the arguments, then figuring
1075 out which entity the name refers to. */
1076 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1077 to INTENT(OUT) or INTENT(INOUT). */
1080 resolve_function (gfc_expr
* expr
)
1082 gfc_actual_arglist
*arg
;
1086 if (resolve_actual_arglist (expr
->value
.function
.actual
) == FAILURE
)
1089 /* See if function is already resolved. */
1091 if (expr
->value
.function
.name
!= NULL
)
1093 if (expr
->ts
.type
== BT_UNKNOWN
)
1094 expr
->ts
= expr
->symtree
->n
.sym
->ts
;
1099 /* Apply the rules of section 14.1.2. */
1101 switch (procedure_kind (expr
->symtree
->n
.sym
))
1104 t
= resolve_generic_f (expr
);
1107 case PTYPE_SPECIFIC
:
1108 t
= resolve_specific_f (expr
);
1112 t
= resolve_unknown_f (expr
);
1116 gfc_internal_error ("resolve_function(): bad function type");
1120 /* If the expression is still a function (it might have simplified),
1121 then we check to see if we are calling an elemental function. */
1123 if (expr
->expr_type
!= EXPR_FUNCTION
)
1126 if (expr
->value
.function
.actual
!= NULL
1127 && ((expr
->value
.function
.esym
!= NULL
1128 && expr
->value
.function
.esym
->attr
.elemental
)
1129 || (expr
->value
.function
.isym
!= NULL
1130 && expr
->value
.function
.isym
->elemental
)))
1133 /* The rank of an elemental is the rank of its array argument(s). */
1135 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1137 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1139 expr
->rank
= arg
->expr
->rank
;
1145 if (!pure_function (expr
, &name
))
1150 ("Function reference to '%s' at %L is inside a FORALL block",
1151 name
, &expr
->where
);
1154 else if (gfc_pure (NULL
))
1156 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1157 "procedure within a PURE procedure", name
, &expr
->where
);
1163 find_noncopying_intrinsics (expr
->value
.function
.esym
,
1164 expr
->value
.function
.actual
);
1169 /************* Subroutine resolution *************/
1172 pure_subroutine (gfc_code
* c
, gfc_symbol
* sym
)
1179 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1180 sym
->name
, &c
->loc
);
1181 else if (gfc_pure (NULL
))
1182 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1188 resolve_generic_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1192 if (sym
->attr
.generic
)
1194 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1197 c
->resolved_sym
= s
;
1198 pure_subroutine (c
, s
);
1202 /* TODO: Need to search for elemental references in generic interface. */
1205 if (sym
->attr
.intrinsic
)
1206 return gfc_intrinsic_sub_interface (c
, 0);
1213 resolve_generic_s (gfc_code
* c
)
1218 sym
= c
->symtree
->n
.sym
;
1220 m
= resolve_generic_s0 (c
, sym
);
1223 if (m
== MATCH_ERROR
)
1226 if (sym
->ns
->parent
!= NULL
)
1228 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1231 m
= resolve_generic_s0 (c
, sym
);
1234 if (m
== MATCH_ERROR
)
1239 /* Last ditch attempt. */
1241 if (!gfc_generic_intrinsic (sym
->name
))
1244 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1245 sym
->name
, &c
->loc
);
1249 m
= gfc_intrinsic_sub_interface (c
, 0);
1253 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1254 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1260 /* Resolve a subroutine call known to be specific. */
1263 resolve_specific_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1267 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1269 if (sym
->attr
.dummy
)
1271 sym
->attr
.proc
= PROC_DUMMY
;
1275 sym
->attr
.proc
= PROC_EXTERNAL
;
1279 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1282 if (sym
->attr
.intrinsic
)
1284 m
= gfc_intrinsic_sub_interface (c
, 1);
1288 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1289 "with an intrinsic", sym
->name
, &c
->loc
);
1297 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1299 c
->resolved_sym
= sym
;
1300 pure_subroutine (c
, sym
);
1307 resolve_specific_s (gfc_code
* c
)
1312 sym
= c
->symtree
->n
.sym
;
1314 m
= resolve_specific_s0 (c
, sym
);
1317 if (m
== MATCH_ERROR
)
1320 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1324 m
= resolve_specific_s0 (c
, sym
);
1327 if (m
== MATCH_ERROR
)
1331 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1332 sym
->name
, &c
->loc
);
1338 /* Resolve a subroutine call not known to be generic nor specific. */
1341 resolve_unknown_s (gfc_code
* c
)
1345 sym
= c
->symtree
->n
.sym
;
1347 if (sym
->attr
.dummy
)
1349 sym
->attr
.proc
= PROC_DUMMY
;
1353 /* See if we have an intrinsic function reference. */
1355 if (gfc_intrinsic_name (sym
->name
, 1))
1357 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1362 /* The reference is to an external name. */
1365 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1367 c
->resolved_sym
= sym
;
1369 pure_subroutine (c
, sym
);
1375 /* Resolve a subroutine call. Although it was tempting to use the same code
1376 for functions, subroutines and functions are stored differently and this
1377 makes things awkward. */
1380 resolve_call (gfc_code
* c
)
1384 if (resolve_actual_arglist (c
->ext
.actual
) == FAILURE
)
1388 if (c
->resolved_sym
== NULL
)
1389 switch (procedure_kind (c
->symtree
->n
.sym
))
1392 t
= resolve_generic_s (c
);
1395 case PTYPE_SPECIFIC
:
1396 t
= resolve_specific_s (c
);
1400 t
= resolve_unknown_s (c
);
1404 gfc_internal_error ("resolve_subroutine(): bad function type");
1408 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
1412 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1413 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1414 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1415 if their shapes do not match. If either op1->shape or op2->shape is
1416 NULL, return SUCCESS. */
1419 compare_shapes (gfc_expr
* op1
, gfc_expr
* op2
)
1426 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
1428 for (i
= 0; i
< op1
->rank
; i
++)
1430 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
1432 gfc_error ("Shapes for operands at %L and %L are not conformable",
1433 &op1
->where
, &op2
->where
);
1443 /* Resolve an operator expression node. This can involve replacing the
1444 operation with a user defined function call. */
1447 resolve_operator (gfc_expr
* e
)
1449 gfc_expr
*op1
, *op2
;
1453 /* Resolve all subnodes-- give them types. */
1455 switch (e
->value
.op
.operator)
1458 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
1461 /* Fall through... */
1464 case INTRINSIC_UPLUS
:
1465 case INTRINSIC_UMINUS
:
1466 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
1471 /* Typecheck the new node. */
1473 op1
= e
->value
.op
.op1
;
1474 op2
= e
->value
.op
.op2
;
1476 switch (e
->value
.op
.operator)
1478 case INTRINSIC_UPLUS
:
1479 case INTRINSIC_UMINUS
:
1480 if (op1
->ts
.type
== BT_INTEGER
1481 || op1
->ts
.type
== BT_REAL
1482 || op1
->ts
.type
== BT_COMPLEX
)
1488 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
1489 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
1492 case INTRINSIC_PLUS
:
1493 case INTRINSIC_MINUS
:
1494 case INTRINSIC_TIMES
:
1495 case INTRINSIC_DIVIDE
:
1496 case INTRINSIC_POWER
:
1497 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1499 gfc_type_convert_binary (e
);
1504 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1505 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1506 gfc_typename (&op2
->ts
));
1509 case INTRINSIC_CONCAT
:
1510 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1512 e
->ts
.type
= BT_CHARACTER
;
1513 e
->ts
.kind
= op1
->ts
.kind
;
1518 _("Operands of string concatenation operator at %%L are %s/%s"),
1519 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
1525 case INTRINSIC_NEQV
:
1526 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
1528 e
->ts
.type
= BT_LOGICAL
;
1529 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
1530 if (op1
->ts
.kind
< e
->ts
.kind
)
1531 gfc_convert_type (op1
, &e
->ts
, 2);
1532 else if (op2
->ts
.kind
< e
->ts
.kind
)
1533 gfc_convert_type (op2
, &e
->ts
, 2);
1537 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
1538 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1539 gfc_typename (&op2
->ts
));
1544 if (op1
->ts
.type
== BT_LOGICAL
)
1546 e
->ts
.type
= BT_LOGICAL
;
1547 e
->ts
.kind
= op1
->ts
.kind
;
1551 sprintf (msg
, _("Operand of .NOT. operator at %%L is %s"),
1552 gfc_typename (&op1
->ts
));
1559 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1561 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
1565 /* Fall through... */
1569 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1571 e
->ts
.type
= BT_LOGICAL
;
1572 e
->ts
.kind
= gfc_default_logical_kind
;
1576 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1578 gfc_type_convert_binary (e
);
1580 e
->ts
.type
= BT_LOGICAL
;
1581 e
->ts
.kind
= gfc_default_logical_kind
;
1585 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
1587 _("Logicals at %%L must be compared with %s instead of %s"),
1588 e
->value
.op
.operator == INTRINSIC_EQ
? ".EQV." : ".NEQV.",
1589 gfc_op2string (e
->value
.op
.operator));
1592 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1593 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1594 gfc_typename (&op2
->ts
));
1598 case INTRINSIC_USER
:
1600 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
1601 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
1603 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
1604 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
1605 gfc_typename (&op2
->ts
));
1610 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1613 /* Deal with arrayness of an operand through an operator. */
1617 switch (e
->value
.op
.operator)
1619 case INTRINSIC_PLUS
:
1620 case INTRINSIC_MINUS
:
1621 case INTRINSIC_TIMES
:
1622 case INTRINSIC_DIVIDE
:
1623 case INTRINSIC_POWER
:
1624 case INTRINSIC_CONCAT
:
1628 case INTRINSIC_NEQV
:
1636 if (op1
->rank
== 0 && op2
->rank
== 0)
1639 if (op1
->rank
== 0 && op2
->rank
!= 0)
1641 e
->rank
= op2
->rank
;
1643 if (e
->shape
== NULL
)
1644 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1647 if (op1
->rank
!= 0 && op2
->rank
== 0)
1649 e
->rank
= op1
->rank
;
1651 if (e
->shape
== NULL
)
1652 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1655 if (op1
->rank
!= 0 && op2
->rank
!= 0)
1657 if (op1
->rank
== op2
->rank
)
1659 e
->rank
= op1
->rank
;
1660 if (e
->shape
== NULL
)
1662 t
= compare_shapes(op1
, op2
);
1666 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1671 gfc_error ("Inconsistent ranks for operator at %L and %L",
1672 &op1
->where
, &op2
->where
);
1675 /* Allow higher level expressions to work. */
1683 case INTRINSIC_UPLUS
:
1684 case INTRINSIC_UMINUS
:
1685 e
->rank
= op1
->rank
;
1687 if (e
->shape
== NULL
)
1688 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1690 /* Simply copy arrayness attribute */
1697 /* Attempt to simplify the expression. */
1699 t
= gfc_simplify_expr (e
, 0);
1704 if (gfc_extend_expr (e
) == SUCCESS
)
1707 gfc_error (msg
, &e
->where
);
1713 /************** Array resolution subroutines **************/
1717 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
1720 /* Compare two integer expressions. */
1723 compare_bound (gfc_expr
* a
, gfc_expr
* b
)
1727 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
1728 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
1731 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
1732 gfc_internal_error ("compare_bound(): Bad expression");
1734 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
1744 /* Compare an integer expression with an integer. */
1747 compare_bound_int (gfc_expr
* a
, int b
)
1751 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
1754 if (a
->ts
.type
!= BT_INTEGER
)
1755 gfc_internal_error ("compare_bound_int(): Bad expression");
1757 i
= mpz_cmp_si (a
->value
.integer
, b
);
1767 /* Compare a single dimension of an array reference to the array
1771 check_dimension (int i
, gfc_array_ref
* ar
, gfc_array_spec
* as
)
1774 /* Given start, end and stride values, calculate the minimum and
1775 maximum referenced indexes. */
1783 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1785 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1791 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
1793 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
1797 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
1799 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
1802 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1803 it is legal (see 6.2.2.3.1). */
1808 gfc_internal_error ("check_dimension(): Bad array reference");
1814 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
1819 /* Compare an array reference with an array specification. */
1822 compare_spec_to_ref (gfc_array_ref
* ar
)
1829 /* TODO: Full array sections are only allowed as actual parameters. */
1830 if (as
->type
== AS_ASSUMED_SIZE
1831 && (/*ar->type == AR_FULL
1832 ||*/ (ar
->type
== AR_SECTION
1833 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
1835 gfc_error ("Rightmost upper bound of assumed size array section"
1836 " not specified at %L", &ar
->where
);
1840 if (ar
->type
== AR_FULL
)
1843 if (as
->rank
!= ar
->dimen
)
1845 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1846 &ar
->where
, ar
->dimen
, as
->rank
);
1850 for (i
= 0; i
< as
->rank
; i
++)
1851 if (check_dimension (i
, ar
, as
) == FAILURE
)
1858 /* Resolve one part of an array index. */
1861 gfc_resolve_index (gfc_expr
* index
, int check_scalar
)
1868 if (gfc_resolve_expr (index
) == FAILURE
)
1871 if (check_scalar
&& index
->rank
!= 0)
1873 gfc_error ("Array index at %L must be scalar", &index
->where
);
1877 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
1879 gfc_error ("Array index at %L must be of INTEGER type",
1884 if (index
->ts
.type
== BT_REAL
)
1885 if (gfc_notify_std (GFC_STD_GNU
, "Extension: REAL array index at %L",
1886 &index
->where
) == FAILURE
)
1889 if (index
->ts
.kind
!= gfc_index_integer_kind
1890 || index
->ts
.type
!= BT_INTEGER
)
1892 ts
.type
= BT_INTEGER
;
1893 ts
.kind
= gfc_index_integer_kind
;
1895 gfc_convert_type_warn (index
, &ts
, 2, 0);
1901 /* Resolve a dim argument to an intrinsic function. */
1904 gfc_resolve_dim_arg (gfc_expr
*dim
)
1909 if (gfc_resolve_expr (dim
) == FAILURE
)
1914 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
1918 if (dim
->ts
.type
!= BT_INTEGER
)
1920 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
1923 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
1927 ts
.type
= BT_INTEGER
;
1928 ts
.kind
= gfc_index_integer_kind
;
1930 gfc_convert_type_warn (dim
, &ts
, 2, 0);
1936 /* Given an expression that contains array references, update those array
1937 references to point to the right array specifications. While this is
1938 filled in during matching, this information is difficult to save and load
1939 in a module, so we take care of it here.
1941 The idea here is that the original array reference comes from the
1942 base symbol. We traverse the list of reference structures, setting
1943 the stored reference to references. Component references can
1944 provide an additional array specification. */
1947 find_array_spec (gfc_expr
* e
)
1953 as
= e
->symtree
->n
.sym
->as
;
1955 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1960 gfc_internal_error ("find_array_spec(): Missing spec");
1967 for (c
= e
->symtree
->n
.sym
->ts
.derived
->components
; c
; c
= c
->next
)
1968 if (c
== ref
->u
.c
.component
)
1972 gfc_internal_error ("find_array_spec(): Component not found");
1977 gfc_internal_error ("find_array_spec(): unused as(1)");
1988 gfc_internal_error ("find_array_spec(): unused as(2)");
1992 /* Resolve an array reference. */
1995 resolve_array_ref (gfc_array_ref
* ar
)
1997 int i
, check_scalar
;
1999 for (i
= 0; i
< ar
->dimen
; i
++)
2001 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
2003 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
2005 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
2007 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
2010 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
2011 switch (ar
->start
[i
]->rank
)
2014 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2018 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
2022 gfc_error ("Array index at %L is an array of rank %d",
2023 &ar
->c_where
[i
], ar
->start
[i
]->rank
);
2028 /* If the reference type is unknown, figure out what kind it is. */
2030 if (ar
->type
== AR_UNKNOWN
)
2032 ar
->type
= AR_ELEMENT
;
2033 for (i
= 0; i
< ar
->dimen
; i
++)
2034 if (ar
->dimen_type
[i
] == DIMEN_RANGE
2035 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2037 ar
->type
= AR_SECTION
;
2042 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
2050 resolve_substring (gfc_ref
* ref
)
2053 if (ref
->u
.ss
.start
!= NULL
)
2055 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
2058 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
2060 gfc_error ("Substring start index at %L must be of type INTEGER",
2061 &ref
->u
.ss
.start
->where
);
2065 if (ref
->u
.ss
.start
->rank
!= 0)
2067 gfc_error ("Substring start index at %L must be scalar",
2068 &ref
->u
.ss
.start
->where
);
2072 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
)
2074 gfc_error ("Substring start index at %L is less than one",
2075 &ref
->u
.ss
.start
->where
);
2080 if (ref
->u
.ss
.end
!= NULL
)
2082 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
2085 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
2087 gfc_error ("Substring end index at %L must be of type INTEGER",
2088 &ref
->u
.ss
.end
->where
);
2092 if (ref
->u
.ss
.end
->rank
!= 0)
2094 gfc_error ("Substring end index at %L must be scalar",
2095 &ref
->u
.ss
.end
->where
);
2099 if (ref
->u
.ss
.length
!= NULL
2100 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
)
2102 gfc_error ("Substring end index at %L is out of bounds",
2103 &ref
->u
.ss
.start
->where
);
2112 /* Resolve subtype references. */
2115 resolve_ref (gfc_expr
* expr
)
2117 int current_part_dimension
, n_components
, seen_part_dimension
;
2120 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2121 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
2123 find_array_spec (expr
);
2127 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2131 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
2139 resolve_substring (ref
);
2143 /* Check constraints on part references. */
2145 current_part_dimension
= 0;
2146 seen_part_dimension
= 0;
2149 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2154 switch (ref
->u
.ar
.type
)
2158 current_part_dimension
= 1;
2162 current_part_dimension
= 0;
2166 gfc_internal_error ("resolve_ref(): Bad array reference");
2172 if ((current_part_dimension
|| seen_part_dimension
)
2173 && ref
->u
.c
.component
->pointer
)
2176 ("Component to the right of a part reference with nonzero "
2177 "rank must not have the POINTER attribute at %L",
2189 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
2190 || ref
->next
== NULL
)
2191 && current_part_dimension
2192 && seen_part_dimension
)
2195 gfc_error ("Two or more part references with nonzero rank must "
2196 "not be specified at %L", &expr
->where
);
2200 if (ref
->type
== REF_COMPONENT
)
2202 if (current_part_dimension
)
2203 seen_part_dimension
= 1;
2205 /* reset to make sure */
2206 current_part_dimension
= 0;
2214 /* Given an expression, determine its shape. This is easier than it sounds.
2215 Leaves the shape array NULL if it is not possible to determine the shape. */
2218 expression_shape (gfc_expr
* e
)
2220 mpz_t array
[GFC_MAX_DIMENSIONS
];
2223 if (e
->rank
== 0 || e
->shape
!= NULL
)
2226 for (i
= 0; i
< e
->rank
; i
++)
2227 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2230 e
->shape
= gfc_get_shape (e
->rank
);
2232 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
2237 for (i
--; i
>= 0; i
--)
2238 mpz_clear (array
[i
]);
2242 /* Given a variable expression node, compute the rank of the expression by
2243 examining the base symbol and any reference structures it may have. */
2246 expression_rank (gfc_expr
* e
)
2253 if (e
->expr_type
== EXPR_ARRAY
)
2255 /* Constructors can have a rank different from one via RESHAPE(). */
2257 if (e
->symtree
== NULL
)
2263 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
2264 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
2270 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2272 if (ref
->type
!= REF_ARRAY
)
2275 if (ref
->u
.ar
.type
== AR_FULL
)
2277 rank
= ref
->u
.ar
.as
->rank
;
2281 if (ref
->u
.ar
.type
== AR_SECTION
)
2283 /* Figure out the rank of the section. */
2285 gfc_internal_error ("expression_rank(): Two array specs");
2287 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2288 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
2289 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2299 expression_shape (e
);
2303 /* Resolve a variable expression. */
2306 resolve_variable (gfc_expr
* e
)
2310 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
2313 if (e
->symtree
== NULL
)
2316 sym
= e
->symtree
->n
.sym
;
2317 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2319 e
->ts
.type
= BT_PROCEDURE
;
2323 if (sym
->ts
.type
!= BT_UNKNOWN
)
2324 gfc_variable_attr (e
, &e
->ts
);
2327 /* Must be a simple variable reference. */
2328 if (gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2337 /* Resolve an expression. That is, make sure that types of operands agree
2338 with their operators, intrinsic operators are converted to function calls
2339 for overloaded types and unresolved function references are resolved. */
2342 gfc_resolve_expr (gfc_expr
* e
)
2349 switch (e
->expr_type
)
2352 t
= resolve_operator (e
);
2356 t
= resolve_function (e
);
2360 t
= resolve_variable (e
);
2362 expression_rank (e
);
2365 case EXPR_SUBSTRING
:
2366 t
= resolve_ref (e
);
2376 if (resolve_ref (e
) == FAILURE
)
2379 t
= gfc_resolve_array_constructor (e
);
2380 /* Also try to expand a constructor. */
2383 expression_rank (e
);
2384 gfc_expand_constructor (e
);
2389 case EXPR_STRUCTURE
:
2390 t
= resolve_ref (e
);
2394 t
= resolve_structure_cons (e
);
2398 t
= gfc_simplify_expr (e
, 0);
2402 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2409 /* Resolve an expression from an iterator. They must be scalar and have
2410 INTEGER or (optionally) REAL type. */
2413 gfc_resolve_iterator_expr (gfc_expr
* expr
, bool real_ok
,
2414 const char * name_msgid
)
2416 if (gfc_resolve_expr (expr
) == FAILURE
)
2419 if (expr
->rank
!= 0)
2421 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
2425 if (!(expr
->ts
.type
== BT_INTEGER
2426 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
2429 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid
),
2432 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
2439 /* Resolve the expressions in an iterator structure. If REAL_OK is
2440 false allow only INTEGER type iterators, otherwise allow REAL types. */
2443 gfc_resolve_iterator (gfc_iterator
* iter
, bool real_ok
)
2446 if (iter
->var
->ts
.type
== BT_REAL
)
2447 gfc_notify_std (GFC_STD_F95_DEL
,
2448 "Obsolete: REAL DO loop iterator at %L",
2451 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
2455 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
2457 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2462 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
2463 "Start expression in DO loop") == FAILURE
)
2466 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
2467 "End expression in DO loop") == FAILURE
)
2470 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
2471 "Step expression in DO loop") == FAILURE
)
2474 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
2476 if ((iter
->step
->ts
.type
== BT_INTEGER
2477 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
2478 || (iter
->step
->ts
.type
== BT_REAL
2479 && mpfr_sgn (iter
->step
->value
.real
) == 0))
2481 gfc_error ("Step expression in DO loop at %L cannot be zero",
2482 &iter
->step
->where
);
2487 /* Convert start, end, and step to the same type as var. */
2488 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
2489 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
2490 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2492 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
2493 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
2494 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2496 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
2497 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
2498 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
2504 /* Resolve a list of FORALL iterators. */
2507 resolve_forall_iterators (gfc_forall_iterator
* iter
)
2512 if (gfc_resolve_expr (iter
->var
) == SUCCESS
2513 && iter
->var
->ts
.type
!= BT_INTEGER
)
2514 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2517 if (gfc_resolve_expr (iter
->start
) == SUCCESS
2518 && iter
->start
->ts
.type
!= BT_INTEGER
)
2519 gfc_error ("FORALL start expression at %L must be INTEGER",
2520 &iter
->start
->where
);
2521 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
2522 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2524 if (gfc_resolve_expr (iter
->end
) == SUCCESS
2525 && iter
->end
->ts
.type
!= BT_INTEGER
)
2526 gfc_error ("FORALL end expression at %L must be INTEGER",
2528 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
2529 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2531 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
2532 && iter
->stride
->ts
.type
!= BT_INTEGER
)
2533 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2534 &iter
->stride
->where
);
2535 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
2536 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
2543 /* Given a pointer to a symbol that is a derived type, see if any components
2544 have the POINTER attribute. The search is recursive if necessary.
2545 Returns zero if no pointer components are found, nonzero otherwise. */
2548 derived_pointer (gfc_symbol
* sym
)
2552 for (c
= sym
->components
; c
; c
= c
->next
)
2557 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
2565 /* Given a pointer to a symbol that is a derived type, see if it's
2566 inaccessible, i.e. if it's defined in another module and the components are
2567 PRIVATE. The search is recursive if necessary. Returns zero if no
2568 inaccessible components are found, nonzero otherwise. */
2571 derived_inaccessible (gfc_symbol
*sym
)
2575 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
2578 for (c
= sym
->components
; c
; c
= c
->next
)
2580 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
2588 /* Resolve the argument of a deallocate expression. The expression must be
2589 a pointer or a full array. */
2592 resolve_deallocate_expr (gfc_expr
* e
)
2594 symbol_attribute attr
;
2598 if (gfc_resolve_expr (e
) == FAILURE
)
2601 attr
= gfc_expr_attr (e
);
2605 if (e
->expr_type
!= EXPR_VARIABLE
)
2608 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2609 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2613 if (ref
->u
.ar
.type
!= AR_FULL
)
2618 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2619 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2627 if (allocatable
== 0)
2630 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2631 "ALLOCATABLE or a POINTER", &e
->where
);
2638 /* Given the expression node e for an allocatable/pointer of derived type to be
2639 allocated, get the expression node to be initialized afterwards (needed for
2640 derived types with default initializers). */
2643 expr_to_initialize (gfc_expr
* e
)
2649 result
= gfc_copy_expr (e
);
2651 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
2652 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
2653 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
2655 ref
->u
.ar
.type
= AR_FULL
;
2657 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2658 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
2660 result
->rank
= ref
->u
.ar
.dimen
;
2668 /* Resolve the expression in an ALLOCATE statement, doing the additional
2669 checks to see whether the expression is OK or not. The expression must
2670 have a trailing array reference that gives the size of the array. */
2673 resolve_allocate_expr (gfc_expr
* e
, gfc_code
* code
)
2675 int i
, pointer
, allocatable
, dimension
;
2676 symbol_attribute attr
;
2677 gfc_ref
*ref
, *ref2
;
2682 if (gfc_resolve_expr (e
) == FAILURE
)
2685 /* Make sure the expression is allocatable or a pointer. If it is
2686 pointer, the next-to-last reference must be a pointer. */
2690 if (e
->expr_type
!= EXPR_VARIABLE
)
2694 attr
= gfc_expr_attr (e
);
2695 pointer
= attr
.pointer
;
2696 dimension
= attr
.dimension
;
2701 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2702 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
2703 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
2705 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
2709 if (ref
->next
!= NULL
)
2714 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2715 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2717 pointer
= ref
->u
.c
.component
->pointer
;
2718 dimension
= ref
->u
.c
.component
->dimension
;
2728 if (allocatable
== 0 && pointer
== 0)
2730 gfc_error ("Expression in ALLOCATE statement at %L must be "
2731 "ALLOCATABLE or a POINTER", &e
->where
);
2735 /* Add default initializer for those derived types that need them. */
2736 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
2738 init_st
= gfc_get_code ();
2739 init_st
->loc
= code
->loc
;
2740 init_st
->op
= EXEC_ASSIGN
;
2741 init_st
->expr
= expr_to_initialize (e
);
2742 init_st
->expr2
= init_e
;
2744 init_st
->next
= code
->next
;
2745 code
->next
= init_st
;
2748 if (pointer
&& dimension
== 0)
2751 /* Make sure the next-to-last reference node is an array specification. */
2753 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
2755 gfc_error ("Array specification required in ALLOCATE statement "
2756 "at %L", &e
->where
);
2760 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
2763 /* Make sure that the array section reference makes sense in the
2764 context of an ALLOCATE specification. */
2768 for (i
= 0; i
< ar
->dimen
; i
++)
2769 switch (ar
->dimen_type
[i
])
2775 if (ar
->start
[i
] != NULL
2776 && ar
->end
[i
] != NULL
2777 && ar
->stride
[i
] == NULL
)
2780 /* Fall Through... */
2784 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2793 /************ SELECT CASE resolution subroutines ************/
2795 /* Callback function for our mergesort variant. Determines interval
2796 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2797 op1 > op2. Assumes we're not dealing with the default case.
2798 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2799 There are nine situations to check. */
2802 compare_cases (const gfc_case
* op1
, const gfc_case
* op2
)
2806 if (op1
->low
== NULL
) /* op1 = (:L) */
2808 /* op2 = (:N), so overlap. */
2810 /* op2 = (M:) or (M:N), L < M */
2811 if (op2
->low
!= NULL
2812 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2815 else if (op1
->high
== NULL
) /* op1 = (K:) */
2817 /* op2 = (M:), so overlap. */
2819 /* op2 = (:N) or (M:N), K > N */
2820 if (op2
->high
!= NULL
2821 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2824 else /* op1 = (K:L) */
2826 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
2827 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
2828 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
2829 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
2830 else /* op2 = (M:N) */
2834 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
2837 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
2846 /* Merge-sort a double linked case list, detecting overlap in the
2847 process. LIST is the head of the double linked case list before it
2848 is sorted. Returns the head of the sorted list if we don't see any
2849 overlap, or NULL otherwise. */
2852 check_case_overlap (gfc_case
* list
)
2854 gfc_case
*p
, *q
, *e
, *tail
;
2855 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
2857 /* If the passed list was empty, return immediately. */
2864 /* Loop unconditionally. The only exit from this loop is a return
2865 statement, when we've finished sorting the case list. */
2872 /* Count the number of merges we do in this pass. */
2875 /* Loop while there exists a merge to be done. */
2880 /* Count this merge. */
2883 /* Cut the list in two pieces by stepping INSIZE places
2884 forward in the list, starting from P. */
2887 for (i
= 0; i
< insize
; i
++)
2896 /* Now we have two lists. Merge them! */
2897 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
2900 /* See from which the next case to merge comes from. */
2903 /* P is empty so the next case must come from Q. */
2908 else if (qsize
== 0 || q
== NULL
)
2917 cmp
= compare_cases (p
, q
);
2920 /* The whole case range for P is less than the
2928 /* The whole case range for Q is greater than
2929 the case range for P. */
2936 /* The cases overlap, or they are the same
2937 element in the list. Either way, we must
2938 issue an error and get the next case from P. */
2939 /* FIXME: Sort P and Q by line number. */
2940 gfc_error ("CASE label at %L overlaps with CASE "
2941 "label at %L", &p
->where
, &q
->where
);
2949 /* Add the next element to the merged list. */
2958 /* P has now stepped INSIZE places along, and so has Q. So
2959 they're the same. */
2964 /* If we have done only one merge or none at all, we've
2965 finished sorting the cases. */
2974 /* Otherwise repeat, merging lists twice the size. */
2980 /* Check to see if an expression is suitable for use in a CASE statement.
2981 Makes sure that all case expressions are scalar constants of the same
2982 type. Return FAILURE if anything is wrong. */
2985 validate_case_label_expr (gfc_expr
* e
, gfc_expr
* case_expr
)
2987 if (e
== NULL
) return SUCCESS
;
2989 if (e
->ts
.type
!= case_expr
->ts
.type
)
2991 gfc_error ("Expression in CASE statement at %L must be of type %s",
2992 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
2996 /* C805 (R808) For a given case-construct, each case-value shall be of
2997 the same type as case-expr. For character type, length differences
2998 are allowed, but the kind type parameters shall be the same. */
3000 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
3002 gfc_error("Expression in CASE statement at %L must be kind %d",
3003 &e
->where
, case_expr
->ts
.kind
);
3007 /* Convert the case value kind to that of case expression kind, if needed.
3008 FIXME: Should a warning be issued? */
3009 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
3010 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
3014 gfc_error ("Expression in CASE statement at %L must be scalar",
3023 /* Given a completely parsed select statement, we:
3025 - Validate all expressions and code within the SELECT.
3026 - Make sure that the selection expression is not of the wrong type.
3027 - Make sure that no case ranges overlap.
3028 - Eliminate unreachable cases and unreachable code resulting from
3029 removing case labels.
3031 The standard does allow unreachable cases, e.g. CASE (5:3). But
3032 they are a hassle for code generation, and to prevent that, we just
3033 cut them out here. This is not necessary for overlapping cases
3034 because they are illegal and we never even try to generate code.
3036 We have the additional caveat that a SELECT construct could have
3037 been a computed GOTO in the source code. Fortunately we can fairly
3038 easily work around that here: The case_expr for a "real" SELECT CASE
3039 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3040 we have to do is make sure that the case_expr is a scalar integer
3044 resolve_select (gfc_code
* code
)
3047 gfc_expr
*case_expr
;
3048 gfc_case
*cp
, *default_case
, *tail
, *head
;
3049 int seen_unreachable
;
3054 if (code
->expr
== NULL
)
3056 /* This was actually a computed GOTO statement. */
3057 case_expr
= code
->expr2
;
3058 if (case_expr
->ts
.type
!= BT_INTEGER
3059 || case_expr
->rank
!= 0)
3060 gfc_error ("Selection expression in computed GOTO statement "
3061 "at %L must be a scalar integer expression",
3064 /* Further checking is not necessary because this SELECT was built
3065 by the compiler, so it should always be OK. Just move the
3066 case_expr from expr2 to expr so that we can handle computed
3067 GOTOs as normal SELECTs from here on. */
3068 code
->expr
= code
->expr2
;
3073 case_expr
= code
->expr
;
3075 type
= case_expr
->ts
.type
;
3076 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
3078 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3079 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
3081 /* Punt. Going on here just produce more garbage error messages. */
3085 if (case_expr
->rank
!= 0)
3087 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3088 "expression", &case_expr
->where
);
3094 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3095 of the SELECT CASE expression and its CASE values. Walk the lists
3096 of case values, and if we find a mismatch, promote case_expr to
3097 the appropriate kind. */
3099 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
3101 for (body
= code
->block
; body
; body
= body
->block
)
3103 /* Walk the case label list. */
3104 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
3106 /* Intercept the DEFAULT case. It does not have a kind. */
3107 if (cp
->low
== NULL
&& cp
->high
== NULL
)
3110 /* Unreachable case ranges are discarded, so ignore. */
3111 if (cp
->low
!= NULL
&& cp
->high
!= NULL
3112 && cp
->low
!= cp
->high
3113 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
3116 /* FIXME: Should a warning be issued? */
3118 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
3119 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
3121 if (cp
->high
!= NULL
3122 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
3123 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
3128 /* Assume there is no DEFAULT case. */
3129 default_case
= NULL
;
3133 for (body
= code
->block
; body
; body
= body
->block
)
3135 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3137 seen_unreachable
= 0;
3139 /* Walk the case label list, making sure that all case labels
3141 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
3143 /* Count the number of cases in the whole construct. */
3146 /* Intercept the DEFAULT case. */
3147 if (cp
->low
== NULL
&& cp
->high
== NULL
)
3149 if (default_case
!= NULL
)
3151 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3152 "by a second DEFAULT CASE at %L",
3153 &default_case
->where
, &cp
->where
);
3164 /* Deal with single value cases and case ranges. Errors are
3165 issued from the validation function. */
3166 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
3167 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
3173 if (type
== BT_LOGICAL
3174 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
3175 || cp
->low
!= cp
->high
))
3178 ("Logical range in CASE statement at %L is not allowed",
3184 if (cp
->low
!= NULL
&& cp
->high
!= NULL
3185 && cp
->low
!= cp
->high
3186 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
3188 if (gfc_option
.warn_surprising
)
3189 gfc_warning ("Range specification at %L can never "
3190 "be matched", &cp
->where
);
3192 cp
->unreachable
= 1;
3193 seen_unreachable
= 1;
3197 /* If the case range can be matched, it can also overlap with
3198 other cases. To make sure it does not, we put it in a
3199 double linked list here. We sort that with a merge sort
3200 later on to detect any overlapping cases. */
3204 head
->right
= head
->left
= NULL
;
3209 tail
->right
->left
= tail
;
3216 /* It there was a failure in the previous case label, give up
3217 for this case label list. Continue with the next block. */
3221 /* See if any case labels that are unreachable have been seen.
3222 If so, we eliminate them. This is a bit of a kludge because
3223 the case lists for a single case statement (label) is a
3224 single forward linked lists. */
3225 if (seen_unreachable
)
3227 /* Advance until the first case in the list is reachable. */
3228 while (body
->ext
.case_list
!= NULL
3229 && body
->ext
.case_list
->unreachable
)
3231 gfc_case
*n
= body
->ext
.case_list
;
3232 body
->ext
.case_list
= body
->ext
.case_list
->next
;
3234 gfc_free_case_list (n
);
3237 /* Strip all other unreachable cases. */
3238 if (body
->ext
.case_list
)
3240 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
3242 if (cp
->next
->unreachable
)
3244 gfc_case
*n
= cp
->next
;
3245 cp
->next
= cp
->next
->next
;
3247 gfc_free_case_list (n
);
3254 /* See if there were overlapping cases. If the check returns NULL,
3255 there was overlap. In that case we don't do anything. If head
3256 is non-NULL, we prepend the DEFAULT case. The sorted list can
3257 then used during code generation for SELECT CASE constructs with
3258 a case expression of a CHARACTER type. */
3261 head
= check_case_overlap (head
);
3263 /* Prepend the default_case if it is there. */
3264 if (head
!= NULL
&& default_case
)
3266 default_case
->left
= NULL
;
3267 default_case
->right
= head
;
3268 head
->left
= default_case
;
3272 /* Eliminate dead blocks that may be the result if we've seen
3273 unreachable case labels for a block. */
3274 for (body
= code
; body
&& body
->block
; body
= body
->block
)
3276 if (body
->block
->ext
.case_list
== NULL
)
3278 /* Cut the unreachable block from the code chain. */
3279 gfc_code
*c
= body
->block
;
3280 body
->block
= c
->block
;
3282 /* Kill the dead block, but not the blocks below it. */
3284 gfc_free_statements (c
);
3288 /* More than two cases is legal but insane for logical selects.
3289 Issue a warning for it. */
3290 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
3292 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3297 /* Resolve a transfer statement. This is making sure that:
3298 -- a derived type being transferred has only non-pointer components
3299 -- a derived type being transferred doesn't have private components, unless
3300 it's being transferred from the module where the type was defined
3301 -- we're not trying to transfer a whole assumed size array. */
3304 resolve_transfer (gfc_code
* code
)
3313 if (exp
->expr_type
!= EXPR_VARIABLE
)
3316 sym
= exp
->symtree
->n
.sym
;
3319 /* Go to actual component transferred. */
3320 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
3321 if (ref
->type
== REF_COMPONENT
)
3322 ts
= &ref
->u
.c
.component
->ts
;
3324 if (ts
->type
== BT_DERIVED
)
3326 /* Check that transferred derived type doesn't contain POINTER
3328 if (derived_pointer (ts
->derived
))
3330 gfc_error ("Data transfer element at %L cannot have "
3331 "POINTER components", &code
->loc
);
3335 if (derived_inaccessible (ts
->derived
))
3337 gfc_error ("Data transfer element at %L cannot have "
3338 "PRIVATE components",&code
->loc
);
3343 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
3344 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
3346 gfc_error ("Data transfer element at %L cannot be a full reference to "
3347 "an assumed-size array", &code
->loc
);
3353 /*********** Toplevel code resolution subroutines ***********/
3355 /* Given a branch to a label and a namespace, if the branch is conforming.
3356 The code node described where the branch is located. */
3359 resolve_branch (gfc_st_label
* label
, gfc_code
* code
)
3361 gfc_code
*block
, *found
;
3369 /* Step one: is this a valid branching target? */
3371 if (lp
->defined
== ST_LABEL_UNKNOWN
)
3373 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
3378 if (lp
->defined
!= ST_LABEL_TARGET
)
3380 gfc_error ("Statement at %L is not a valid branch target statement "
3381 "for the branch statement at %L", &lp
->where
, &code
->loc
);
3385 /* Step two: make sure this branch is not a branch to itself ;-) */
3387 if (code
->here
== label
)
3389 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
3393 /* Step three: Try to find the label in the parse tree. To do this,
3394 we traverse the tree block-by-block: first the block that
3395 contains this GOTO, then the block that it is nested in, etc. We
3396 can ignore other blocks because branching into another block is
3401 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3403 for (block
= stack
->head
; block
; block
= block
->next
)
3405 if (block
->here
== label
)
3418 /* still nothing, so illegal. */
3419 gfc_error_now ("Label at %L is not in the same block as the "
3420 "GOTO statement at %L", &lp
->where
, &code
->loc
);
3424 /* Step four: Make sure that the branching target is legal if
3425 the statement is an END {SELECT,DO,IF}. */
3427 if (found
->op
== EXEC_NOP
)
3429 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3430 if (stack
->current
->next
== found
)
3434 gfc_notify_std (GFC_STD_F95_DEL
,
3435 "Obsolete: GOTO at %L jumps to END of construct at %L",
3436 &code
->loc
, &found
->loc
);
3441 /* Check whether EXPR1 has the same shape as EXPR2. */
3444 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
3446 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3447 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
3448 try result
= FAILURE
;
3451 /* Compare the rank. */
3452 if (expr1
->rank
!= expr2
->rank
)
3455 /* Compare the size of each dimension. */
3456 for (i
=0; i
<expr1
->rank
; i
++)
3458 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
3461 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
3464 if (mpz_cmp (shape
[i
], shape2
[i
]))
3468 /* When either of the two expression is an assumed size array, we
3469 ignore the comparison of dimension sizes. */
3474 for (i
--; i
>=0; i
--)
3476 mpz_clear (shape
[i
]);
3477 mpz_clear (shape2
[i
]);
3483 /* Check whether a WHERE assignment target or a WHERE mask expression
3484 has the same shape as the outmost WHERE mask expression. */
3487 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
3493 cblock
= code
->block
;
3495 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3496 In case of nested WHERE, only the outmost one is stored. */
3497 if (mask
== NULL
) /* outmost WHERE */
3499 else /* inner WHERE */
3506 /* Check if the mask-expr has a consistent shape with the
3507 outmost WHERE mask-expr. */
3508 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
3509 gfc_error ("WHERE mask at %L has inconsistent shape",
3510 &cblock
->expr
->where
);
3513 /* the assignment statement of a WHERE statement, or the first
3514 statement in where-body-construct of a WHERE construct */
3515 cnext
= cblock
->next
;
3520 /* WHERE assignment statement */
3523 /* Check shape consistent for WHERE assignment target. */
3524 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
3525 gfc_error ("WHERE assignment target at %L has "
3526 "inconsistent shape", &cnext
->expr
->where
);
3529 /* WHERE or WHERE construct is part of a where-body-construct */
3531 resolve_where (cnext
, e
);
3535 gfc_error ("Unsupported statement inside WHERE at %L",
3538 /* the next statement within the same where-body-construct */
3539 cnext
= cnext
->next
;
3541 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3542 cblock
= cblock
->block
;
3547 /* Check whether the FORALL index appears in the expression or not. */
3550 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
3554 gfc_actual_arglist
*args
;
3557 switch (expr
->expr_type
)
3560 gcc_assert (expr
->symtree
->n
.sym
);
3562 /* A scalar assignment */
3565 if (expr
->symtree
->n
.sym
== symbol
)
3571 /* the expr is array ref, substring or struct component. */
3578 /* Check if the symbol appears in the array subscript. */
3580 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3583 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
3587 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
3591 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
3597 if (expr
->symtree
->n
.sym
== symbol
)
3600 /* Check if the symbol appears in the substring section. */
3601 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3603 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3611 gfc_error("expresion reference type error at %L", &expr
->where
);
3617 /* If the expression is a function call, then check if the symbol
3618 appears in the actual arglist of the function. */
3620 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3622 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
3627 /* It seems not to happen. */
3628 case EXPR_SUBSTRING
:
3632 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
3633 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3635 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3640 /* It seems not to happen. */
3641 case EXPR_STRUCTURE
:
3643 gfc_error ("Unsupported statement while finding forall index in "
3648 /* Find the FORALL index in the first operand. */
3649 if (expr
->value
.op
.op1
)
3651 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
3655 /* Find the FORALL index in the second operand. */
3656 if (expr
->value
.op
.op2
)
3658 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
3671 /* Resolve assignment in FORALL construct.
3672 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3673 FORALL index variables. */
3676 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3680 for (n
= 0; n
< nvar
; n
++)
3682 gfc_symbol
*forall_index
;
3684 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
3686 /* Check whether the assignment target is one of the FORALL index
3688 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
3689 && (code
->expr
->symtree
->n
.sym
== forall_index
))
3690 gfc_error ("Assignment to a FORALL index variable at %L",
3691 &code
->expr
->where
);
3694 /* If one of the FORALL index variables doesn't appear in the
3695 assignment target, then there will be a many-to-one
3697 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
3698 gfc_error ("The FORALL with index '%s' cause more than one "
3699 "assignment to this object at %L",
3700 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
3706 /* Resolve WHERE statement in FORALL construct. */
3709 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
){
3713 cblock
= code
->block
;
3716 /* the assignment statement of a WHERE statement, or the first
3717 statement in where-body-construct of a WHERE construct */
3718 cnext
= cblock
->next
;
3723 /* WHERE assignment statement */
3725 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
3728 /* WHERE or WHERE construct is part of a where-body-construct */
3730 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
3734 gfc_error ("Unsupported statement inside WHERE at %L",
3737 /* the next statement within the same where-body-construct */
3738 cnext
= cnext
->next
;
3740 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3741 cblock
= cblock
->block
;
3746 /* Traverse the FORALL body to check whether the following errors exist:
3747 1. For assignment, check if a many-to-one assignment happens.
3748 2. For WHERE statement, check the WHERE body to see if there is any
3749 many-to-one assignment. */
3752 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3756 c
= code
->block
->next
;
3762 case EXEC_POINTER_ASSIGN
:
3763 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
3766 /* Because the resolve_blocks() will handle the nested FORALL,
3767 there is no need to handle it here. */
3771 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
3776 /* The next statement in the FORALL body. */
3782 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3783 gfc_resolve_forall_body to resolve the FORALL body. */
3785 static void resolve_blocks (gfc_code
*, gfc_namespace
*);
3788 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
3790 static gfc_expr
**var_expr
;
3791 static int total_var
= 0;
3792 static int nvar
= 0;
3793 gfc_forall_iterator
*fa
;
3794 gfc_symbol
*forall_index
;
3798 /* Start to resolve a FORALL construct */
3799 if (forall_save
== 0)
3801 /* Count the total number of FORALL index in the nested FORALL
3802 construct in order to allocate the VAR_EXPR with proper size. */
3804 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
3806 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3808 next
= next
->block
->next
;
3811 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3812 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
3815 /* The information about FORALL iterator, including FORALL index start, end
3816 and stride. The FORALL index can not appear in start, end or stride. */
3817 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3819 /* Check if any outer FORALL index name is the same as the current
3821 for (i
= 0; i
< nvar
; i
++)
3823 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
3825 gfc_error ("An outer FORALL construct already has an index "
3826 "with this name %L", &fa
->var
->where
);
3830 /* Record the current FORALL index. */
3831 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
3833 forall_index
= fa
->var
->symtree
->n
.sym
;
3835 /* Check if the FORALL index appears in start, end or stride. */
3836 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
3837 gfc_error ("A FORALL index must not appear in a limit or stride "
3838 "expression in the same FORALL at %L", &fa
->start
->where
);
3839 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
3840 gfc_error ("A FORALL index must not appear in a limit or stride "
3841 "expression in the same FORALL at %L", &fa
->end
->where
);
3842 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
3843 gfc_error ("A FORALL index must not appear in a limit or stride "
3844 "expression in the same FORALL at %L", &fa
->stride
->where
);
3848 /* Resolve the FORALL body. */
3849 gfc_resolve_forall_body (code
, nvar
, var_expr
);
3851 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3852 resolve_blocks (code
->block
, ns
);
3854 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3855 for (i
= 0; i
< total_var
; i
++)
3856 gfc_free_expr (var_expr
[i
]);
3858 /* Reset the counters. */
3864 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3867 static void resolve_code (gfc_code
*, gfc_namespace
*);
3870 resolve_blocks (gfc_code
* b
, gfc_namespace
* ns
)
3874 for (; b
; b
= b
->block
)
3876 t
= gfc_resolve_expr (b
->expr
);
3877 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
3883 if (t
== SUCCESS
&& b
->expr
!= NULL
3884 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
3886 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3893 && (b
->expr
->ts
.type
!= BT_LOGICAL
3894 || b
->expr
->rank
== 0))
3896 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3901 resolve_branch (b
->label
, b
);
3914 gfc_internal_error ("resolve_block(): Bad block type");
3917 resolve_code (b
->next
, ns
);
3922 /* Given a block of code, recursively resolve everything pointed to by this
3926 resolve_code (gfc_code
* code
, gfc_namespace
* ns
)
3928 int forall_save
= 0;
3933 frame
.prev
= cs_base
;
3937 for (; code
; code
= code
->next
)
3939 frame
.current
= code
;
3941 if (code
->op
== EXEC_FORALL
)
3943 forall_save
= forall_flag
;
3945 gfc_resolve_forall (code
, ns
, forall_save
);
3948 resolve_blocks (code
->block
, ns
);
3950 if (code
->op
== EXEC_FORALL
)
3951 forall_flag
= forall_save
;
3953 t
= gfc_resolve_expr (code
->expr
);
3954 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
3970 resolve_where (code
, NULL
);
3974 if (code
->expr
!= NULL
)
3976 if (code
->expr
->ts
.type
!= BT_INTEGER
)
3977 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3978 "variable", &code
->expr
->where
);
3979 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
3980 gfc_error ("Variable '%s' has not been assigned a target label "
3981 "at %L", code
->expr
->symtree
->n
.sym
->name
,
3982 &code
->expr
->where
);
3985 resolve_branch (code
->label
, code
);
3989 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_INTEGER
)
3990 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3991 "return specifier", &code
->expr
->where
);
3998 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
4001 if (gfc_pure (NULL
))
4003 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
4006 ("Cannot assign to variable '%s' in PURE procedure at %L",
4007 code
->expr
->symtree
->n
.sym
->name
, &code
->expr
->where
);
4011 if (code
->expr2
->ts
.type
== BT_DERIVED
4012 && derived_pointer (code
->expr2
->ts
.derived
))
4015 ("Right side of assignment at %L is a derived type "
4016 "containing a POINTER in a PURE procedure",
4017 &code
->expr2
->where
);
4022 gfc_check_assign (code
->expr
, code
->expr2
, 1);
4025 case EXEC_LABEL_ASSIGN
:
4026 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
4027 gfc_error ("Label %d referenced at %L is never defined",
4028 code
->label
->value
, &code
->label
->where
);
4030 && (code
->expr
->expr_type
!= EXPR_VARIABLE
4031 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
4032 || code
->expr
->symtree
->n
.sym
->ts
.kind
4033 != gfc_default_integer_kind
4034 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
4035 gfc_error ("ASSIGN statement at %L requires a scalar "
4036 "default INTEGER variable", &code
->expr
->where
);
4039 case EXEC_POINTER_ASSIGN
:
4043 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
4046 case EXEC_ARITHMETIC_IF
:
4048 && code
->expr
->ts
.type
!= BT_INTEGER
4049 && code
->expr
->ts
.type
!= BT_REAL
)
4050 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4051 "expression", &code
->expr
->where
);
4053 resolve_branch (code
->label
, code
);
4054 resolve_branch (code
->label2
, code
);
4055 resolve_branch (code
->label3
, code
);
4059 if (t
== SUCCESS
&& code
->expr
!= NULL
4060 && (code
->expr
->ts
.type
!= BT_LOGICAL
4061 || code
->expr
->rank
!= 0))
4062 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4063 &code
->expr
->where
);
4068 resolve_call (code
);
4072 /* Select is complicated. Also, a SELECT construct could be
4073 a transformed computed GOTO. */
4074 resolve_select (code
);
4078 if (code
->ext
.iterator
!= NULL
)
4079 gfc_resolve_iterator (code
->ext
.iterator
, true);
4083 if (code
->expr
== NULL
)
4084 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4086 && (code
->expr
->rank
!= 0
4087 || code
->expr
->ts
.type
!= BT_LOGICAL
))
4088 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4089 "a scalar LOGICAL expression", &code
->expr
->where
);
4093 if (t
== SUCCESS
&& code
->expr
!= NULL
4094 && code
->expr
->ts
.type
!= BT_INTEGER
)
4095 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4096 "of type INTEGER", &code
->expr
->where
);
4098 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
4099 resolve_allocate_expr (a
->expr
, code
);
4103 case EXEC_DEALLOCATE
:
4104 if (t
== SUCCESS
&& code
->expr
!= NULL
4105 && code
->expr
->ts
.type
!= BT_INTEGER
)
4107 ("STAT tag in DEALLOCATE statement at %L must be of type "
4108 "INTEGER", &code
->expr
->where
);
4110 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
4111 resolve_deallocate_expr (a
->expr
);
4116 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
4119 resolve_branch (code
->ext
.open
->err
, code
);
4123 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
4126 resolve_branch (code
->ext
.close
->err
, code
);
4129 case EXEC_BACKSPACE
:
4133 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
4136 resolve_branch (code
->ext
.filepos
->err
, code
);
4140 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
4143 resolve_branch (code
->ext
.inquire
->err
, code
);
4147 gcc_assert (code
->ext
.inquire
!= NULL
);
4148 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
4151 resolve_branch (code
->ext
.inquire
->err
, code
);
4156 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
4159 resolve_branch (code
->ext
.dt
->err
, code
);
4160 resolve_branch (code
->ext
.dt
->end
, code
);
4161 resolve_branch (code
->ext
.dt
->eor
, code
);
4165 resolve_transfer (code
);
4169 resolve_forall_iterators (code
->ext
.forall_iterator
);
4171 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
4173 ("FORALL mask clause at %L requires a LOGICAL expression",
4174 &code
->expr
->where
);
4178 gfc_internal_error ("resolve_code(): Bad statement code");
4182 cs_base
= frame
.prev
;
4186 /* Resolve initial values and make sure they are compatible with
4190 resolve_values (gfc_symbol
* sym
)
4193 if (sym
->value
== NULL
)
4196 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
4199 gfc_check_assign_symbol (sym
, sym
->value
);
4203 /* Do anything necessary to resolve a symbol. Right now, we just
4204 assume that an otherwise unknown symbol is a variable. This sort
4205 of thing commonly happens for symbols in module. */
4208 resolve_symbol (gfc_symbol
* sym
)
4210 /* Zero if we are checking a formal namespace. */
4211 static int formal_ns_flag
= 1;
4212 int formal_ns_save
, check_constant
, mp_flag
;
4215 gfc_symtree
* symtree
;
4216 gfc_symtree
* this_symtree
;
4219 gfc_formal_arglist
* arg
;
4221 if (sym
->attr
.flavor
== FL_UNKNOWN
)
4224 /* If we find that a flavorless symbol is an interface in one of the
4225 parent namespaces, find its symtree in this namespace, free the
4226 symbol and set the symtree to point to the interface symbol. */
4227 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
4229 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
4230 if (symtree
&& symtree
->n
.sym
->generic
)
4232 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
4236 gfc_free_symbol (sym
);
4237 symtree
->n
.sym
->refs
++;
4238 this_symtree
->n
.sym
= symtree
->n
.sym
;
4243 /* Otherwise give it a flavor according to such attributes as
4245 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
4246 sym
->attr
.flavor
= FL_VARIABLE
;
4249 sym
->attr
.flavor
= FL_PROCEDURE
;
4250 if (sym
->attr
.dimension
)
4251 sym
->attr
.function
= 1;
4255 /* Symbols that are module procedures with results (functions) have
4256 the types and array specification copied for type checking in
4257 procedures that call them, as well as for saving to a module
4258 file. These symbols can't stand the scrutiny that their results
4260 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
4262 /* Assign default type to symbols that need one and don't have one. */
4263 if (sym
->ts
.type
== BT_UNKNOWN
)
4265 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
4266 gfc_set_default_type (sym
, 1, NULL
);
4268 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
4270 /* The specific case of an external procedure should emit an error
4271 in the case that there is no implicit type. */
4273 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
4276 /* Result may be in another namespace. */
4277 resolve_symbol (sym
->result
);
4279 sym
->ts
= sym
->result
->ts
;
4280 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
4281 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
4282 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
4287 /* Assumed size arrays and assumed shape arrays must be dummy
4291 && (sym
->as
->type
== AS_ASSUMED_SIZE
4292 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
4293 && sym
->attr
.dummy
== 0)
4295 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
4296 gfc_error ("Assumed size array at %L must be a dummy argument",
4299 gfc_error ("Assumed shape array at %L must be a dummy argument",
4304 /* A parameter array's shape needs to be constant. */
4306 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->as
!= NULL
4307 && !gfc_is_compile_time_shape (sym
->as
))
4309 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4310 "or assumed shape", sym
->name
, &sym
->declared_at
);
4314 /* A module array's shape needs to be constant. */
4316 if (sym
->ns
->proc_name
4317 && sym
->attr
.flavor
== FL_VARIABLE
4318 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
4319 && !sym
->attr
.use_assoc
4320 && !sym
->attr
.allocatable
4321 && !sym
->attr
.pointer
4323 && !gfc_is_compile_time_shape (sym
->as
))
4325 gfc_error ("Module array '%s' at %L cannot be automatic "
4326 "or assumed shape", sym
->name
, &sym
->declared_at
);
4330 /* Make sure that character string variables with assumed length are
4333 if (sym
->attr
.flavor
== FL_VARIABLE
&& !sym
->attr
.result
4334 && sym
->ts
.type
== BT_CHARACTER
4335 && sym
->ts
.cl
->length
== NULL
&& sym
->attr
.dummy
== 0)
4337 gfc_error ("Entity with assumed character length at %L must be a "
4338 "dummy argument or a PARAMETER", &sym
->declared_at
);
4342 /* Make sure a parameter that has been implicitly typed still
4343 matches the implicit type, since PARAMETER statements can precede
4344 IMPLICIT statements. */
4346 if (sym
->attr
.flavor
== FL_PARAMETER
4347 && sym
->attr
.implicit_type
4348 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
4349 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4350 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
4352 /* Make sure the types of derived parameters are consistent. This
4353 type checking is deferred until resolution because the type may
4354 refer to a derived type from the host. */
4356 if (sym
->attr
.flavor
== FL_PARAMETER
4357 && sym
->ts
.type
== BT_DERIVED
4358 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
4359 gfc_error ("Incompatible derived type in PARAMETER at %L",
4360 &sym
->value
->where
);
4362 /* Make sure symbols with known intent or optional are really dummy
4363 variable. Because of ENTRY statement, this has to be deferred
4364 until resolution time. */
4366 if (! sym
->attr
.dummy
4367 && (sym
->attr
.optional
4368 || sym
->attr
.intent
!= INTENT_UNKNOWN
))
4370 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
4374 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
4376 if (sym
->ts
.type
== BT_CHARACTER
)
4378 gfc_charlen
*cl
= sym
->ts
.cl
;
4379 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
4381 gfc_error ("Character-valued statement function '%s' at %L must "
4382 "have constant length", sym
->name
, &sym
->declared_at
);
4388 /* If a derived type symbol has reached this point, without its
4389 type being declared, we have an error. Notice that most
4390 conditions that produce undefined derived types have already
4391 been dealt with. However, the likes of:
4392 implicit type(t) (t) ..... call foo (t) will get us here if
4393 the type is not declared in the scope of the implicit
4394 statement. Change the type to BT_UNKNOWN, both because it is so
4395 and to prevent an ICE. */
4396 if (sym
->ts
.type
== BT_DERIVED
4397 && sym
->ts
.derived
->components
== NULL
)
4399 gfc_error ("The derived type '%s' at %L is of type '%s', "
4400 "which has not been defined.", sym
->name
,
4401 &sym
->declared_at
, sym
->ts
.derived
->name
);
4402 sym
->ts
.type
= BT_UNKNOWN
;
4406 /* If a component of a derived type is of a type declared to be private,
4407 either the derived type definition must contain the PRIVATE statement,
4408 or the derived type must be private. (4.4.1 just after R427) */
4409 if (sym
->attr
.flavor
== FL_DERIVED
4410 && sym
->component_access
!= ACCESS_PRIVATE
4411 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
4413 for (c
= sym
->components
; c
; c
= c
->next
)
4415 if (c
->ts
.type
== BT_DERIVED
4416 && !c
->ts
.derived
->attr
.use_assoc
4417 && !gfc_check_access(c
->ts
.derived
->attr
.access
,
4418 c
->ts
.derived
->ns
->default_access
))
4420 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4421 "a component of '%s', which is PUBLIC at %L",
4422 c
->name
, sym
->name
, &sym
->declared_at
);
4428 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
4429 default initialization is defined (5.1.2.4.4). */
4430 if (sym
->ts
.type
== BT_DERIVED
4432 && sym
->attr
.intent
== INTENT_OUT
4434 && sym
->as
->type
== AS_ASSUMED_SIZE
)
4436 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
4440 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
4441 "ASSUMED SIZE and so cannot have a default initializer",
4442 sym
->name
, &sym
->declared_at
);
4449 /* Ensure that derived type formal arguments of a public procedure
4450 are not of a private type. */
4451 if (sym
->attr
.flavor
== FL_PROCEDURE
4452 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
4454 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
4457 && arg
->sym
->ts
.type
== BT_DERIVED
4458 && !arg
->sym
->ts
.derived
->attr
.use_assoc
4459 && !gfc_check_access(arg
->sym
->ts
.derived
->attr
.access
,
4460 arg
->sym
->ts
.derived
->ns
->default_access
))
4462 gfc_error_now ("'%s' is a PRIVATE type and cannot be "
4463 "a dummy argument of '%s', which is PUBLIC at %L",
4464 arg
->sym
->name
, sym
->name
, &sym
->declared_at
);
4465 /* Stop this message from recurring. */
4466 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
4472 /* Constraints on deferred shape variable. */
4473 if (sym
->attr
.flavor
== FL_VARIABLE
4474 || (sym
->attr
.flavor
== FL_PROCEDURE
4475 && sym
->attr
.function
))
4477 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
4479 if (sym
->attr
.allocatable
)
4481 if (sym
->attr
.dimension
)
4482 gfc_error ("Allocatable array '%s' at %L must have "
4483 "a deferred shape", sym
->name
, &sym
->declared_at
);
4485 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4486 sym
->name
, &sym
->declared_at
);
4490 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
4492 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4493 sym
->name
, &sym
->declared_at
);
4500 if (!mp_flag
&& !sym
->attr
.allocatable
4501 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
4503 gfc_error ("Array '%s' at %L cannot have a deferred shape",
4504 sym
->name
, &sym
->declared_at
);
4510 switch (sym
->attr
.flavor
)
4513 /* Can the symbol have an initializer? */
4515 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
4516 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
4518 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
4520 /* Don't allow initialization of automatic arrays. */
4521 for (i
= 0; i
< sym
->as
->rank
; i
++)
4523 if (sym
->as
->lower
[i
] == NULL
4524 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4525 || sym
->as
->upper
[i
] == NULL
4526 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
4534 /* Reject illegal initializers. */
4535 if (sym
->value
&& flag
)
4537 if (sym
->attr
.allocatable
)
4538 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4539 sym
->name
, &sym
->declared_at
);
4540 else if (sym
->attr
.external
)
4541 gfc_error ("External '%s' at %L cannot have an initializer",
4542 sym
->name
, &sym
->declared_at
);
4543 else if (sym
->attr
.dummy
)
4544 gfc_error ("Dummy '%s' at %L cannot have an initializer",
4545 sym
->name
, &sym
->declared_at
);
4546 else if (sym
->attr
.intrinsic
)
4547 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4548 sym
->name
, &sym
->declared_at
);
4549 else if (sym
->attr
.result
)
4550 gfc_error ("Function result '%s' at %L cannot have an initializer",
4551 sym
->name
, &sym
->declared_at
);
4553 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4554 sym
->name
, &sym
->declared_at
);
4558 /* Assign default initializer. */
4559 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| flag
)
4560 && !sym
->attr
.pointer
)
4561 sym
->value
= gfc_default_initializer (&sym
->ts
);
4565 /* Reject PRIVATE objects in a PUBLIC namelist. */
4566 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
4568 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
4570 if (!nl
->sym
->attr
.use_assoc
4572 !(sym
->ns
->parent
== nl
->sym
->ns
)
4574 !gfc_check_access(nl
->sym
->attr
.access
,
4575 nl
->sym
->ns
->default_access
))
4576 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4577 "PUBLIC namelist at %L", nl
->sym
->name
,
4585 /* An external symbol falls through to here if it is not referenced. */
4586 if (sym
->attr
.external
&& sym
->value
)
4588 gfc_error ("External object '%s' at %L may not have an initializer",
4589 sym
->name
, &sym
->declared_at
);
4597 /* Make sure that intrinsic exist */
4598 if (sym
->attr
.intrinsic
4599 && ! gfc_intrinsic_name(sym
->name
, 0)
4600 && ! gfc_intrinsic_name(sym
->name
, 1))
4601 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
4603 /* Resolve array specifier. Check as well some constraints
4604 on COMMON blocks. */
4606 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
4607 gfc_resolve_array_spec (sym
->as
, check_constant
);
4609 /* Resolve formal namespaces. */
4611 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
4613 formal_ns_save
= formal_ns_flag
;
4615 gfc_resolve (sym
->formal_ns
);
4616 formal_ns_flag
= formal_ns_save
;
4622 /************* Resolve DATA statements *************/
4626 gfc_data_value
*vnode
;
4632 /* Advance the values structure to point to the next value in the data list. */
4635 next_data_value (void)
4637 while (values
.left
== 0)
4639 if (values
.vnode
->next
== NULL
)
4642 values
.vnode
= values
.vnode
->next
;
4643 values
.left
= values
.vnode
->repeat
;
4651 check_data_variable (gfc_data_variable
* var
, locus
* where
)
4657 ar_type mark
= AR_UNKNOWN
;
4659 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
4663 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
4667 mpz_init_set_si (offset
, 0);
4670 if (e
->expr_type
!= EXPR_VARIABLE
)
4671 gfc_internal_error ("check_data_variable(): Bad expression");
4675 mpz_init_set_ui (size
, 1);
4682 /* Find the array section reference. */
4683 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4685 if (ref
->type
!= REF_ARRAY
)
4687 if (ref
->u
.ar
.type
== AR_ELEMENT
)
4693 /* Set marks according to the reference pattern. */
4694 switch (ref
->u
.ar
.type
)
4702 /* Get the start position of array section. */
4703 gfc_get_section_index (ar
, section_index
, &offset
);
4711 if (gfc_array_size (e
, &size
) == FAILURE
)
4713 gfc_error ("Nonconstant array section at %L in DATA statement",
4722 while (mpz_cmp_ui (size
, 0) > 0)
4724 if (next_data_value () == FAILURE
)
4726 gfc_error ("DATA statement at %L has more variables than values",
4732 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
4736 /* If we have more than one element left in the repeat count,
4737 and we have more than one element left in the target variable,
4738 then create a range assignment. */
4739 /* ??? Only done for full arrays for now, since array sections
4741 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
4742 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
4746 if (mpz_cmp_ui (size
, values
.left
) >= 0)
4748 mpz_init_set_ui (range
, values
.left
);
4749 mpz_sub_ui (size
, size
, values
.left
);
4754 mpz_init_set (range
, size
);
4755 values
.left
-= mpz_get_ui (size
);
4756 mpz_set_ui (size
, 0);
4759 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
4762 mpz_add (offset
, offset
, range
);
4766 /* Assign initial value to symbol. */
4770 mpz_sub_ui (size
, size
, 1);
4772 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
4774 if (mark
== AR_FULL
)
4775 mpz_add_ui (offset
, offset
, 1);
4777 /* Modify the array section indexes and recalculate the offset
4778 for next element. */
4779 else if (mark
== AR_SECTION
)
4780 gfc_advance_section (section_index
, ar
, &offset
);
4784 if (mark
== AR_SECTION
)
4786 for (i
= 0; i
< ar
->dimen
; i
++)
4787 mpz_clear (section_index
[i
]);
4797 static try traverse_data_var (gfc_data_variable
*, locus
*);
4799 /* Iterate over a list of elements in a DATA statement. */
4802 traverse_data_list (gfc_data_variable
* var
, locus
* where
)
4805 iterator_stack frame
;
4808 mpz_init (frame
.value
);
4810 mpz_init_set (trip
, var
->iter
.end
->value
.integer
);
4811 mpz_sub (trip
, trip
, var
->iter
.start
->value
.integer
);
4812 mpz_add (trip
, trip
, var
->iter
.step
->value
.integer
);
4814 mpz_div (trip
, trip
, var
->iter
.step
->value
.integer
);
4816 mpz_set (frame
.value
, var
->iter
.start
->value
.integer
);
4818 frame
.prev
= iter_stack
;
4819 frame
.variable
= var
->iter
.var
->symtree
;
4820 iter_stack
= &frame
;
4822 while (mpz_cmp_ui (trip
, 0) > 0)
4824 if (traverse_data_var (var
->list
, where
) == FAILURE
)
4830 e
= gfc_copy_expr (var
->expr
);
4831 if (gfc_simplify_expr (e
, 1) == FAILURE
)
4837 mpz_add (frame
.value
, frame
.value
, var
->iter
.step
->value
.integer
);
4839 mpz_sub_ui (trip
, trip
, 1);
4843 mpz_clear (frame
.value
);
4845 iter_stack
= frame
.prev
;
4850 /* Type resolve variables in the variable list of a DATA statement. */
4853 traverse_data_var (gfc_data_variable
* var
, locus
* where
)
4857 for (; var
; var
= var
->next
)
4859 if (var
->expr
== NULL
)
4860 t
= traverse_data_list (var
, where
);
4862 t
= check_data_variable (var
, where
);
4872 /* Resolve the expressions and iterators associated with a data statement.
4873 This is separate from the assignment checking because data lists should
4874 only be resolved once. */
4877 resolve_data_variables (gfc_data_variable
* d
)
4879 for (; d
; d
= d
->next
)
4881 if (d
->list
== NULL
)
4883 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
4888 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
4891 if (d
->iter
.start
->expr_type
!= EXPR_CONSTANT
4892 || d
->iter
.end
->expr_type
!= EXPR_CONSTANT
4893 || d
->iter
.step
->expr_type
!= EXPR_CONSTANT
)
4894 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4896 if (resolve_data_variables (d
->list
) == FAILURE
)
4905 /* Resolve a single DATA statement. We implement this by storing a pointer to
4906 the value list into static variables, and then recursively traversing the
4907 variables list, expanding iterators and such. */
4910 resolve_data (gfc_data
* d
)
4912 if (resolve_data_variables (d
->var
) == FAILURE
)
4915 values
.vnode
= d
->value
;
4916 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
4918 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
4921 /* At this point, we better not have any values left. */
4923 if (next_data_value () == SUCCESS
)
4924 gfc_error ("DATA statement at %L has more values than variables",
4929 /* Determines if a variable is not 'pure', ie not assignable within a pure
4930 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4934 gfc_impure_variable (gfc_symbol
* sym
)
4936 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
4939 if (sym
->ns
!= gfc_current_ns
)
4940 return !sym
->attr
.function
;
4942 /* TODO: Check storage association through EQUIVALENCE statements */
4948 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4949 symbol of the current procedure. */
4952 gfc_pure (gfc_symbol
* sym
)
4954 symbol_attribute attr
;
4957 sym
= gfc_current_ns
->proc_name
;
4963 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
4967 /* Test whether the current procedure is elemental or not. */
4970 gfc_elemental (gfc_symbol
* sym
)
4972 symbol_attribute attr
;
4975 sym
= gfc_current_ns
->proc_name
;
4980 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
4984 /* Warn about unused labels. */
4987 warn_unused_label (gfc_namespace
* ns
)
4998 for (; l
; l
= l
->prev
)
5000 if (l
->defined
== ST_LABEL_UNKNOWN
)
5003 switch (l
->referenced
)
5005 case ST_LABEL_UNKNOWN
:
5006 gfc_warning ("Label %d at %L defined but not used", l
->value
,
5010 case ST_LABEL_BAD_TARGET
:
5011 gfc_warning ("Label %d at %L defined but cannot be used", l
->value
,
5022 /* Returns the sequence type of a symbol or sequence. */
5025 sequence_type (gfc_typespec ts
)
5034 if (ts
.derived
->components
== NULL
)
5035 return SEQ_NONDEFAULT
;
5037 result
= sequence_type (ts
.derived
->components
->ts
);
5038 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
5039 if (sequence_type (c
->ts
) != result
)
5045 if (ts
.kind
!= gfc_default_character_kind
)
5046 return SEQ_NONDEFAULT
;
5048 return SEQ_CHARACTER
;
5051 if (ts
.kind
!= gfc_default_integer_kind
)
5052 return SEQ_NONDEFAULT
;
5057 if (!(ts
.kind
== gfc_default_real_kind
5058 || ts
.kind
== gfc_default_double_kind
))
5059 return SEQ_NONDEFAULT
;
5064 if (ts
.kind
!= gfc_default_complex_kind
)
5065 return SEQ_NONDEFAULT
;
5070 if (ts
.kind
!= gfc_default_logical_kind
)
5071 return SEQ_NONDEFAULT
;
5076 return SEQ_NONDEFAULT
;
5081 /* Resolve derived type EQUIVALENCE object. */
5084 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
5087 gfc_component
*c
= derived
->components
;
5092 /* Shall not be an object of nonsequence derived type. */
5093 if (!derived
->attr
.sequence
)
5095 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5096 "attribute to be an EQUIVALENCE object", sym
->name
, &e
->where
);
5100 for (; c
; c
= c
->next
)
5103 if (d
&& (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
5106 /* Shall not be an object of sequence derived type containing a pointer
5107 in the structure. */
5110 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5111 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
5117 gfc_error ("Derived type variable '%s' at %L with default initializer "
5118 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
5126 /* Resolve equivalence object.
5127 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5128 an allocatable array, an object of nonsequence derived type, an object of
5129 sequence derived type containing a pointer at any level of component
5130 selection, an automatic object, a function name, an entry name, a result
5131 name, a named constant, a structure component, or a subobject of any of
5132 the preceding objects. A substring shall not have length zero. A
5133 derived type shall not have components with default initialization nor
5134 shall two objects of an equivalence group be initialized.
5135 The simple constraints are done in symbol.c(check_conflict) and the rest
5136 are implemented here. */
5139 resolve_equivalence (gfc_equiv
*eq
)
5142 gfc_symbol
*derived
;
5143 gfc_symbol
*first_sym
;
5146 locus
*last_where
= NULL
;
5147 seq_type eq_type
, last_eq_type
;
5148 gfc_typespec
*last_ts
;
5150 const char *value_name
;
5154 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
5156 first_sym
= eq
->expr
->symtree
->n
.sym
;
5158 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
5162 e
->ts
= e
->symtree
->n
.sym
->ts
;
5163 /* match_varspec might not know yet if it is seeing
5164 array reference or substring reference, as it doesn't
5166 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5168 gfc_ref
*ref
= e
->ref
;
5169 sym
= e
->symtree
->n
.sym
;
5171 if (sym
->attr
.dimension
)
5173 ref
->u
.ar
.as
= sym
->as
;
5177 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5178 if (e
->ts
.type
== BT_CHARACTER
5180 && ref
->type
== REF_ARRAY
5181 && ref
->u
.ar
.dimen
== 1
5182 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
5183 && ref
->u
.ar
.stride
[0] == NULL
)
5185 gfc_expr
*start
= ref
->u
.ar
.start
[0];
5186 gfc_expr
*end
= ref
->u
.ar
.end
[0];
5189 /* Optimize away the (:) reference. */
5190 if (start
== NULL
&& end
== NULL
)
5195 e
->ref
->next
= ref
->next
;
5200 ref
->type
= REF_SUBSTRING
;
5202 start
= gfc_int_expr (1);
5203 ref
->u
.ss
.start
= start
;
5204 if (end
== NULL
&& e
->ts
.cl
)
5205 end
= gfc_copy_expr (e
->ts
.cl
->length
);
5206 ref
->u
.ss
.end
= end
;
5207 ref
->u
.ss
.length
= e
->ts
.cl
;
5214 /* Any further ref is an error. */
5217 gcc_assert (ref
->type
== REF_ARRAY
);
5218 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5224 if (gfc_resolve_expr (e
) == FAILURE
)
5227 sym
= e
->symtree
->n
.sym
;
5229 /* An equivalence statement cannot have more than one initialized
5233 if (value_name
!= NULL
)
5235 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5236 "be in the EQUIVALENCE statement at %L",
5237 value_name
, sym
->name
, &e
->where
);
5241 value_name
= sym
->name
;
5244 /* Shall not equivalence common block variables in a PURE procedure. */
5245 if (sym
->ns
->proc_name
5246 && sym
->ns
->proc_name
->attr
.pure
5247 && sym
->attr
.in_common
)
5249 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5250 "object in the pure procedure '%s'",
5251 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
5255 /* Shall not be a named constant. */
5256 if (e
->expr_type
== EXPR_CONSTANT
)
5258 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5259 "object", sym
->name
, &e
->where
);
5263 derived
= e
->ts
.derived
;
5264 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
5267 /* Check that the types correspond correctly:
5269 A numeric sequence structure may be equivalenced to another sequence
5270 structure, an object of default integer type, default real type, double
5271 precision real type, default logical type such that components of the
5272 structure ultimately only become associated to objects of the same
5273 kind. A character sequence structure may be equivalenced to an object
5274 of default character kind or another character sequence structure.
5275 Other objects may be equivalenced only to objects of the same type and
5278 /* Identical types are unconditionally OK. */
5279 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
5280 goto identical_types
;
5282 last_eq_type
= sequence_type (*last_ts
);
5283 eq_type
= sequence_type (sym
->ts
);
5285 /* Since the pair of objects is not of the same type, mixed or
5286 non-default sequences can be rejected. */
5288 msg
= "Sequence %s with mixed components in EQUIVALENCE "
5289 "statement at %L with different type objects";
5291 && last_eq_type
== SEQ_MIXED
5292 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
5293 last_where
) == FAILURE
)
5294 || (eq_type
== SEQ_MIXED
5295 && gfc_notify_std (GFC_STD_GNU
, msg
,sym
->name
,
5296 &e
->where
) == FAILURE
))
5299 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
5300 "statement at %L with objects of different type";
5302 && last_eq_type
== SEQ_NONDEFAULT
5303 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
5304 last_where
) == FAILURE
)
5305 || (eq_type
== SEQ_NONDEFAULT
5306 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
5307 &e
->where
) == FAILURE
))
5310 msg
="Non-CHARACTER object '%s' in default CHARACTER "
5311 "EQUIVALENCE statement at %L";
5312 if (last_eq_type
== SEQ_CHARACTER
5313 && eq_type
!= SEQ_CHARACTER
5314 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
5315 &e
->where
) == FAILURE
)
5318 msg
="Non-NUMERIC object '%s' in default NUMERIC "
5319 "EQUIVALENCE statement at %L";
5320 if (last_eq_type
== SEQ_NUMERIC
5321 && eq_type
!= SEQ_NUMERIC
5322 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
5323 &e
->where
) == FAILURE
)
5328 last_where
= &e
->where
;
5333 /* Shall not be an automatic array. */
5334 if (e
->ref
->type
== REF_ARRAY
5335 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
5337 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
5338 "an EQUIVALENCE object", sym
->name
, &e
->where
);
5345 /* Shall not be a structure component. */
5346 if (r
->type
== REF_COMPONENT
)
5348 gfc_error ("Structure component '%s' at %L cannot be an "
5349 "EQUIVALENCE object",
5350 r
->u
.c
.component
->name
, &e
->where
);
5354 /* A substring shall not have length zero. */
5355 if (r
->type
== REF_SUBSTRING
)
5357 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
5359 gfc_error ("Substring at %L has length zero",
5360 &r
->u
.ss
.start
->where
);
5370 /* Resolve function and ENTRY types, issue diagnostics if needed. */
5373 resolve_fntype (gfc_namespace
* ns
)
5378 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
5381 /* If there are any entries, ns->proc_name is the entry master
5382 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
5384 sym
= ns
->entries
->sym
;
5386 sym
= ns
->proc_name
;
5387 if (sym
->result
== sym
5388 && sym
->ts
.type
== BT_UNKNOWN
5389 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
5390 && !sym
->attr
.untyped
)
5392 gfc_error ("Function '%s' at %L has no IMPLICIT type",
5393 sym
->name
, &sym
->declared_at
);
5394 sym
->attr
.untyped
= 1;
5398 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
5400 if (el
->sym
->result
== el
->sym
5401 && el
->sym
->ts
.type
== BT_UNKNOWN
5402 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
5403 && !el
->sym
->attr
.untyped
)
5405 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
5406 el
->sym
->name
, &el
->sym
->declared_at
);
5407 el
->sym
->attr
.untyped
= 1;
5413 /* This function is called after a complete program unit has been compiled.
5414 Its purpose is to examine all of the expressions associated with a program
5415 unit, assign types to all intermediate expressions, make sure that all
5416 assignments are to compatible types and figure out which names refer to
5417 which functions or subroutines. */
5420 gfc_resolve (gfc_namespace
* ns
)
5422 gfc_namespace
*old_ns
, *n
;
5427 old_ns
= gfc_current_ns
;
5428 gfc_current_ns
= ns
;
5430 resolve_entries (ns
);
5432 resolve_contained_functions (ns
);
5434 gfc_traverse_ns (ns
, resolve_symbol
);
5436 resolve_fntype (ns
);
5438 for (n
= ns
->contained
; n
; n
= n
->sibling
)
5440 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
5441 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
5442 "also be PURE", n
->proc_name
->name
,
5443 &n
->proc_name
->declared_at
);
5449 gfc_check_interfaces (ns
);
5451 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
5453 if (cl
->length
== NULL
|| gfc_resolve_expr (cl
->length
) == FAILURE
)
5456 if (gfc_simplify_expr (cl
->length
, 0) == FAILURE
)
5459 if (gfc_specification_expr (cl
->length
) == FAILURE
)
5463 gfc_traverse_ns (ns
, resolve_values
);
5469 for (d
= ns
->data
; d
; d
= d
->next
)
5473 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
5475 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
5476 resolve_equivalence (eq
);
5479 resolve_code (ns
->code
, ns
);
5481 /* Warn about unused labels. */
5482 if (gfc_option
.warn_unused_labels
)
5483 warn_unused_label (ns
);
5485 gfc_current_ns
= old_ns
;