1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 /* Types used in equivalence statements. */
34 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
38 /* Stack to push the current if we descend into a block during
39 resolution. See resolve_branch() and resolve_code(). */
41 typedef struct code_stack
43 struct gfc_code
*head
, *current
;
44 struct code_stack
*prev
;
48 static code_stack
*cs_base
= NULL
;
51 /* Nonzero if we're inside a FORALL block. */
53 static int forall_flag
;
55 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
57 static int omp_workshare_flag
;
59 /* Nonzero if we are processing a formal arglist. The corresponding function
60 resets the flag each time that it is read. */
61 static int formal_arg_flag
= 0;
64 gfc_is_formal_arg (void)
66 return formal_arg_flag
;
69 /* Resolve types of formal argument lists. These have to be done early so that
70 the formal argument lists of module procedures can be copied to the
71 containing module before the individual procedures are resolved
72 individually. We also resolve argument lists of procedures in interface
73 blocks because they are self-contained scoping units.
75 Since a dummy argument cannot be a non-dummy procedure, the only
76 resort left for untyped names are the IMPLICIT types. */
79 resolve_formal_arglist (gfc_symbol
* proc
)
81 gfc_formal_arglist
*f
;
85 /* TODO: Procedures whose return character length parameter is not constant
86 or assumed must also have explicit interfaces. */
87 if (proc
->result
!= NULL
)
92 if (gfc_elemental (proc
)
93 || sym
->attr
.pointer
|| sym
->attr
.allocatable
94 || (sym
->as
&& sym
->as
->rank
> 0))
95 proc
->attr
.always_explicit
= 1;
99 for (f
= proc
->formal
; f
; f
= f
->next
)
105 /* Alternate return placeholder. */
106 if (gfc_elemental (proc
))
107 gfc_error ("Alternate return specifier in elemental subroutine "
108 "'%s' at %L is not allowed", proc
->name
,
110 if (proc
->attr
.function
)
111 gfc_error ("Alternate return specifier in function "
112 "'%s' at %L is not allowed", proc
->name
,
117 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
118 resolve_formal_arglist (sym
);
120 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
122 if (gfc_pure (proc
) && !gfc_pure (sym
))
125 ("Dummy procedure '%s' of PURE procedure at %L must also "
126 "be PURE", sym
->name
, &sym
->declared_at
);
130 if (gfc_elemental (proc
))
133 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
141 if (sym
->ts
.type
== BT_UNKNOWN
)
143 if (!sym
->attr
.function
|| sym
->result
== sym
)
144 gfc_set_default_type (sym
, 1, sym
->ns
);
147 gfc_resolve_array_spec (sym
->as
, 0);
149 /* We can't tell if an array with dimension (:) is assumed or deferred
150 shape until we know if it has the pointer or allocatable attributes.
152 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
153 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
155 sym
->as
->type
= AS_ASSUMED_SHAPE
;
156 for (i
= 0; i
< sym
->as
->rank
; i
++)
157 sym
->as
->lower
[i
] = gfc_int_expr (1);
160 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
161 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
162 || sym
->attr
.optional
)
163 proc
->attr
.always_explicit
= 1;
165 /* If the flavor is unknown at this point, it has to be a variable.
166 A procedure specification would have already set the type. */
168 if (sym
->attr
.flavor
== FL_UNKNOWN
)
169 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
173 if (proc
->attr
.function
&& !sym
->attr
.pointer
174 && sym
->attr
.flavor
!= FL_PROCEDURE
175 && sym
->attr
.intent
!= INTENT_IN
)
177 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
178 "INTENT(IN)", sym
->name
, proc
->name
,
181 if (proc
->attr
.subroutine
&& !sym
->attr
.pointer
182 && sym
->attr
.intent
== INTENT_UNKNOWN
)
185 ("Argument '%s' of pure subroutine '%s' at %L must have "
186 "its INTENT specified", sym
->name
, proc
->name
,
191 if (gfc_elemental (proc
))
196 ("Argument '%s' of elemental procedure at %L must be scalar",
197 sym
->name
, &sym
->declared_at
);
201 if (sym
->attr
.pointer
)
204 ("Argument '%s' of elemental procedure at %L cannot have "
205 "the POINTER attribute", sym
->name
, &sym
->declared_at
);
210 /* Each dummy shall be specified to be scalar. */
211 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
216 ("Argument '%s' of statement function at %L must be scalar",
217 sym
->name
, &sym
->declared_at
);
221 if (sym
->ts
.type
== BT_CHARACTER
)
223 gfc_charlen
*cl
= sym
->ts
.cl
;
224 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
227 ("Character-valued argument '%s' of statement function at "
228 "%L must has constant length",
229 sym
->name
, &sym
->declared_at
);
239 /* Work function called when searching for symbols that have argument lists
240 associated with them. */
243 find_arglists (gfc_symbol
* sym
)
246 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
249 resolve_formal_arglist (sym
);
253 /* Given a namespace, resolve all formal argument lists within the namespace.
257 resolve_formal_arglists (gfc_namespace
* ns
)
263 gfc_traverse_ns (ns
, find_arglists
);
268 resolve_contained_fntype (gfc_symbol
* sym
, gfc_namespace
* ns
)
272 /* If this namespace is not a function, ignore it. */
274 || !(sym
->attr
.function
275 || sym
->attr
.flavor
== FL_VARIABLE
))
278 /* Try to find out of what the return type is. */
279 if (sym
->result
!= NULL
)
282 if (sym
->ts
.type
== BT_UNKNOWN
)
284 t
= gfc_set_default_type (sym
, 0, ns
);
286 if (t
== FAILURE
&& !sym
->attr
.untyped
)
288 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
289 sym
->name
, &sym
->declared_at
); /* FIXME */
290 sym
->attr
.untyped
= 1;
294 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
295 lists the only ways a character length value of * can be used: dummy arguments
296 of procedures, named constants, and function results in external functions.
297 Internal function results are not on that list; ergo, not permitted. */
299 if (sym
->ts
.type
== BT_CHARACTER
)
301 gfc_charlen
*cl
= sym
->ts
.cl
;
302 if (!cl
|| !cl
->length
)
303 gfc_error ("Character-valued internal function '%s' at %L must "
304 "not be assumed length", sym
->name
, &sym
->declared_at
);
309 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
310 introduce duplicates. */
313 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
315 gfc_formal_arglist
*f
, *new_arglist
;
318 for (; new_args
!= NULL
; new_args
= new_args
->next
)
320 new_sym
= new_args
->sym
;
321 /* See if ths arg is already in the formal argument list. */
322 for (f
= proc
->formal
; f
; f
= f
->next
)
324 if (new_sym
== f
->sym
)
331 /* Add a new argument. Argument order is not important. */
332 new_arglist
= gfc_get_formal_arglist ();
333 new_arglist
->sym
= new_sym
;
334 new_arglist
->next
= proc
->formal
;
335 proc
->formal
= new_arglist
;
340 /* Resolve alternate entry points. If a symbol has multiple entry points we
341 create a new master symbol for the main routine, and turn the existing
342 symbol into an entry point. */
345 resolve_entries (gfc_namespace
* ns
)
347 gfc_namespace
*old_ns
;
351 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
352 static int master_count
= 0;
354 if (ns
->proc_name
== NULL
)
357 /* No need to do anything if this procedure doesn't have alternate entry
362 /* We may already have resolved alternate entry points. */
363 if (ns
->proc_name
->attr
.entry_master
)
366 /* If this isn't a procedure something has gone horribly wrong. */
367 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
369 /* Remember the current namespace. */
370 old_ns
= gfc_current_ns
;
374 /* Add the main entry point to the list of entry points. */
375 el
= gfc_get_entry_list ();
376 el
->sym
= ns
->proc_name
;
378 el
->next
= ns
->entries
;
380 ns
->proc_name
->attr
.entry
= 1;
382 /* Add an entry statement for it. */
389 /* Create a new symbol for the master function. */
390 /* Give the internal function a unique name (within this file).
391 Also include the function name so the user has some hope of figuring
392 out what is going on. */
393 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
394 master_count
++, ns
->proc_name
->name
);
395 gfc_get_ha_symbol (name
, &proc
);
396 gcc_assert (proc
!= NULL
);
398 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
399 if (ns
->proc_name
->attr
.subroutine
)
400 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
404 gfc_typespec
*ts
, *fts
;
406 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
408 fts
= &ns
->entries
->sym
->result
->ts
;
409 if (fts
->type
== BT_UNKNOWN
)
410 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
411 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
413 ts
= &el
->sym
->result
->ts
;
414 if (ts
->type
== BT_UNKNOWN
)
415 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
416 if (! gfc_compare_types (ts
, fts
)
417 || (el
->sym
->result
->attr
.dimension
418 != ns
->entries
->sym
->result
->attr
.dimension
)
419 || (el
->sym
->result
->attr
.pointer
420 != ns
->entries
->sym
->result
->attr
.pointer
))
426 sym
= ns
->entries
->sym
->result
;
427 /* All result types the same. */
429 if (sym
->attr
.dimension
)
430 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
431 if (sym
->attr
.pointer
)
432 gfc_add_pointer (&proc
->attr
, NULL
);
436 /* Otherwise the result will be passed through a union by
438 proc
->attr
.mixed_entry_master
= 1;
439 for (el
= ns
->entries
; el
; el
= el
->next
)
441 sym
= el
->sym
->result
;
442 if (sym
->attr
.dimension
)
444 if (el
== ns
->entries
)
446 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
447 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
450 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
451 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
453 else if (sym
->attr
.pointer
)
455 if (el
== ns
->entries
)
457 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
458 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
461 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
462 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
467 if (ts
->type
== BT_UNKNOWN
)
468 ts
= gfc_get_default_type (sym
, NULL
);
472 if (ts
->kind
== gfc_default_integer_kind
)
476 if (ts
->kind
== gfc_default_real_kind
477 || ts
->kind
== gfc_default_double_kind
)
481 if (ts
->kind
== gfc_default_complex_kind
)
485 if (ts
->kind
== gfc_default_logical_kind
)
489 /* We will issue error elsewhere. */
497 if (el
== ns
->entries
)
499 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
500 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
504 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
505 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
512 proc
->attr
.access
= ACCESS_PRIVATE
;
513 proc
->attr
.entry_master
= 1;
515 /* Merge all the entry point arguments. */
516 for (el
= ns
->entries
; el
; el
= el
->next
)
517 merge_argument_lists (proc
, el
->sym
->formal
);
519 /* Use the master function for the function body. */
520 ns
->proc_name
= proc
;
522 /* Finalize the new symbols. */
523 gfc_commit_symbols ();
525 /* Restore the original namespace. */
526 gfc_current_ns
= old_ns
;
530 /* Resolve contained function types. Because contained functions can call one
531 another, they have to be worked out before any of the contained procedures
534 The good news is that if a function doesn't already have a type, the only
535 way it can get one is through an IMPLICIT type or a RESULT variable, because
536 by definition contained functions are contained namespace they're contained
537 in, not in a sibling or parent namespace. */
540 resolve_contained_functions (gfc_namespace
* ns
)
542 gfc_namespace
*child
;
545 resolve_formal_arglists (ns
);
547 for (child
= ns
->contained
; child
; child
= child
->sibling
)
549 /* Resolve alternate entry points first. */
550 resolve_entries (child
);
552 /* Then check function return types. */
553 resolve_contained_fntype (child
->proc_name
, child
);
554 for (el
= child
->entries
; el
; el
= el
->next
)
555 resolve_contained_fntype (el
->sym
, child
);
560 /* Resolve all of the elements of a structure constructor and make sure that
561 the types are correct. */
564 resolve_structure_cons (gfc_expr
* expr
)
566 gfc_constructor
*cons
;
571 cons
= expr
->value
.constructor
;
572 /* A constructor may have references if it is the result of substituting a
573 parameter variable. In this case we just pull out the component we
576 comp
= expr
->ref
->u
.c
.sym
->components
;
578 comp
= expr
->ts
.derived
->components
;
580 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
588 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
594 /* If we don't have the right type, try to convert it. */
596 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
599 if (comp
->pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
600 gfc_error ("The element in the derived type constructor at %L, "
601 "for pointer component '%s', is %s but should be %s",
602 &cons
->expr
->where
, comp
->name
,
603 gfc_basic_typename (cons
->expr
->ts
.type
),
604 gfc_basic_typename (comp
->ts
.type
));
606 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
615 /****************** Expression name resolution ******************/
617 /* Returns 0 if a symbol was not declared with a type or
618 attribute declaration statement, nonzero otherwise. */
621 was_declared (gfc_symbol
* sym
)
627 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
630 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
631 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
632 || a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
639 /* Determine if a symbol is generic or not. */
642 generic_sym (gfc_symbol
* sym
)
646 if (sym
->attr
.generic
||
647 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
650 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
653 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
655 return (s
== NULL
) ? 0 : generic_sym (s
);
659 /* Determine if a symbol is specific or not. */
662 specific_sym (gfc_symbol
* sym
)
666 if (sym
->attr
.if_source
== IFSRC_IFBODY
667 || sym
->attr
.proc
== PROC_MODULE
668 || sym
->attr
.proc
== PROC_INTERNAL
669 || sym
->attr
.proc
== PROC_ST_FUNCTION
670 || (sym
->attr
.intrinsic
&&
671 gfc_specific_intrinsic (sym
->name
))
672 || sym
->attr
.external
)
675 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
678 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
680 return (s
== NULL
) ? 0 : specific_sym (s
);
684 /* Figure out if the procedure is specific, generic or unknown. */
687 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
691 procedure_kind (gfc_symbol
* sym
)
694 if (generic_sym (sym
))
695 return PTYPE_GENERIC
;
697 if (specific_sym (sym
))
698 return PTYPE_SPECIFIC
;
700 return PTYPE_UNKNOWN
;
703 /* Check references to assumed size arrays. The flag need_full_assumed_size
704 is non-zero when matching actual arguments. */
706 static int need_full_assumed_size
= 0;
709 check_assumed_size_reference (gfc_symbol
* sym
, gfc_expr
* e
)
715 if (need_full_assumed_size
716 || !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
719 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
720 if (ref
->type
== REF_ARRAY
)
721 for (dim
= 0; dim
< ref
->u
.ar
.as
->rank
; dim
++)
722 last
= (ref
->u
.ar
.end
[dim
] == NULL
) && (ref
->u
.ar
.type
== DIMEN_ELEMENT
);
726 gfc_error ("The upper bound in the last dimension must "
727 "appear in the reference to the assumed size "
728 "array '%s' at %L.", sym
->name
, &e
->where
);
735 /* Look for bad assumed size array references in argument expressions
736 of elemental and array valued intrinsic procedures. Since this is
737 called from procedure resolution functions, it only recurses at
741 resolve_assumed_size_actual (gfc_expr
*e
)
746 switch (e
->expr_type
)
750 && check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
755 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
756 || resolve_assumed_size_actual (e
->value
.op
.op2
))
767 /* Resolve an actual argument list. Most of the time, this is just
768 resolving the expressions in the list.
769 The exception is that we sometimes have to decide whether arguments
770 that look like procedure arguments are really simple variable
774 resolve_actual_arglist (gfc_actual_arglist
* arg
)
777 gfc_symtree
*parent_st
;
780 for (; arg
; arg
= arg
->next
)
786 /* Check the label is a valid branching target. */
789 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
791 gfc_error ("Label %d referenced at %L is never defined",
792 arg
->label
->value
, &arg
->label
->where
);
799 if (e
->ts
.type
!= BT_PROCEDURE
)
801 if (gfc_resolve_expr (e
) != SUCCESS
)
806 /* See if the expression node should really be a variable
809 sym
= e
->symtree
->n
.sym
;
811 if (sym
->attr
.flavor
== FL_PROCEDURE
812 || sym
->attr
.intrinsic
813 || sym
->attr
.external
)
816 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
818 gfc_error ("Statement function '%s' at %L is not allowed as an "
819 "actual argument", sym
->name
, &e
->where
);
822 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
823 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
825 gfc_error ("Internal procedure '%s' is not allowed as an "
826 "actual argument at %L", sym
->name
, &e
->where
);
829 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
831 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
832 "allowed as an actual argument at %L", sym
->name
,
836 /* If the symbol is the function that names the current (or
837 parent) scope, then we really have a variable reference. */
839 if (sym
->attr
.function
&& sym
->result
== sym
840 && (sym
->ns
->proc_name
== sym
841 || (sym
->ns
->parent
!= NULL
842 && sym
->ns
->parent
->proc_name
== sym
)))
848 /* See if the name is a module procedure in a parent unit. */
850 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
853 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
855 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
859 if (parent_st
== NULL
)
862 sym
= parent_st
->n
.sym
;
863 e
->symtree
= parent_st
; /* Point to the right thing. */
865 if (sym
->attr
.flavor
== FL_PROCEDURE
866 || sym
->attr
.intrinsic
867 || sym
->attr
.external
)
873 e
->expr_type
= EXPR_VARIABLE
;
877 e
->rank
= sym
->as
->rank
;
878 e
->ref
= gfc_get_ref ();
879 e
->ref
->type
= REF_ARRAY
;
880 e
->ref
->u
.ar
.type
= AR_FULL
;
881 e
->ref
->u
.ar
.as
= sym
->as
;
889 /* Go through each actual argument in ACTUAL and see if it can be
890 implemented as an inlined, non-copying intrinsic. FNSYM is the
891 function being called, or NULL if not known. */
894 find_noncopying_intrinsics (gfc_symbol
* fnsym
, gfc_actual_arglist
* actual
)
896 gfc_actual_arglist
*ap
;
899 for (ap
= actual
; ap
; ap
= ap
->next
)
901 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
902 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
903 ap
->expr
->inline_noncopying_intrinsic
= 1;
906 /* This function does the checking of references to global procedures
907 as defined in sections 18.1 and 14.1, respectively, of the Fortran
908 77 and 95 standards. It checks for a gsymbol for the name, making
909 one if it does not already exist. If it already exists, then the
910 reference being resolved must correspond to the type of gsymbol.
911 Otherwise, the new symbol is equipped with the attributes of the
912 reference. The corresponding code that is called in creating
913 global entities is parse.c. */
916 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
921 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
923 gsym
= gfc_get_gsymbol (sym
->name
);
925 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
926 global_used (gsym
, where
);
928 if (gsym
->type
== GSYM_UNKNOWN
)
931 gsym
->where
= *where
;
937 /************* Function resolution *************/
939 /* Resolve a function call known to be generic.
940 Section 14.1.2.4.1. */
943 resolve_generic_f0 (gfc_expr
* expr
, gfc_symbol
* sym
)
947 if (sym
->attr
.generic
)
950 gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
953 expr
->value
.function
.name
= s
->name
;
954 expr
->value
.function
.esym
= s
;
957 expr
->rank
= s
->as
->rank
;
961 /* TODO: Need to search for elemental references in generic interface */
964 if (sym
->attr
.intrinsic
)
965 return gfc_intrinsic_func_interface (expr
, 0);
972 resolve_generic_f (gfc_expr
* expr
)
977 sym
= expr
->symtree
->n
.sym
;
981 m
= resolve_generic_f0 (expr
, sym
);
984 else if (m
== MATCH_ERROR
)
988 if (sym
->ns
->parent
== NULL
)
990 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
994 if (!generic_sym (sym
))
998 /* Last ditch attempt. */
1000 if (!gfc_generic_intrinsic (expr
->symtree
->n
.sym
->name
))
1002 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
1003 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1007 m
= gfc_intrinsic_func_interface (expr
, 0);
1012 ("Generic function '%s' at %L is not consistent with a specific "
1013 "intrinsic interface", expr
->symtree
->n
.sym
->name
, &expr
->where
);
1019 /* Resolve a function call known to be specific. */
1022 resolve_specific_f0 (gfc_symbol
* sym
, gfc_expr
* expr
)
1026 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1028 if (sym
->attr
.dummy
)
1030 sym
->attr
.proc
= PROC_DUMMY
;
1034 sym
->attr
.proc
= PROC_EXTERNAL
;
1038 if (sym
->attr
.proc
== PROC_MODULE
1039 || sym
->attr
.proc
== PROC_ST_FUNCTION
1040 || sym
->attr
.proc
== PROC_INTERNAL
)
1043 if (sym
->attr
.intrinsic
)
1045 m
= gfc_intrinsic_func_interface (expr
, 1);
1050 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1051 "an intrinsic", sym
->name
, &expr
->where
);
1059 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1062 expr
->value
.function
.name
= sym
->name
;
1063 expr
->value
.function
.esym
= sym
;
1064 if (sym
->as
!= NULL
)
1065 expr
->rank
= sym
->as
->rank
;
1072 resolve_specific_f (gfc_expr
* expr
)
1077 sym
= expr
->symtree
->n
.sym
;
1081 m
= resolve_specific_f0 (sym
, expr
);
1084 if (m
== MATCH_ERROR
)
1087 if (sym
->ns
->parent
== NULL
)
1090 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1096 gfc_error ("Unable to resolve the specific function '%s' at %L",
1097 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1103 /* Resolve a procedure call not known to be generic nor specific. */
1106 resolve_unknown_f (gfc_expr
* expr
)
1111 sym
= expr
->symtree
->n
.sym
;
1113 if (sym
->attr
.dummy
)
1115 sym
->attr
.proc
= PROC_DUMMY
;
1116 expr
->value
.function
.name
= sym
->name
;
1120 /* See if we have an intrinsic function reference. */
1122 if (gfc_intrinsic_name (sym
->name
, 0))
1124 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1129 /* The reference is to an external name. */
1131 sym
->attr
.proc
= PROC_EXTERNAL
;
1132 expr
->value
.function
.name
= sym
->name
;
1133 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1135 if (sym
->as
!= NULL
)
1136 expr
->rank
= sym
->as
->rank
;
1138 /* Type of the expression is either the type of the symbol or the
1139 default type of the symbol. */
1142 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1144 if (sym
->ts
.type
!= BT_UNKNOWN
)
1148 ts
= gfc_get_default_type (sym
, sym
->ns
);
1150 if (ts
->type
== BT_UNKNOWN
)
1152 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1153 sym
->name
, &expr
->where
);
1164 /* Figure out if a function reference is pure or not. Also set the name
1165 of the function for a potential error message. Return nonzero if the
1166 function is PURE, zero if not. */
1169 pure_function (gfc_expr
* e
, const char **name
)
1173 if (e
->value
.function
.esym
)
1175 pure
= gfc_pure (e
->value
.function
.esym
);
1176 *name
= e
->value
.function
.esym
->name
;
1178 else if (e
->value
.function
.isym
)
1180 pure
= e
->value
.function
.isym
->pure
1181 || e
->value
.function
.isym
->elemental
;
1182 *name
= e
->value
.function
.isym
->name
;
1186 /* Implicit functions are not pure. */
1188 *name
= e
->value
.function
.name
;
1195 /* Resolve a function call, which means resolving the arguments, then figuring
1196 out which entity the name refers to. */
1197 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1198 to INTENT(OUT) or INTENT(INOUT). */
1201 resolve_function (gfc_expr
* expr
)
1203 gfc_actual_arglist
*arg
;
1212 sym
= expr
->symtree
->n
.sym
;
1214 /* If the procedure is not internal, a statement function or a module
1215 procedure,it must be external and should be checked for usage. */
1216 if (sym
&& !sym
->attr
.dummy
&& !sym
->attr
.contained
1217 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1218 && !sym
->attr
.use_assoc
)
1219 resolve_global_procedure (sym
, &expr
->where
, 0);
1221 /* Switch off assumed size checking and do this again for certain kinds
1222 of procedure, once the procedure itself is resolved. */
1223 need_full_assumed_size
++;
1225 if (resolve_actual_arglist (expr
->value
.function
.actual
) == FAILURE
)
1228 /* Resume assumed_size checking. */
1229 need_full_assumed_size
--;
1231 if (sym
&& sym
->ts
.type
== BT_CHARACTER
1232 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
1234 if (sym
->attr
.if_source
== IFSRC_IFBODY
)
1236 /* This follows from a slightly odd requirement at 5.1.1.5 in the
1237 standard that allows assumed character length functions to be
1238 declared in interfaces but not used. Picking up the symbol here,
1239 rather than resolve_symbol, accomplishes that. */
1240 gfc_error ("Function '%s' can be declared in an interface to "
1241 "return CHARACTER(*) but cannot be used at %L",
1242 sym
->name
, &expr
->where
);
1246 /* Internal procedures are taken care of in resolve_contained_fntype. */
1247 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
)
1249 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1250 "be used at %L since it is not a dummy argument",
1251 sym
->name
, &expr
->where
);
1256 /* See if function is already resolved. */
1258 if (expr
->value
.function
.name
!= NULL
)
1260 if (expr
->ts
.type
== BT_UNKNOWN
)
1266 /* Apply the rules of section 14.1.2. */
1268 switch (procedure_kind (sym
))
1271 t
= resolve_generic_f (expr
);
1274 case PTYPE_SPECIFIC
:
1275 t
= resolve_specific_f (expr
);
1279 t
= resolve_unknown_f (expr
);
1283 gfc_internal_error ("resolve_function(): bad function type");
1287 /* If the expression is still a function (it might have simplified),
1288 then we check to see if we are calling an elemental function. */
1290 if (expr
->expr_type
!= EXPR_FUNCTION
)
1293 temp
= need_full_assumed_size
;
1294 need_full_assumed_size
= 0;
1296 if (expr
->value
.function
.actual
!= NULL
1297 && ((expr
->value
.function
.esym
!= NULL
1298 && expr
->value
.function
.esym
->attr
.elemental
)
1299 || (expr
->value
.function
.isym
!= NULL
1300 && expr
->value
.function
.isym
->elemental
)))
1302 /* The rank of an elemental is the rank of its array argument(s). */
1303 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1305 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1307 expr
->rank
= arg
->expr
->rank
;
1308 if (!expr
->shape
&& arg
->expr
->shape
)
1310 expr
->shape
= gfc_get_shape (expr
->rank
);
1311 for (i
= 0; i
< expr
->rank
; i
++)
1312 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1318 /* Being elemental, the last upper bound of an assumed size array
1319 argument must be present. */
1320 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1322 if (arg
->expr
!= NULL
1323 && arg
->expr
->rank
> 0
1324 && resolve_assumed_size_actual (arg
->expr
))
1328 if (omp_workshare_flag
1329 && expr
->value
.function
.esym
1330 && ! gfc_elemental (expr
->value
.function
.esym
))
1332 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1333 " in WORKSHARE construct", expr
->value
.function
.esym
->name
,
1338 else if (expr
->value
.function
.actual
!= NULL
1339 && expr
->value
.function
.isym
!= NULL
1340 && expr
->value
.function
.isym
->generic_id
!= GFC_ISYM_LBOUND
1341 && expr
->value
.function
.isym
->generic_id
!= GFC_ISYM_LOC
1342 && expr
->value
.function
.isym
->generic_id
!= GFC_ISYM_PRESENT
)
1344 /* Array instrinsics must also have the last upper bound of an
1345 asumed size array argument. UBOUND and SIZE have to be
1346 excluded from the check if the second argument is anything
1349 inquiry
= expr
->value
.function
.isym
->generic_id
== GFC_ISYM_UBOUND
1350 || expr
->value
.function
.isym
->generic_id
== GFC_ISYM_SIZE
;
1352 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1354 if (inquiry
&& arg
->next
!= NULL
&& arg
->next
->expr
1355 && arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
1358 if (arg
->expr
!= NULL
1359 && arg
->expr
->rank
> 0
1360 && resolve_assumed_size_actual (arg
->expr
))
1365 need_full_assumed_size
= temp
;
1367 if (!pure_function (expr
, &name
) && name
)
1372 ("Function reference to '%s' at %L is inside a FORALL block",
1373 name
, &expr
->where
);
1376 else if (gfc_pure (NULL
))
1378 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1379 "procedure within a PURE procedure", name
, &expr
->where
);
1384 /* Character lengths of use associated functions may contains references to
1385 symbols not referenced from the current program unit otherwise. Make sure
1386 those symbols are marked as referenced. */
1388 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
1389 && expr
->value
.function
.esym
->attr
.use_assoc
)
1391 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
1395 find_noncopying_intrinsics (expr
->value
.function
.esym
,
1396 expr
->value
.function
.actual
);
1401 /************* Subroutine resolution *************/
1404 pure_subroutine (gfc_code
* c
, gfc_symbol
* sym
)
1411 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1412 sym
->name
, &c
->loc
);
1413 else if (gfc_pure (NULL
))
1414 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1420 resolve_generic_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1424 if (sym
->attr
.generic
)
1426 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1429 c
->resolved_sym
= s
;
1430 pure_subroutine (c
, s
);
1434 /* TODO: Need to search for elemental references in generic interface. */
1437 if (sym
->attr
.intrinsic
)
1438 return gfc_intrinsic_sub_interface (c
, 0);
1445 resolve_generic_s (gfc_code
* c
)
1450 sym
= c
->symtree
->n
.sym
;
1452 m
= resolve_generic_s0 (c
, sym
);
1455 if (m
== MATCH_ERROR
)
1458 if (sym
->ns
->parent
!= NULL
)
1460 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1463 m
= resolve_generic_s0 (c
, sym
);
1466 if (m
== MATCH_ERROR
)
1471 /* Last ditch attempt. */
1473 if (!gfc_generic_intrinsic (sym
->name
))
1476 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1477 sym
->name
, &c
->loc
);
1481 m
= gfc_intrinsic_sub_interface (c
, 0);
1485 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1486 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1492 /* Resolve a subroutine call known to be specific. */
1495 resolve_specific_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1499 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1501 if (sym
->attr
.dummy
)
1503 sym
->attr
.proc
= PROC_DUMMY
;
1507 sym
->attr
.proc
= PROC_EXTERNAL
;
1511 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1514 if (sym
->attr
.intrinsic
)
1516 m
= gfc_intrinsic_sub_interface (c
, 1);
1520 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1521 "with an intrinsic", sym
->name
, &c
->loc
);
1529 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1531 c
->resolved_sym
= sym
;
1532 pure_subroutine (c
, sym
);
1539 resolve_specific_s (gfc_code
* c
)
1544 sym
= c
->symtree
->n
.sym
;
1546 m
= resolve_specific_s0 (c
, sym
);
1549 if (m
== MATCH_ERROR
)
1552 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1556 m
= resolve_specific_s0 (c
, sym
);
1559 if (m
== MATCH_ERROR
)
1563 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1564 sym
->name
, &c
->loc
);
1570 /* Resolve a subroutine call not known to be generic nor specific. */
1573 resolve_unknown_s (gfc_code
* c
)
1577 sym
= c
->symtree
->n
.sym
;
1579 if (sym
->attr
.dummy
)
1581 sym
->attr
.proc
= PROC_DUMMY
;
1585 /* See if we have an intrinsic function reference. */
1587 if (gfc_intrinsic_name (sym
->name
, 1))
1589 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1594 /* The reference is to an external name. */
1597 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1599 c
->resolved_sym
= sym
;
1601 pure_subroutine (c
, sym
);
1607 /* Resolve a subroutine call. Although it was tempting to use the same code
1608 for functions, subroutines and functions are stored differently and this
1609 makes things awkward. */
1612 resolve_call (gfc_code
* c
)
1616 if (c
->symtree
&& c
->symtree
->n
.sym
1617 && c
->symtree
->n
.sym
->ts
.type
!= BT_UNKNOWN
)
1619 gfc_error ("'%s' at %L has a type, which is not consistent with "
1620 "the CALL at %L", c
->symtree
->n
.sym
->name
,
1621 &c
->symtree
->n
.sym
->declared_at
, &c
->loc
);
1625 /* If the procedure is not internal or module, it must be external and
1626 should be checked for usage. */
1627 if (c
->symtree
&& c
->symtree
->n
.sym
1628 && !c
->symtree
->n
.sym
->attr
.dummy
1629 && !c
->symtree
->n
.sym
->attr
.contained
1630 && !c
->symtree
->n
.sym
->attr
.use_assoc
)
1631 resolve_global_procedure (c
->symtree
->n
.sym
, &c
->loc
, 1);
1633 /* Switch off assumed size checking and do this again for certain kinds
1634 of procedure, once the procedure itself is resolved. */
1635 need_full_assumed_size
++;
1637 if (resolve_actual_arglist (c
->ext
.actual
) == FAILURE
)
1640 /* Resume assumed_size checking. */
1641 need_full_assumed_size
--;
1645 if (c
->resolved_sym
== NULL
)
1646 switch (procedure_kind (c
->symtree
->n
.sym
))
1649 t
= resolve_generic_s (c
);
1652 case PTYPE_SPECIFIC
:
1653 t
= resolve_specific_s (c
);
1657 t
= resolve_unknown_s (c
);
1661 gfc_internal_error ("resolve_subroutine(): bad function type");
1664 if (c
->ext
.actual
!= NULL
1665 && c
->symtree
->n
.sym
->attr
.elemental
)
1667 gfc_actual_arglist
* a
;
1668 /* Being elemental, the last upper bound of an assumed size array
1669 argument must be present. */
1670 for (a
= c
->ext
.actual
; a
; a
= a
->next
)
1673 && a
->expr
->rank
> 0
1674 && resolve_assumed_size_actual (a
->expr
))
1680 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
1684 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1685 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1686 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1687 if their shapes do not match. If either op1->shape or op2->shape is
1688 NULL, return SUCCESS. */
1691 compare_shapes (gfc_expr
* op1
, gfc_expr
* op2
)
1698 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
1700 for (i
= 0; i
< op1
->rank
; i
++)
1702 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
1704 gfc_error ("Shapes for operands at %L and %L are not conformable",
1705 &op1
->where
, &op2
->where
);
1715 /* Resolve an operator expression node. This can involve replacing the
1716 operation with a user defined function call. */
1719 resolve_operator (gfc_expr
* e
)
1721 gfc_expr
*op1
, *op2
;
1725 /* Resolve all subnodes-- give them types. */
1727 switch (e
->value
.op
.operator)
1730 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
1733 /* Fall through... */
1736 case INTRINSIC_UPLUS
:
1737 case INTRINSIC_UMINUS
:
1738 case INTRINSIC_PARENTHESES
:
1739 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
1744 /* Typecheck the new node. */
1746 op1
= e
->value
.op
.op1
;
1747 op2
= e
->value
.op
.op2
;
1749 switch (e
->value
.op
.operator)
1751 case INTRINSIC_UPLUS
:
1752 case INTRINSIC_UMINUS
:
1753 if (op1
->ts
.type
== BT_INTEGER
1754 || op1
->ts
.type
== BT_REAL
1755 || op1
->ts
.type
== BT_COMPLEX
)
1761 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
1762 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
1765 case INTRINSIC_PLUS
:
1766 case INTRINSIC_MINUS
:
1767 case INTRINSIC_TIMES
:
1768 case INTRINSIC_DIVIDE
:
1769 case INTRINSIC_POWER
:
1770 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1772 gfc_type_convert_binary (e
);
1777 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1778 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1779 gfc_typename (&op2
->ts
));
1782 case INTRINSIC_CONCAT
:
1783 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1785 e
->ts
.type
= BT_CHARACTER
;
1786 e
->ts
.kind
= op1
->ts
.kind
;
1791 _("Operands of string concatenation operator at %%L are %s/%s"),
1792 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
1798 case INTRINSIC_NEQV
:
1799 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
1801 e
->ts
.type
= BT_LOGICAL
;
1802 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
1803 if (op1
->ts
.kind
< e
->ts
.kind
)
1804 gfc_convert_type (op1
, &e
->ts
, 2);
1805 else if (op2
->ts
.kind
< e
->ts
.kind
)
1806 gfc_convert_type (op2
, &e
->ts
, 2);
1810 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
1811 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1812 gfc_typename (&op2
->ts
));
1817 if (op1
->ts
.type
== BT_LOGICAL
)
1819 e
->ts
.type
= BT_LOGICAL
;
1820 e
->ts
.kind
= op1
->ts
.kind
;
1824 sprintf (msg
, _("Operand of .NOT. operator at %%L is %s"),
1825 gfc_typename (&op1
->ts
));
1832 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
1834 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
1838 /* Fall through... */
1842 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
1844 e
->ts
.type
= BT_LOGICAL
;
1845 e
->ts
.kind
= gfc_default_logical_kind
;
1849 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1851 gfc_type_convert_binary (e
);
1853 e
->ts
.type
= BT_LOGICAL
;
1854 e
->ts
.kind
= gfc_default_logical_kind
;
1858 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
1860 _("Logicals at %%L must be compared with %s instead of %s"),
1861 e
->value
.op
.operator == INTRINSIC_EQ
? ".EQV." : ".NEQV.",
1862 gfc_op2string (e
->value
.op
.operator));
1865 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1866 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
1867 gfc_typename (&op2
->ts
));
1871 case INTRINSIC_USER
:
1873 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
1874 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
1876 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
1877 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
1878 gfc_typename (&op2
->ts
));
1882 case INTRINSIC_PARENTHESES
:
1886 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1889 /* Deal with arrayness of an operand through an operator. */
1893 switch (e
->value
.op
.operator)
1895 case INTRINSIC_PLUS
:
1896 case INTRINSIC_MINUS
:
1897 case INTRINSIC_TIMES
:
1898 case INTRINSIC_DIVIDE
:
1899 case INTRINSIC_POWER
:
1900 case INTRINSIC_CONCAT
:
1904 case INTRINSIC_NEQV
:
1912 if (op1
->rank
== 0 && op2
->rank
== 0)
1915 if (op1
->rank
== 0 && op2
->rank
!= 0)
1917 e
->rank
= op2
->rank
;
1919 if (e
->shape
== NULL
)
1920 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
1923 if (op1
->rank
!= 0 && op2
->rank
== 0)
1925 e
->rank
= op1
->rank
;
1927 if (e
->shape
== NULL
)
1928 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1931 if (op1
->rank
!= 0 && op2
->rank
!= 0)
1933 if (op1
->rank
== op2
->rank
)
1935 e
->rank
= op1
->rank
;
1936 if (e
->shape
== NULL
)
1938 t
= compare_shapes(op1
, op2
);
1942 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1947 gfc_error ("Inconsistent ranks for operator at %L and %L",
1948 &op1
->where
, &op2
->where
);
1951 /* Allow higher level expressions to work. */
1959 case INTRINSIC_UPLUS
:
1960 case INTRINSIC_UMINUS
:
1961 case INTRINSIC_PARENTHESES
:
1962 e
->rank
= op1
->rank
;
1964 if (e
->shape
== NULL
)
1965 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
1967 /* Simply copy arrayness attribute */
1974 /* Attempt to simplify the expression. */
1976 t
= gfc_simplify_expr (e
, 0);
1981 if (gfc_extend_expr (e
) == SUCCESS
)
1984 gfc_error (msg
, &e
->where
);
1990 /************** Array resolution subroutines **************/
1994 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
1997 /* Compare two integer expressions. */
2000 compare_bound (gfc_expr
* a
, gfc_expr
* b
)
2004 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
2005 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
2008 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
2009 gfc_internal_error ("compare_bound(): Bad expression");
2011 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
2021 /* Compare an integer expression with an integer. */
2024 compare_bound_int (gfc_expr
* a
, int b
)
2028 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
2031 if (a
->ts
.type
!= BT_INTEGER
)
2032 gfc_internal_error ("compare_bound_int(): Bad expression");
2034 i
= mpz_cmp_si (a
->value
.integer
, b
);
2044 /* Compare a single dimension of an array reference to the array
2048 check_dimension (int i
, gfc_array_ref
* ar
, gfc_array_spec
* as
)
2051 /* Given start, end and stride values, calculate the minimum and
2052 maximum referenced indexes. */
2060 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
2062 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
2068 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
2070 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
2074 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
2076 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
2079 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
2080 it is legal (see 6.2.2.3.1). */
2085 gfc_internal_error ("check_dimension(): Bad array reference");
2091 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
2096 /* Compare an array reference with an array specification. */
2099 compare_spec_to_ref (gfc_array_ref
* ar
)
2106 /* TODO: Full array sections are only allowed as actual parameters. */
2107 if (as
->type
== AS_ASSUMED_SIZE
2108 && (/*ar->type == AR_FULL
2109 ||*/ (ar
->type
== AR_SECTION
2110 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
2112 gfc_error ("Rightmost upper bound of assumed size array section"
2113 " not specified at %L", &ar
->where
);
2117 if (ar
->type
== AR_FULL
)
2120 if (as
->rank
!= ar
->dimen
)
2122 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2123 &ar
->where
, ar
->dimen
, as
->rank
);
2127 for (i
= 0; i
< as
->rank
; i
++)
2128 if (check_dimension (i
, ar
, as
) == FAILURE
)
2135 /* Resolve one part of an array index. */
2138 gfc_resolve_index (gfc_expr
* index
, int check_scalar
)
2145 if (gfc_resolve_expr (index
) == FAILURE
)
2148 if (check_scalar
&& index
->rank
!= 0)
2150 gfc_error ("Array index at %L must be scalar", &index
->where
);
2154 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
2156 gfc_error ("Array index at %L must be of INTEGER type",
2161 if (index
->ts
.type
== BT_REAL
)
2162 if (gfc_notify_std (GFC_STD_GNU
, "Extension: REAL array index at %L",
2163 &index
->where
) == FAILURE
)
2166 if (index
->ts
.kind
!= gfc_index_integer_kind
2167 || index
->ts
.type
!= BT_INTEGER
)
2170 ts
.type
= BT_INTEGER
;
2171 ts
.kind
= gfc_index_integer_kind
;
2173 gfc_convert_type_warn (index
, &ts
, 2, 0);
2179 /* Resolve a dim argument to an intrinsic function. */
2182 gfc_resolve_dim_arg (gfc_expr
*dim
)
2187 if (gfc_resolve_expr (dim
) == FAILURE
)
2192 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
2196 if (dim
->ts
.type
!= BT_INTEGER
)
2198 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
2201 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
2205 ts
.type
= BT_INTEGER
;
2206 ts
.kind
= gfc_index_integer_kind
;
2208 gfc_convert_type_warn (dim
, &ts
, 2, 0);
2214 /* Given an expression that contains array references, update those array
2215 references to point to the right array specifications. While this is
2216 filled in during matching, this information is difficult to save and load
2217 in a module, so we take care of it here.
2219 The idea here is that the original array reference comes from the
2220 base symbol. We traverse the list of reference structures, setting
2221 the stored reference to references. Component references can
2222 provide an additional array specification. */
2225 find_array_spec (gfc_expr
* e
)
2231 as
= e
->symtree
->n
.sym
->as
;
2233 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2238 gfc_internal_error ("find_array_spec(): Missing spec");
2245 for (c
= e
->symtree
->n
.sym
->ts
.derived
->components
; c
; c
= c
->next
)
2246 if (c
== ref
->u
.c
.component
)
2250 gfc_internal_error ("find_array_spec(): Component not found");
2255 gfc_internal_error ("find_array_spec(): unused as(1)");
2266 gfc_internal_error ("find_array_spec(): unused as(2)");
2270 /* Resolve an array reference. */
2273 resolve_array_ref (gfc_array_ref
* ar
)
2275 int i
, check_scalar
;
2277 for (i
= 0; i
< ar
->dimen
; i
++)
2279 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
2281 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
2283 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
2285 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
2288 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
2289 switch (ar
->start
[i
]->rank
)
2292 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2296 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
2300 gfc_error ("Array index at %L is an array of rank %d",
2301 &ar
->c_where
[i
], ar
->start
[i
]->rank
);
2306 /* If the reference type is unknown, figure out what kind it is. */
2308 if (ar
->type
== AR_UNKNOWN
)
2310 ar
->type
= AR_ELEMENT
;
2311 for (i
= 0; i
< ar
->dimen
; i
++)
2312 if (ar
->dimen_type
[i
] == DIMEN_RANGE
2313 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2315 ar
->type
= AR_SECTION
;
2320 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
2328 resolve_substring (gfc_ref
* ref
)
2331 if (ref
->u
.ss
.start
!= NULL
)
2333 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
2336 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
2338 gfc_error ("Substring start index at %L must be of type INTEGER",
2339 &ref
->u
.ss
.start
->where
);
2343 if (ref
->u
.ss
.start
->rank
!= 0)
2345 gfc_error ("Substring start index at %L must be scalar",
2346 &ref
->u
.ss
.start
->where
);
2350 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
)
2352 gfc_error ("Substring start index at %L is less than one",
2353 &ref
->u
.ss
.start
->where
);
2358 if (ref
->u
.ss
.end
!= NULL
)
2360 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
2363 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
2365 gfc_error ("Substring end index at %L must be of type INTEGER",
2366 &ref
->u
.ss
.end
->where
);
2370 if (ref
->u
.ss
.end
->rank
!= 0)
2372 gfc_error ("Substring end index at %L must be scalar",
2373 &ref
->u
.ss
.end
->where
);
2377 if (ref
->u
.ss
.length
!= NULL
2378 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
)
2380 gfc_error ("Substring end index at %L is out of bounds",
2381 &ref
->u
.ss
.start
->where
);
2390 /* Resolve subtype references. */
2393 resolve_ref (gfc_expr
* expr
)
2395 int current_part_dimension
, n_components
, seen_part_dimension
;
2398 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2399 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
2401 find_array_spec (expr
);
2405 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2409 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
2417 resolve_substring (ref
);
2421 /* Check constraints on part references. */
2423 current_part_dimension
= 0;
2424 seen_part_dimension
= 0;
2427 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2432 switch (ref
->u
.ar
.type
)
2436 current_part_dimension
= 1;
2440 current_part_dimension
= 0;
2444 gfc_internal_error ("resolve_ref(): Bad array reference");
2450 if ((current_part_dimension
|| seen_part_dimension
)
2451 && ref
->u
.c
.component
->pointer
)
2454 ("Component to the right of a part reference with nonzero "
2455 "rank must not have the POINTER attribute at %L",
2467 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
2468 || ref
->next
== NULL
)
2469 && current_part_dimension
2470 && seen_part_dimension
)
2473 gfc_error ("Two or more part references with nonzero rank must "
2474 "not be specified at %L", &expr
->where
);
2478 if (ref
->type
== REF_COMPONENT
)
2480 if (current_part_dimension
)
2481 seen_part_dimension
= 1;
2483 /* reset to make sure */
2484 current_part_dimension
= 0;
2492 /* Given an expression, determine its shape. This is easier than it sounds.
2493 Leaves the shape array NULL if it is not possible to determine the shape. */
2496 expression_shape (gfc_expr
* e
)
2498 mpz_t array
[GFC_MAX_DIMENSIONS
];
2501 if (e
->rank
== 0 || e
->shape
!= NULL
)
2504 for (i
= 0; i
< e
->rank
; i
++)
2505 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2508 e
->shape
= gfc_get_shape (e
->rank
);
2510 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
2515 for (i
--; i
>= 0; i
--)
2516 mpz_clear (array
[i
]);
2520 /* Given a variable expression node, compute the rank of the expression by
2521 examining the base symbol and any reference structures it may have. */
2524 expression_rank (gfc_expr
* e
)
2531 if (e
->expr_type
== EXPR_ARRAY
)
2533 /* Constructors can have a rank different from one via RESHAPE(). */
2535 if (e
->symtree
== NULL
)
2541 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
2542 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
2548 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2550 if (ref
->type
!= REF_ARRAY
)
2553 if (ref
->u
.ar
.type
== AR_FULL
)
2555 rank
= ref
->u
.ar
.as
->rank
;
2559 if (ref
->u
.ar
.type
== AR_SECTION
)
2561 /* Figure out the rank of the section. */
2563 gfc_internal_error ("expression_rank(): Two array specs");
2565 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2566 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
2567 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2577 expression_shape (e
);
2581 /* Resolve a variable expression. */
2584 resolve_variable (gfc_expr
* e
)
2588 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
2591 if (e
->symtree
== NULL
)
2594 sym
= e
->symtree
->n
.sym
;
2595 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2597 e
->ts
.type
= BT_PROCEDURE
;
2601 if (sym
->ts
.type
!= BT_UNKNOWN
)
2602 gfc_variable_attr (e
, &e
->ts
);
2605 /* Must be a simple variable reference. */
2606 if (gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2611 if (check_assumed_size_reference (sym
, e
))
2618 /* Resolve an expression. That is, make sure that types of operands agree
2619 with their operators, intrinsic operators are converted to function calls
2620 for overloaded types and unresolved function references are resolved. */
2623 gfc_resolve_expr (gfc_expr
* e
)
2630 switch (e
->expr_type
)
2633 t
= resolve_operator (e
);
2637 t
= resolve_function (e
);
2641 t
= resolve_variable (e
);
2643 expression_rank (e
);
2646 case EXPR_SUBSTRING
:
2647 t
= resolve_ref (e
);
2657 if (resolve_ref (e
) == FAILURE
)
2660 t
= gfc_resolve_array_constructor (e
);
2661 /* Also try to expand a constructor. */
2664 expression_rank (e
);
2665 gfc_expand_constructor (e
);
2670 case EXPR_STRUCTURE
:
2671 t
= resolve_ref (e
);
2675 t
= resolve_structure_cons (e
);
2679 t
= gfc_simplify_expr (e
, 0);
2683 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2690 /* Resolve an expression from an iterator. They must be scalar and have
2691 INTEGER or (optionally) REAL type. */
2694 gfc_resolve_iterator_expr (gfc_expr
* expr
, bool real_ok
,
2695 const char * name_msgid
)
2697 if (gfc_resolve_expr (expr
) == FAILURE
)
2700 if (expr
->rank
!= 0)
2702 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
2706 if (!(expr
->ts
.type
== BT_INTEGER
2707 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
2710 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid
),
2713 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
2720 /* Resolve the expressions in an iterator structure. If REAL_OK is
2721 false allow only INTEGER type iterators, otherwise allow REAL types. */
2724 gfc_resolve_iterator (gfc_iterator
* iter
, bool real_ok
)
2727 if (iter
->var
->ts
.type
== BT_REAL
)
2728 gfc_notify_std (GFC_STD_F95_DEL
,
2729 "Obsolete: REAL DO loop iterator at %L",
2732 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
2736 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
2738 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2743 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
2744 "Start expression in DO loop") == FAILURE
)
2747 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
2748 "End expression in DO loop") == FAILURE
)
2751 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
2752 "Step expression in DO loop") == FAILURE
)
2755 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
2757 if ((iter
->step
->ts
.type
== BT_INTEGER
2758 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
2759 || (iter
->step
->ts
.type
== BT_REAL
2760 && mpfr_sgn (iter
->step
->value
.real
) == 0))
2762 gfc_error ("Step expression in DO loop at %L cannot be zero",
2763 &iter
->step
->where
);
2768 /* Convert start, end, and step to the same type as var. */
2769 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
2770 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
2771 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2773 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
2774 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
2775 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2777 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
2778 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
2779 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
2785 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
2786 to be a scalar INTEGER variable. The subscripts and stride are scalar
2787 INTEGERs, and if stride is a constant it must be nonzero. */
2790 resolve_forall_iterators (gfc_forall_iterator
* iter
)
2795 if (gfc_resolve_expr (iter
->var
) == SUCCESS
2796 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
2797 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
2800 if (gfc_resolve_expr (iter
->start
) == SUCCESS
2801 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
2802 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
2803 &iter
->start
->where
);
2804 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
2805 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
2807 if (gfc_resolve_expr (iter
->end
) == SUCCESS
2808 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
2809 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
2811 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
2812 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
2814 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
2816 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
2817 gfc_error ("FORALL stride expression at %L must be a scalar %s",
2818 &iter
->stride
->where
, "INTEGER");
2820 if (iter
->stride
->expr_type
== EXPR_CONSTANT
2821 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
2822 gfc_error ("FORALL stride expression at %L cannot be zero",
2823 &iter
->stride
->where
);
2825 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
2826 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
2833 /* Given a pointer to a symbol that is a derived type, see if any components
2834 have the POINTER attribute. The search is recursive if necessary.
2835 Returns zero if no pointer components are found, nonzero otherwise. */
2838 derived_pointer (gfc_symbol
* sym
)
2842 for (c
= sym
->components
; c
; c
= c
->next
)
2847 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
2855 /* Given a pointer to a symbol that is a derived type, see if it's
2856 inaccessible, i.e. if it's defined in another module and the components are
2857 PRIVATE. The search is recursive if necessary. Returns zero if no
2858 inaccessible components are found, nonzero otherwise. */
2861 derived_inaccessible (gfc_symbol
*sym
)
2865 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
2868 for (c
= sym
->components
; c
; c
= c
->next
)
2870 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
2878 /* Resolve the argument of a deallocate expression. The expression must be
2879 a pointer or a full array. */
2882 resolve_deallocate_expr (gfc_expr
* e
)
2884 symbol_attribute attr
;
2888 if (gfc_resolve_expr (e
) == FAILURE
)
2891 attr
= gfc_expr_attr (e
);
2895 if (e
->expr_type
!= EXPR_VARIABLE
)
2898 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2899 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2903 if (ref
->u
.ar
.type
!= AR_FULL
)
2908 allocatable
= (ref
->u
.c
.component
->as
!= NULL
2909 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
2917 if (allocatable
== 0)
2920 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2921 "ALLOCATABLE or a POINTER", &e
->where
);
2924 if (e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2926 gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
2927 e
->symtree
->n
.sym
->name
, &e
->where
);
2935 /* Given the expression node e for an allocatable/pointer of derived type to be
2936 allocated, get the expression node to be initialized afterwards (needed for
2937 derived types with default initializers). */
2940 expr_to_initialize (gfc_expr
* e
)
2946 result
= gfc_copy_expr (e
);
2948 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
2949 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
2950 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
2952 ref
->u
.ar
.type
= AR_FULL
;
2954 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2955 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
2957 result
->rank
= ref
->u
.ar
.dimen
;
2965 /* Resolve the expression in an ALLOCATE statement, doing the additional
2966 checks to see whether the expression is OK or not. The expression must
2967 have a trailing array reference that gives the size of the array. */
2970 resolve_allocate_expr (gfc_expr
* e
, gfc_code
* code
)
2972 int i
, pointer
, allocatable
, dimension
;
2973 symbol_attribute attr
;
2974 gfc_ref
*ref
, *ref2
;
2979 if (gfc_resolve_expr (e
) == FAILURE
)
2982 /* Make sure the expression is allocatable or a pointer. If it is
2983 pointer, the next-to-last reference must be a pointer. */
2987 if (e
->expr_type
!= EXPR_VARIABLE
)
2991 attr
= gfc_expr_attr (e
);
2992 pointer
= attr
.pointer
;
2993 dimension
= attr
.dimension
;
2998 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
2999 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
3000 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
3002 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
3006 if (ref
->next
!= NULL
)
3011 allocatable
= (ref
->u
.c
.component
->as
!= NULL
3012 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
3014 pointer
= ref
->u
.c
.component
->pointer
;
3015 dimension
= ref
->u
.c
.component
->dimension
;
3025 if (allocatable
== 0 && pointer
== 0)
3027 gfc_error ("Expression in ALLOCATE statement at %L must be "
3028 "ALLOCATABLE or a POINTER", &e
->where
);
3032 if (e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3034 gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
3035 e
->symtree
->n
.sym
->name
, &e
->where
);
3039 /* Add default initializer for those derived types that need them. */
3040 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
3042 init_st
= gfc_get_code ();
3043 init_st
->loc
= code
->loc
;
3044 init_st
->op
= EXEC_ASSIGN
;
3045 init_st
->expr
= expr_to_initialize (e
);
3046 init_st
->expr2
= init_e
;
3048 init_st
->next
= code
->next
;
3049 code
->next
= init_st
;
3052 if (pointer
&& dimension
== 0)
3055 /* Make sure the next-to-last reference node is an array specification. */
3057 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
3059 gfc_error ("Array specification required in ALLOCATE statement "
3060 "at %L", &e
->where
);
3064 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
3067 /* Make sure that the array section reference makes sense in the
3068 context of an ALLOCATE specification. */
3072 for (i
= 0; i
< ar
->dimen
; i
++)
3073 switch (ar
->dimen_type
[i
])
3079 if (ar
->start
[i
] != NULL
3080 && ar
->end
[i
] != NULL
3081 && ar
->stride
[i
] == NULL
)
3084 /* Fall Through... */
3088 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3097 /************ SELECT CASE resolution subroutines ************/
3099 /* Callback function for our mergesort variant. Determines interval
3100 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3101 op1 > op2. Assumes we're not dealing with the default case.
3102 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3103 There are nine situations to check. */
3106 compare_cases (const gfc_case
* op1
, const gfc_case
* op2
)
3110 if (op1
->low
== NULL
) /* op1 = (:L) */
3112 /* op2 = (:N), so overlap. */
3114 /* op2 = (M:) or (M:N), L < M */
3115 if (op2
->low
!= NULL
3116 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3119 else if (op1
->high
== NULL
) /* op1 = (K:) */
3121 /* op2 = (M:), so overlap. */
3123 /* op2 = (:N) or (M:N), K > N */
3124 if (op2
->high
!= NULL
3125 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3128 else /* op1 = (K:L) */
3130 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
3131 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
3132 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
3133 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
3134 else /* op2 = (M:N) */
3138 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3141 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3150 /* Merge-sort a double linked case list, detecting overlap in the
3151 process. LIST is the head of the double linked case list before it
3152 is sorted. Returns the head of the sorted list if we don't see any
3153 overlap, or NULL otherwise. */
3156 check_case_overlap (gfc_case
* list
)
3158 gfc_case
*p
, *q
, *e
, *tail
;
3159 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
3161 /* If the passed list was empty, return immediately. */
3168 /* Loop unconditionally. The only exit from this loop is a return
3169 statement, when we've finished sorting the case list. */
3176 /* Count the number of merges we do in this pass. */
3179 /* Loop while there exists a merge to be done. */
3184 /* Count this merge. */
3187 /* Cut the list in two pieces by stepping INSIZE places
3188 forward in the list, starting from P. */
3191 for (i
= 0; i
< insize
; i
++)
3200 /* Now we have two lists. Merge them! */
3201 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
3204 /* See from which the next case to merge comes from. */
3207 /* P is empty so the next case must come from Q. */
3212 else if (qsize
== 0 || q
== NULL
)
3221 cmp
= compare_cases (p
, q
);
3224 /* The whole case range for P is less than the
3232 /* The whole case range for Q is greater than
3233 the case range for P. */
3240 /* The cases overlap, or they are the same
3241 element in the list. Either way, we must
3242 issue an error and get the next case from P. */
3243 /* FIXME: Sort P and Q by line number. */
3244 gfc_error ("CASE label at %L overlaps with CASE "
3245 "label at %L", &p
->where
, &q
->where
);
3253 /* Add the next element to the merged list. */
3262 /* P has now stepped INSIZE places along, and so has Q. So
3263 they're the same. */
3268 /* If we have done only one merge or none at all, we've
3269 finished sorting the cases. */
3278 /* Otherwise repeat, merging lists twice the size. */
3284 /* Check to see if an expression is suitable for use in a CASE statement.
3285 Makes sure that all case expressions are scalar constants of the same
3286 type. Return FAILURE if anything is wrong. */
3289 validate_case_label_expr (gfc_expr
* e
, gfc_expr
* case_expr
)
3291 if (e
== NULL
) return SUCCESS
;
3293 if (e
->ts
.type
!= case_expr
->ts
.type
)
3295 gfc_error ("Expression in CASE statement at %L must be of type %s",
3296 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
3300 /* C805 (R808) For a given case-construct, each case-value shall be of
3301 the same type as case-expr. For character type, length differences
3302 are allowed, but the kind type parameters shall be the same. */
3304 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
3306 gfc_error("Expression in CASE statement at %L must be kind %d",
3307 &e
->where
, case_expr
->ts
.kind
);
3311 /* Convert the case value kind to that of case expression kind, if needed.
3312 FIXME: Should a warning be issued? */
3313 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
3314 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
3318 gfc_error ("Expression in CASE statement at %L must be scalar",
3327 /* Given a completely parsed select statement, we:
3329 - Validate all expressions and code within the SELECT.
3330 - Make sure that the selection expression is not of the wrong type.
3331 - Make sure that no case ranges overlap.
3332 - Eliminate unreachable cases and unreachable code resulting from
3333 removing case labels.
3335 The standard does allow unreachable cases, e.g. CASE (5:3). But
3336 they are a hassle for code generation, and to prevent that, we just
3337 cut them out here. This is not necessary for overlapping cases
3338 because they are illegal and we never even try to generate code.
3340 We have the additional caveat that a SELECT construct could have
3341 been a computed GOTO in the source code. Fortunately we can fairly
3342 easily work around that here: The case_expr for a "real" SELECT CASE
3343 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3344 we have to do is make sure that the case_expr is a scalar integer
3348 resolve_select (gfc_code
* code
)
3351 gfc_expr
*case_expr
;
3352 gfc_case
*cp
, *default_case
, *tail
, *head
;
3353 int seen_unreachable
;
3358 if (code
->expr
== NULL
)
3360 /* This was actually a computed GOTO statement. */
3361 case_expr
= code
->expr2
;
3362 if (case_expr
->ts
.type
!= BT_INTEGER
3363 || case_expr
->rank
!= 0)
3364 gfc_error ("Selection expression in computed GOTO statement "
3365 "at %L must be a scalar integer expression",
3368 /* Further checking is not necessary because this SELECT was built
3369 by the compiler, so it should always be OK. Just move the
3370 case_expr from expr2 to expr so that we can handle computed
3371 GOTOs as normal SELECTs from here on. */
3372 code
->expr
= code
->expr2
;
3377 case_expr
= code
->expr
;
3379 type
= case_expr
->ts
.type
;
3380 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
3382 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3383 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
3385 /* Punt. Going on here just produce more garbage error messages. */
3389 if (case_expr
->rank
!= 0)
3391 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3392 "expression", &case_expr
->where
);
3398 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3399 of the SELECT CASE expression and its CASE values. Walk the lists
3400 of case values, and if we find a mismatch, promote case_expr to
3401 the appropriate kind. */
3403 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
3405 for (body
= code
->block
; body
; body
= body
->block
)
3407 /* Walk the case label list. */
3408 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
3410 /* Intercept the DEFAULT case. It does not have a kind. */
3411 if (cp
->low
== NULL
&& cp
->high
== NULL
)
3414 /* Unreachable case ranges are discarded, so ignore. */
3415 if (cp
->low
!= NULL
&& cp
->high
!= NULL
3416 && cp
->low
!= cp
->high
3417 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
3420 /* FIXME: Should a warning be issued? */
3422 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
3423 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
3425 if (cp
->high
!= NULL
3426 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
3427 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
3432 /* Assume there is no DEFAULT case. */
3433 default_case
= NULL
;
3437 for (body
= code
->block
; body
; body
= body
->block
)
3439 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3441 seen_unreachable
= 0;
3443 /* Walk the case label list, making sure that all case labels
3445 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
3447 /* Count the number of cases in the whole construct. */
3450 /* Intercept the DEFAULT case. */
3451 if (cp
->low
== NULL
&& cp
->high
== NULL
)
3453 if (default_case
!= NULL
)
3455 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3456 "by a second DEFAULT CASE at %L",
3457 &default_case
->where
, &cp
->where
);
3468 /* Deal with single value cases and case ranges. Errors are
3469 issued from the validation function. */
3470 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
3471 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
3477 if (type
== BT_LOGICAL
3478 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
3479 || cp
->low
!= cp
->high
))
3482 ("Logical range in CASE statement at %L is not allowed",
3488 if (cp
->low
!= NULL
&& cp
->high
!= NULL
3489 && cp
->low
!= cp
->high
3490 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
3492 if (gfc_option
.warn_surprising
)
3493 gfc_warning ("Range specification at %L can never "
3494 "be matched", &cp
->where
);
3496 cp
->unreachable
= 1;
3497 seen_unreachable
= 1;
3501 /* If the case range can be matched, it can also overlap with
3502 other cases. To make sure it does not, we put it in a
3503 double linked list here. We sort that with a merge sort
3504 later on to detect any overlapping cases. */
3508 head
->right
= head
->left
= NULL
;
3513 tail
->right
->left
= tail
;
3520 /* It there was a failure in the previous case label, give up
3521 for this case label list. Continue with the next block. */
3525 /* See if any case labels that are unreachable have been seen.
3526 If so, we eliminate them. This is a bit of a kludge because
3527 the case lists for a single case statement (label) is a
3528 single forward linked lists. */
3529 if (seen_unreachable
)
3531 /* Advance until the first case in the list is reachable. */
3532 while (body
->ext
.case_list
!= NULL
3533 && body
->ext
.case_list
->unreachable
)
3535 gfc_case
*n
= body
->ext
.case_list
;
3536 body
->ext
.case_list
= body
->ext
.case_list
->next
;
3538 gfc_free_case_list (n
);
3541 /* Strip all other unreachable cases. */
3542 if (body
->ext
.case_list
)
3544 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
3546 if (cp
->next
->unreachable
)
3548 gfc_case
*n
= cp
->next
;
3549 cp
->next
= cp
->next
->next
;
3551 gfc_free_case_list (n
);
3558 /* See if there were overlapping cases. If the check returns NULL,
3559 there was overlap. In that case we don't do anything. If head
3560 is non-NULL, we prepend the DEFAULT case. The sorted list can
3561 then used during code generation for SELECT CASE constructs with
3562 a case expression of a CHARACTER type. */
3565 head
= check_case_overlap (head
);
3567 /* Prepend the default_case if it is there. */
3568 if (head
!= NULL
&& default_case
)
3570 default_case
->left
= NULL
;
3571 default_case
->right
= head
;
3572 head
->left
= default_case
;
3576 /* Eliminate dead blocks that may be the result if we've seen
3577 unreachable case labels for a block. */
3578 for (body
= code
; body
&& body
->block
; body
= body
->block
)
3580 if (body
->block
->ext
.case_list
== NULL
)
3582 /* Cut the unreachable block from the code chain. */
3583 gfc_code
*c
= body
->block
;
3584 body
->block
= c
->block
;
3586 /* Kill the dead block, but not the blocks below it. */
3588 gfc_free_statements (c
);
3592 /* More than two cases is legal but insane for logical selects.
3593 Issue a warning for it. */
3594 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
3596 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3601 /* Resolve a transfer statement. This is making sure that:
3602 -- a derived type being transferred has only non-pointer components
3603 -- a derived type being transferred doesn't have private components, unless
3604 it's being transferred from the module where the type was defined
3605 -- we're not trying to transfer a whole assumed size array. */
3608 resolve_transfer (gfc_code
* code
)
3617 if (exp
->expr_type
!= EXPR_VARIABLE
)
3620 sym
= exp
->symtree
->n
.sym
;
3623 /* Go to actual component transferred. */
3624 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
3625 if (ref
->type
== REF_COMPONENT
)
3626 ts
= &ref
->u
.c
.component
->ts
;
3628 if (ts
->type
== BT_DERIVED
)
3630 /* Check that transferred derived type doesn't contain POINTER
3632 if (derived_pointer (ts
->derived
))
3634 gfc_error ("Data transfer element at %L cannot have "
3635 "POINTER components", &code
->loc
);
3639 if (derived_inaccessible (ts
->derived
))
3641 gfc_error ("Data transfer element at %L cannot have "
3642 "PRIVATE components",&code
->loc
);
3647 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
3648 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
3650 gfc_error ("Data transfer element at %L cannot be a full reference to "
3651 "an assumed-size array", &code
->loc
);
3657 /*********** Toplevel code resolution subroutines ***********/
3659 /* Given a branch to a label and a namespace, if the branch is conforming.
3660 The code node described where the branch is located. */
3663 resolve_branch (gfc_st_label
* label
, gfc_code
* code
)
3665 gfc_code
*block
, *found
;
3673 /* Step one: is this a valid branching target? */
3675 if (lp
->defined
== ST_LABEL_UNKNOWN
)
3677 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
3682 if (lp
->defined
!= ST_LABEL_TARGET
)
3684 gfc_error ("Statement at %L is not a valid branch target statement "
3685 "for the branch statement at %L", &lp
->where
, &code
->loc
);
3689 /* Step two: make sure this branch is not a branch to itself ;-) */
3691 if (code
->here
== label
)
3693 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
3697 /* Step three: Try to find the label in the parse tree. To do this,
3698 we traverse the tree block-by-block: first the block that
3699 contains this GOTO, then the block that it is nested in, etc. We
3700 can ignore other blocks because branching into another block is
3705 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3707 for (block
= stack
->head
; block
; block
= block
->next
)
3709 if (block
->here
== label
)
3722 /* The label is not in an enclosing block, so illegal. This was
3723 allowed in Fortran 66, so we allow it as extension. We also
3724 forego further checks if we run into this. */
3725 gfc_notify_std (GFC_STD_LEGACY
,
3726 "Label at %L is not in the same block as the "
3727 "GOTO statement at %L", &lp
->where
, &code
->loc
);
3731 /* Step four: Make sure that the branching target is legal if
3732 the statement is an END {SELECT,DO,IF}. */
3734 if (found
->op
== EXEC_NOP
)
3736 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
3737 if (stack
->current
->next
== found
)
3741 gfc_notify_std (GFC_STD_F95_DEL
,
3742 "Obsolete: GOTO at %L jumps to END of construct at %L",
3743 &code
->loc
, &found
->loc
);
3748 /* Check whether EXPR1 has the same shape as EXPR2. */
3751 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
3753 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3754 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
3755 try result
= FAILURE
;
3758 /* Compare the rank. */
3759 if (expr1
->rank
!= expr2
->rank
)
3762 /* Compare the size of each dimension. */
3763 for (i
=0; i
<expr1
->rank
; i
++)
3765 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
3768 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
3771 if (mpz_cmp (shape
[i
], shape2
[i
]))
3775 /* When either of the two expression is an assumed size array, we
3776 ignore the comparison of dimension sizes. */
3781 for (i
--; i
>=0; i
--)
3783 mpz_clear (shape
[i
]);
3784 mpz_clear (shape2
[i
]);
3790 /* Check whether a WHERE assignment target or a WHERE mask expression
3791 has the same shape as the outmost WHERE mask expression. */
3794 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
3800 cblock
= code
->block
;
3802 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3803 In case of nested WHERE, only the outmost one is stored. */
3804 if (mask
== NULL
) /* outmost WHERE */
3806 else /* inner WHERE */
3813 /* Check if the mask-expr has a consistent shape with the
3814 outmost WHERE mask-expr. */
3815 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
3816 gfc_error ("WHERE mask at %L has inconsistent shape",
3817 &cblock
->expr
->where
);
3820 /* the assignment statement of a WHERE statement, or the first
3821 statement in where-body-construct of a WHERE construct */
3822 cnext
= cblock
->next
;
3827 /* WHERE assignment statement */
3830 /* Check shape consistent for WHERE assignment target. */
3831 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
3832 gfc_error ("WHERE assignment target at %L has "
3833 "inconsistent shape", &cnext
->expr
->where
);
3836 /* WHERE or WHERE construct is part of a where-body-construct */
3838 resolve_where (cnext
, e
);
3842 gfc_error ("Unsupported statement inside WHERE at %L",
3845 /* the next statement within the same where-body-construct */
3846 cnext
= cnext
->next
;
3848 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3849 cblock
= cblock
->block
;
3854 /* Check whether the FORALL index appears in the expression or not. */
3857 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
3861 gfc_actual_arglist
*args
;
3864 switch (expr
->expr_type
)
3867 gcc_assert (expr
->symtree
->n
.sym
);
3869 /* A scalar assignment */
3872 if (expr
->symtree
->n
.sym
== symbol
)
3878 /* the expr is array ref, substring or struct component. */
3885 /* Check if the symbol appears in the array subscript. */
3887 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3890 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
3894 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
3898 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
3904 if (expr
->symtree
->n
.sym
== symbol
)
3907 /* Check if the symbol appears in the substring section. */
3908 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3910 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3918 gfc_error("expresion reference type error at %L", &expr
->where
);
3924 /* If the expression is a function call, then check if the symbol
3925 appears in the actual arglist of the function. */
3927 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3929 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
3934 /* It seems not to happen. */
3935 case EXPR_SUBSTRING
:
3939 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
3940 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
3942 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
3947 /* It seems not to happen. */
3948 case EXPR_STRUCTURE
:
3950 gfc_error ("Unsupported statement while finding forall index in "
3955 /* Find the FORALL index in the first operand. */
3956 if (expr
->value
.op
.op1
)
3958 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
3962 /* Find the FORALL index in the second operand. */
3963 if (expr
->value
.op
.op2
)
3965 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
3978 /* Resolve assignment in FORALL construct.
3979 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3980 FORALL index variables. */
3983 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
3987 for (n
= 0; n
< nvar
; n
++)
3989 gfc_symbol
*forall_index
;
3991 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
3993 /* Check whether the assignment target is one of the FORALL index
3995 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
3996 && (code
->expr
->symtree
->n
.sym
== forall_index
))
3997 gfc_error ("Assignment to a FORALL index variable at %L",
3998 &code
->expr
->where
);
4001 /* If one of the FORALL index variables doesn't appear in the
4002 assignment target, then there will be a many-to-one
4004 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
4005 gfc_error ("The FORALL with index '%s' cause more than one "
4006 "assignment to this object at %L",
4007 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
4013 /* Resolve WHERE statement in FORALL construct. */
4016 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
){
4020 cblock
= code
->block
;
4023 /* the assignment statement of a WHERE statement, or the first
4024 statement in where-body-construct of a WHERE construct */
4025 cnext
= cblock
->next
;
4030 /* WHERE assignment statement */
4032 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
4035 /* WHERE or WHERE construct is part of a where-body-construct */
4037 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
4041 gfc_error ("Unsupported statement inside WHERE at %L",
4044 /* the next statement within the same where-body-construct */
4045 cnext
= cnext
->next
;
4047 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4048 cblock
= cblock
->block
;
4053 /* Traverse the FORALL body to check whether the following errors exist:
4054 1. For assignment, check if a many-to-one assignment happens.
4055 2. For WHERE statement, check the WHERE body to see if there is any
4056 many-to-one assignment. */
4059 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4063 c
= code
->block
->next
;
4069 case EXEC_POINTER_ASSIGN
:
4070 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
4073 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4074 there is no need to handle it here. */
4078 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
4083 /* The next statement in the FORALL body. */
4089 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4090 gfc_resolve_forall_body to resolve the FORALL body. */
4093 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
4095 static gfc_expr
**var_expr
;
4096 static int total_var
= 0;
4097 static int nvar
= 0;
4098 gfc_forall_iterator
*fa
;
4099 gfc_symbol
*forall_index
;
4103 /* Start to resolve a FORALL construct */
4104 if (forall_save
== 0)
4106 /* Count the total number of FORALL index in the nested FORALL
4107 construct in order to allocate the VAR_EXPR with proper size. */
4109 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
4111 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4113 next
= next
->block
->next
;
4116 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4117 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
4120 /* The information about FORALL iterator, including FORALL index start, end
4121 and stride. The FORALL index can not appear in start, end or stride. */
4122 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4124 /* Check if any outer FORALL index name is the same as the current
4126 for (i
= 0; i
< nvar
; i
++)
4128 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
4130 gfc_error ("An outer FORALL construct already has an index "
4131 "with this name %L", &fa
->var
->where
);
4135 /* Record the current FORALL index. */
4136 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
4138 forall_index
= fa
->var
->symtree
->n
.sym
;
4140 /* Check if the FORALL index appears in start, end or stride. */
4141 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
4142 gfc_error ("A FORALL index must not appear in a limit or stride "
4143 "expression in the same FORALL at %L", &fa
->start
->where
);
4144 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
4145 gfc_error ("A FORALL index must not appear in a limit or stride "
4146 "expression in the same FORALL at %L", &fa
->end
->where
);
4147 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
4148 gfc_error ("A FORALL index must not appear in a limit or stride "
4149 "expression in the same FORALL at %L", &fa
->stride
->where
);
4153 /* Resolve the FORALL body. */
4154 gfc_resolve_forall_body (code
, nvar
, var_expr
);
4156 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4157 gfc_resolve_blocks (code
->block
, ns
);
4159 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4160 for (i
= 0; i
< total_var
; i
++)
4161 gfc_free_expr (var_expr
[i
]);
4163 /* Reset the counters. */
4169 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4172 static void resolve_code (gfc_code
*, gfc_namespace
*);
4175 gfc_resolve_blocks (gfc_code
* b
, gfc_namespace
* ns
)
4179 for (; b
; b
= b
->block
)
4181 t
= gfc_resolve_expr (b
->expr
);
4182 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
4188 if (t
== SUCCESS
&& b
->expr
!= NULL
4189 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
4191 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
4198 && (b
->expr
->ts
.type
!= BT_LOGICAL
4199 || b
->expr
->rank
== 0))
4201 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4206 resolve_branch (b
->label
, b
);
4218 case EXEC_OMP_ATOMIC
:
4219 case EXEC_OMP_CRITICAL
:
4221 case EXEC_OMP_MASTER
:
4222 case EXEC_OMP_ORDERED
:
4223 case EXEC_OMP_PARALLEL
:
4224 case EXEC_OMP_PARALLEL_DO
:
4225 case EXEC_OMP_PARALLEL_SECTIONS
:
4226 case EXEC_OMP_PARALLEL_WORKSHARE
:
4227 case EXEC_OMP_SECTIONS
:
4228 case EXEC_OMP_SINGLE
:
4229 case EXEC_OMP_WORKSHARE
:
4233 gfc_internal_error ("resolve_block(): Bad block type");
4236 resolve_code (b
->next
, ns
);
4241 /* Given a block of code, recursively resolve everything pointed to by this
4245 resolve_code (gfc_code
* code
, gfc_namespace
* ns
)
4247 int omp_workshare_save
;
4252 frame
.prev
= cs_base
;
4256 for (; code
; code
= code
->next
)
4258 frame
.current
= code
;
4260 if (code
->op
== EXEC_FORALL
)
4262 int forall_save
= forall_flag
;
4265 gfc_resolve_forall (code
, ns
, forall_save
);
4266 forall_flag
= forall_save
;
4268 else if (code
->block
)
4270 omp_workshare_save
= -1;
4273 case EXEC_OMP_PARALLEL_WORKSHARE
:
4274 omp_workshare_save
= omp_workshare_flag
;
4275 omp_workshare_flag
= 1;
4276 gfc_resolve_omp_parallel_blocks (code
, ns
);
4278 case EXEC_OMP_PARALLEL
:
4279 case EXEC_OMP_PARALLEL_DO
:
4280 case EXEC_OMP_PARALLEL_SECTIONS
:
4281 omp_workshare_save
= omp_workshare_flag
;
4282 omp_workshare_flag
= 0;
4283 gfc_resolve_omp_parallel_blocks (code
, ns
);
4286 gfc_resolve_omp_do_blocks (code
, ns
);
4288 case EXEC_OMP_WORKSHARE
:
4289 omp_workshare_save
= omp_workshare_flag
;
4290 omp_workshare_flag
= 1;
4293 gfc_resolve_blocks (code
->block
, ns
);
4297 if (omp_workshare_save
!= -1)
4298 omp_workshare_flag
= omp_workshare_save
;
4301 t
= gfc_resolve_expr (code
->expr
);
4302 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
4318 resolve_where (code
, NULL
);
4322 if (code
->expr
!= NULL
)
4324 if (code
->expr
->ts
.type
!= BT_INTEGER
)
4325 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4326 "variable", &code
->expr
->where
);
4327 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
4328 gfc_error ("Variable '%s' has not been assigned a target label "
4329 "at %L", code
->expr
->symtree
->n
.sym
->name
,
4330 &code
->expr
->where
);
4333 resolve_branch (code
->label
, code
);
4337 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_INTEGER
)
4338 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
4339 "return specifier", &code
->expr
->where
);
4346 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
4348 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
4350 gfc_error ("Subroutine '%s' called instead of assignment at "
4351 "%L must be PURE", code
->symtree
->n
.sym
->name
,
4358 if (gfc_pure (NULL
))
4360 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
4363 ("Cannot assign to variable '%s' in PURE procedure at %L",
4364 code
->expr
->symtree
->n
.sym
->name
, &code
->expr
->where
);
4368 if (code
->expr2
->ts
.type
== BT_DERIVED
4369 && derived_pointer (code
->expr2
->ts
.derived
))
4372 ("Right side of assignment at %L is a derived type "
4373 "containing a POINTER in a PURE procedure",
4374 &code
->expr2
->where
);
4379 gfc_check_assign (code
->expr
, code
->expr2
, 1);
4382 case EXEC_LABEL_ASSIGN
:
4383 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
4384 gfc_error ("Label %d referenced at %L is never defined",
4385 code
->label
->value
, &code
->label
->where
);
4387 && (code
->expr
->expr_type
!= EXPR_VARIABLE
4388 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
4389 || code
->expr
->symtree
->n
.sym
->ts
.kind
4390 != gfc_default_integer_kind
4391 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
4392 gfc_error ("ASSIGN statement at %L requires a scalar "
4393 "default INTEGER variable", &code
->expr
->where
);
4396 case EXEC_POINTER_ASSIGN
:
4400 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
4403 case EXEC_ARITHMETIC_IF
:
4405 && code
->expr
->ts
.type
!= BT_INTEGER
4406 && code
->expr
->ts
.type
!= BT_REAL
)
4407 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4408 "expression", &code
->expr
->where
);
4410 resolve_branch (code
->label
, code
);
4411 resolve_branch (code
->label2
, code
);
4412 resolve_branch (code
->label3
, code
);
4416 if (t
== SUCCESS
&& code
->expr
!= NULL
4417 && (code
->expr
->ts
.type
!= BT_LOGICAL
4418 || code
->expr
->rank
!= 0))
4419 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4420 &code
->expr
->where
);
4425 resolve_call (code
);
4429 /* Select is complicated. Also, a SELECT construct could be
4430 a transformed computed GOTO. */
4431 resolve_select (code
);
4435 if (code
->ext
.iterator
!= NULL
)
4437 gfc_iterator
*iter
= code
->ext
.iterator
;
4438 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
4439 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
4444 if (code
->expr
== NULL
)
4445 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4447 && (code
->expr
->rank
!= 0
4448 || code
->expr
->ts
.type
!= BT_LOGICAL
))
4449 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4450 "a scalar LOGICAL expression", &code
->expr
->where
);
4454 if (t
== SUCCESS
&& code
->expr
!= NULL
4455 && code
->expr
->ts
.type
!= BT_INTEGER
)
4456 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4457 "of type INTEGER", &code
->expr
->where
);
4459 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
4460 resolve_allocate_expr (a
->expr
, code
);
4464 case EXEC_DEALLOCATE
:
4465 if (t
== SUCCESS
&& code
->expr
!= NULL
4466 && code
->expr
->ts
.type
!= BT_INTEGER
)
4468 ("STAT tag in DEALLOCATE statement at %L must be of type "
4469 "INTEGER", &code
->expr
->where
);
4471 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
4472 resolve_deallocate_expr (a
->expr
);
4477 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
4480 resolve_branch (code
->ext
.open
->err
, code
);
4484 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
4487 resolve_branch (code
->ext
.close
->err
, code
);
4490 case EXEC_BACKSPACE
:
4494 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
4497 resolve_branch (code
->ext
.filepos
->err
, code
);
4501 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
4504 resolve_branch (code
->ext
.inquire
->err
, code
);
4508 gcc_assert (code
->ext
.inquire
!= NULL
);
4509 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
4512 resolve_branch (code
->ext
.inquire
->err
, code
);
4517 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
4520 resolve_branch (code
->ext
.dt
->err
, code
);
4521 resolve_branch (code
->ext
.dt
->end
, code
);
4522 resolve_branch (code
->ext
.dt
->eor
, code
);
4526 resolve_transfer (code
);
4530 resolve_forall_iterators (code
->ext
.forall_iterator
);
4532 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
4534 ("FORALL mask clause at %L requires a LOGICAL expression",
4535 &code
->expr
->where
);
4538 case EXEC_OMP_ATOMIC
:
4539 case EXEC_OMP_BARRIER
:
4540 case EXEC_OMP_CRITICAL
:
4541 case EXEC_OMP_FLUSH
:
4543 case EXEC_OMP_MASTER
:
4544 case EXEC_OMP_ORDERED
:
4545 case EXEC_OMP_SECTIONS
:
4546 case EXEC_OMP_SINGLE
:
4547 case EXEC_OMP_WORKSHARE
:
4548 gfc_resolve_omp_directive (code
, ns
);
4551 case EXEC_OMP_PARALLEL
:
4552 case EXEC_OMP_PARALLEL_DO
:
4553 case EXEC_OMP_PARALLEL_SECTIONS
:
4554 case EXEC_OMP_PARALLEL_WORKSHARE
:
4555 omp_workshare_save
= omp_workshare_flag
;
4556 omp_workshare_flag
= 0;
4557 gfc_resolve_omp_directive (code
, ns
);
4558 omp_workshare_flag
= omp_workshare_save
;
4562 gfc_internal_error ("resolve_code(): Bad statement code");
4566 cs_base
= frame
.prev
;
4570 /* Resolve initial values and make sure they are compatible with
4574 resolve_values (gfc_symbol
* sym
)
4577 if (sym
->value
== NULL
)
4580 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
4583 gfc_check_assign_symbol (sym
, sym
->value
);
4587 /* Resolve an index expression. */
4590 resolve_index_expr (gfc_expr
* e
)
4593 if (gfc_resolve_expr (e
) == FAILURE
)
4596 if (gfc_simplify_expr (e
, 0) == FAILURE
)
4599 if (gfc_specification_expr (e
) == FAILURE
)
4605 /* Resolve a charlen structure. */
4608 resolve_charlen (gfc_charlen
*cl
)
4615 if (resolve_index_expr (cl
->length
) == FAILURE
)
4622 /* Test for non-constant shape arrays. */
4625 is_non_constant_shape_array (gfc_symbol
*sym
)
4630 if (sym
->as
!= NULL
)
4632 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
4633 has not been simplified; parameter array references. Do the
4634 simplification now. */
4635 for (i
= 0; i
< sym
->as
->rank
; i
++)
4637 e
= sym
->as
->lower
[i
];
4638 if (e
&& (resolve_index_expr (e
) == FAILURE
4639 || !gfc_is_constant_expr (e
)))
4642 e
= sym
->as
->upper
[i
];
4643 if (e
&& (resolve_index_expr (e
) == FAILURE
4644 || !gfc_is_constant_expr (e
)))
4651 /* Resolution of common features of flavors variable and procedure. */
4654 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
4656 /* Constraints on deferred shape variable. */
4657 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
4659 if (sym
->attr
.allocatable
)
4661 if (sym
->attr
.dimension
)
4662 gfc_error ("Allocatable array '%s' at %L must have "
4663 "a deferred shape", sym
->name
, &sym
->declared_at
);
4665 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4666 sym
->name
, &sym
->declared_at
);
4670 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
4672 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4673 sym
->name
, &sym
->declared_at
);
4680 if (!mp_flag
&& !sym
->attr
.allocatable
4681 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
4683 gfc_error ("Array '%s' at %L cannot have a deferred shape",
4684 sym
->name
, &sym
->declared_at
);
4691 /* Resolve symbols with flavor variable. */
4694 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
4699 gfc_expr
*constructor_expr
;
4701 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
4704 /* The shape of a main program or module array needs to be constant. */
4705 if (sym
->ns
->proc_name
4706 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
4707 || sym
->ns
->proc_name
->attr
.is_main_program
)
4708 && !sym
->attr
.use_assoc
4709 && !sym
->attr
.allocatable
4710 && !sym
->attr
.pointer
4711 && is_non_constant_shape_array (sym
))
4713 gfc_error ("The module or main program array '%s' at %L must "
4714 "have constant shape", sym
->name
, &sym
->declared_at
);
4718 if (sym
->ts
.type
== BT_CHARACTER
)
4720 /* Make sure that character string variables with assumed length are
4722 e
= sym
->ts
.cl
->length
;
4723 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
4725 gfc_error ("Entity with assumed character length at %L must be a "
4726 "dummy argument or a PARAMETER", &sym
->declared_at
);
4730 if (!gfc_is_constant_expr (e
)
4731 && !(e
->expr_type
== EXPR_VARIABLE
4732 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
4733 && sym
->ns
->proc_name
4734 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
4735 || sym
->ns
->proc_name
->attr
.is_main_program
)
4736 && !sym
->attr
.use_assoc
)
4738 gfc_error ("'%s' at %L must have constant character length "
4739 "in this context", sym
->name
, &sym
->declared_at
);
4744 /* Can the symbol have an initializer? */
4746 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
4747 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
4749 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
4751 /* Don't allow initialization of automatic arrays. */
4752 for (i
= 0; i
< sym
->as
->rank
; i
++)
4754 if (sym
->as
->lower
[i
] == NULL
4755 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4756 || sym
->as
->upper
[i
] == NULL
4757 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
4765 /* Reject illegal initializers. */
4766 if (sym
->value
&& flag
)
4768 if (sym
->attr
.allocatable
)
4769 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4770 sym
->name
, &sym
->declared_at
);
4771 else if (sym
->attr
.external
)
4772 gfc_error ("External '%s' at %L cannot have an initializer",
4773 sym
->name
, &sym
->declared_at
);
4774 else if (sym
->attr
.dummy
)
4775 gfc_error ("Dummy '%s' at %L cannot have an initializer",
4776 sym
->name
, &sym
->declared_at
);
4777 else if (sym
->attr
.intrinsic
)
4778 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4779 sym
->name
, &sym
->declared_at
);
4780 else if (sym
->attr
.result
)
4781 gfc_error ("Function result '%s' at %L cannot have an initializer",
4782 sym
->name
, &sym
->declared_at
);
4784 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4785 sym
->name
, &sym
->declared_at
);
4789 /* 4th constraint in section 11.3: "If an object of a type for which
4790 component-initialization is specified (R429) appears in the
4791 specification-part of a module and does not have the ALLOCATABLE
4792 or POINTER attribute, the object shall have the SAVE attribute." */
4794 constructor_expr
= NULL
;
4795 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| flag
))
4796 constructor_expr
= gfc_default_initializer (&sym
->ts
);
4798 if (sym
->ns
->proc_name
4799 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
4801 && !sym
->ns
->save_all
&& !sym
->attr
.save
4802 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
)
4804 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
4805 sym
->name
, &sym
->declared_at
,
4806 "for default initialization of a component");
4810 /* Assign default initializer. */
4811 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| flag
)
4812 && !sym
->attr
.pointer
)
4813 sym
->value
= gfc_default_initializer (&sym
->ts
);
4819 /* Resolve a procedure. */
4822 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
4824 gfc_formal_arglist
*arg
;
4826 if (sym
->attr
.function
4827 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
4830 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
4832 if (sym
->ts
.type
== BT_CHARACTER
)
4834 gfc_charlen
*cl
= sym
->ts
.cl
;
4835 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
4837 gfc_error ("Character-valued statement function '%s' at %L must "
4838 "have constant length", sym
->name
, &sym
->declared_at
);
4844 /* Ensure that derived type for are not of a private type. Internal
4845 module procedures are excluded by 2.2.3.3 - ie. they are not
4846 externally accessible and can access all the objects accesible in
4848 if (!(sym
->ns
->parent
4849 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
4850 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
4852 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
4855 && arg
->sym
->ts
.type
== BT_DERIVED
4856 && !arg
->sym
->ts
.derived
->attr
.use_assoc
4857 && !gfc_check_access(arg
->sym
->ts
.derived
->attr
.access
,
4858 arg
->sym
->ts
.derived
->ns
->default_access
))
4860 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
4861 "a dummy argument of '%s', which is "
4862 "PUBLIC at %L", arg
->sym
->name
, sym
->name
,
4864 /* Stop this message from recurring. */
4865 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
4871 /* An external symbol may not have an intializer because it is taken to be
4873 if (sym
->attr
.external
&& sym
->value
)
4875 gfc_error ("External object '%s' at %L may not have an initializer",
4876 sym
->name
, &sym
->declared_at
);
4880 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
4881 char-len-param shall not be array-valued, pointer-valued, recursive
4882 or pure. ....snip... A character value of * may only be used in the
4883 following ways: (i) Dummy arg of procedure - dummy associates with
4884 actual length; (ii) To declare a named constant; or (iii) External
4885 function - but length must be declared in calling scoping unit. */
4886 if (sym
->attr
.function
4887 && sym
->ts
.type
== BT_CHARACTER
4888 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
4890 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
4891 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
4893 if (sym
->as
&& sym
->as
->rank
)
4894 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4895 "array-valued", sym
->name
, &sym
->declared_at
);
4897 if (sym
->attr
.pointer
)
4898 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4899 "pointer-valued", sym
->name
, &sym
->declared_at
);
4902 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4903 "pure", sym
->name
, &sym
->declared_at
);
4905 if (sym
->attr
.recursive
)
4906 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
4907 "recursive", sym
->name
, &sym
->declared_at
);
4912 /* Appendix B.2 of the standard. Contained functions give an
4913 error anyway. Fixed-form is likely to be F77/legacy. */
4914 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
4915 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
4916 "'%s' at %L is obsolescent in fortran 95",
4917 sym
->name
, &sym
->declared_at
);
4923 /* Resolve the components of a derived type. */
4926 resolve_fl_derived (gfc_symbol
*sym
)
4929 gfc_dt_list
* dt_list
;
4932 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
4934 if (c
->ts
.type
== BT_CHARACTER
)
4936 if (c
->ts
.cl
->length
== NULL
4937 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
4938 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
4940 gfc_error ("Character length of component '%s' needs to "
4941 "be a constant specification expression at %L.",
4943 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
4948 if (c
->ts
.type
== BT_DERIVED
4949 && sym
->component_access
!= ACCESS_PRIVATE
4950 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
)
4951 && !c
->ts
.derived
->attr
.use_assoc
4952 && !gfc_check_access(c
->ts
.derived
->attr
.access
,
4953 c
->ts
.derived
->ns
->default_access
))
4955 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4956 "a component of '%s', which is PUBLIC at %L",
4957 c
->name
, sym
->name
, &sym
->declared_at
);
4961 if (c
->pointer
|| c
->as
== NULL
)
4964 for (i
= 0; i
< c
->as
->rank
; i
++)
4966 if (c
->as
->lower
[i
] == NULL
4967 || !gfc_is_constant_expr (c
->as
->lower
[i
])
4968 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
4969 || c
->as
->upper
[i
] == NULL
4970 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
4971 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
4973 gfc_error ("Component '%s' of '%s' at %L must have "
4974 "constant array bounds.",
4975 c
->name
, sym
->name
, &c
->loc
);
4981 /* Add derived type to the derived type list. */
4982 dt_list
= gfc_get_dt_list ();
4983 dt_list
->next
= sym
->ns
->derived_types
;
4984 dt_list
->derived
= sym
;
4985 sym
->ns
->derived_types
= dt_list
;
4992 resolve_fl_namelist (gfc_symbol
*sym
)
4997 /* Reject PRIVATE objects in a PUBLIC namelist. */
4998 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5000 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5002 if (!nl
->sym
->attr
.use_assoc
5003 && !(sym
->ns
->parent
== nl
->sym
->ns
)
5004 && !gfc_check_access(nl
->sym
->attr
.access
,
5005 nl
->sym
->ns
->default_access
))
5007 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5008 "PUBLIC namelist at %L", nl
->sym
->name
,
5015 /* Reject namelist arrays that are not constant shape. */
5016 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5018 if (is_non_constant_shape_array (nl
->sym
))
5020 gfc_error ("The array '%s' must have constant shape to be "
5021 "a NAMELIST object at %L", nl
->sym
->name
,
5027 /* 14.1.2 A module or internal procedure represent local entities
5028 of the same type as a namelist member and so are not allowed.
5029 Note that this is sometimes caught by check_conflict so the
5030 same message has been used. */
5031 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5034 if (sym
->ns
->parent
&& nl
->sym
&& nl
->sym
->name
)
5035 gfc_find_symbol (nl
->sym
->name
, sym
->ns
->parent
, 0, &nlsym
);
5036 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
5038 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5039 "attribute in '%s' at %L", nlsym
->name
,
5050 resolve_fl_parameter (gfc_symbol
*sym
)
5052 /* A parameter array's shape needs to be constant. */
5053 if (sym
->as
!= NULL
&& !gfc_is_compile_time_shape (sym
->as
))
5055 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5056 "or assumed shape", sym
->name
, &sym
->declared_at
);
5060 /* Make sure a parameter that has been implicitly typed still
5061 matches the implicit type, since PARAMETER statements can precede
5062 IMPLICIT statements. */
5063 if (sym
->attr
.implicit_type
5064 && !gfc_compare_types (&sym
->ts
,
5065 gfc_get_default_type (sym
, sym
->ns
)))
5067 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
5068 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
5072 /* Make sure the types of derived parameters are consistent. This
5073 type checking is deferred until resolution because the type may
5074 refer to a derived type from the host. */
5075 if (sym
->ts
.type
== BT_DERIVED
5076 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
5078 gfc_error ("Incompatible derived type in PARAMETER at %L",
5079 &sym
->value
->where
);
5086 /* Do anything necessary to resolve a symbol. Right now, we just
5087 assume that an otherwise unknown symbol is a variable. This sort
5088 of thing commonly happens for symbols in module. */
5091 resolve_symbol (gfc_symbol
* sym
)
5093 /* Zero if we are checking a formal namespace. */
5094 static int formal_ns_flag
= 1;
5095 int formal_ns_save
, check_constant
, mp_flag
;
5096 gfc_symtree
*symtree
;
5097 gfc_symtree
*this_symtree
;
5101 if (sym
->attr
.flavor
== FL_UNKNOWN
)
5104 /* If we find that a flavorless symbol is an interface in one of the
5105 parent namespaces, find its symtree in this namespace, free the
5106 symbol and set the symtree to point to the interface symbol. */
5107 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
5109 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5110 if (symtree
&& symtree
->n
.sym
->generic
)
5112 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
5116 gfc_free_symbol (sym
);
5117 symtree
->n
.sym
->refs
++;
5118 this_symtree
->n
.sym
= symtree
->n
.sym
;
5123 /* Otherwise give it a flavor according to such attributes as
5125 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
5126 sym
->attr
.flavor
= FL_VARIABLE
;
5129 sym
->attr
.flavor
= FL_PROCEDURE
;
5130 if (sym
->attr
.dimension
)
5131 sym
->attr
.function
= 1;
5135 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
5138 /* Symbols that are module procedures with results (functions) have
5139 the types and array specification copied for type checking in
5140 procedures that call them, as well as for saving to a module
5141 file. These symbols can't stand the scrutiny that their results
5143 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
5145 /* Assign default type to symbols that need one and don't have one. */
5146 if (sym
->ts
.type
== BT_UNKNOWN
)
5148 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
5149 gfc_set_default_type (sym
, 1, NULL
);
5151 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
5153 /* The specific case of an external procedure should emit an error
5154 in the case that there is no implicit type. */
5156 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
5159 /* Result may be in another namespace. */
5160 resolve_symbol (sym
->result
);
5162 sym
->ts
= sym
->result
->ts
;
5163 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
5164 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
5165 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
5166 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
5171 /* Assumed size arrays and assumed shape arrays must be dummy
5175 && (sym
->as
->type
== AS_ASSUMED_SIZE
5176 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
5177 && sym
->attr
.dummy
== 0)
5179 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
5180 gfc_error ("Assumed size array at %L must be a dummy argument",
5183 gfc_error ("Assumed shape array at %L must be a dummy argument",
5188 /* Make sure symbols with known intent or optional are really dummy
5189 variable. Because of ENTRY statement, this has to be deferred
5190 until resolution time. */
5192 if (!sym
->attr
.dummy
5193 && (sym
->attr
.optional
5194 || sym
->attr
.intent
!= INTENT_UNKNOWN
))
5196 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
5200 /* If a derived type symbol has reached this point, without its
5201 type being declared, we have an error. Notice that most
5202 conditions that produce undefined derived types have already
5203 been dealt with. However, the likes of:
5204 implicit type(t) (t) ..... call foo (t) will get us here if
5205 the type is not declared in the scope of the implicit
5206 statement. Change the type to BT_UNKNOWN, both because it is so
5207 and to prevent an ICE. */
5208 if (sym
->ts
.type
== BT_DERIVED
5209 && sym
->ts
.derived
->components
== NULL
)
5211 gfc_error ("The derived type '%s' at %L is of type '%s', "
5212 "which has not been defined.", sym
->name
,
5213 &sym
->declared_at
, sym
->ts
.derived
->name
);
5214 sym
->ts
.type
= BT_UNKNOWN
;
5218 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
5219 default initialization is defined (5.1.2.4.4). */
5220 if (sym
->ts
.type
== BT_DERIVED
5222 && sym
->attr
.intent
== INTENT_OUT
5224 && sym
->as
->type
== AS_ASSUMED_SIZE
)
5226 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
5230 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
5231 "ASSUMED SIZE and so cannot have a default initializer",
5232 sym
->name
, &sym
->declared_at
);
5238 switch (sym
->attr
.flavor
)
5241 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
5246 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
5251 if (resolve_fl_namelist (sym
) == FAILURE
)
5256 if (resolve_fl_parameter (sym
) == FAILURE
)
5266 /* Make sure that intrinsic exist */
5267 if (sym
->attr
.intrinsic
5268 && ! gfc_intrinsic_name(sym
->name
, 0)
5269 && ! gfc_intrinsic_name(sym
->name
, 1))
5270 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
5272 /* Resolve array specifier. Check as well some constraints
5273 on COMMON blocks. */
5275 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
5276 gfc_resolve_array_spec (sym
->as
, check_constant
);
5278 /* Resolve formal namespaces. */
5280 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
5282 formal_ns_save
= formal_ns_flag
;
5284 gfc_resolve (sym
->formal_ns
);
5285 formal_ns_flag
= formal_ns_save
;
5288 /* Check threadprivate restrictions. */
5289 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
5290 && (!sym
->attr
.in_common
5291 && sym
->module
== NULL
5292 && (sym
->ns
->proc_name
== NULL
5293 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
5294 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
5299 /************* Resolve DATA statements *************/
5303 gfc_data_value
*vnode
;
5309 /* Advance the values structure to point to the next value in the data list. */
5312 next_data_value (void)
5314 while (values
.left
== 0)
5316 if (values
.vnode
->next
== NULL
)
5319 values
.vnode
= values
.vnode
->next
;
5320 values
.left
= values
.vnode
->repeat
;
5328 check_data_variable (gfc_data_variable
* var
, locus
* where
)
5334 ar_type mark
= AR_UNKNOWN
;
5336 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
5340 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
5344 mpz_init_set_si (offset
, 0);
5347 if (e
->expr_type
!= EXPR_VARIABLE
)
5348 gfc_internal_error ("check_data_variable(): Bad expression");
5350 if (e
->symtree
->n
.sym
->ns
->is_block_data
5351 && !e
->symtree
->n
.sym
->attr
.in_common
)
5353 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
5354 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
5359 mpz_init_set_ui (size
, 1);
5366 /* Find the array section reference. */
5367 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5369 if (ref
->type
!= REF_ARRAY
)
5371 if (ref
->u
.ar
.type
== AR_ELEMENT
)
5377 /* Set marks according to the reference pattern. */
5378 switch (ref
->u
.ar
.type
)
5386 /* Get the start position of array section. */
5387 gfc_get_section_index (ar
, section_index
, &offset
);
5395 if (gfc_array_size (e
, &size
) == FAILURE
)
5397 gfc_error ("Nonconstant array section at %L in DATA statement",
5406 while (mpz_cmp_ui (size
, 0) > 0)
5408 if (next_data_value () == FAILURE
)
5410 gfc_error ("DATA statement at %L has more variables than values",
5416 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
5420 /* If we have more than one element left in the repeat count,
5421 and we have more than one element left in the target variable,
5422 then create a range assignment. */
5423 /* ??? Only done for full arrays for now, since array sections
5425 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
5426 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
5430 if (mpz_cmp_ui (size
, values
.left
) >= 0)
5432 mpz_init_set_ui (range
, values
.left
);
5433 mpz_sub_ui (size
, size
, values
.left
);
5438 mpz_init_set (range
, size
);
5439 values
.left
-= mpz_get_ui (size
);
5440 mpz_set_ui (size
, 0);
5443 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
5446 mpz_add (offset
, offset
, range
);
5450 /* Assign initial value to symbol. */
5454 mpz_sub_ui (size
, size
, 1);
5456 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
5458 if (mark
== AR_FULL
)
5459 mpz_add_ui (offset
, offset
, 1);
5461 /* Modify the array section indexes and recalculate the offset
5462 for next element. */
5463 else if (mark
== AR_SECTION
)
5464 gfc_advance_section (section_index
, ar
, &offset
);
5468 if (mark
== AR_SECTION
)
5470 for (i
= 0; i
< ar
->dimen
; i
++)
5471 mpz_clear (section_index
[i
]);
5481 static try traverse_data_var (gfc_data_variable
*, locus
*);
5483 /* Iterate over a list of elements in a DATA statement. */
5486 traverse_data_list (gfc_data_variable
* var
, locus
* where
)
5489 iterator_stack frame
;
5492 mpz_init (frame
.value
);
5494 mpz_init_set (trip
, var
->iter
.end
->value
.integer
);
5495 mpz_sub (trip
, trip
, var
->iter
.start
->value
.integer
);
5496 mpz_add (trip
, trip
, var
->iter
.step
->value
.integer
);
5498 mpz_div (trip
, trip
, var
->iter
.step
->value
.integer
);
5500 mpz_set (frame
.value
, var
->iter
.start
->value
.integer
);
5502 frame
.prev
= iter_stack
;
5503 frame
.variable
= var
->iter
.var
->symtree
;
5504 iter_stack
= &frame
;
5506 while (mpz_cmp_ui (trip
, 0) > 0)
5508 if (traverse_data_var (var
->list
, where
) == FAILURE
)
5514 e
= gfc_copy_expr (var
->expr
);
5515 if (gfc_simplify_expr (e
, 1) == FAILURE
)
5521 mpz_add (frame
.value
, frame
.value
, var
->iter
.step
->value
.integer
);
5523 mpz_sub_ui (trip
, trip
, 1);
5527 mpz_clear (frame
.value
);
5529 iter_stack
= frame
.prev
;
5534 /* Type resolve variables in the variable list of a DATA statement. */
5537 traverse_data_var (gfc_data_variable
* var
, locus
* where
)
5541 for (; var
; var
= var
->next
)
5543 if (var
->expr
== NULL
)
5544 t
= traverse_data_list (var
, where
);
5546 t
= check_data_variable (var
, where
);
5556 /* Resolve the expressions and iterators associated with a data statement.
5557 This is separate from the assignment checking because data lists should
5558 only be resolved once. */
5561 resolve_data_variables (gfc_data_variable
* d
)
5563 for (; d
; d
= d
->next
)
5565 if (d
->list
== NULL
)
5567 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
5572 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
5575 if (d
->iter
.start
->expr_type
!= EXPR_CONSTANT
5576 || d
->iter
.end
->expr_type
!= EXPR_CONSTANT
5577 || d
->iter
.step
->expr_type
!= EXPR_CONSTANT
)
5578 gfc_internal_error ("resolve_data_variables(): Bad iterator");
5580 if (resolve_data_variables (d
->list
) == FAILURE
)
5589 /* Resolve a single DATA statement. We implement this by storing a pointer to
5590 the value list into static variables, and then recursively traversing the
5591 variables list, expanding iterators and such. */
5594 resolve_data (gfc_data
* d
)
5596 if (resolve_data_variables (d
->var
) == FAILURE
)
5599 values
.vnode
= d
->value
;
5600 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
5602 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
5605 /* At this point, we better not have any values left. */
5607 if (next_data_value () == SUCCESS
)
5608 gfc_error ("DATA statement at %L has more values than variables",
5613 /* Determines if a variable is not 'pure', ie not assignable within a pure
5614 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
5618 gfc_impure_variable (gfc_symbol
* sym
)
5620 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
5623 if (sym
->ns
!= gfc_current_ns
)
5624 return !sym
->attr
.function
;
5626 /* TODO: Check storage association through EQUIVALENCE statements */
5632 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
5633 symbol of the current procedure. */
5636 gfc_pure (gfc_symbol
* sym
)
5638 symbol_attribute attr
;
5641 sym
= gfc_current_ns
->proc_name
;
5647 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
5651 /* Test whether the current procedure is elemental or not. */
5654 gfc_elemental (gfc_symbol
* sym
)
5656 symbol_attribute attr
;
5659 sym
= gfc_current_ns
->proc_name
;
5664 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
5668 /* Warn about unused labels. */
5671 warn_unused_label (gfc_st_label
* label
)
5676 warn_unused_label (label
->left
);
5678 if (label
->defined
== ST_LABEL_UNKNOWN
)
5681 switch (label
->referenced
)
5683 case ST_LABEL_UNKNOWN
:
5684 gfc_warning ("Label %d at %L defined but not used", label
->value
,
5688 case ST_LABEL_BAD_TARGET
:
5689 gfc_warning ("Label %d at %L defined but cannot be used",
5690 label
->value
, &label
->where
);
5697 warn_unused_label (label
->right
);
5701 /* Returns the sequence type of a symbol or sequence. */
5704 sequence_type (gfc_typespec ts
)
5713 if (ts
.derived
->components
== NULL
)
5714 return SEQ_NONDEFAULT
;
5716 result
= sequence_type (ts
.derived
->components
->ts
);
5717 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
5718 if (sequence_type (c
->ts
) != result
)
5724 if (ts
.kind
!= gfc_default_character_kind
)
5725 return SEQ_NONDEFAULT
;
5727 return SEQ_CHARACTER
;
5730 if (ts
.kind
!= gfc_default_integer_kind
)
5731 return SEQ_NONDEFAULT
;
5736 if (!(ts
.kind
== gfc_default_real_kind
5737 || ts
.kind
== gfc_default_double_kind
))
5738 return SEQ_NONDEFAULT
;
5743 if (ts
.kind
!= gfc_default_complex_kind
)
5744 return SEQ_NONDEFAULT
;
5749 if (ts
.kind
!= gfc_default_logical_kind
)
5750 return SEQ_NONDEFAULT
;
5755 return SEQ_NONDEFAULT
;
5760 /* Resolve derived type EQUIVALENCE object. */
5763 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
5766 gfc_component
*c
= derived
->components
;
5771 /* Shall not be an object of nonsequence derived type. */
5772 if (!derived
->attr
.sequence
)
5774 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5775 "attribute to be an EQUIVALENCE object", sym
->name
, &e
->where
);
5779 for (; c
; c
= c
->next
)
5782 if (d
&& (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
5785 /* Shall not be an object of sequence derived type containing a pointer
5786 in the structure. */
5789 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5790 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
5796 gfc_error ("Derived type variable '%s' at %L with default initializer "
5797 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
5805 /* Resolve equivalence object.
5806 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5807 an allocatable array, an object of nonsequence derived type, an object of
5808 sequence derived type containing a pointer at any level of component
5809 selection, an automatic object, a function name, an entry name, a result
5810 name, a named constant, a structure component, or a subobject of any of
5811 the preceding objects. A substring shall not have length zero. A
5812 derived type shall not have components with default initialization nor
5813 shall two objects of an equivalence group be initialized.
5814 The simple constraints are done in symbol.c(check_conflict) and the rest
5815 are implemented here. */
5818 resolve_equivalence (gfc_equiv
*eq
)
5821 gfc_symbol
*derived
;
5822 gfc_symbol
*first_sym
;
5825 locus
*last_where
= NULL
;
5826 seq_type eq_type
, last_eq_type
;
5827 gfc_typespec
*last_ts
;
5829 const char *value_name
;
5833 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
5835 first_sym
= eq
->expr
->symtree
->n
.sym
;
5837 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
5841 e
->ts
= e
->symtree
->n
.sym
->ts
;
5842 /* match_varspec might not know yet if it is seeing
5843 array reference or substring reference, as it doesn't
5845 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5847 gfc_ref
*ref
= e
->ref
;
5848 sym
= e
->symtree
->n
.sym
;
5850 if (sym
->attr
.dimension
)
5852 ref
->u
.ar
.as
= sym
->as
;
5856 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5857 if (e
->ts
.type
== BT_CHARACTER
5859 && ref
->type
== REF_ARRAY
5860 && ref
->u
.ar
.dimen
== 1
5861 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
5862 && ref
->u
.ar
.stride
[0] == NULL
)
5864 gfc_expr
*start
= ref
->u
.ar
.start
[0];
5865 gfc_expr
*end
= ref
->u
.ar
.end
[0];
5868 /* Optimize away the (:) reference. */
5869 if (start
== NULL
&& end
== NULL
)
5874 e
->ref
->next
= ref
->next
;
5879 ref
->type
= REF_SUBSTRING
;
5881 start
= gfc_int_expr (1);
5882 ref
->u
.ss
.start
= start
;
5883 if (end
== NULL
&& e
->ts
.cl
)
5884 end
= gfc_copy_expr (e
->ts
.cl
->length
);
5885 ref
->u
.ss
.end
= end
;
5886 ref
->u
.ss
.length
= e
->ts
.cl
;
5893 /* Any further ref is an error. */
5896 gcc_assert (ref
->type
== REF_ARRAY
);
5897 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5903 if (gfc_resolve_expr (e
) == FAILURE
)
5906 sym
= e
->symtree
->n
.sym
;
5908 /* An equivalence statement cannot have more than one initialized
5912 if (value_name
!= NULL
)
5914 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5915 "be in the EQUIVALENCE statement at %L",
5916 value_name
, sym
->name
, &e
->where
);
5920 value_name
= sym
->name
;
5923 /* Shall not equivalence common block variables in a PURE procedure. */
5924 if (sym
->ns
->proc_name
5925 && sym
->ns
->proc_name
->attr
.pure
5926 && sym
->attr
.in_common
)
5928 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5929 "object in the pure procedure '%s'",
5930 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
5934 /* Shall not be a named constant. */
5935 if (e
->expr_type
== EXPR_CONSTANT
)
5937 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5938 "object", sym
->name
, &e
->where
);
5942 derived
= e
->ts
.derived
;
5943 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
5946 /* Check that the types correspond correctly:
5948 A numeric sequence structure may be equivalenced to another sequence
5949 structure, an object of default integer type, default real type, double
5950 precision real type, default logical type such that components of the
5951 structure ultimately only become associated to objects of the same
5952 kind. A character sequence structure may be equivalenced to an object
5953 of default character kind or another character sequence structure.
5954 Other objects may be equivalenced only to objects of the same type and
5957 /* Identical types are unconditionally OK. */
5958 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
5959 goto identical_types
;
5961 last_eq_type
= sequence_type (*last_ts
);
5962 eq_type
= sequence_type (sym
->ts
);
5964 /* Since the pair of objects is not of the same type, mixed or
5965 non-default sequences can be rejected. */
5967 msg
= "Sequence %s with mixed components in EQUIVALENCE "
5968 "statement at %L with different type objects";
5970 && last_eq_type
== SEQ_MIXED
5971 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
5972 last_where
) == FAILURE
)
5973 || (eq_type
== SEQ_MIXED
5974 && gfc_notify_std (GFC_STD_GNU
, msg
,sym
->name
,
5975 &e
->where
) == FAILURE
))
5978 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
5979 "statement at %L with objects of different type";
5981 && last_eq_type
== SEQ_NONDEFAULT
5982 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
5983 last_where
) == FAILURE
)
5984 || (eq_type
== SEQ_NONDEFAULT
5985 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
5986 &e
->where
) == FAILURE
))
5989 msg
="Non-CHARACTER object '%s' in default CHARACTER "
5990 "EQUIVALENCE statement at %L";
5991 if (last_eq_type
== SEQ_CHARACTER
5992 && eq_type
!= SEQ_CHARACTER
5993 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
5994 &e
->where
) == FAILURE
)
5997 msg
="Non-NUMERIC object '%s' in default NUMERIC "
5998 "EQUIVALENCE statement at %L";
5999 if (last_eq_type
== SEQ_NUMERIC
6000 && eq_type
!= SEQ_NUMERIC
6001 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
6002 &e
->where
) == FAILURE
)
6007 last_where
= &e
->where
;
6012 /* Shall not be an automatic array. */
6013 if (e
->ref
->type
== REF_ARRAY
6014 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
6016 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
6017 "an EQUIVALENCE object", sym
->name
, &e
->where
);
6024 /* Shall not be a structure component. */
6025 if (r
->type
== REF_COMPONENT
)
6027 gfc_error ("Structure component '%s' at %L cannot be an "
6028 "EQUIVALENCE object",
6029 r
->u
.c
.component
->name
, &e
->where
);
6033 /* A substring shall not have length zero. */
6034 if (r
->type
== REF_SUBSTRING
)
6036 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
6038 gfc_error ("Substring at %L has length zero",
6039 &r
->u
.ss
.start
->where
);
6049 /* Resolve function and ENTRY types, issue diagnostics if needed. */
6052 resolve_fntype (gfc_namespace
* ns
)
6057 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
6060 /* If there are any entries, ns->proc_name is the entry master
6061 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
6063 sym
= ns
->entries
->sym
;
6065 sym
= ns
->proc_name
;
6066 if (sym
->result
== sym
6067 && sym
->ts
.type
== BT_UNKNOWN
6068 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
6069 && !sym
->attr
.untyped
)
6071 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6072 sym
->name
, &sym
->declared_at
);
6073 sym
->attr
.untyped
= 1;
6076 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
6077 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
6078 sym
->ts
.derived
->ns
->default_access
)
6079 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
6081 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6082 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
6086 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
6088 if (el
->sym
->result
== el
->sym
6089 && el
->sym
->ts
.type
== BT_UNKNOWN
6090 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
6091 && !el
->sym
->attr
.untyped
)
6093 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6094 el
->sym
->name
, &el
->sym
->declared_at
);
6095 el
->sym
->attr
.untyped
= 1;
6101 /* Examine all of the expressions associated with a program unit,
6102 assign types to all intermediate expressions, make sure that all
6103 assignments are to compatible types and figure out which names
6104 refer to which functions or subroutines. It doesn't check code
6105 block, which is handled by resolve_code. */
6108 resolve_types (gfc_namespace
* ns
)
6115 gfc_current_ns
= ns
;
6117 resolve_entries (ns
);
6119 resolve_contained_functions (ns
);
6121 gfc_traverse_ns (ns
, resolve_symbol
);
6123 resolve_fntype (ns
);
6125 for (n
= ns
->contained
; n
; n
= n
->sibling
)
6127 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
6128 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
6129 "also be PURE", n
->proc_name
->name
,
6130 &n
->proc_name
->declared_at
);
6136 gfc_check_interfaces (ns
);
6138 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
6139 resolve_charlen (cl
);
6141 gfc_traverse_ns (ns
, resolve_values
);
6147 for (d
= ns
->data
; d
; d
= d
->next
)
6151 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
6153 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
6154 resolve_equivalence (eq
);
6156 /* Warn about unused labels. */
6157 if (gfc_option
.warn_unused_labels
)
6158 warn_unused_label (ns
->st_labels
);
6162 /* Call resolve_code recursively. */
6165 resolve_codes (gfc_namespace
* ns
)
6169 for (n
= ns
->contained
; n
; n
= n
->sibling
)
6172 gfc_current_ns
= ns
;
6174 resolve_code (ns
->code
, ns
);
6178 /* This function is called after a complete program unit has been compiled.
6179 Its purpose is to examine all of the expressions associated with a program
6180 unit, assign types to all intermediate expressions, make sure that all
6181 assignments are to compatible types and figure out which names refer to
6182 which functions or subroutines. */
6185 gfc_resolve (gfc_namespace
* ns
)
6187 gfc_namespace
*old_ns
;
6189 old_ns
= gfc_current_ns
;
6194 gfc_current_ns
= old_ns
;