1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000-2016 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "target-memory.h" /* for gfc_convert_boz */
29 #include "constructor.h"
32 /* The following set of functions provide access to gfc_expr* of
33 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
35 There are two functions available elsewhere that provide
36 slightly different flavours of variables. Namely:
37 expr.c (gfc_get_variable_expr)
38 symbol.c (gfc_lval_expr_from_sym)
39 TODO: Merge these functions, if possible. */
41 /* Get a new expression node. */
49 gfc_clear_ts (&e
->ts
);
57 /* Get a new expression node that is an array constructor
58 of given type and kind. */
61 gfc_get_array_expr (bt type
, int kind
, locus
*where
)
66 e
->expr_type
= EXPR_ARRAY
;
67 e
->value
.constructor
= NULL
;
80 /* Get a new expression node that is the NULL expression. */
83 gfc_get_null_expr (locus
*where
)
88 e
->expr_type
= EXPR_NULL
;
89 e
->ts
.type
= BT_UNKNOWN
;
98 /* Get a new expression node that is an operator expression node. */
101 gfc_get_operator_expr (locus
*where
, gfc_intrinsic_op op
,
102 gfc_expr
*op1
, gfc_expr
*op2
)
107 e
->expr_type
= EXPR_OP
;
109 e
->value
.op
.op1
= op1
;
110 e
->value
.op
.op2
= op2
;
119 /* Get a new expression node that is an structure constructor
120 of given type and kind. */
123 gfc_get_structure_constructor_expr (bt type
, int kind
, locus
*where
)
128 e
->expr_type
= EXPR_STRUCTURE
;
129 e
->value
.constructor
= NULL
;
140 /* Get a new expression node that is an constant of given type and kind. */
143 gfc_get_constant_expr (bt type
, int kind
, locus
*where
)
148 gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
153 e
->expr_type
= EXPR_CONSTANT
;
161 mpz_init (e
->value
.integer
);
165 gfc_set_model_kind (kind
);
166 mpfr_init (e
->value
.real
);
170 gfc_set_model_kind (kind
);
171 mpc_init2 (e
->value
.complex, mpfr_get_default_prec());
182 /* Get a new expression node that is an string constant.
183 If no string is passed, a string of len is allocated,
184 blanked and null-terminated. */
187 gfc_get_character_expr (int kind
, locus
*where
, const char *src
, int len
)
194 dest
= gfc_get_wide_string (len
+ 1);
195 gfc_wide_memset (dest
, ' ', len
);
199 dest
= gfc_char_to_widechar (src
);
201 e
= gfc_get_constant_expr (BT_CHARACTER
, kind
,
202 where
? where
: &gfc_current_locus
);
203 e
->value
.character
.string
= dest
;
204 e
->value
.character
.length
= len
;
210 /* Get a new expression node that is an integer constant. */
213 gfc_get_int_expr (int kind
, locus
*where
, int value
)
216 p
= gfc_get_constant_expr (BT_INTEGER
, kind
,
217 where
? where
: &gfc_current_locus
);
219 mpz_set_si (p
->value
.integer
, value
);
225 /* Get a new expression node that is a logical constant. */
228 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
231 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
232 where
? where
: &gfc_current_locus
);
234 p
->value
.logical
= value
;
241 gfc_get_iokind_expr (locus
*where
, io_kind k
)
245 /* Set the types to something compatible with iokind. This is needed to
246 get through gfc_free_expr later since iokind really has no Basic Type,
250 e
->expr_type
= EXPR_CONSTANT
;
251 e
->ts
.type
= BT_LOGICAL
;
259 /* Given an expression pointer, return a copy of the expression. This
260 subroutine is recursive. */
263 gfc_copy_expr (gfc_expr
*p
)
275 switch (q
->expr_type
)
278 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
279 q
->value
.character
.string
= s
;
280 memcpy (s
, p
->value
.character
.string
,
281 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
285 /* Copy target representation, if it exists. */
286 if (p
->representation
.string
)
288 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
289 q
->representation
.string
= c
;
290 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
293 /* Copy the values of any pointer components of p->value. */
297 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
301 gfc_set_model_kind (q
->ts
.kind
);
302 mpfr_init (q
->value
.real
);
303 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
307 gfc_set_model_kind (q
->ts
.kind
);
308 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
309 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
313 if (p
->representation
.string
)
314 q
->value
.character
.string
315 = gfc_char_to_widechar (q
->representation
.string
);
318 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
319 q
->value
.character
.string
= s
;
321 /* This is the case for the C_NULL_CHAR named constant. */
322 if (p
->value
.character
.length
== 0
323 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
326 /* Need to set the length to 1 to make sure the NUL
327 terminator is copied. */
328 q
->value
.character
.length
= 1;
331 memcpy (s
, p
->value
.character
.string
,
332 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
341 break; /* Already done. */
345 /* Should never be reached. */
347 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
354 switch (q
->value
.op
.op
)
357 case INTRINSIC_PARENTHESES
:
358 case INTRINSIC_UPLUS
:
359 case INTRINSIC_UMINUS
:
360 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
363 default: /* Binary operators. */
364 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
365 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
372 q
->value
.function
.actual
=
373 gfc_copy_actual_arglist (p
->value
.function
.actual
);
378 q
->value
.compcall
.actual
=
379 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
380 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
385 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
393 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
395 q
->ref
= gfc_copy_ref (p
->ref
);
402 gfc_clear_shape (mpz_t
*shape
, int rank
)
406 for (i
= 0; i
< rank
; i
++)
407 mpz_clear (shape
[i
]);
412 gfc_free_shape (mpz_t
**shape
, int rank
)
417 gfc_clear_shape (*shape
, rank
);
423 /* Workhorse function for gfc_free_expr() that frees everything
424 beneath an expression node, but not the node itself. This is
425 useful when we want to simplify a node and replace it with
426 something else or the expression node belongs to another structure. */
429 free_expr0 (gfc_expr
*e
)
431 switch (e
->expr_type
)
434 /* Free any parts of the value that need freeing. */
438 mpz_clear (e
->value
.integer
);
442 mpfr_clear (e
->value
.real
);
446 free (e
->value
.character
.string
);
450 mpc_clear (e
->value
.complex);
457 /* Free the representation. */
458 free (e
->representation
.string
);
463 if (e
->value
.op
.op1
!= NULL
)
464 gfc_free_expr (e
->value
.op
.op1
);
465 if (e
->value
.op
.op2
!= NULL
)
466 gfc_free_expr (e
->value
.op
.op2
);
470 gfc_free_actual_arglist (e
->value
.function
.actual
);
475 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
483 gfc_constructor_free (e
->value
.constructor
);
487 free (e
->value
.character
.string
);
494 gfc_internal_error ("free_expr0(): Bad expr type");
497 /* Free a shape array. */
498 gfc_free_shape (&e
->shape
, e
->rank
);
500 gfc_free_ref_list (e
->ref
);
502 memset (e
, '\0', sizeof (gfc_expr
));
506 /* Free an expression node and everything beneath it. */
509 gfc_free_expr (gfc_expr
*e
)
518 /* Free an argument list and everything below it. */
521 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
523 gfc_actual_arglist
*a2
;
528 gfc_free_expr (a1
->expr
);
535 /* Copy an arglist structure and all of the arguments. */
538 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
540 gfc_actual_arglist
*head
, *tail
, *new_arg
;
544 for (; p
; p
= p
->next
)
546 new_arg
= gfc_get_actual_arglist ();
549 new_arg
->expr
= gfc_copy_expr (p
->expr
);
550 new_arg
->next
= NULL
;
555 tail
->next
= new_arg
;
564 /* Free a list of reference structures. */
567 gfc_free_ref_list (gfc_ref
*p
)
579 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
581 gfc_free_expr (p
->u
.ar
.start
[i
]);
582 gfc_free_expr (p
->u
.ar
.end
[i
]);
583 gfc_free_expr (p
->u
.ar
.stride
[i
]);
589 gfc_free_expr (p
->u
.ss
.start
);
590 gfc_free_expr (p
->u
.ss
.end
);
602 /* Graft the *src expression onto the *dest subexpression. */
605 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
613 /* Try to extract an integer constant from the passed expression node.
614 Returns an error message or NULL if the result is set. It is
615 tempting to generate an error and return true or false, but
616 failure is OK for some callers. */
619 gfc_extract_int (gfc_expr
*expr
, int *result
)
621 if (expr
->expr_type
!= EXPR_CONSTANT
)
622 return _("Constant expression required at %C");
624 if (expr
->ts
.type
!= BT_INTEGER
)
625 return _("Integer expression required at %C");
627 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
628 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
630 return _("Integer value too large in expression at %C");
633 *result
= (int) mpz_get_si (expr
->value
.integer
);
639 /* Recursively copy a list of reference structures. */
642 gfc_copy_ref (gfc_ref
*src
)
650 dest
= gfc_get_ref ();
651 dest
->type
= src
->type
;
656 ar
= gfc_copy_array_ref (&src
->u
.ar
);
662 dest
->u
.c
= src
->u
.c
;
666 dest
->u
.ss
= src
->u
.ss
;
667 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
668 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
672 dest
->next
= gfc_copy_ref (src
->next
);
678 /* Detect whether an expression has any vector index array references. */
681 gfc_has_vector_index (gfc_expr
*e
)
685 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
686 if (ref
->type
== REF_ARRAY
)
687 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
688 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
694 /* Copy a shape array. */
697 gfc_copy_shape (mpz_t
*shape
, int rank
)
705 new_shape
= gfc_get_shape (rank
);
707 for (n
= 0; n
< rank
; n
++)
708 mpz_init_set (new_shape
[n
], shape
[n
]);
714 /* Copy a shape array excluding dimension N, where N is an integer
715 constant expression. Dimensions are numbered in Fortran style --
718 So, if the original shape array contains R elements
719 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
720 the result contains R-1 elements:
721 { s1 ... sN-1 sN+1 ... sR-1}
723 If anything goes wrong -- N is not a constant, its value is out
724 of range -- or anything else, just returns NULL. */
727 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
729 mpz_t
*new_shape
, *s
;
735 || dim
->expr_type
!= EXPR_CONSTANT
736 || dim
->ts
.type
!= BT_INTEGER
)
739 n
= mpz_get_si (dim
->value
.integer
);
740 n
--; /* Convert to zero based index. */
741 if (n
< 0 || n
>= rank
)
744 s
= new_shape
= gfc_get_shape (rank
- 1);
746 for (i
= 0; i
< rank
; i
++)
750 mpz_init_set (*s
, shape
[i
]);
758 /* Return the maximum kind of two expressions. In general, higher
759 kind numbers mean more precision for numeric types. */
762 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
764 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
768 /* Returns nonzero if the type is numeric, zero otherwise. */
771 numeric_type (bt type
)
773 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
777 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
780 gfc_numeric_ts (gfc_typespec
*ts
)
782 return numeric_type (ts
->type
);
786 /* Return an expression node with an optional argument list attached.
787 A variable number of gfc_expr pointers are strung together in an
788 argument list with a NULL pointer terminating the list. */
791 gfc_build_conversion (gfc_expr
*e
)
796 p
->expr_type
= EXPR_FUNCTION
;
798 p
->value
.function
.actual
= gfc_get_actual_arglist ();
799 p
->value
.function
.actual
->expr
= e
;
805 /* Given an expression node with some sort of numeric binary
806 expression, insert type conversions required to make the operands
807 have the same type. Conversion warnings are disabled if wconversion
810 The exception is that the operands of an exponential don't have to
811 have the same type. If possible, the base is promoted to the type
812 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
813 1.0**2 stays as it is. */
816 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
820 op1
= e
->value
.op
.op1
;
821 op2
= e
->value
.op
.op2
;
823 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
825 gfc_clear_ts (&e
->ts
);
829 /* Kind conversions of same type. */
830 if (op1
->ts
.type
== op2
->ts
.type
)
832 if (op1
->ts
.kind
== op2
->ts
.kind
)
834 /* No type conversions. */
839 if (op1
->ts
.kind
> op2
->ts
.kind
)
840 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
842 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
848 /* Integer combined with real or complex. */
849 if (op2
->ts
.type
== BT_INTEGER
)
853 /* Special case for ** operator. */
854 if (e
->value
.op
.op
== INTRINSIC_POWER
)
857 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
861 if (op1
->ts
.type
== BT_INTEGER
)
864 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
868 /* Real combined with complex. */
869 e
->ts
.type
= BT_COMPLEX
;
870 if (op1
->ts
.kind
> op2
->ts
.kind
)
871 e
->ts
.kind
= op1
->ts
.kind
;
873 e
->ts
.kind
= op2
->ts
.kind
;
874 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
875 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
876 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
877 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
884 /* Function to determine if an expression is constant or not. This
885 function expects that the expression has already been simplified. */
888 gfc_is_constant_expr (gfc_expr
*e
)
891 gfc_actual_arglist
*arg
;
897 switch (e
->expr_type
)
900 return (gfc_is_constant_expr (e
->value
.op
.op1
)
901 && (e
->value
.op
.op2
== NULL
902 || gfc_is_constant_expr (e
->value
.op
.op2
)));
910 gcc_assert (e
->symtree
|| e
->value
.function
.esym
911 || e
->value
.function
.isym
);
913 /* Call to intrinsic with at least one argument. */
914 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
916 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
917 if (!gfc_is_constant_expr (arg
->expr
))
921 /* Specification functions are constant. */
922 /* F95, 7.1.6.2; F2003, 7.1.7 */
925 sym
= e
->symtree
->n
.sym
;
926 if (e
->value
.function
.esym
)
927 sym
= e
->value
.function
.esym
;
930 && sym
->attr
.function
932 && !sym
->attr
.intrinsic
933 && !sym
->attr
.recursive
934 && sym
->attr
.proc
!= PROC_INTERNAL
935 && sym
->attr
.proc
!= PROC_ST_FUNCTION
936 && sym
->attr
.proc
!= PROC_UNKNOWN
937 && gfc_sym_get_dummy_args (sym
) == NULL
)
940 if (e
->value
.function
.isym
941 && (e
->value
.function
.isym
->elemental
942 || e
->value
.function
.isym
->pure
943 || e
->value
.function
.isym
->inquiry
944 || e
->value
.function
.isym
->transformational
))
954 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
955 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
959 c
= gfc_constructor_first (e
->value
.constructor
);
960 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
961 return gfc_constant_ac (e
);
963 for (; c
; c
= gfc_constructor_next (c
))
964 if (!gfc_is_constant_expr (c
->expr
))
971 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
977 /* Is true if an array reference is followed by a component or substring
980 is_subref_array (gfc_expr
* e
)
985 if (e
->expr_type
!= EXPR_VARIABLE
)
988 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
992 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
994 if (ref
->type
== REF_ARRAY
995 && ref
->u
.ar
.type
!= AR_ELEMENT
)
999 && ref
->type
!= REF_ARRAY
)
1006 /* Try to collapse intrinsic expressions. */
1009 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1011 gfc_intrinsic_op op
;
1012 gfc_expr
*op1
, *op2
, *result
;
1014 if (p
->value
.op
.op
== INTRINSIC_USER
)
1017 op1
= p
->value
.op
.op1
;
1018 op2
= p
->value
.op
.op2
;
1019 op
= p
->value
.op
.op
;
1021 if (!gfc_simplify_expr (op1
, type
))
1023 if (!gfc_simplify_expr (op2
, type
))
1026 if (!gfc_is_constant_expr (op1
)
1027 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1031 p
->value
.op
.op1
= NULL
;
1032 p
->value
.op
.op2
= NULL
;
1036 case INTRINSIC_PARENTHESES
:
1037 result
= gfc_parentheses (op1
);
1040 case INTRINSIC_UPLUS
:
1041 result
= gfc_uplus (op1
);
1044 case INTRINSIC_UMINUS
:
1045 result
= gfc_uminus (op1
);
1048 case INTRINSIC_PLUS
:
1049 result
= gfc_add (op1
, op2
);
1052 case INTRINSIC_MINUS
:
1053 result
= gfc_subtract (op1
, op2
);
1056 case INTRINSIC_TIMES
:
1057 result
= gfc_multiply (op1
, op2
);
1060 case INTRINSIC_DIVIDE
:
1061 result
= gfc_divide (op1
, op2
);
1064 case INTRINSIC_POWER
:
1065 result
= gfc_power (op1
, op2
);
1068 case INTRINSIC_CONCAT
:
1069 result
= gfc_concat (op1
, op2
);
1073 case INTRINSIC_EQ_OS
:
1074 result
= gfc_eq (op1
, op2
, op
);
1078 case INTRINSIC_NE_OS
:
1079 result
= gfc_ne (op1
, op2
, op
);
1083 case INTRINSIC_GT_OS
:
1084 result
= gfc_gt (op1
, op2
, op
);
1088 case INTRINSIC_GE_OS
:
1089 result
= gfc_ge (op1
, op2
, op
);
1093 case INTRINSIC_LT_OS
:
1094 result
= gfc_lt (op1
, op2
, op
);
1098 case INTRINSIC_LE_OS
:
1099 result
= gfc_le (op1
, op2
, op
);
1103 result
= gfc_not (op1
);
1107 result
= gfc_and (op1
, op2
);
1111 result
= gfc_or (op1
, op2
);
1115 result
= gfc_eqv (op1
, op2
);
1118 case INTRINSIC_NEQV
:
1119 result
= gfc_neqv (op1
, op2
);
1123 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1128 gfc_free_expr (op1
);
1129 gfc_free_expr (op2
);
1133 result
->rank
= p
->rank
;
1134 result
->where
= p
->where
;
1135 gfc_replace_expr (p
, result
);
1141 /* Subroutine to simplify constructor expressions. Mutually recursive
1142 with gfc_simplify_expr(). */
1145 simplify_constructor (gfc_constructor_base base
, int type
)
1150 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1153 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1154 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1155 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1160 /* Try and simplify a copy. Replace the original if successful
1161 but keep going through the constructor at all costs. Not
1162 doing so can make a dog's dinner of complicated things. */
1163 p
= gfc_copy_expr (c
->expr
);
1165 if (!gfc_simplify_expr (p
, type
))
1171 gfc_replace_expr (c
->expr
, p
);
1179 /* Pull a single array element out of an array constructor. */
1182 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1183 gfc_constructor
**rval
)
1185 unsigned long nelemen
;
1191 gfc_constructor
*cons
;
1198 mpz_init_set_ui (offset
, 0);
1201 mpz_init_set_ui (span
, 1);
1202 for (i
= 0; i
< ar
->dimen
; i
++)
1204 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1205 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1213 if (e
->expr_type
!= EXPR_CONSTANT
)
1219 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1220 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1222 /* Check the bounds. */
1223 if ((ar
->as
->upper
[i
]
1224 && mpz_cmp (e
->value
.integer
,
1225 ar
->as
->upper
[i
]->value
.integer
) > 0)
1226 || (mpz_cmp (e
->value
.integer
,
1227 ar
->as
->lower
[i
]->value
.integer
) < 0))
1229 gfc_error ("Index in dimension %d is out of bounds "
1230 "at %L", i
+ 1, &ar
->c_where
[i
]);
1236 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1237 mpz_mul (delta
, delta
, span
);
1238 mpz_add (offset
, offset
, delta
);
1240 mpz_set_ui (tmp
, 1);
1241 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1242 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1243 mpz_mul (span
, span
, tmp
);
1246 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1247 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1266 /* Find a component of a structure constructor. */
1268 static gfc_constructor
*
1269 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1271 gfc_component
*pick
= ref
->u
.c
.component
;
1272 gfc_constructor
*c
= gfc_constructor_first (base
);
1274 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1275 int ext
= dt
->attr
.extension
;
1277 /* For extended types, check if the desired component is in one of the
1279 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1280 pick
->name
, true, true, NULL
))
1282 dt
= dt
->components
->ts
.u
.derived
;
1283 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1287 gfc_component
*comp
= dt
->components
;
1288 while (comp
!= pick
)
1291 c
= gfc_constructor_next (c
);
1298 /* Replace an expression with the contents of a constructor, removing
1299 the subobject reference in the process. */
1302 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1312 e
= gfc_copy_expr (p
);
1313 e
->ref
= p
->ref
->next
;
1314 p
->ref
->next
= NULL
;
1315 gfc_replace_expr (p
, e
);
1319 /* Pull an array section out of an array constructor. */
1322 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1329 long unsigned one
= 1;
1331 mpz_t start
[GFC_MAX_DIMENSIONS
];
1332 mpz_t end
[GFC_MAX_DIMENSIONS
];
1333 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1334 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1335 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1340 gfc_constructor_base base
;
1341 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1351 base
= expr
->value
.constructor
;
1352 expr
->value
.constructor
= NULL
;
1354 rank
= ref
->u
.ar
.as
->rank
;
1356 if (expr
->shape
== NULL
)
1357 expr
->shape
= gfc_get_shape (rank
);
1359 mpz_init_set_ui (delta_mpz
, one
);
1360 mpz_init_set_ui (nelts
, one
);
1363 /* Do the initialization now, so that we can cleanup without
1364 keeping track of where we were. */
1365 for (d
= 0; d
< rank
; d
++)
1367 mpz_init (delta
[d
]);
1368 mpz_init (start
[d
]);
1371 mpz_init (stride
[d
]);
1375 /* Build the counters to clock through the array reference. */
1377 for (d
= 0; d
< rank
; d
++)
1379 /* Make this stretch of code easier on the eye! */
1380 begin
= ref
->u
.ar
.start
[d
];
1381 finish
= ref
->u
.ar
.end
[d
];
1382 step
= ref
->u
.ar
.stride
[d
];
1383 lower
= ref
->u
.ar
.as
->lower
[d
];
1384 upper
= ref
->u
.ar
.as
->upper
[d
];
1386 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1388 gfc_constructor
*ci
;
1391 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1397 gcc_assert (begin
->rank
== 1);
1398 /* Zero-sized arrays have no shape and no elements, stop early. */
1401 mpz_init_set_ui (nelts
, 0);
1405 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1406 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1407 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1408 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1411 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1413 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1414 || mpz_cmp (ci
->expr
->value
.integer
,
1415 lower
->value
.integer
) < 0)
1417 gfc_error ("index in dimension %d is out of bounds "
1418 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1426 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1427 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1428 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1434 /* Obtain the stride. */
1436 mpz_set (stride
[d
], step
->value
.integer
);
1438 mpz_set_ui (stride
[d
], one
);
1440 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1441 mpz_set_ui (stride
[d
], one
);
1443 /* Obtain the start value for the index. */
1445 mpz_set (start
[d
], begin
->value
.integer
);
1447 mpz_set (start
[d
], lower
->value
.integer
);
1449 mpz_set (ctr
[d
], start
[d
]);
1451 /* Obtain the end value for the index. */
1453 mpz_set (end
[d
], finish
->value
.integer
);
1455 mpz_set (end
[d
], upper
->value
.integer
);
1457 /* Separate 'if' because elements sometimes arrive with
1459 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1460 mpz_set (end
[d
], begin
->value
.integer
);
1462 /* Check the bounds. */
1463 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1464 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1465 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1466 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1468 gfc_error ("index in dimension %d is out of bounds "
1469 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1474 /* Calculate the number of elements and the shape. */
1475 mpz_set (tmp_mpz
, stride
[d
]);
1476 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1477 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1478 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1479 mpz_mul (nelts
, nelts
, tmp_mpz
);
1481 /* An element reference reduces the rank of the expression; don't
1482 add anything to the shape array. */
1483 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1484 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1487 /* Calculate the 'stride' (=delta) for conversion of the
1488 counter values into the index along the constructor. */
1489 mpz_set (delta
[d
], delta_mpz
);
1490 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1491 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1492 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1496 cons
= gfc_constructor_first (base
);
1498 /* Now clock through the array reference, calculating the index in
1499 the source constructor and transferring the elements to the new
1501 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1503 mpz_init_set_ui (ptr
, 0);
1506 for (d
= 0; d
< rank
; d
++)
1508 mpz_set (tmp_mpz
, ctr
[d
]);
1509 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1510 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1511 mpz_add (ptr
, ptr
, tmp_mpz
);
1513 if (!incr_ctr
) continue;
1515 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1517 gcc_assert(vecsub
[d
]);
1519 if (!gfc_constructor_next (vecsub
[d
]))
1520 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1523 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1526 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1530 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1532 if (mpz_cmp_ui (stride
[d
], 0) > 0
1533 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1534 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1535 mpz_set (ctr
[d
], start
[d
]);
1541 limit
= mpz_get_ui (ptr
);
1542 if (limit
>= flag_max_array_constructor
)
1544 gfc_error ("The number of elements in the array constructor "
1545 "at %L requires an increase of the allowed %d "
1546 "upper limit. See -fmax-array-constructor "
1547 "option", &expr
->where
, flag_max_array_constructor
);
1551 cons
= gfc_constructor_lookup (base
, limit
);
1553 gfc_constructor_append_expr (&expr
->value
.constructor
,
1554 gfc_copy_expr (cons
->expr
), NULL
);
1561 mpz_clear (delta_mpz
);
1562 mpz_clear (tmp_mpz
);
1564 for (d
= 0; d
< rank
; d
++)
1566 mpz_clear (delta
[d
]);
1567 mpz_clear (start
[d
]);
1570 mpz_clear (stride
[d
]);
1572 gfc_constructor_free (base
);
1576 /* Pull a substring out of an expression. */
1579 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1586 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1587 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1590 *newp
= gfc_copy_expr (p
);
1591 free ((*newp
)->value
.character
.string
);
1593 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1594 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1595 length
= end
- start
+ 1;
1597 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1598 (*newp
)->value
.character
.length
= length
;
1599 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1600 length
* sizeof (gfc_char_t
));
1607 /* Simplify a subobject reference of a constructor. This occurs when
1608 parameter variable values are substituted. */
1611 simplify_const_ref (gfc_expr
*p
)
1613 gfc_constructor
*cons
, *c
;
1619 switch (p
->ref
->type
)
1622 switch (p
->ref
->u
.ar
.type
)
1625 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1626 will generate this. */
1627 if (p
->expr_type
!= EXPR_ARRAY
)
1629 remove_subobject_ref (p
, NULL
);
1632 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1638 remove_subobject_ref (p
, cons
);
1642 if (!find_array_section (p
, p
->ref
))
1644 p
->ref
->u
.ar
.type
= AR_FULL
;
1649 if (p
->ref
->next
!= NULL
1650 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1652 for (c
= gfc_constructor_first (p
->value
.constructor
);
1653 c
; c
= gfc_constructor_next (c
))
1655 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1656 if (!simplify_const_ref (c
->expr
))
1660 if (gfc_bt_struct (p
->ts
.type
)
1662 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1664 /* There may have been component references. */
1665 p
->ts
= c
->expr
->ts
;
1669 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1671 if (p
->ts
.type
== BT_CHARACTER
1672 && last_ref
->type
== REF_SUBSTRING
)
1674 /* If this is a CHARACTER array and we possibly took
1675 a substring out of it, update the type-spec's
1676 character length according to the first element
1677 (as all should have the same length). */
1679 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1681 const gfc_expr
* first
= c
->expr
;
1682 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1683 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1684 string_len
= first
->value
.character
.length
;
1690 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1693 gfc_free_expr (p
->ts
.u
.cl
->length
);
1696 = gfc_get_int_expr (gfc_default_integer_kind
,
1700 gfc_free_ref_list (p
->ref
);
1711 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1712 remove_subobject_ref (p
, cons
);
1716 if (!find_substring_ref (p
, &newp
))
1719 gfc_replace_expr (p
, newp
);
1720 gfc_free_ref_list (p
->ref
);
1730 /* Simplify a chain of references. */
1733 simplify_ref_chain (gfc_ref
*ref
, int type
)
1737 for (; ref
; ref
= ref
->next
)
1742 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1744 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1746 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1748 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1754 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1756 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1768 /* Try to substitute the value of a parameter variable. */
1771 simplify_parameter_variable (gfc_expr
*p
, int type
)
1776 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1782 /* Do not copy subobject refs for constant. */
1783 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1784 e
->ref
= gfc_copy_ref (p
->ref
);
1785 t
= gfc_simplify_expr (e
, type
);
1787 /* Only use the simplification if it eliminated all subobject references. */
1789 gfc_replace_expr (p
, e
);
1796 /* Given an expression, simplify it by collapsing constant
1797 expressions. Most simplification takes place when the expression
1798 tree is being constructed. If an intrinsic function is simplified
1799 at some point, we get called again to collapse the result against
1802 We work by recursively simplifying expression nodes, simplifying
1803 intrinsic functions where possible, which can lead to further
1804 constant collapsing. If an operator has constant operand(s), we
1805 rip the expression apart, and rebuild it, hoping that it becomes
1808 The expression type is defined for:
1809 0 Basic expression parsing
1810 1 Simplifying array constructors -- will substitute
1812 Returns false on error, true otherwise.
1813 NOTE: Will return true even if the expression can not be simplified. */
1816 gfc_simplify_expr (gfc_expr
*p
, int type
)
1818 gfc_actual_arglist
*ap
;
1823 switch (p
->expr_type
)
1830 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1831 if (!gfc_simplify_expr (ap
->expr
, type
))
1834 if (p
->value
.function
.isym
!= NULL
1835 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1840 case EXPR_SUBSTRING
:
1841 if (!simplify_ref_chain (p
->ref
, type
))
1844 if (gfc_is_constant_expr (p
))
1850 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1852 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1853 start
--; /* Convert from one-based to zero-based. */
1856 end
= p
->value
.character
.length
;
1857 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1858 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1863 s
= gfc_get_wide_string (end
- start
+ 2);
1864 memcpy (s
, p
->value
.character
.string
+ start
,
1865 (end
- start
) * sizeof (gfc_char_t
));
1866 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1867 free (p
->value
.character
.string
);
1868 p
->value
.character
.string
= s
;
1869 p
->value
.character
.length
= end
- start
;
1870 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1871 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1873 p
->value
.character
.length
);
1874 gfc_free_ref_list (p
->ref
);
1876 p
->expr_type
= EXPR_CONSTANT
;
1881 if (!simplify_intrinsic_op (p
, type
))
1886 /* Only substitute array parameter variables if we are in an
1887 initialization expression, or we want a subsection. */
1888 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1889 && (gfc_init_expr_flag
|| p
->ref
1890 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1892 if (!simplify_parameter_variable (p
, type
))
1899 gfc_simplify_iterator_var (p
);
1902 /* Simplify subcomponent references. */
1903 if (!simplify_ref_chain (p
->ref
, type
))
1908 case EXPR_STRUCTURE
:
1910 if (!simplify_ref_chain (p
->ref
, type
))
1913 if (!simplify_constructor (p
->value
.constructor
, type
))
1916 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1917 && p
->ref
->u
.ar
.type
== AR_FULL
)
1918 gfc_expand_constructor (p
, false);
1920 if (!simplify_const_ref (p
))
1934 /* Returns the type of an expression with the exception that iterator
1935 variables are automatically integers no matter what else they may
1941 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
1948 /* Scalarize an expression for an elemental intrinsic call. */
1951 scalarize_intrinsic_call (gfc_expr
*e
)
1953 gfc_actual_arglist
*a
, *b
;
1954 gfc_constructor_base ctor
;
1955 gfc_constructor
*args
[5];
1956 gfc_constructor
*ci
, *new_ctor
;
1957 gfc_expr
*expr
, *old
;
1958 int n
, i
, rank
[5], array_arg
;
1960 /* Find which, if any, arguments are arrays. Assume that the old
1961 expression carries the type information and that the first arg
1962 that is an array expression carries all the shape information.*/
1964 a
= e
->value
.function
.actual
;
1965 for (; a
; a
= a
->next
)
1968 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
1971 expr
= gfc_copy_expr (a
->expr
);
1978 old
= gfc_copy_expr (e
);
1980 gfc_constructor_free (expr
->value
.constructor
);
1981 expr
->value
.constructor
= NULL
;
1983 expr
->where
= old
->where
;
1984 expr
->expr_type
= EXPR_ARRAY
;
1986 /* Copy the array argument constructors into an array, with nulls
1989 a
= old
->value
.function
.actual
;
1990 for (; a
; a
= a
->next
)
1992 /* Check that this is OK for an initialization expression. */
1993 if (a
->expr
&& !gfc_check_init_expr (a
->expr
))
1997 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1999 rank
[n
] = a
->expr
->rank
;
2000 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2001 args
[n
] = gfc_constructor_first (ctor
);
2003 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2006 rank
[n
] = a
->expr
->rank
;
2009 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2010 args
[n
] = gfc_constructor_first (ctor
);
2019 /* Using the array argument as the master, step through the array
2020 calling the function for each element and advancing the array
2021 constructors together. */
2022 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2024 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2025 gfc_copy_expr (old
), NULL
);
2027 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2029 b
= old
->value
.function
.actual
;
2030 for (i
= 0; i
< n
; i
++)
2033 new_ctor
->expr
->value
.function
.actual
2034 = a
= gfc_get_actual_arglist ();
2037 a
->next
= gfc_get_actual_arglist ();
2042 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2044 a
->expr
= gfc_copy_expr (b
->expr
);
2049 /* Simplify the function calls. If the simplification fails, the
2050 error will be flagged up down-stream or the library will deal
2052 gfc_simplify_expr (new_ctor
->expr
, 0);
2054 for (i
= 0; i
< n
; i
++)
2056 args
[i
] = gfc_constructor_next (args
[i
]);
2058 for (i
= 1; i
< n
; i
++)
2059 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2060 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2066 /* Free "expr" but not the pointers it contains. */
2068 gfc_free_expr (old
);
2072 gfc_error_now ("elemental function arguments at %C are not compliant");
2075 gfc_free_expr (expr
);
2076 gfc_free_expr (old
);
2082 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2084 gfc_expr
*op1
= e
->value
.op
.op1
;
2085 gfc_expr
*op2
= e
->value
.op
.op2
;
2087 if (!(*check_function
)(op1
))
2090 switch (e
->value
.op
.op
)
2092 case INTRINSIC_UPLUS
:
2093 case INTRINSIC_UMINUS
:
2094 if (!numeric_type (et0 (op1
)))
2099 case INTRINSIC_EQ_OS
:
2101 case INTRINSIC_NE_OS
:
2103 case INTRINSIC_GT_OS
:
2105 case INTRINSIC_GE_OS
:
2107 case INTRINSIC_LT_OS
:
2109 case INTRINSIC_LE_OS
:
2110 if (!(*check_function
)(op2
))
2113 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2114 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2116 gfc_error ("Numeric or CHARACTER operands are required in "
2117 "expression at %L", &e
->where
);
2122 case INTRINSIC_PLUS
:
2123 case INTRINSIC_MINUS
:
2124 case INTRINSIC_TIMES
:
2125 case INTRINSIC_DIVIDE
:
2126 case INTRINSIC_POWER
:
2127 if (!(*check_function
)(op2
))
2130 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2135 case INTRINSIC_CONCAT
:
2136 if (!(*check_function
)(op2
))
2139 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2141 gfc_error ("Concatenation operator in expression at %L "
2142 "must have two CHARACTER operands", &op1
->where
);
2146 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2148 gfc_error ("Concat operator at %L must concatenate strings of the "
2149 "same kind", &e
->where
);
2156 if (et0 (op1
) != BT_LOGICAL
)
2158 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2159 "operand", &op1
->where
);
2168 case INTRINSIC_NEQV
:
2169 if (!(*check_function
)(op2
))
2172 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2174 gfc_error ("LOGICAL operands are required in expression at %L",
2181 case INTRINSIC_PARENTHESES
:
2185 gfc_error ("Only intrinsic operators can be used in expression at %L",
2193 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2198 /* F2003, 7.1.7 (3): In init expression, allocatable components
2199 must not be data-initialized. */
2201 check_alloc_comp_init (gfc_expr
*e
)
2203 gfc_component
*comp
;
2204 gfc_constructor
*ctor
;
2206 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2207 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2209 for (comp
= e
->ts
.u
.derived
->components
,
2210 ctor
= gfc_constructor_first (e
->value
.constructor
);
2211 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2213 if (comp
->attr
.allocatable
&& ctor
->expr
2214 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2216 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2217 "component %qs in structure constructor at %L",
2218 comp
->name
, &ctor
->expr
->where
);
2227 check_init_expr_arguments (gfc_expr
*e
)
2229 gfc_actual_arglist
*ap
;
2231 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2232 if (!gfc_check_init_expr (ap
->expr
))
2238 static bool check_restricted (gfc_expr
*);
2240 /* F95, 7.1.6.1, Initialization expressions, (7)
2241 F2003, 7.1.7 Initialization expression, (8) */
2244 check_inquiry (gfc_expr
*e
, int not_restricted
)
2247 const char *const *functions
;
2249 static const char *const inquiry_func_f95
[] = {
2250 "lbound", "shape", "size", "ubound",
2251 "bit_size", "len", "kind",
2252 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2253 "precision", "radix", "range", "tiny",
2257 static const char *const inquiry_func_f2003
[] = {
2258 "lbound", "shape", "size", "ubound",
2259 "bit_size", "len", "kind",
2260 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2261 "precision", "radix", "range", "tiny",
2266 gfc_actual_arglist
*ap
;
2268 if (!e
->value
.function
.isym
2269 || !e
->value
.function
.isym
->inquiry
)
2272 /* An undeclared parameter will get us here (PR25018). */
2273 if (e
->symtree
== NULL
)
2276 if (e
->symtree
->n
.sym
->from_intmod
)
2278 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2279 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2280 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2283 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2284 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2289 name
= e
->symtree
->n
.sym
->name
;
2291 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2292 ? inquiry_func_f2003
: inquiry_func_f95
;
2294 for (i
= 0; functions
[i
]; i
++)
2295 if (strcmp (functions
[i
], name
) == 0)
2298 if (functions
[i
] == NULL
)
2302 /* At this point we have an inquiry function with a variable argument. The
2303 type of the variable might be undefined, but we need it now, because the
2304 arguments of these functions are not allowed to be undefined. */
2306 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2311 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2313 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2314 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2317 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2320 /* Assumed character length will not reduce to a constant expression
2321 with LEN, as required by the standard. */
2322 if (i
== 5 && not_restricted
2323 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2324 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2325 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2327 gfc_error ("Assumed or deferred character length variable %qs "
2328 " in constant expression at %L",
2329 ap
->expr
->symtree
->n
.sym
->name
,
2333 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2336 if (not_restricted
== 0
2337 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2338 && !check_restricted (ap
->expr
))
2341 if (not_restricted
== 0
2342 && ap
->expr
->expr_type
== EXPR_VARIABLE
2343 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2344 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2352 /* F95, 7.1.6.1, Initialization expressions, (5)
2353 F2003, 7.1.7 Initialization expression, (5) */
2356 check_transformational (gfc_expr
*e
)
2358 static const char * const trans_func_f95
[] = {
2359 "repeat", "reshape", "selected_int_kind",
2360 "selected_real_kind", "transfer", "trim", NULL
2363 static const char * const trans_func_f2003
[] = {
2364 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2365 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2366 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2367 "trim", "unpack", NULL
2372 const char *const *functions
;
2374 if (!e
->value
.function
.isym
2375 || !e
->value
.function
.isym
->transformational
)
2378 name
= e
->symtree
->n
.sym
->name
;
2380 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2381 ? trans_func_f2003
: trans_func_f95
;
2383 /* NULL() is dealt with below. */
2384 if (strcmp ("null", name
) == 0)
2387 for (i
= 0; functions
[i
]; i
++)
2388 if (strcmp (functions
[i
], name
) == 0)
2391 if (functions
[i
] == NULL
)
2393 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2394 "in an initialization expression", name
, &e
->where
);
2398 return check_init_expr_arguments (e
);
2402 /* F95, 7.1.6.1, Initialization expressions, (6)
2403 F2003, 7.1.7 Initialization expression, (6) */
2406 check_null (gfc_expr
*e
)
2408 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2411 return check_init_expr_arguments (e
);
2416 check_elemental (gfc_expr
*e
)
2418 if (!e
->value
.function
.isym
2419 || !e
->value
.function
.isym
->elemental
)
2422 if (e
->ts
.type
!= BT_INTEGER
2423 && e
->ts
.type
!= BT_CHARACTER
2424 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2425 "initialization expression at %L", &e
->where
))
2428 return check_init_expr_arguments (e
);
2433 check_conversion (gfc_expr
*e
)
2435 if (!e
->value
.function
.isym
2436 || !e
->value
.function
.isym
->conversion
)
2439 return check_init_expr_arguments (e
);
2443 /* Verify that an expression is an initialization expression. A side
2444 effect is that the expression tree is reduced to a single constant
2445 node if all goes well. This would normally happen when the
2446 expression is constructed but function references are assumed to be
2447 intrinsics in the context of initialization expressions. If
2448 false is returned an error message has been generated. */
2451 gfc_check_init_expr (gfc_expr
*e
)
2459 switch (e
->expr_type
)
2462 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2464 t
= gfc_simplify_expr (e
, 0);
2473 gfc_intrinsic_sym
* isym
= NULL
;
2474 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2476 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2477 IEEE_EXCEPTIONS modules. */
2478 int mod
= sym
->from_intmod
;
2479 if (mod
== INTMOD_NONE
&& sym
->generic
)
2480 mod
= sym
->generic
->sym
->from_intmod
;
2481 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2483 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2486 gfc_replace_expr (e
, new_expr
);
2492 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2493 into an array constructor, we need to skip the error check here.
2494 Conversion errors are caught below in scalarize_intrinsic_call. */
2495 conversion
= e
->value
.function
.isym
2496 && (e
->value
.function
.isym
->conversion
== 1);
2498 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2499 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2501 gfc_error ("Function %qs in initialization expression at %L "
2502 "must be an intrinsic function",
2503 e
->symtree
->n
.sym
->name
, &e
->where
);
2507 if ((m
= check_conversion (e
)) == MATCH_NO
2508 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2509 && (m
= check_null (e
)) == MATCH_NO
2510 && (m
= check_transformational (e
)) == MATCH_NO
2511 && (m
= check_elemental (e
)) == MATCH_NO
)
2513 gfc_error ("Intrinsic function %qs at %L is not permitted "
2514 "in an initialization expression",
2515 e
->symtree
->n
.sym
->name
, &e
->where
);
2519 if (m
== MATCH_ERROR
)
2522 /* Try to scalarize an elemental intrinsic function that has an
2524 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2525 if (isym
&& isym
->elemental
2526 && (t
= scalarize_intrinsic_call (e
)))
2531 t
= gfc_simplify_expr (e
, 0);
2538 if (gfc_check_iter_variable (e
))
2541 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2543 /* A PARAMETER shall not be used to define itself, i.e.
2544 REAL, PARAMETER :: x = transfer(0, x)
2546 if (!e
->symtree
->n
.sym
->value
)
2548 gfc_error ("PARAMETER %qs is used at %L before its definition "
2549 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2553 t
= simplify_parameter_variable (e
, 0);
2558 if (gfc_in_match_data ())
2563 if (e
->symtree
->n
.sym
->as
)
2565 switch (e
->symtree
->n
.sym
->as
->type
)
2567 case AS_ASSUMED_SIZE
:
2568 gfc_error ("Assumed size array %qs at %L is not permitted "
2569 "in an initialization expression",
2570 e
->symtree
->n
.sym
->name
, &e
->where
);
2573 case AS_ASSUMED_SHAPE
:
2574 gfc_error ("Assumed shape array %qs at %L is not permitted "
2575 "in an initialization expression",
2576 e
->symtree
->n
.sym
->name
, &e
->where
);
2580 gfc_error ("Deferred array %qs at %L is not permitted "
2581 "in an initialization expression",
2582 e
->symtree
->n
.sym
->name
, &e
->where
);
2586 gfc_error ("Array %qs at %L is a variable, which does "
2587 "not reduce to a constant expression",
2588 e
->symtree
->n
.sym
->name
, &e
->where
);
2596 gfc_error ("Parameter %qs at %L has not been declared or is "
2597 "a variable, which does not reduce to a constant "
2598 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2607 case EXPR_SUBSTRING
:
2610 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2614 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2616 t
= gfc_simplify_expr (e
, 0);
2622 case EXPR_STRUCTURE
:
2623 t
= e
->ts
.is_iso_c
? true : false;
2627 t
= check_alloc_comp_init (e
);
2631 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2638 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2642 t
= gfc_expand_constructor (e
, true);
2646 t
= gfc_check_constructor_type (e
);
2650 gfc_internal_error ("check_init_expr(): Unknown expression type");
2656 /* Reduces a general expression to an initialization expression (a constant).
2657 This used to be part of gfc_match_init_expr.
2658 Note that this function doesn't free the given expression on false. */
2661 gfc_reduce_init_expr (gfc_expr
*expr
)
2665 gfc_init_expr_flag
= true;
2666 t
= gfc_resolve_expr (expr
);
2668 t
= gfc_check_init_expr (expr
);
2669 gfc_init_expr_flag
= false;
2674 if (expr
->expr_type
== EXPR_ARRAY
)
2676 if (!gfc_check_constructor_type (expr
))
2678 if (!gfc_expand_constructor (expr
, true))
2686 /* Match an initialization expression. We work by first matching an
2687 expression, then reducing it to a constant. */
2690 gfc_match_init_expr (gfc_expr
**result
)
2698 gfc_init_expr_flag
= true;
2700 m
= gfc_match_expr (&expr
);
2703 gfc_init_expr_flag
= false;
2707 t
= gfc_reduce_init_expr (expr
);
2710 gfc_free_expr (expr
);
2711 gfc_init_expr_flag
= false;
2716 gfc_init_expr_flag
= false;
2722 /* Given an actual argument list, test to see that each argument is a
2723 restricted expression and optionally if the expression type is
2724 integer or character. */
2727 restricted_args (gfc_actual_arglist
*a
)
2729 for (; a
; a
= a
->next
)
2731 if (!check_restricted (a
->expr
))
2739 /************* Restricted/specification expressions *************/
2742 /* Make sure a non-intrinsic function is a specification function. */
2745 external_spec_function (gfc_expr
*e
)
2749 f
= e
->value
.function
.esym
;
2751 /* IEEE functions allowed are "a reference to a transformational function
2752 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
2753 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
2754 IEEE_EXCEPTIONS". */
2755 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
2756 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
2758 if (!strcmp (f
->name
, "ieee_selected_real_kind")
2759 || !strcmp (f
->name
, "ieee_support_rounding")
2760 || !strcmp (f
->name
, "ieee_support_flag")
2761 || !strcmp (f
->name
, "ieee_support_halting")
2762 || !strcmp (f
->name
, "ieee_support_datatype")
2763 || !strcmp (f
->name
, "ieee_support_denormal")
2764 || !strcmp (f
->name
, "ieee_support_divide")
2765 || !strcmp (f
->name
, "ieee_support_inf")
2766 || !strcmp (f
->name
, "ieee_support_io")
2767 || !strcmp (f
->name
, "ieee_support_nan")
2768 || !strcmp (f
->name
, "ieee_support_sqrt")
2769 || !strcmp (f
->name
, "ieee_support_standard")
2770 || !strcmp (f
->name
, "ieee_support_underflow_control"))
2771 goto function_allowed
;
2774 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2776 gfc_error ("Specification function %qs at %L cannot be a statement "
2777 "function", f
->name
, &e
->where
);
2781 if (f
->attr
.proc
== PROC_INTERNAL
)
2783 gfc_error ("Specification function %qs at %L cannot be an internal "
2784 "function", f
->name
, &e
->where
);
2788 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2790 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
2796 if (f
->attr
.recursive
2797 && !gfc_notify_std (GFC_STD_F2003
,
2798 "Specification function '%s' "
2799 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
2803 return restricted_args (e
->value
.function
.actual
);
2807 /* Check to see that a function reference to an intrinsic is a
2808 restricted expression. */
2811 restricted_intrinsic (gfc_expr
*e
)
2813 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2814 if (check_inquiry (e
, 0) == MATCH_YES
)
2817 return restricted_args (e
->value
.function
.actual
);
2821 /* Check the expressions of an actual arglist. Used by check_restricted. */
2824 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
2826 for (; arg
; arg
= arg
->next
)
2827 if (!checker (arg
->expr
))
2834 /* Check the subscription expressions of a reference chain with a checking
2835 function; used by check_restricted. */
2838 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
2848 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2850 if (!checker (ref
->u
.ar
.start
[dim
]))
2852 if (!checker (ref
->u
.ar
.end
[dim
]))
2854 if (!checker (ref
->u
.ar
.stride
[dim
]))
2860 /* Nothing needed, just proceed to next reference. */
2864 if (!checker (ref
->u
.ss
.start
))
2866 if (!checker (ref
->u
.ss
.end
))
2875 return check_references (ref
->next
, checker
);
2878 /* Return true if ns is a parent of the current ns. */
2881 is_parent_of_current_ns (gfc_namespace
*ns
)
2884 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
2891 /* Verify that an expression is a restricted expression. Like its
2892 cousin check_init_expr(), an error message is generated if we
2896 check_restricted (gfc_expr
*e
)
2904 switch (e
->expr_type
)
2907 t
= check_intrinsic_op (e
, check_restricted
);
2909 t
= gfc_simplify_expr (e
, 0);
2914 if (e
->value
.function
.esym
)
2916 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2918 t
= external_spec_function (e
);
2922 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2925 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2928 t
= restricted_intrinsic (e
);
2933 sym
= e
->symtree
->n
.sym
;
2936 /* If a dummy argument appears in a context that is valid for a
2937 restricted expression in an elemental procedure, it will have
2938 already been simplified away once we get here. Therefore we
2939 don't need to jump through hoops to distinguish valid from
2941 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2942 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2944 gfc_error ("Dummy argument %qs not allowed in expression at %L",
2945 sym
->name
, &e
->where
);
2949 if (sym
->attr
.optional
)
2951 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
2952 sym
->name
, &e
->where
);
2956 if (sym
->attr
.intent
== INTENT_OUT
)
2958 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
2959 sym
->name
, &e
->where
);
2963 /* Check reference chain if any. */
2964 if (!check_references (e
->ref
, &check_restricted
))
2967 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2968 processed in resolve.c(resolve_formal_arglist). This is done so
2969 that host associated dummy array indices are accepted (PR23446).
2970 This mechanism also does the same for the specification expressions
2971 of array-valued functions. */
2973 || sym
->attr
.in_common
2974 || sym
->attr
.use_assoc
2976 || sym
->attr
.implied_index
2977 || sym
->attr
.flavor
== FL_PARAMETER
2978 || is_parent_of_current_ns (sym
->ns
)
2979 || (sym
->ns
->proc_name
!= NULL
2980 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2981 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2987 gfc_error ("Variable %qs cannot appear in the expression at %L",
2988 sym
->name
, &e
->where
);
2989 /* Prevent a repetition of the error. */
2998 case EXPR_SUBSTRING
:
2999 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3003 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3005 t
= gfc_simplify_expr (e
, 0);
3009 case EXPR_STRUCTURE
:
3010 t
= gfc_check_constructor (e
, check_restricted
);
3014 t
= gfc_check_constructor (e
, check_restricted
);
3018 gfc_internal_error ("check_restricted(): Unknown expression type");
3025 /* Check to see that an expression is a specification expression. If
3026 we return false, an error has been generated. */
3029 gfc_specification_expr (gfc_expr
*e
)
3031 gfc_component
*comp
;
3036 if (e
->ts
.type
!= BT_INTEGER
)
3038 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3039 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3043 comp
= gfc_get_proc_ptr_comp (e
);
3044 if (e
->expr_type
== EXPR_FUNCTION
3045 && !e
->value
.function
.isym
3046 && !e
->value
.function
.esym
3047 && !gfc_pure (e
->symtree
->n
.sym
)
3048 && (!comp
|| !comp
->attr
.pure
))
3050 gfc_error ("Function %qs at %L must be PURE",
3051 e
->symtree
->n
.sym
->name
, &e
->where
);
3052 /* Prevent repeat error messages. */
3053 e
->symtree
->n
.sym
->attr
.pure
= 1;
3059 gfc_error ("Expression at %L must be scalar", &e
->where
);
3063 if (!gfc_simplify_expr (e
, 0))
3066 return check_restricted (e
);
3070 /************** Expression conformance checks. *************/
3072 /* Given two expressions, make sure that the arrays are conformable. */
3075 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3077 int op1_flag
, op2_flag
, d
;
3078 mpz_t op1_size
, op2_size
;
3084 if (op1
->rank
== 0 || op2
->rank
== 0)
3087 va_start (argp
, optype_msgid
);
3088 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3091 if (op1
->rank
!= op2
->rank
)
3093 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3094 op1
->rank
, op2
->rank
, &op1
->where
);
3100 for (d
= 0; d
< op1
->rank
; d
++)
3102 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3103 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3105 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3107 gfc_error ("Different shape for %s at %L on dimension %d "
3108 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3109 (int) mpz_get_si (op1_size
),
3110 (int) mpz_get_si (op2_size
));
3116 mpz_clear (op1_size
);
3118 mpz_clear (op2_size
);
3128 /* Given an assignable expression and an arbitrary expression, make
3129 sure that the assignment can take place. Only add a call to the intrinsic
3130 conversion routines, when allow_convert is set. When this assign is a
3131 coarray call, then the convert is done by the coarray routine implictly and
3132 adding the intrinsic conversion would do harm in most cases. */
3135 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3142 sym
= lvalue
->symtree
->n
.sym
;
3144 /* See if this is the component or subcomponent of a pointer. */
3145 has_pointer
= sym
->attr
.pointer
;
3146 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3147 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3153 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3154 variable local to a function subprogram. Its existence begins when
3155 execution of the function is initiated and ends when execution of the
3156 function is terminated...
3157 Therefore, the left hand side is no longer a variable, when it is: */
3158 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3159 && !sym
->attr
.external
)
3164 /* (i) Use associated; */
3165 if (sym
->attr
.use_assoc
)
3168 /* (ii) The assignment is in the main program; or */
3169 if (gfc_current_ns
->proc_name
3170 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3173 /* (iii) A module or internal procedure... */
3174 if (gfc_current_ns
->proc_name
3175 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3176 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3177 && gfc_current_ns
->parent
3178 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3179 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3180 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3182 /* ... that is not a function... */
3183 if (gfc_current_ns
->proc_name
3184 && !gfc_current_ns
->proc_name
->attr
.function
)
3187 /* ... or is not an entry and has a different name. */
3188 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3192 /* (iv) Host associated and not the function symbol or the
3193 parent result. This picks up sibling references, which
3194 cannot be entries. */
3195 if (!sym
->attr
.entry
3196 && sym
->ns
== gfc_current_ns
->parent
3197 && sym
!= gfc_current_ns
->proc_name
3198 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3203 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3208 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3210 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3211 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3215 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3217 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3222 if (rvalue
->expr_type
== EXPR_NULL
)
3224 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3225 && lvalue
->symtree
->n
.sym
->attr
.data
)
3229 gfc_error ("NULL appears on right-hand side in assignment at %L",
3235 /* This is possibly a typo: x = f() instead of x => f(). */
3237 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3238 gfc_warning (OPT_Wsurprising
,
3239 "POINTER-valued function appears on right-hand side of "
3240 "assignment at %L", &rvalue
->where
);
3242 /* Check size of array assignments. */
3243 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3244 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3247 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3248 && lvalue
->symtree
->n
.sym
->attr
.data
3249 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3250 "initialize non-integer variable %qs",
3251 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3253 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3254 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3255 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3259 /* Handle the case of a BOZ literal on the RHS. */
3260 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3263 if (warn_surprising
)
3264 gfc_warning (OPT_Wsurprising
,
3265 "BOZ literal at %L is bitwise transferred "
3266 "non-integer symbol %qs", &rvalue
->where
,
3267 lvalue
->symtree
->n
.sym
->name
);
3268 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3270 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3272 if (rc
== ARITH_UNDERFLOW
)
3273 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3274 ". This check can be disabled with the option "
3275 "%<-fno-range-check%>", &rvalue
->where
);
3276 else if (rc
== ARITH_OVERFLOW
)
3277 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3278 ". This check can be disabled with the option "
3279 "%<-fno-range-check%>", &rvalue
->where
);
3280 else if (rc
== ARITH_NAN
)
3281 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3282 ". This check can be disabled with the option "
3283 "%<-fno-range-check%>", &rvalue
->where
);
3288 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3291 /* Only DATA Statements come here. */
3294 /* Numeric can be converted to any other numeric. And Hollerith can be
3295 converted to any other type. */
3296 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3297 || rvalue
->ts
.type
== BT_HOLLERITH
)
3300 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3303 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3304 "conversion of %s to %s", &lvalue
->where
,
3305 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3310 /* Assignment is the only case where character variables of different
3311 kind values can be converted into one another. */
3312 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3314 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3315 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3323 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3327 /* Check that a pointer assignment is OK. We first check lvalue, and
3328 we only check rvalue if it's not an assignment to NULL() or a
3329 NULLIFY statement. */
3332 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3334 symbol_attribute attr
, lhs_attr
;
3336 bool is_pure
, is_implicit_pure
, rank_remap
;
3339 lhs_attr
= gfc_expr_attr (lvalue
);
3340 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3342 gfc_error ("Pointer assignment target is not a POINTER at %L",
3347 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3348 && !lhs_attr
.proc_pointer
)
3350 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3351 "l-value since it is a procedure",
3352 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3356 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3359 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3361 if (ref
->type
== REF_COMPONENT
)
3362 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3364 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3368 if (ref
->u
.ar
.type
== AR_FULL
)
3371 if (ref
->u
.ar
.type
!= AR_SECTION
)
3373 gfc_error ("Expected bounds specification for %qs at %L",
3374 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3378 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3379 "for %qs in pointer assignment at %L",
3380 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3383 /* When bounds are given, all lbounds are necessary and either all
3384 or none of the upper bounds; no strides are allowed. If the
3385 upper bounds are present, we may do rank remapping. */
3386 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3388 if (!ref
->u
.ar
.start
[dim
]
3389 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3391 gfc_error ("Lower bound has to be present at %L",
3395 if (ref
->u
.ar
.stride
[dim
])
3397 gfc_error ("Stride must not be present at %L",
3403 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3406 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3407 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3409 gfc_error ("Either all or none of the upper bounds"
3410 " must be specified at %L", &lvalue
->where
);
3418 is_pure
= gfc_pure (NULL
);
3419 is_implicit_pure
= gfc_implicit_pure (NULL
);
3421 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3422 kind, etc for lvalue and rvalue must match, and rvalue must be a
3423 pure variable if we're in a pure function. */
3424 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3427 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3428 if (lvalue
->expr_type
== EXPR_VARIABLE
3429 && gfc_is_coindexed (lvalue
))
3432 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3433 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3435 gfc_error ("Pointer object at %L shall not have a coindex",
3441 /* Checks on rvalue for procedure pointer assignments. */
3446 gfc_component
*comp1
, *comp2
;
3449 attr
= gfc_expr_attr (rvalue
);
3450 if (!((rvalue
->expr_type
== EXPR_NULL
)
3451 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3452 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3453 || (rvalue
->expr_type
== EXPR_VARIABLE
3454 && attr
.flavor
== FL_PROCEDURE
)))
3456 gfc_error ("Invalid procedure pointer assignment at %L",
3460 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3462 /* Check for intrinsics. */
3463 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3464 if (!sym
->attr
.intrinsic
3465 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3466 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3468 sym
->attr
.intrinsic
= 1;
3469 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3470 attr
= gfc_expr_attr (rvalue
);
3472 /* Check for result of embracing function. */
3473 if (sym
->attr
.function
&& sym
->result
== sym
)
3477 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3478 if (sym
== ns
->proc_name
)
3480 gfc_error ("Function result %qs is invalid as proc-target "
3481 "in procedure pointer assignment at %L",
3482 sym
->name
, &rvalue
->where
);
3489 gfc_error ("Abstract interface %qs is invalid "
3490 "in procedure pointer assignment at %L",
3491 rvalue
->symtree
->name
, &rvalue
->where
);
3494 /* Check for F08:C729. */
3495 if (attr
.flavor
== FL_PROCEDURE
)
3497 if (attr
.proc
== PROC_ST_FUNCTION
)
3499 gfc_error ("Statement function %qs is invalid "
3500 "in procedure pointer assignment at %L",
3501 rvalue
->symtree
->name
, &rvalue
->where
);
3504 if (attr
.proc
== PROC_INTERNAL
&&
3505 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3506 "is invalid in procedure pointer assignment "
3507 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3509 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3510 attr
.subroutine
) == 0)
3512 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3513 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3517 /* Check for F08:C730. */
3518 if (attr
.elemental
&& !attr
.intrinsic
)
3520 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3521 "in procedure pointer assignment at %L",
3522 rvalue
->symtree
->name
, &rvalue
->where
);
3526 /* Ensure that the calling convention is the same. As other attributes
3527 such as DLLEXPORT may differ, one explicitly only tests for the
3528 calling conventions. */
3529 if (rvalue
->expr_type
== EXPR_VARIABLE
3530 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3531 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3533 symbol_attribute calls
;
3536 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3537 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3538 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3540 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3541 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3543 gfc_error ("Mismatch in the procedure pointer assignment "
3544 "at %L: mismatch in the calling convention",
3550 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3552 s1
= comp1
->ts
.interface
;
3555 s1
= lvalue
->symtree
->n
.sym
;
3556 if (s1
->ts
.interface
)
3557 s1
= s1
->ts
.interface
;
3560 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3563 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3565 s2
= comp2
->ts
.interface
->result
;
3570 s2
= comp2
->ts
.interface
;
3574 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3576 if (rvalue
->value
.function
.esym
)
3577 s2
= rvalue
->value
.function
.esym
->result
;
3579 s2
= rvalue
->symtree
->n
.sym
->result
;
3585 s2
= rvalue
->symtree
->n
.sym
;
3589 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3590 s2
= s2
->ts
.interface
;
3592 /* Special check for the case of absent interface on the lvalue.
3593 * All other interface checks are done below. */
3594 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
3596 gfc_error ("Interface mismatch in procedure pointer assignment "
3597 "at %L: '%s' is not a subroutine", &rvalue
->where
, name
);
3601 if (s1
== s2
|| !s1
|| !s2
)
3604 /* F08:7.2.2.4 (4) */
3605 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
3606 && gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3608 gfc_error ("Explicit interface required for %qs at %L: %s",
3609 s1
->name
, &lvalue
->where
, err
);
3612 if (s2
->attr
.if_source
== IFSRC_UNKNOWN
3613 && gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3615 gfc_error ("Explicit interface required for %qs at %L: %s",
3616 s2
->name
, &rvalue
->where
, err
);
3620 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3621 err
, sizeof(err
), NULL
, NULL
))
3623 gfc_error ("Interface mismatch in procedure pointer assignment "
3624 "at %L: %s", &rvalue
->where
, err
);
3628 /* Check F2008Cor2, C729. */
3629 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
3630 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
3632 gfc_error ("Procedure pointer target %qs at %L must be either an "
3633 "intrinsic, host or use associated, referenced or have "
3634 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
3641 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3643 /* Check for F03:C717. */
3644 if (UNLIMITED_POLY (rvalue
)
3645 && !(UNLIMITED_POLY (lvalue
)
3646 || (lvalue
->ts
.type
== BT_DERIVED
3647 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3648 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3649 gfc_error ("Data-pointer-object at %L must be unlimited "
3650 "polymorphic, or of a type with the BIND or SEQUENCE "
3651 "attribute, to be compatible with an unlimited "
3652 "polymorphic target", &lvalue
->where
);
3654 gfc_error ("Different types in pointer assignment at %L; "
3655 "attempted assignment of %s to %s", &lvalue
->where
,
3656 gfc_typename (&rvalue
->ts
),
3657 gfc_typename (&lvalue
->ts
));
3661 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3663 gfc_error ("Different kind type parameters in pointer "
3664 "assignment at %L", &lvalue
->where
);
3668 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3670 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3674 /* Make sure the vtab is present. */
3675 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
3676 gfc_find_vtab (&rvalue
->ts
);
3678 /* Check rank remapping. */
3683 /* If this can be determined, check that the target must be at least as
3684 large as the pointer assigned to it is. */
3685 if (gfc_array_size (lvalue
, &lsize
)
3686 && gfc_array_size (rvalue
, &rsize
)
3687 && mpz_cmp (rsize
, lsize
) < 0)
3689 gfc_error ("Rank remapping target is smaller than size of the"
3690 " pointer (%ld < %ld) at %L",
3691 mpz_get_si (rsize
), mpz_get_si (lsize
),
3696 /* The target must be either rank one or it must be simply contiguous
3697 and F2008 must be allowed. */
3698 if (rvalue
->rank
!= 1)
3700 if (!gfc_is_simply_contiguous (rvalue
, true, false))
3702 gfc_error ("Rank remapping target must be rank 1 or"
3703 " simply contiguous at %L", &rvalue
->where
);
3706 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
3707 "rank 1 at %L", &rvalue
->where
))
3712 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3713 if (rvalue
->expr_type
== EXPR_NULL
)
3716 if (lvalue
->ts
.type
== BT_CHARACTER
)
3718 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3723 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3724 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3726 attr
= gfc_expr_attr (rvalue
);
3728 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3730 gfc_error ("Target expression in pointer assignment "
3731 "at %L must deliver a pointer result",
3736 if (!attr
.target
&& !attr
.pointer
)
3738 gfc_error ("Pointer assignment target is neither TARGET "
3739 "nor POINTER at %L", &rvalue
->where
);
3743 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3745 gfc_error ("Bad target in pointer assignment in PURE "
3746 "procedure at %L", &rvalue
->where
);
3749 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3750 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3752 if (gfc_has_vector_index (rvalue
))
3754 gfc_error ("Pointer assignment with vector subscript "
3755 "on rhs at %L", &rvalue
->where
);
3759 if (attr
.is_protected
&& attr
.use_assoc
3760 && !(attr
.pointer
|| attr
.proc_pointer
))
3762 gfc_error ("Pointer assignment target has PROTECTED "
3763 "attribute at %L", &rvalue
->where
);
3767 /* F2008, C725. For PURE also C1283. */
3768 if (rvalue
->expr_type
== EXPR_VARIABLE
3769 && gfc_is_coindexed (rvalue
))
3772 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3773 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3775 gfc_error ("Data target at %L shall not have a coindex",
3781 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3782 if (warn_target_lifetime
3783 && rvalue
->expr_type
== EXPR_VARIABLE
3784 && !rvalue
->symtree
->n
.sym
->attr
.save
3785 && !attr
.pointer
&& !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3786 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3787 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3788 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3793 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3794 || lvalue
->symtree
->n
.sym
->attr
.result
3795 || lvalue
->symtree
->n
.sym
->attr
.function
3796 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3797 && lvalue
->symtree
->n
.sym
->ns
3798 != rvalue
->symtree
->n
.sym
->ns
)
3799 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3800 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3802 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3803 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3804 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3805 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3806 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3808 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3815 gfc_warning (OPT_Wtarget_lifetime
,
3816 "Pointer at %L in pointer assignment might outlive the "
3817 "pointer target", &lvalue
->where
);
3824 /* Relative of gfc_check_assign() except that the lvalue is a single
3825 symbol. Used for initialization assignments. */
3828 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3832 bool pointer
, proc_pointer
;
3834 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3836 lvalue
.expr_type
= EXPR_VARIABLE
;
3837 lvalue
.ts
= sym
->ts
;
3839 lvalue
.rank
= sym
->as
->rank
;
3840 lvalue
.symtree
= XCNEW (gfc_symtree
);
3841 lvalue
.symtree
->n
.sym
= sym
;
3842 lvalue
.where
= sym
->declared_at
;
3846 lvalue
.ref
= gfc_get_ref ();
3847 lvalue
.ref
->type
= REF_COMPONENT
;
3848 lvalue
.ref
->u
.c
.component
= comp
;
3849 lvalue
.ref
->u
.c
.sym
= sym
;
3850 lvalue
.ts
= comp
->ts
;
3851 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
3852 lvalue
.where
= comp
->loc
;
3853 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3854 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
3855 proc_pointer
= comp
->attr
.proc_pointer
;
3859 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3860 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
3861 proc_pointer
= sym
->attr
.proc_pointer
;
3864 if (pointer
|| proc_pointer
)
3865 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3868 /* If a conversion function, e.g., __convert_i8_i4, was inserted
3869 into an array constructor, we should check if it can be reduced
3870 as an initialization expression. */
3871 if (rvalue
->expr_type
== EXPR_FUNCTION
3872 && rvalue
->value
.function
.isym
3873 && (rvalue
->value
.function
.isym
->conversion
== 1))
3874 gfc_check_init_expr (rvalue
);
3876 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3879 free (lvalue
.symtree
);
3885 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3887 /* F08:C461. Additional checks for pointer initialization. */
3888 symbol_attribute attr
;
3889 attr
= gfc_expr_attr (rvalue
);
3890 if (attr
.allocatable
)
3892 gfc_error ("Pointer initialization target at %L "
3893 "must not be ALLOCATABLE", &rvalue
->where
);
3896 if (!attr
.target
|| attr
.pointer
)
3898 gfc_error ("Pointer initialization target at %L "
3899 "must have the TARGET attribute", &rvalue
->where
);
3903 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
3904 && rvalue
->symtree
->n
.sym
->ns
->proc_name
3905 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
3907 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
3908 attr
.save
= SAVE_IMPLICIT
;
3913 gfc_error ("Pointer initialization target at %L "
3914 "must have the SAVE attribute", &rvalue
->where
);
3919 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3921 /* F08:C1220. Additional checks for procedure pointer initialization. */
3922 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3923 if (attr
.proc_pointer
)
3925 gfc_error ("Procedure pointer initialization target at %L "
3926 "may not be a procedure pointer", &rvalue
->where
);
3935 /* Build an initializer for a local integer, real, complex, logical, or
3936 character variable, based on the command line flags finit-local-zero,
3937 finit-integer=, finit-real=, finit-logical=, and finit-character=. */
3940 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
3943 gfc_expr
*init_expr
;
3946 /* Try to build an initializer expression. */
3947 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
3949 /* We will only initialize integers, reals, complex, logicals, and
3950 characters, and only if the corresponding command-line flags
3951 were set. Otherwise, we free init_expr and return null. */
3955 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
3956 mpz_set_si (init_expr
->value
.integer
,
3957 gfc_option
.flag_init_integer_value
);
3960 gfc_free_expr (init_expr
);
3966 switch (flag_init_real
)
3968 case GFC_INIT_REAL_SNAN
:
3969 init_expr
->is_snan
= 1;
3971 case GFC_INIT_REAL_NAN
:
3972 mpfr_set_nan (init_expr
->value
.real
);
3975 case GFC_INIT_REAL_INF
:
3976 mpfr_set_inf (init_expr
->value
.real
, 1);
3979 case GFC_INIT_REAL_NEG_INF
:
3980 mpfr_set_inf (init_expr
->value
.real
, -1);
3983 case GFC_INIT_REAL_ZERO
:
3984 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
3988 gfc_free_expr (init_expr
);
3995 switch (flag_init_real
)
3997 case GFC_INIT_REAL_SNAN
:
3998 init_expr
->is_snan
= 1;
4000 case GFC_INIT_REAL_NAN
:
4001 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4002 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4005 case GFC_INIT_REAL_INF
:
4006 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4007 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4010 case GFC_INIT_REAL_NEG_INF
:
4011 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4012 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4015 case GFC_INIT_REAL_ZERO
:
4016 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4020 gfc_free_expr (init_expr
);
4027 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
4028 init_expr
->value
.logical
= 0;
4029 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
4030 init_expr
->value
.logical
= 1;
4033 gfc_free_expr (init_expr
);
4039 /* For characters, the length must be constant in order to
4040 create a default initializer. */
4041 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
4043 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4045 char_len
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
4046 init_expr
->value
.character
.length
= char_len
;
4047 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4048 for (i
= 0; i
< char_len
; i
++)
4049 init_expr
->value
.character
.string
[i
]
4050 = (unsigned char) gfc_option
.flag_init_character_value
;
4054 gfc_free_expr (init_expr
);
4057 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
4058 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4060 gfc_actual_arglist
*arg
;
4061 init_expr
= gfc_get_expr ();
4062 init_expr
->where
= *where
;
4063 init_expr
->ts
= *ts
;
4064 init_expr
->expr_type
= EXPR_FUNCTION
;
4065 init_expr
->value
.function
.isym
=
4066 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4067 init_expr
->value
.function
.name
= "repeat";
4068 arg
= gfc_get_actual_arglist ();
4069 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4070 arg
->expr
->value
.character
.string
[0] =
4071 gfc_option
.flag_init_character_value
;
4072 arg
->next
= gfc_get_actual_arglist ();
4073 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4074 init_expr
->value
.function
.actual
= arg
;
4079 gfc_free_expr (init_expr
);
4086 /* Apply an initialization expression to a typespec. Can be used for symbols or
4087 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4088 combined with some effort. */
4091 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4093 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4095 && ts
->u
.cl
->length
&& ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4099 gcc_assert (ts
->u
.cl
&& ts
->u
.cl
->length
);
4100 gcc_assert (ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
4101 gcc_assert (ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
);
4103 len
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
4105 if (init
->expr_type
== EXPR_CONSTANT
)
4106 gfc_set_constant_character_len (len
, init
, -1);
4109 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4110 init
->ts
.u
.cl
->length
->value
.integer
))
4112 gfc_constructor
*ctor
;
4113 ctor
= gfc_constructor_first (init
->value
.constructor
);
4118 bool has_ts
= (init
->ts
.u
.cl
4119 && init
->ts
.u
.cl
->length_from_typespec
);
4121 /* Remember the length of the first element for checking
4122 that all elements *in the constructor* have the same
4123 length. This need not be the length of the LHS! */
4124 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4125 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4126 first_len
= ctor
->expr
->value
.character
.length
;
4128 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4129 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4131 gfc_set_constant_character_len (len
, ctor
->expr
,
4132 has_ts
? -1 : first_len
);
4133 if (!ctor
->expr
->ts
.u
.cl
)
4135 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4137 ctor
->expr
->ts
.u
.cl
->length
4138 = gfc_copy_expr (ts
->u
.cl
->length
);
4146 /* Check whether an expression is a structure constructor and whether it has
4147 other values than NULL. */
4150 is_non_empty_structure_constructor (gfc_expr
* e
)
4152 if (e
->expr_type
!= EXPR_STRUCTURE
)
4155 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4158 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4160 cons
= gfc_constructor_next (cons
);
4166 /* Check for default initializer; sym->value is not enough
4167 as it is also set for EXPR_NULL of allocatables. */
4170 gfc_has_default_initializer (gfc_symbol
*der
)
4174 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4175 for (c
= der
->components
; c
; c
= c
->next
)
4176 if (gfc_bt_struct (c
->ts
.type
))
4178 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4179 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4181 && is_non_empty_structure_constructor (c
->initializer
))
4182 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4184 if (c
->attr
.pointer
&& c
->initializer
)
4198 Generate an initializer expression which initializes the entirety of a union.
4199 A normal structure constructor is insufficient without undue effort, because
4200 components of maps may be oddly aligned/overlapped. (For example if a
4201 character is initialized from one map overtop a real from the other, only one
4202 byte of the real is actually initialized.) Unfortunately we don't know the
4203 size of the union right now, so we can't generate a proper initializer, but
4204 we use a NULL expr as a placeholder and do the right thing later in
4205 gfc_trans_subcomponent_assign.
4208 generate_union_initializer (gfc_component
*un
)
4210 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4213 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4214 placeholder
->ts
= un
->ts
;
4219 /* Get the user-specified initializer for a union, if any. This means the user
4220 has said to initialize component(s) of a map. For simplicity's sake we
4221 only allow the user to initialize the first map. We don't have to worry
4222 about overlapping initializers as they are released early in resolution (see
4223 resolve_fl_struct). */
4226 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4229 gfc_expr
*init
=NULL
;
4231 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4234 for (map
= union_type
->components
; map
; map
= map
->next
)
4236 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4238 init
= gfc_default_initializer (&map
->ts
);
4251 /* Fetch or generate an initializer for the given component.
4252 Only generate an initializer if generate is true. */
4255 component_initializer (gfc_typespec
*ts
, gfc_component
*c
, bool generate
)
4257 gfc_expr
*init
= NULL
;
4259 /* See if we can find the initializer immediately. */
4260 if (c
->initializer
|| !generate
4261 || (ts
->type
== BT_CLASS
&& !c
->attr
.allocatable
))
4262 return c
->initializer
;
4264 /* Recursively handle derived type components. */
4265 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4266 init
= gfc_generate_initializer (&c
->ts
, true);
4268 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4270 gfc_component
*map
= NULL
;
4271 gfc_constructor
*ctor
;
4272 gfc_expr
*user_init
;
4274 /* If we don't have a user initializer and we aren't generating one, this
4275 union has no initializer. */
4276 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4277 if (!user_init
&& !generate
)
4280 /* Otherwise use a structure constructor. */
4281 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4285 /* If we are to generate an initializer for the union, add a constructor
4286 which initializes the whole union first. */
4289 ctor
= gfc_constructor_get ();
4290 ctor
->expr
= generate_union_initializer (c
);
4291 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4294 /* If we found an initializer in one of our maps, apply it. Note this
4295 is applied _after_ the entire-union initializer above if any. */
4298 ctor
= gfc_constructor_get ();
4299 ctor
->expr
= user_init
;
4300 ctor
->n
.component
= map
;
4301 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4305 /* Treat simple components like locals. */
4308 init
= gfc_build_default_init_expr (&c
->ts
, &c
->loc
);
4309 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4316 /* Get an expression for a default initializer of a derived type. */
4319 gfc_default_initializer (gfc_typespec
*ts
)
4321 return gfc_generate_initializer (ts
, false);
4325 /* Get or generate an expression for a default initializer of a derived type.
4326 If -finit-derived is specified, generate default initialization expressions
4327 for components that lack them when generate is set. */
4330 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4332 gfc_expr
*init
, *tmp
;
4333 gfc_component
*comp
;
4334 generate
= flag_init_derived
&& generate
;
4336 /* See if we have a default initializer in this, but not in nested
4337 types (otherwise we could use gfc_has_default_initializer()).
4338 We don't need to check if we are going to generate them. */
4339 comp
= ts
->u
.derived
->components
;
4342 for (; comp
; comp
= comp
->next
)
4343 if (comp
->initializer
|| comp
->attr
.allocatable
4344 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4345 && CLASS_DATA (comp
)->attr
.allocatable
))
4352 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4353 &ts
->u
.derived
->declared_at
);
4356 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4358 gfc_constructor
*ctor
= gfc_constructor_get();
4360 /* Fetch or generate an initializer for the component. */
4361 tmp
= component_initializer (ts
, comp
, generate
);
4364 /* Save the component ref for STRUCTUREs and UNIONs. */
4365 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4366 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4367 ctor
->n
.component
= comp
;
4369 /* If the initializer was not generated, we need a copy. */
4370 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4371 if ((comp
->ts
.type
!= tmp
->ts
.type
4372 || comp
->ts
.kind
!= tmp
->ts
.kind
)
4373 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4374 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
4377 if (comp
->attr
.allocatable
4378 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
4380 ctor
->expr
= gfc_get_expr ();
4381 ctor
->expr
->expr_type
= EXPR_NULL
;
4382 ctor
->expr
->where
= init
->where
;
4383 ctor
->expr
->ts
= comp
->ts
;
4386 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4393 /* Given a symbol, create an expression node with that symbol as a
4394 variable. If the symbol is array valued, setup a reference of the
4398 gfc_get_variable_expr (gfc_symtree
*var
)
4402 e
= gfc_get_expr ();
4403 e
->expr_type
= EXPR_VARIABLE
;
4405 e
->ts
= var
->n
.sym
->ts
;
4407 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
4408 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
4409 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
4410 && CLASS_DATA (var
->n
.sym
)->as
)))
4412 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
4413 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
4414 e
->ref
= gfc_get_ref ();
4415 e
->ref
->type
= REF_ARRAY
;
4416 e
->ref
->u
.ar
.type
= AR_FULL
;
4417 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
4418 ? CLASS_DATA (var
->n
.sym
)->as
4426 /* Adds a full array reference to an expression, as needed. */
4429 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4432 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4437 ref
->next
= gfc_get_ref ();
4442 e
->ref
= gfc_get_ref ();
4445 ref
->type
= REF_ARRAY
;
4446 ref
->u
.ar
.type
= AR_FULL
;
4447 ref
->u
.ar
.dimen
= e
->rank
;
4448 ref
->u
.ar
.where
= e
->where
;
4454 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4458 lval
= gfc_get_expr ();
4459 lval
->expr_type
= EXPR_VARIABLE
;
4460 lval
->where
= sym
->declared_at
;
4462 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4464 /* It will always be a full array. */
4465 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
4466 lval
->rank
= as
? as
->rank
: 0;
4468 gfc_add_full_array_ref (lval
, as
);
4473 /* Returns the array_spec of a full array expression. A NULL is
4474 returned otherwise. */
4476 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4481 if (expr
->rank
== 0)
4484 /* Follow any component references. */
4485 if (expr
->expr_type
== EXPR_VARIABLE
4486 || expr
->expr_type
== EXPR_CONSTANT
)
4488 as
= expr
->symtree
->n
.sym
->as
;
4489 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4494 as
= ref
->u
.c
.component
->as
;
4502 switch (ref
->u
.ar
.type
)
4525 /* General expression traversal function. */
4528 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4529 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4534 gfc_actual_arglist
*args
;
4541 if ((*func
) (expr
, sym
, &f
))
4544 if (expr
->ts
.type
== BT_CHARACTER
4546 && expr
->ts
.u
.cl
->length
4547 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4548 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4551 switch (expr
->expr_type
)
4556 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4558 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4566 case EXPR_SUBSTRING
:
4569 case EXPR_STRUCTURE
:
4571 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4572 c
; c
= gfc_constructor_next (c
))
4574 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4578 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4580 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4582 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4584 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4591 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4593 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4609 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4611 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4613 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4615 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4621 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4623 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4628 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4629 && ref
->u
.c
.component
->ts
.u
.cl
4630 && ref
->u
.c
.component
->ts
.u
.cl
->length
4631 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4633 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4637 if (ref
->u
.c
.component
->as
)
4638 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4639 + ref
->u
.c
.component
->as
->corank
; i
++)
4641 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4644 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4658 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4661 expr_set_symbols_referenced (gfc_expr
*expr
,
4662 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4663 int *f ATTRIBUTE_UNUSED
)
4665 if (expr
->expr_type
!= EXPR_VARIABLE
)
4667 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4672 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4674 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4678 /* Determine if an expression is a procedure pointer component and return
4679 the component in that case. Otherwise return NULL. */
4682 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4686 if (!expr
|| !expr
->ref
)
4693 if (ref
->type
== REF_COMPONENT
4694 && ref
->u
.c
.component
->attr
.proc_pointer
)
4695 return ref
->u
.c
.component
;
4701 /* Determine if an expression is a procedure pointer component. */
4704 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4706 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4710 /* Determine if an expression is a function with an allocatable class scalar
4713 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
4715 if (expr
->expr_type
== EXPR_FUNCTION
4716 && expr
->value
.function
.esym
4717 && expr
->value
.function
.esym
->result
4718 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4719 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4720 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4727 /* Determine if an expression is a function with an allocatable class array
4730 gfc_is_alloc_class_array_function (gfc_expr
*expr
)
4732 if (expr
->expr_type
== EXPR_FUNCTION
4733 && expr
->value
.function
.esym
4734 && expr
->value
.function
.esym
->result
4735 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4736 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4737 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4744 /* Walk an expression tree and check each variable encountered for being typed.
4745 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4746 mode as is a basic arithmetic expression using those; this is for things in
4749 INTEGER :: arr(n), n
4750 INTEGER :: arr(n + 1), n
4752 The namespace is needed for IMPLICIT typing. */
4754 static gfc_namespace
* check_typed_ns
;
4757 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4758 int* f ATTRIBUTE_UNUSED
)
4762 if (e
->expr_type
!= EXPR_VARIABLE
)
4765 gcc_assert (e
->symtree
);
4766 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4773 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4777 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4781 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4782 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4784 if (e
->expr_type
== EXPR_OP
)
4788 gcc_assert (e
->value
.op
.op1
);
4789 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4791 if (t
&& e
->value
.op
.op2
)
4792 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4798 /* Otherwise, walk the expression and do it strictly. */
4799 check_typed_ns
= ns
;
4800 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4802 return error_found
? false : true;
4807 gfc_ref_this_image (gfc_ref
*ref
)
4811 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4813 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4814 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4821 gfc_find_stat_co(gfc_expr
*e
)
4825 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4826 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4827 return ref
->u
.ar
.stat
;
4829 if (e
->value
.function
.actual
->expr
)
4830 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
4832 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4833 return ref
->u
.ar
.stat
;
4839 gfc_is_coindexed (gfc_expr
*e
)
4843 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4844 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4845 return !gfc_ref_this_image (ref
);
4851 /* Coarrays are variables with a corank but not being coindexed. However, also
4852 the following is a coarray: A subobject of a coarray is a coarray if it does
4853 not have any cosubscripts, vector subscripts, allocatable component
4854 selection, or pointer component selection. (F2008, 2.4.7) */
4857 gfc_is_coarray (gfc_expr
*e
)
4861 gfc_component
*comp
;
4866 if (e
->expr_type
!= EXPR_VARIABLE
)
4870 sym
= e
->symtree
->n
.sym
;
4872 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4873 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4875 coarray
= sym
->attr
.codimension
;
4877 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4881 comp
= ref
->u
.c
.component
;
4882 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4883 && (CLASS_DATA (comp
)->attr
.class_pointer
4884 || CLASS_DATA (comp
)->attr
.allocatable
))
4887 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4889 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4892 coarray
= comp
->attr
.codimension
;
4900 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4906 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4907 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4918 return coarray
&& !coindexed
;
4923 gfc_get_corank (gfc_expr
*e
)
4928 if (!gfc_is_coarray (e
))
4931 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4932 corank
= e
->ts
.u
.derived
->components
->as
4933 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4935 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4937 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4939 if (ref
->type
== REF_ARRAY
)
4940 corank
= ref
->u
.ar
.as
->corank
;
4941 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4948 /* Check whether the expression has an ultimate allocatable component.
4949 Being itself allocatable does not count. */
4951 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4953 gfc_ref
*ref
, *last
= NULL
;
4955 if (e
->expr_type
!= EXPR_VARIABLE
)
4958 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4959 if (ref
->type
== REF_COMPONENT
)
4962 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4963 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4964 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4965 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4969 if (e
->ts
.type
== BT_CLASS
)
4970 return CLASS_DATA (e
)->attr
.alloc_comp
;
4971 else if (e
->ts
.type
== BT_DERIVED
)
4972 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4978 /* Check whether the expression has an pointer component.
4979 Being itself a pointer does not count. */
4981 gfc_has_ultimate_pointer (gfc_expr
*e
)
4983 gfc_ref
*ref
, *last
= NULL
;
4985 if (e
->expr_type
!= EXPR_VARIABLE
)
4988 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4989 if (ref
->type
== REF_COMPONENT
)
4992 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4993 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4994 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4995 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4999 if (e
->ts
.type
== BT_CLASS
)
5000 return CLASS_DATA (e
)->attr
.pointer_comp
;
5001 else if (e
->ts
.type
== BT_DERIVED
)
5002 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5008 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5009 Note: A scalar is not regarded as "simply contiguous" by the standard.
5010 if bool is not strict, some further checks are done - for instance,
5011 a "(::1)" is accepted. */
5014 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5018 gfc_array_ref
*ar
= NULL
;
5019 gfc_ref
*ref
, *part_ref
= NULL
;
5022 if (expr
->expr_type
== EXPR_FUNCTION
)
5023 return expr
->value
.function
.esym
5024 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
5025 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5028 if (!permit_element
&& expr
->rank
== 0)
5031 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5034 return false; /* Array shall be last part-ref. */
5036 if (ref
->type
== REF_COMPONENT
)
5038 else if (ref
->type
== REF_SUBSTRING
)
5040 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5044 sym
= expr
->symtree
->n
.sym
;
5045 if (expr
->ts
.type
!= BT_CLASS
5047 && !part_ref
->u
.c
.component
->attr
.contiguous
5048 && part_ref
->u
.c
.component
->attr
.pointer
)
5050 && !sym
->attr
.contiguous
5051 && (sym
->attr
.pointer
5052 || sym
->as
->type
== AS_ASSUMED_RANK
5053 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
5056 if (!ar
|| ar
->type
== AR_FULL
)
5059 gcc_assert (ar
->type
== AR_SECTION
);
5061 /* Check for simply contiguous array */
5063 for (i
= 0; i
< ar
->dimen
; i
++)
5065 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5068 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5074 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5077 /* If the previous section was not contiguous, that's an error,
5078 unless we have effective only one element and checking is not
5080 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5081 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5082 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5083 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5084 ar
->end
[i
]->value
.integer
) != 0))
5087 /* Following the standard, "(::1)" or - if known at compile time -
5088 "(lbound:ubound)" are not simply contiguous; if strict
5089 is false, they are regarded as simply contiguous. */
5090 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5091 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5092 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5096 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5097 || !ar
->as
->lower
[i
]
5098 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5099 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5100 ar
->as
->lower
[i
]->value
.integer
) != 0))
5104 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5105 || !ar
->as
->upper
[i
]
5106 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5107 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5108 ar
->as
->upper
[i
]->value
.integer
) != 0))
5116 /* Build call to an intrinsic procedure. The number of arguments has to be
5117 passed (rather than ending the list with a NULL value) because we may
5118 want to add arguments but with a NULL-expression. */
5121 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5122 locus where
, unsigned numarg
, ...)
5125 gfc_actual_arglist
* atail
;
5126 gfc_intrinsic_sym
* isym
;
5129 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5131 isym
= gfc_intrinsic_function_by_id (id
);
5134 result
= gfc_get_expr ();
5135 result
->expr_type
= EXPR_FUNCTION
;
5136 result
->ts
= isym
->ts
;
5137 result
->where
= where
;
5138 result
->value
.function
.name
= mangled_name
;
5139 result
->value
.function
.isym
= isym
;
5141 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5142 gfc_commit_symbol (result
->symtree
->n
.sym
);
5143 gcc_assert (result
->symtree
5144 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5145 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5146 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5147 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5148 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5149 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5151 va_start (ap
, numarg
);
5153 for (i
= 0; i
< numarg
; ++i
)
5157 atail
->next
= gfc_get_actual_arglist ();
5158 atail
= atail
->next
;
5161 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5163 atail
->expr
= va_arg (ap
, gfc_expr
*);
5171 /* Check if an expression may appear in a variable definition context
5172 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5173 This is called from the various places when resolving
5174 the pieces that make up such a context.
5175 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5176 variables), some checks are not performed.
5178 Optionally, a possible error message can be suppressed if context is NULL
5179 and just the return status (true / false) be requested. */
5182 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5183 bool own_scope
, const char* context
)
5185 gfc_symbol
* sym
= NULL
;
5187 bool check_intentin
;
5189 symbol_attribute attr
;
5193 if (e
->expr_type
== EXPR_VARIABLE
)
5195 gcc_assert (e
->symtree
);
5196 sym
= e
->symtree
->n
.sym
;
5198 else if (e
->expr_type
== EXPR_FUNCTION
)
5200 gcc_assert (e
->symtree
);
5201 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5204 attr
= gfc_expr_attr (e
);
5205 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5207 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5210 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5211 " context (%s) at %L", context
, &e
->where
);
5215 else if (e
->expr_type
!= EXPR_VARIABLE
)
5218 gfc_error ("Non-variable expression in variable definition context (%s)"
5219 " at %L", context
, &e
->where
);
5223 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
5226 gfc_error ("Named constant %qs in variable definition context (%s)"
5227 " at %L", sym
->name
, context
, &e
->where
);
5230 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
5231 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
5232 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5235 gfc_error ("%qs in variable definition context (%s) at %L is not"
5236 " a variable", sym
->name
, context
, &e
->where
);
5240 /* Find out whether the expr is a pointer; this also means following
5241 component references to the last one. */
5242 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
5243 if (pointer
&& !is_pointer
)
5246 gfc_error ("Non-POINTER in pointer association context (%s)"
5247 " at %L", context
, &e
->where
);
5251 if (e
->ts
.type
== BT_DERIVED
5252 && e
->ts
.u
.derived
== NULL
)
5255 gfc_error ("Type inaccessible in variable definition context (%s) "
5256 "at %L", context
, &e
->where
);
5263 || (e
->ts
.type
== BT_DERIVED
5264 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5265 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
5268 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5269 context
, &e
->where
);
5273 /* TS18508, C702/C203. */
5276 || (e
->ts
.type
== BT_DERIVED
5277 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5278 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
5281 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5282 context
, &e
->where
);
5286 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5287 component of sub-component of a pointer; we need to distinguish
5288 assignment to a pointer component from pointer-assignment to a pointer
5289 component. Note that (normal) assignment to procedure pointers is not
5291 check_intentin
= !own_scope
;
5292 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5293 && CLASS_DATA (sym
))
5294 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
5295 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
5297 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
5298 check_intentin
= false;
5299 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
5301 ptr_component
= true;
5303 check_intentin
= false;
5306 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
5308 if (pointer
&& is_pointer
)
5311 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5312 " association context (%s) at %L",
5313 sym
->name
, context
, &e
->where
);
5316 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
5319 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5320 " definition context (%s) at %L",
5321 sym
->name
, context
, &e
->where
);
5326 /* PROTECTED and use-associated. */
5327 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
5329 if (pointer
&& is_pointer
)
5332 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5333 " pointer association context (%s) at %L",
5334 sym
->name
, context
, &e
->where
);
5337 if (!pointer
&& !is_pointer
)
5340 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5341 " variable definition context (%s) at %L",
5342 sym
->name
, context
, &e
->where
);
5347 /* Variable not assignable from a PURE procedure but appears in
5348 variable definition context. */
5349 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
5352 gfc_error ("Variable %qs can not appear in a variable definition"
5353 " context (%s) at %L in PURE procedure",
5354 sym
->name
, context
, &e
->where
);
5358 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
5359 && gfc_impure_variable (sym
))
5364 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5366 sym
= ns
->proc_name
;
5369 if (sym
->attr
.flavor
== FL_PROCEDURE
)
5371 sym
->attr
.implicit_pure
= 0;
5376 /* Check variable definition context for associate-names. */
5377 if (!pointer
&& sym
->assoc
)
5380 gfc_association_list
* assoc
;
5382 gcc_assert (sym
->assoc
->target
);
5384 /* If this is a SELECT TYPE temporary (the association is used internally
5385 for SELECT TYPE), silently go over to the target. */
5386 if (sym
->attr
.select_type_temporary
)
5388 gfc_expr
* t
= sym
->assoc
->target
;
5390 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
5391 name
= t
->symtree
->name
;
5393 if (t
->symtree
->n
.sym
->assoc
)
5394 assoc
= t
->symtree
->n
.sym
->assoc
;
5403 gcc_assert (name
&& assoc
);
5405 /* Is association to a valid variable? */
5406 if (!assoc
->variable
)
5410 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
5411 gfc_error ("%qs at %L associated to vector-indexed target can"
5412 " not be used in a variable definition context (%s)",
5413 name
, &e
->where
, context
);
5415 gfc_error ("%qs at %L associated to expression can"
5416 " not be used in a variable definition context (%s)",
5417 name
, &e
->where
, context
);
5422 /* Target must be allowed to appear in a variable definition context. */
5423 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
5426 gfc_error ("Associate-name %qs can not appear in a variable"
5427 " definition context (%s) at %L because its target"
5428 " at %L can not, either",
5429 name
, context
, &e
->where
,
5430 &assoc
->target
->where
);
5435 /* Check for same value in vector expression subscript. */
5438 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
5439 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5440 for (i
= 0; i
< GFC_MAX_DIMENSIONS
5441 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
5442 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5444 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
5445 if (arr
->expr_type
== EXPR_ARRAY
)
5447 gfc_constructor
*c
, *n
;
5450 for (c
= gfc_constructor_first (arr
->value
.constructor
);
5451 c
!= NULL
; c
= gfc_constructor_next (c
))
5453 if (c
== NULL
|| c
->iterator
!= NULL
)
5458 for (n
= gfc_constructor_next (c
); n
!= NULL
;
5459 n
= gfc_constructor_next (n
))
5461 if (n
->iterator
!= NULL
)
5465 if (gfc_dep_compare_expr (ec
, en
) == 0)
5468 gfc_error_now ("Elements with the same value "
5469 "at %L and %L in vector "
5470 "subscript in a variable "
5471 "definition context (%s)",
5472 &(ec
->where
), &(en
->where
),