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 /* Determine if an expression is constant in the sense of F08:7.1.12.
885 * This function expects that the expression has already been simplified. */
888 gfc_is_constant_expr (gfc_expr
*e
)
891 gfc_actual_arglist
*arg
;
896 switch (e
->expr_type
)
899 return (gfc_is_constant_expr (e
->value
.op
.op1
)
900 && (e
->value
.op
.op2
== NULL
901 || gfc_is_constant_expr (e
->value
.op
.op2
)));
909 gcc_assert (e
->symtree
|| e
->value
.function
.esym
910 || e
->value
.function
.isym
);
912 /* Call to intrinsic with at least one argument. */
913 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
915 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
916 if (!gfc_is_constant_expr (arg
->expr
))
920 if (e
->value
.function
.isym
921 && (e
->value
.function
.isym
->elemental
922 || e
->value
.function
.isym
->pure
923 || e
->value
.function
.isym
->inquiry
924 || e
->value
.function
.isym
->transformational
))
934 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
935 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
939 c
= gfc_constructor_first (e
->value
.constructor
);
940 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
941 return gfc_constant_ac (e
);
943 for (; c
; c
= gfc_constructor_next (c
))
944 if (!gfc_is_constant_expr (c
->expr
))
951 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
957 /* Is true if an array reference is followed by a component or substring
960 is_subref_array (gfc_expr
* e
)
965 if (e
->expr_type
!= EXPR_VARIABLE
)
968 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
972 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
974 if (ref
->type
== REF_ARRAY
975 && ref
->u
.ar
.type
!= AR_ELEMENT
)
979 && ref
->type
!= REF_ARRAY
)
986 /* Try to collapse intrinsic expressions. */
989 simplify_intrinsic_op (gfc_expr
*p
, int type
)
992 gfc_expr
*op1
, *op2
, *result
;
994 if (p
->value
.op
.op
== INTRINSIC_USER
)
997 op1
= p
->value
.op
.op1
;
998 op2
= p
->value
.op
.op2
;
1001 if (!gfc_simplify_expr (op1
, type
))
1003 if (!gfc_simplify_expr (op2
, type
))
1006 if (!gfc_is_constant_expr (op1
)
1007 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1011 p
->value
.op
.op1
= NULL
;
1012 p
->value
.op
.op2
= NULL
;
1016 case INTRINSIC_PARENTHESES
:
1017 result
= gfc_parentheses (op1
);
1020 case INTRINSIC_UPLUS
:
1021 result
= gfc_uplus (op1
);
1024 case INTRINSIC_UMINUS
:
1025 result
= gfc_uminus (op1
);
1028 case INTRINSIC_PLUS
:
1029 result
= gfc_add (op1
, op2
);
1032 case INTRINSIC_MINUS
:
1033 result
= gfc_subtract (op1
, op2
);
1036 case INTRINSIC_TIMES
:
1037 result
= gfc_multiply (op1
, op2
);
1040 case INTRINSIC_DIVIDE
:
1041 result
= gfc_divide (op1
, op2
);
1044 case INTRINSIC_POWER
:
1045 result
= gfc_power (op1
, op2
);
1048 case INTRINSIC_CONCAT
:
1049 result
= gfc_concat (op1
, op2
);
1053 case INTRINSIC_EQ_OS
:
1054 result
= gfc_eq (op1
, op2
, op
);
1058 case INTRINSIC_NE_OS
:
1059 result
= gfc_ne (op1
, op2
, op
);
1063 case INTRINSIC_GT_OS
:
1064 result
= gfc_gt (op1
, op2
, op
);
1068 case INTRINSIC_GE_OS
:
1069 result
= gfc_ge (op1
, op2
, op
);
1073 case INTRINSIC_LT_OS
:
1074 result
= gfc_lt (op1
, op2
, op
);
1078 case INTRINSIC_LE_OS
:
1079 result
= gfc_le (op1
, op2
, op
);
1083 result
= gfc_not (op1
);
1087 result
= gfc_and (op1
, op2
);
1091 result
= gfc_or (op1
, op2
);
1095 result
= gfc_eqv (op1
, op2
);
1098 case INTRINSIC_NEQV
:
1099 result
= gfc_neqv (op1
, op2
);
1103 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1108 gfc_free_expr (op1
);
1109 gfc_free_expr (op2
);
1113 result
->rank
= p
->rank
;
1114 result
->where
= p
->where
;
1115 gfc_replace_expr (p
, result
);
1121 /* Subroutine to simplify constructor expressions. Mutually recursive
1122 with gfc_simplify_expr(). */
1125 simplify_constructor (gfc_constructor_base base
, int type
)
1130 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1133 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1134 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1135 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1140 /* Try and simplify a copy. Replace the original if successful
1141 but keep going through the constructor at all costs. Not
1142 doing so can make a dog's dinner of complicated things. */
1143 p
= gfc_copy_expr (c
->expr
);
1145 if (!gfc_simplify_expr (p
, type
))
1151 gfc_replace_expr (c
->expr
, p
);
1159 /* Pull a single array element out of an array constructor. */
1162 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1163 gfc_constructor
**rval
)
1165 unsigned long nelemen
;
1171 gfc_constructor
*cons
;
1178 mpz_init_set_ui (offset
, 0);
1181 mpz_init_set_ui (span
, 1);
1182 for (i
= 0; i
< ar
->dimen
; i
++)
1184 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1185 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1193 if (e
->expr_type
!= EXPR_CONSTANT
)
1199 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1200 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1202 /* Check the bounds. */
1203 if ((ar
->as
->upper
[i
]
1204 && mpz_cmp (e
->value
.integer
,
1205 ar
->as
->upper
[i
]->value
.integer
) > 0)
1206 || (mpz_cmp (e
->value
.integer
,
1207 ar
->as
->lower
[i
]->value
.integer
) < 0))
1209 gfc_error ("Index in dimension %d is out of bounds "
1210 "at %L", i
+ 1, &ar
->c_where
[i
]);
1216 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1217 mpz_mul (delta
, delta
, span
);
1218 mpz_add (offset
, offset
, delta
);
1220 mpz_set_ui (tmp
, 1);
1221 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1222 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1223 mpz_mul (span
, span
, tmp
);
1226 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1227 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1246 /* Find a component of a structure constructor. */
1248 static gfc_constructor
*
1249 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1251 gfc_component
*pick
= ref
->u
.c
.component
;
1252 gfc_constructor
*c
= gfc_constructor_first (base
);
1254 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1255 int ext
= dt
->attr
.extension
;
1257 /* For extended types, check if the desired component is in one of the
1259 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1260 pick
->name
, true, true, NULL
))
1262 dt
= dt
->components
->ts
.u
.derived
;
1263 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1267 gfc_component
*comp
= dt
->components
;
1268 while (comp
!= pick
)
1271 c
= gfc_constructor_next (c
);
1278 /* Replace an expression with the contents of a constructor, removing
1279 the subobject reference in the process. */
1282 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1292 e
= gfc_copy_expr (p
);
1293 e
->ref
= p
->ref
->next
;
1294 p
->ref
->next
= NULL
;
1295 gfc_replace_expr (p
, e
);
1299 /* Pull an array section out of an array constructor. */
1302 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1309 long unsigned one
= 1;
1311 mpz_t start
[GFC_MAX_DIMENSIONS
];
1312 mpz_t end
[GFC_MAX_DIMENSIONS
];
1313 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1314 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1315 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1320 gfc_constructor_base base
;
1321 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1331 base
= expr
->value
.constructor
;
1332 expr
->value
.constructor
= NULL
;
1334 rank
= ref
->u
.ar
.as
->rank
;
1336 if (expr
->shape
== NULL
)
1337 expr
->shape
= gfc_get_shape (rank
);
1339 mpz_init_set_ui (delta_mpz
, one
);
1340 mpz_init_set_ui (nelts
, one
);
1343 /* Do the initialization now, so that we can cleanup without
1344 keeping track of where we were. */
1345 for (d
= 0; d
< rank
; d
++)
1347 mpz_init (delta
[d
]);
1348 mpz_init (start
[d
]);
1351 mpz_init (stride
[d
]);
1355 /* Build the counters to clock through the array reference. */
1357 for (d
= 0; d
< rank
; d
++)
1359 /* Make this stretch of code easier on the eye! */
1360 begin
= ref
->u
.ar
.start
[d
];
1361 finish
= ref
->u
.ar
.end
[d
];
1362 step
= ref
->u
.ar
.stride
[d
];
1363 lower
= ref
->u
.ar
.as
->lower
[d
];
1364 upper
= ref
->u
.ar
.as
->upper
[d
];
1366 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1368 gfc_constructor
*ci
;
1371 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1377 gcc_assert (begin
->rank
== 1);
1378 /* Zero-sized arrays have no shape and no elements, stop early. */
1381 mpz_init_set_ui (nelts
, 0);
1385 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1386 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1387 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1388 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1391 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1393 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1394 || mpz_cmp (ci
->expr
->value
.integer
,
1395 lower
->value
.integer
) < 0)
1397 gfc_error ("index in dimension %d is out of bounds "
1398 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1406 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1407 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1408 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1414 /* Obtain the stride. */
1416 mpz_set (stride
[d
], step
->value
.integer
);
1418 mpz_set_ui (stride
[d
], one
);
1420 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1421 mpz_set_ui (stride
[d
], one
);
1423 /* Obtain the start value for the index. */
1425 mpz_set (start
[d
], begin
->value
.integer
);
1427 mpz_set (start
[d
], lower
->value
.integer
);
1429 mpz_set (ctr
[d
], start
[d
]);
1431 /* Obtain the end value for the index. */
1433 mpz_set (end
[d
], finish
->value
.integer
);
1435 mpz_set (end
[d
], upper
->value
.integer
);
1437 /* Separate 'if' because elements sometimes arrive with
1439 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1440 mpz_set (end
[d
], begin
->value
.integer
);
1442 /* Check the bounds. */
1443 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1444 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1445 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1446 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1448 gfc_error ("index in dimension %d is out of bounds "
1449 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1454 /* Calculate the number of elements and the shape. */
1455 mpz_set (tmp_mpz
, stride
[d
]);
1456 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1457 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1458 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1459 mpz_mul (nelts
, nelts
, tmp_mpz
);
1461 /* An element reference reduces the rank of the expression; don't
1462 add anything to the shape array. */
1463 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1464 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1467 /* Calculate the 'stride' (=delta) for conversion of the
1468 counter values into the index along the constructor. */
1469 mpz_set (delta
[d
], delta_mpz
);
1470 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1471 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1472 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1476 cons
= gfc_constructor_first (base
);
1478 /* Now clock through the array reference, calculating the index in
1479 the source constructor and transferring the elements to the new
1481 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1483 mpz_init_set_ui (ptr
, 0);
1486 for (d
= 0; d
< rank
; d
++)
1488 mpz_set (tmp_mpz
, ctr
[d
]);
1489 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1490 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1491 mpz_add (ptr
, ptr
, tmp_mpz
);
1493 if (!incr_ctr
) continue;
1495 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1497 gcc_assert(vecsub
[d
]);
1499 if (!gfc_constructor_next (vecsub
[d
]))
1500 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1503 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1506 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1510 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1512 if (mpz_cmp_ui (stride
[d
], 0) > 0
1513 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1514 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1515 mpz_set (ctr
[d
], start
[d
]);
1521 limit
= mpz_get_ui (ptr
);
1522 if (limit
>= flag_max_array_constructor
)
1524 gfc_error ("The number of elements in the array constructor "
1525 "at %L requires an increase of the allowed %d "
1526 "upper limit. See -fmax-array-constructor "
1527 "option", &expr
->where
, flag_max_array_constructor
);
1531 cons
= gfc_constructor_lookup (base
, limit
);
1533 gfc_constructor_append_expr (&expr
->value
.constructor
,
1534 gfc_copy_expr (cons
->expr
), NULL
);
1541 mpz_clear (delta_mpz
);
1542 mpz_clear (tmp_mpz
);
1544 for (d
= 0; d
< rank
; d
++)
1546 mpz_clear (delta
[d
]);
1547 mpz_clear (start
[d
]);
1550 mpz_clear (stride
[d
]);
1552 gfc_constructor_free (base
);
1556 /* Pull a substring out of an expression. */
1559 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1566 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1567 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1570 *newp
= gfc_copy_expr (p
);
1571 free ((*newp
)->value
.character
.string
);
1573 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1574 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1575 length
= end
- start
+ 1;
1577 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1578 (*newp
)->value
.character
.length
= length
;
1579 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1580 length
* sizeof (gfc_char_t
));
1587 /* Simplify a subobject reference of a constructor. This occurs when
1588 parameter variable values are substituted. */
1591 simplify_const_ref (gfc_expr
*p
)
1593 gfc_constructor
*cons
, *c
;
1599 switch (p
->ref
->type
)
1602 switch (p
->ref
->u
.ar
.type
)
1605 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1606 will generate this. */
1607 if (p
->expr_type
!= EXPR_ARRAY
)
1609 remove_subobject_ref (p
, NULL
);
1612 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1618 remove_subobject_ref (p
, cons
);
1622 if (!find_array_section (p
, p
->ref
))
1624 p
->ref
->u
.ar
.type
= AR_FULL
;
1629 if (p
->ref
->next
!= NULL
1630 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1632 for (c
= gfc_constructor_first (p
->value
.constructor
);
1633 c
; c
= gfc_constructor_next (c
))
1635 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1636 if (!simplify_const_ref (c
->expr
))
1640 if (gfc_bt_struct (p
->ts
.type
)
1642 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1644 /* There may have been component references. */
1645 p
->ts
= c
->expr
->ts
;
1649 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1651 if (p
->ts
.type
== BT_CHARACTER
1652 && last_ref
->type
== REF_SUBSTRING
)
1654 /* If this is a CHARACTER array and we possibly took
1655 a substring out of it, update the type-spec's
1656 character length according to the first element
1657 (as all should have the same length). */
1659 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1661 const gfc_expr
* first
= c
->expr
;
1662 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1663 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1664 string_len
= first
->value
.character
.length
;
1670 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1673 gfc_free_expr (p
->ts
.u
.cl
->length
);
1676 = gfc_get_int_expr (gfc_default_integer_kind
,
1680 gfc_free_ref_list (p
->ref
);
1691 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1692 remove_subobject_ref (p
, cons
);
1696 if (!find_substring_ref (p
, &newp
))
1699 gfc_replace_expr (p
, newp
);
1700 gfc_free_ref_list (p
->ref
);
1710 /* Simplify a chain of references. */
1713 simplify_ref_chain (gfc_ref
*ref
, int type
)
1717 for (; ref
; ref
= ref
->next
)
1722 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1724 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1726 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1728 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1734 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1736 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1748 /* Try to substitute the value of a parameter variable. */
1751 simplify_parameter_variable (gfc_expr
*p
, int type
)
1756 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1762 /* Do not copy subobject refs for constant. */
1763 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1764 e
->ref
= gfc_copy_ref (p
->ref
);
1765 t
= gfc_simplify_expr (e
, type
);
1767 /* Only use the simplification if it eliminated all subobject references. */
1769 gfc_replace_expr (p
, e
);
1776 /* Given an expression, simplify it by collapsing constant
1777 expressions. Most simplification takes place when the expression
1778 tree is being constructed. If an intrinsic function is simplified
1779 at some point, we get called again to collapse the result against
1782 We work by recursively simplifying expression nodes, simplifying
1783 intrinsic functions where possible, which can lead to further
1784 constant collapsing. If an operator has constant operand(s), we
1785 rip the expression apart, and rebuild it, hoping that it becomes
1788 The expression type is defined for:
1789 0 Basic expression parsing
1790 1 Simplifying array constructors -- will substitute
1792 Returns false on error, true otherwise.
1793 NOTE: Will return true even if the expression can not be simplified. */
1796 gfc_simplify_expr (gfc_expr
*p
, int type
)
1798 gfc_actual_arglist
*ap
;
1803 switch (p
->expr_type
)
1810 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1811 if (!gfc_simplify_expr (ap
->expr
, type
))
1814 if (p
->value
.function
.isym
!= NULL
1815 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1820 case EXPR_SUBSTRING
:
1821 if (!simplify_ref_chain (p
->ref
, type
))
1824 if (gfc_is_constant_expr (p
))
1830 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1832 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1833 start
--; /* Convert from one-based to zero-based. */
1836 end
= p
->value
.character
.length
;
1837 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1838 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1843 s
= gfc_get_wide_string (end
- start
+ 2);
1844 memcpy (s
, p
->value
.character
.string
+ start
,
1845 (end
- start
) * sizeof (gfc_char_t
));
1846 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1847 free (p
->value
.character
.string
);
1848 p
->value
.character
.string
= s
;
1849 p
->value
.character
.length
= end
- start
;
1850 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1851 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1853 p
->value
.character
.length
);
1854 gfc_free_ref_list (p
->ref
);
1856 p
->expr_type
= EXPR_CONSTANT
;
1861 if (!simplify_intrinsic_op (p
, type
))
1866 /* Only substitute array parameter variables if we are in an
1867 initialization expression, or we want a subsection. */
1868 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1869 && (gfc_init_expr_flag
|| p
->ref
1870 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1872 if (!simplify_parameter_variable (p
, type
))
1879 gfc_simplify_iterator_var (p
);
1882 /* Simplify subcomponent references. */
1883 if (!simplify_ref_chain (p
->ref
, type
))
1888 case EXPR_STRUCTURE
:
1890 if (!simplify_ref_chain (p
->ref
, type
))
1893 if (!simplify_constructor (p
->value
.constructor
, type
))
1896 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1897 && p
->ref
->u
.ar
.type
== AR_FULL
)
1898 gfc_expand_constructor (p
, false);
1900 if (!simplify_const_ref (p
))
1914 /* Returns the type of an expression with the exception that iterator
1915 variables are automatically integers no matter what else they may
1921 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
1928 /* Scalarize an expression for an elemental intrinsic call. */
1931 scalarize_intrinsic_call (gfc_expr
*e
)
1933 gfc_actual_arglist
*a
, *b
;
1934 gfc_constructor_base ctor
;
1935 gfc_constructor
*args
[5];
1936 gfc_constructor
*ci
, *new_ctor
;
1937 gfc_expr
*expr
, *old
;
1938 int n
, i
, rank
[5], array_arg
;
1940 /* Find which, if any, arguments are arrays. Assume that the old
1941 expression carries the type information and that the first arg
1942 that is an array expression carries all the shape information.*/
1944 a
= e
->value
.function
.actual
;
1945 for (; a
; a
= a
->next
)
1948 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
1951 expr
= gfc_copy_expr (a
->expr
);
1958 old
= gfc_copy_expr (e
);
1960 gfc_constructor_free (expr
->value
.constructor
);
1961 expr
->value
.constructor
= NULL
;
1963 expr
->where
= old
->where
;
1964 expr
->expr_type
= EXPR_ARRAY
;
1966 /* Copy the array argument constructors into an array, with nulls
1969 a
= old
->value
.function
.actual
;
1970 for (; a
; a
= a
->next
)
1972 /* Check that this is OK for an initialization expression. */
1973 if (a
->expr
&& !gfc_check_init_expr (a
->expr
))
1977 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1979 rank
[n
] = a
->expr
->rank
;
1980 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1981 args
[n
] = gfc_constructor_first (ctor
);
1983 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1986 rank
[n
] = a
->expr
->rank
;
1989 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
1990 args
[n
] = gfc_constructor_first (ctor
);
1999 /* Using the array argument as the master, step through the array
2000 calling the function for each element and advancing the array
2001 constructors together. */
2002 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2004 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2005 gfc_copy_expr (old
), NULL
);
2007 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2009 b
= old
->value
.function
.actual
;
2010 for (i
= 0; i
< n
; i
++)
2013 new_ctor
->expr
->value
.function
.actual
2014 = a
= gfc_get_actual_arglist ();
2017 a
->next
= gfc_get_actual_arglist ();
2022 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2024 a
->expr
= gfc_copy_expr (b
->expr
);
2029 /* Simplify the function calls. If the simplification fails, the
2030 error will be flagged up down-stream or the library will deal
2032 gfc_simplify_expr (new_ctor
->expr
, 0);
2034 for (i
= 0; i
< n
; i
++)
2036 args
[i
] = gfc_constructor_next (args
[i
]);
2038 for (i
= 1; i
< n
; i
++)
2039 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2040 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2046 /* Free "expr" but not the pointers it contains. */
2048 gfc_free_expr (old
);
2052 gfc_error_now ("elemental function arguments at %C are not compliant");
2055 gfc_free_expr (expr
);
2056 gfc_free_expr (old
);
2062 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2064 gfc_expr
*op1
= e
->value
.op
.op1
;
2065 gfc_expr
*op2
= e
->value
.op
.op2
;
2067 if (!(*check_function
)(op1
))
2070 switch (e
->value
.op
.op
)
2072 case INTRINSIC_UPLUS
:
2073 case INTRINSIC_UMINUS
:
2074 if (!numeric_type (et0 (op1
)))
2079 case INTRINSIC_EQ_OS
:
2081 case INTRINSIC_NE_OS
:
2083 case INTRINSIC_GT_OS
:
2085 case INTRINSIC_GE_OS
:
2087 case INTRINSIC_LT_OS
:
2089 case INTRINSIC_LE_OS
:
2090 if (!(*check_function
)(op2
))
2093 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2094 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2096 gfc_error ("Numeric or CHARACTER operands are required in "
2097 "expression at %L", &e
->where
);
2102 case INTRINSIC_PLUS
:
2103 case INTRINSIC_MINUS
:
2104 case INTRINSIC_TIMES
:
2105 case INTRINSIC_DIVIDE
:
2106 case INTRINSIC_POWER
:
2107 if (!(*check_function
)(op2
))
2110 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2115 case INTRINSIC_CONCAT
:
2116 if (!(*check_function
)(op2
))
2119 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2121 gfc_error ("Concatenation operator in expression at %L "
2122 "must have two CHARACTER operands", &op1
->where
);
2126 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2128 gfc_error ("Concat operator at %L must concatenate strings of the "
2129 "same kind", &e
->where
);
2136 if (et0 (op1
) != BT_LOGICAL
)
2138 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2139 "operand", &op1
->where
);
2148 case INTRINSIC_NEQV
:
2149 if (!(*check_function
)(op2
))
2152 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2154 gfc_error ("LOGICAL operands are required in expression at %L",
2161 case INTRINSIC_PARENTHESES
:
2165 gfc_error ("Only intrinsic operators can be used in expression at %L",
2173 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2178 /* F2003, 7.1.7 (3): In init expression, allocatable components
2179 must not be data-initialized. */
2181 check_alloc_comp_init (gfc_expr
*e
)
2183 gfc_component
*comp
;
2184 gfc_constructor
*ctor
;
2186 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2187 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2189 for (comp
= e
->ts
.u
.derived
->components
,
2190 ctor
= gfc_constructor_first (e
->value
.constructor
);
2191 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2193 if (comp
->attr
.allocatable
&& ctor
->expr
2194 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2196 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2197 "component %qs in structure constructor at %L",
2198 comp
->name
, &ctor
->expr
->where
);
2207 check_init_expr_arguments (gfc_expr
*e
)
2209 gfc_actual_arglist
*ap
;
2211 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2212 if (!gfc_check_init_expr (ap
->expr
))
2218 static bool check_restricted (gfc_expr
*);
2220 /* F95, 7.1.6.1, Initialization expressions, (7)
2221 F2003, 7.1.7 Initialization expression, (8) */
2224 check_inquiry (gfc_expr
*e
, int not_restricted
)
2227 const char *const *functions
;
2229 static const char *const inquiry_func_f95
[] = {
2230 "lbound", "shape", "size", "ubound",
2231 "bit_size", "len", "kind",
2232 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2233 "precision", "radix", "range", "tiny",
2237 static const char *const inquiry_func_f2003
[] = {
2238 "lbound", "shape", "size", "ubound",
2239 "bit_size", "len", "kind",
2240 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2241 "precision", "radix", "range", "tiny",
2246 gfc_actual_arglist
*ap
;
2248 if (!e
->value
.function
.isym
2249 || !e
->value
.function
.isym
->inquiry
)
2252 /* An undeclared parameter will get us here (PR25018). */
2253 if (e
->symtree
== NULL
)
2256 if (e
->symtree
->n
.sym
->from_intmod
)
2258 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2259 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2260 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2263 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2264 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2269 name
= e
->symtree
->n
.sym
->name
;
2271 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2272 ? inquiry_func_f2003
: inquiry_func_f95
;
2274 for (i
= 0; functions
[i
]; i
++)
2275 if (strcmp (functions
[i
], name
) == 0)
2278 if (functions
[i
] == NULL
)
2282 /* At this point we have an inquiry function with a variable argument. The
2283 type of the variable might be undefined, but we need it now, because the
2284 arguments of these functions are not allowed to be undefined. */
2286 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2291 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2293 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2294 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2297 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2300 /* Assumed character length will not reduce to a constant expression
2301 with LEN, as required by the standard. */
2302 if (i
== 5 && not_restricted
2303 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2304 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2305 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2307 gfc_error ("Assumed or deferred character length variable %qs "
2308 " in constant expression at %L",
2309 ap
->expr
->symtree
->n
.sym
->name
,
2313 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2316 if (not_restricted
== 0
2317 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2318 && !check_restricted (ap
->expr
))
2321 if (not_restricted
== 0
2322 && ap
->expr
->expr_type
== EXPR_VARIABLE
2323 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2324 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2332 /* F95, 7.1.6.1, Initialization expressions, (5)
2333 F2003, 7.1.7 Initialization expression, (5) */
2336 check_transformational (gfc_expr
*e
)
2338 static const char * const trans_func_f95
[] = {
2339 "repeat", "reshape", "selected_int_kind",
2340 "selected_real_kind", "transfer", "trim", NULL
2343 static const char * const trans_func_f2003
[] = {
2344 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2345 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2346 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2347 "trim", "unpack", NULL
2352 const char *const *functions
;
2354 if (!e
->value
.function
.isym
2355 || !e
->value
.function
.isym
->transformational
)
2358 name
= e
->symtree
->n
.sym
->name
;
2360 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2361 ? trans_func_f2003
: trans_func_f95
;
2363 /* NULL() is dealt with below. */
2364 if (strcmp ("null", name
) == 0)
2367 for (i
= 0; functions
[i
]; i
++)
2368 if (strcmp (functions
[i
], name
) == 0)
2371 if (functions
[i
] == NULL
)
2373 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2374 "in an initialization expression", name
, &e
->where
);
2378 return check_init_expr_arguments (e
);
2382 /* F95, 7.1.6.1, Initialization expressions, (6)
2383 F2003, 7.1.7 Initialization expression, (6) */
2386 check_null (gfc_expr
*e
)
2388 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2391 return check_init_expr_arguments (e
);
2396 check_elemental (gfc_expr
*e
)
2398 if (!e
->value
.function
.isym
2399 || !e
->value
.function
.isym
->elemental
)
2402 if (e
->ts
.type
!= BT_INTEGER
2403 && e
->ts
.type
!= BT_CHARACTER
2404 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2405 "initialization expression at %L", &e
->where
))
2408 return check_init_expr_arguments (e
);
2413 check_conversion (gfc_expr
*e
)
2415 if (!e
->value
.function
.isym
2416 || !e
->value
.function
.isym
->conversion
)
2419 return check_init_expr_arguments (e
);
2423 /* Verify that an expression is an initialization expression. A side
2424 effect is that the expression tree is reduced to a single constant
2425 node if all goes well. This would normally happen when the
2426 expression is constructed but function references are assumed to be
2427 intrinsics in the context of initialization expressions. If
2428 false is returned an error message has been generated. */
2431 gfc_check_init_expr (gfc_expr
*e
)
2439 switch (e
->expr_type
)
2442 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2444 t
= gfc_simplify_expr (e
, 0);
2453 gfc_intrinsic_sym
* isym
= NULL
;
2454 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2456 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2457 IEEE_EXCEPTIONS modules. */
2458 int mod
= sym
->from_intmod
;
2459 if (mod
== INTMOD_NONE
&& sym
->generic
)
2460 mod
= sym
->generic
->sym
->from_intmod
;
2461 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2463 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2466 gfc_replace_expr (e
, new_expr
);
2472 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2473 into an array constructor, we need to skip the error check here.
2474 Conversion errors are caught below in scalarize_intrinsic_call. */
2475 conversion
= e
->value
.function
.isym
2476 && (e
->value
.function
.isym
->conversion
== 1);
2478 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2479 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2481 gfc_error ("Function %qs in initialization expression at %L "
2482 "must be an intrinsic function",
2483 e
->symtree
->n
.sym
->name
, &e
->where
);
2487 if ((m
= check_conversion (e
)) == MATCH_NO
2488 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2489 && (m
= check_null (e
)) == MATCH_NO
2490 && (m
= check_transformational (e
)) == MATCH_NO
2491 && (m
= check_elemental (e
)) == MATCH_NO
)
2493 gfc_error ("Intrinsic function %qs at %L is not permitted "
2494 "in an initialization expression",
2495 e
->symtree
->n
.sym
->name
, &e
->where
);
2499 if (m
== MATCH_ERROR
)
2502 /* Try to scalarize an elemental intrinsic function that has an
2504 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2505 if (isym
&& isym
->elemental
2506 && (t
= scalarize_intrinsic_call (e
)))
2511 t
= gfc_simplify_expr (e
, 0);
2518 if (gfc_check_iter_variable (e
))
2521 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2523 /* A PARAMETER shall not be used to define itself, i.e.
2524 REAL, PARAMETER :: x = transfer(0, x)
2526 if (!e
->symtree
->n
.sym
->value
)
2528 gfc_error ("PARAMETER %qs is used at %L before its definition "
2529 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2533 t
= simplify_parameter_variable (e
, 0);
2538 if (gfc_in_match_data ())
2543 if (e
->symtree
->n
.sym
->as
)
2545 switch (e
->symtree
->n
.sym
->as
->type
)
2547 case AS_ASSUMED_SIZE
:
2548 gfc_error ("Assumed size array %qs at %L is not permitted "
2549 "in an initialization expression",
2550 e
->symtree
->n
.sym
->name
, &e
->where
);
2553 case AS_ASSUMED_SHAPE
:
2554 gfc_error ("Assumed shape array %qs at %L is not permitted "
2555 "in an initialization expression",
2556 e
->symtree
->n
.sym
->name
, &e
->where
);
2560 gfc_error ("Deferred array %qs at %L is not permitted "
2561 "in an initialization expression",
2562 e
->symtree
->n
.sym
->name
, &e
->where
);
2566 gfc_error ("Array %qs at %L is a variable, which does "
2567 "not reduce to a constant expression",
2568 e
->symtree
->n
.sym
->name
, &e
->where
);
2576 gfc_error ("Parameter %qs at %L has not been declared or is "
2577 "a variable, which does not reduce to a constant "
2578 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2587 case EXPR_SUBSTRING
:
2590 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2594 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2596 t
= gfc_simplify_expr (e
, 0);
2602 case EXPR_STRUCTURE
:
2603 t
= e
->ts
.is_iso_c
? true : false;
2607 t
= check_alloc_comp_init (e
);
2611 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2618 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2622 t
= gfc_expand_constructor (e
, true);
2626 t
= gfc_check_constructor_type (e
);
2630 gfc_internal_error ("check_init_expr(): Unknown expression type");
2636 /* Reduces a general expression to an initialization expression (a constant).
2637 This used to be part of gfc_match_init_expr.
2638 Note that this function doesn't free the given expression on false. */
2641 gfc_reduce_init_expr (gfc_expr
*expr
)
2645 gfc_init_expr_flag
= true;
2646 t
= gfc_resolve_expr (expr
);
2648 t
= gfc_check_init_expr (expr
);
2649 gfc_init_expr_flag
= false;
2654 if (expr
->expr_type
== EXPR_ARRAY
)
2656 if (!gfc_check_constructor_type (expr
))
2658 if (!gfc_expand_constructor (expr
, true))
2666 /* Match an initialization expression. We work by first matching an
2667 expression, then reducing it to a constant. */
2670 gfc_match_init_expr (gfc_expr
**result
)
2678 gfc_init_expr_flag
= true;
2680 m
= gfc_match_expr (&expr
);
2683 gfc_init_expr_flag
= false;
2687 t
= gfc_reduce_init_expr (expr
);
2690 gfc_free_expr (expr
);
2691 gfc_init_expr_flag
= false;
2696 gfc_init_expr_flag
= false;
2702 /* Given an actual argument list, test to see that each argument is a
2703 restricted expression and optionally if the expression type is
2704 integer or character. */
2707 restricted_args (gfc_actual_arglist
*a
)
2709 for (; a
; a
= a
->next
)
2711 if (!check_restricted (a
->expr
))
2719 /************* Restricted/specification expressions *************/
2722 /* Make sure a non-intrinsic function is a specification function,
2723 * see F08:7.1.11.5. */
2726 external_spec_function (gfc_expr
*e
)
2730 f
= e
->value
.function
.esym
;
2732 /* IEEE functions allowed are "a reference to a transformational function
2733 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
2734 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
2735 IEEE_EXCEPTIONS". */
2736 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
2737 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
2739 if (!strcmp (f
->name
, "ieee_selected_real_kind")
2740 || !strcmp (f
->name
, "ieee_support_rounding")
2741 || !strcmp (f
->name
, "ieee_support_flag")
2742 || !strcmp (f
->name
, "ieee_support_halting")
2743 || !strcmp (f
->name
, "ieee_support_datatype")
2744 || !strcmp (f
->name
, "ieee_support_denormal")
2745 || !strcmp (f
->name
, "ieee_support_divide")
2746 || !strcmp (f
->name
, "ieee_support_inf")
2747 || !strcmp (f
->name
, "ieee_support_io")
2748 || !strcmp (f
->name
, "ieee_support_nan")
2749 || !strcmp (f
->name
, "ieee_support_sqrt")
2750 || !strcmp (f
->name
, "ieee_support_standard")
2751 || !strcmp (f
->name
, "ieee_support_underflow_control"))
2752 goto function_allowed
;
2755 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2757 gfc_error ("Specification function %qs at %L cannot be a statement "
2758 "function", f
->name
, &e
->where
);
2762 if (f
->attr
.proc
== PROC_INTERNAL
)
2764 gfc_error ("Specification function %qs at %L cannot be an internal "
2765 "function", f
->name
, &e
->where
);
2769 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2771 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
2777 if (f
->attr
.recursive
2778 && !gfc_notify_std (GFC_STD_F2003
,
2779 "Specification function '%s' "
2780 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
2784 return restricted_args (e
->value
.function
.actual
);
2788 /* Check to see that a function reference to an intrinsic is a
2789 restricted expression. */
2792 restricted_intrinsic (gfc_expr
*e
)
2794 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2795 if (check_inquiry (e
, 0) == MATCH_YES
)
2798 return restricted_args (e
->value
.function
.actual
);
2802 /* Check the expressions of an actual arglist. Used by check_restricted. */
2805 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
2807 for (; arg
; arg
= arg
->next
)
2808 if (!checker (arg
->expr
))
2815 /* Check the subscription expressions of a reference chain with a checking
2816 function; used by check_restricted. */
2819 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
2829 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2831 if (!checker (ref
->u
.ar
.start
[dim
]))
2833 if (!checker (ref
->u
.ar
.end
[dim
]))
2835 if (!checker (ref
->u
.ar
.stride
[dim
]))
2841 /* Nothing needed, just proceed to next reference. */
2845 if (!checker (ref
->u
.ss
.start
))
2847 if (!checker (ref
->u
.ss
.end
))
2856 return check_references (ref
->next
, checker
);
2859 /* Return true if ns is a parent of the current ns. */
2862 is_parent_of_current_ns (gfc_namespace
*ns
)
2865 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
2872 /* Verify that an expression is a restricted expression. Like its
2873 cousin check_init_expr(), an error message is generated if we
2877 check_restricted (gfc_expr
*e
)
2885 switch (e
->expr_type
)
2888 t
= check_intrinsic_op (e
, check_restricted
);
2890 t
= gfc_simplify_expr (e
, 0);
2895 if (e
->value
.function
.esym
)
2897 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2899 t
= external_spec_function (e
);
2903 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2906 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2909 t
= restricted_intrinsic (e
);
2914 sym
= e
->symtree
->n
.sym
;
2917 /* If a dummy argument appears in a context that is valid for a
2918 restricted expression in an elemental procedure, it will have
2919 already been simplified away once we get here. Therefore we
2920 don't need to jump through hoops to distinguish valid from
2922 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2923 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2925 gfc_error ("Dummy argument %qs not allowed in expression at %L",
2926 sym
->name
, &e
->where
);
2930 if (sym
->attr
.optional
)
2932 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
2933 sym
->name
, &e
->where
);
2937 if (sym
->attr
.intent
== INTENT_OUT
)
2939 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
2940 sym
->name
, &e
->where
);
2944 /* Check reference chain if any. */
2945 if (!check_references (e
->ref
, &check_restricted
))
2948 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2949 processed in resolve.c(resolve_formal_arglist). This is done so
2950 that host associated dummy array indices are accepted (PR23446).
2951 This mechanism also does the same for the specification expressions
2952 of array-valued functions. */
2954 || sym
->attr
.in_common
2955 || sym
->attr
.use_assoc
2957 || sym
->attr
.implied_index
2958 || sym
->attr
.flavor
== FL_PARAMETER
2959 || is_parent_of_current_ns (sym
->ns
)
2960 || (sym
->ns
->proc_name
!= NULL
2961 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2962 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2968 gfc_error ("Variable %qs cannot appear in the expression at %L",
2969 sym
->name
, &e
->where
);
2970 /* Prevent a repetition of the error. */
2979 case EXPR_SUBSTRING
:
2980 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2984 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2986 t
= gfc_simplify_expr (e
, 0);
2990 case EXPR_STRUCTURE
:
2991 t
= gfc_check_constructor (e
, check_restricted
);
2995 t
= gfc_check_constructor (e
, check_restricted
);
2999 gfc_internal_error ("check_restricted(): Unknown expression type");
3006 /* Check to see that an expression is a specification expression. If
3007 we return false, an error has been generated. */
3010 gfc_specification_expr (gfc_expr
*e
)
3012 gfc_component
*comp
;
3017 if (e
->ts
.type
!= BT_INTEGER
)
3019 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3020 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3024 comp
= gfc_get_proc_ptr_comp (e
);
3025 if (e
->expr_type
== EXPR_FUNCTION
3026 && !e
->value
.function
.isym
3027 && !e
->value
.function
.esym
3028 && !gfc_pure (e
->symtree
->n
.sym
)
3029 && (!comp
|| !comp
->attr
.pure
))
3031 gfc_error ("Function %qs at %L must be PURE",
3032 e
->symtree
->n
.sym
->name
, &e
->where
);
3033 /* Prevent repeat error messages. */
3034 e
->symtree
->n
.sym
->attr
.pure
= 1;
3040 gfc_error ("Expression at %L must be scalar", &e
->where
);
3044 if (!gfc_simplify_expr (e
, 0))
3047 return check_restricted (e
);
3051 /************** Expression conformance checks. *************/
3053 /* Given two expressions, make sure that the arrays are conformable. */
3056 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3058 int op1_flag
, op2_flag
, d
;
3059 mpz_t op1_size
, op2_size
;
3065 if (op1
->rank
== 0 || op2
->rank
== 0)
3068 va_start (argp
, optype_msgid
);
3069 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3072 if (op1
->rank
!= op2
->rank
)
3074 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3075 op1
->rank
, op2
->rank
, &op1
->where
);
3081 for (d
= 0; d
< op1
->rank
; d
++)
3083 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3084 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3086 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3088 gfc_error ("Different shape for %s at %L on dimension %d "
3089 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3090 (int) mpz_get_si (op1_size
),
3091 (int) mpz_get_si (op2_size
));
3097 mpz_clear (op1_size
);
3099 mpz_clear (op2_size
);
3109 /* Given an assignable expression and an arbitrary expression, make
3110 sure that the assignment can take place. Only add a call to the intrinsic
3111 conversion routines, when allow_convert is set. When this assign is a
3112 coarray call, then the convert is done by the coarray routine implictly and
3113 adding the intrinsic conversion would do harm in most cases. */
3116 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3123 sym
= lvalue
->symtree
->n
.sym
;
3125 /* See if this is the component or subcomponent of a pointer. */
3126 has_pointer
= sym
->attr
.pointer
;
3127 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3128 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3134 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3135 variable local to a function subprogram. Its existence begins when
3136 execution of the function is initiated and ends when execution of the
3137 function is terminated...
3138 Therefore, the left hand side is no longer a variable, when it is: */
3139 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3140 && !sym
->attr
.external
)
3145 /* (i) Use associated; */
3146 if (sym
->attr
.use_assoc
)
3149 /* (ii) The assignment is in the main program; or */
3150 if (gfc_current_ns
->proc_name
3151 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3154 /* (iii) A module or internal procedure... */
3155 if (gfc_current_ns
->proc_name
3156 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3157 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3158 && gfc_current_ns
->parent
3159 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3160 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3161 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3163 /* ... that is not a function... */
3164 if (gfc_current_ns
->proc_name
3165 && !gfc_current_ns
->proc_name
->attr
.function
)
3168 /* ... or is not an entry and has a different name. */
3169 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3173 /* (iv) Host associated and not the function symbol or the
3174 parent result. This picks up sibling references, which
3175 cannot be entries. */
3176 if (!sym
->attr
.entry
3177 && sym
->ns
== gfc_current_ns
->parent
3178 && sym
!= gfc_current_ns
->proc_name
3179 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3184 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3189 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3191 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3192 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3196 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3198 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3203 if (rvalue
->expr_type
== EXPR_NULL
)
3205 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3206 && lvalue
->symtree
->n
.sym
->attr
.data
)
3210 gfc_error ("NULL appears on right-hand side in assignment at %L",
3216 /* This is possibly a typo: x = f() instead of x => f(). */
3218 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3219 gfc_warning (OPT_Wsurprising
,
3220 "POINTER-valued function appears on right-hand side of "
3221 "assignment at %L", &rvalue
->where
);
3223 /* Check size of array assignments. */
3224 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3225 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3228 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3229 && lvalue
->symtree
->n
.sym
->attr
.data
3230 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3231 "initialize non-integer variable %qs",
3232 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3234 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3235 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3236 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3240 /* Handle the case of a BOZ literal on the RHS. */
3241 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3244 if (warn_surprising
)
3245 gfc_warning (OPT_Wsurprising
,
3246 "BOZ literal at %L is bitwise transferred "
3247 "non-integer symbol %qs", &rvalue
->where
,
3248 lvalue
->symtree
->n
.sym
->name
);
3249 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3251 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3253 if (rc
== ARITH_UNDERFLOW
)
3254 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3255 ". This check can be disabled with the option "
3256 "%<-fno-range-check%>", &rvalue
->where
);
3257 else if (rc
== ARITH_OVERFLOW
)
3258 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3259 ". This check can be disabled with the option "
3260 "%<-fno-range-check%>", &rvalue
->where
);
3261 else if (rc
== ARITH_NAN
)
3262 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3263 ". This check can be disabled with the option "
3264 "%<-fno-range-check%>", &rvalue
->where
);
3269 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3272 /* Only DATA Statements come here. */
3275 /* Numeric can be converted to any other numeric. And Hollerith can be
3276 converted to any other type. */
3277 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3278 || rvalue
->ts
.type
== BT_HOLLERITH
)
3281 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3284 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3285 "conversion of %s to %s", &lvalue
->where
,
3286 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3291 /* Assignment is the only case where character variables of different
3292 kind values can be converted into one another. */
3293 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3295 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3296 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3304 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3308 /* Check that a pointer assignment is OK. We first check lvalue, and
3309 we only check rvalue if it's not an assignment to NULL() or a
3310 NULLIFY statement. */
3313 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3315 symbol_attribute attr
, lhs_attr
;
3317 bool is_pure
, is_implicit_pure
, rank_remap
;
3320 lhs_attr
= gfc_expr_attr (lvalue
);
3321 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3323 gfc_error ("Pointer assignment target is not a POINTER at %L",
3328 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3329 && !lhs_attr
.proc_pointer
)
3331 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3332 "l-value since it is a procedure",
3333 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3337 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3340 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3342 if (ref
->type
== REF_COMPONENT
)
3343 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3345 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3349 if (ref
->u
.ar
.type
== AR_FULL
)
3352 if (ref
->u
.ar
.type
!= AR_SECTION
)
3354 gfc_error ("Expected bounds specification for %qs at %L",
3355 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3359 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3360 "for %qs in pointer assignment at %L",
3361 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3364 /* When bounds are given, all lbounds are necessary and either all
3365 or none of the upper bounds; no strides are allowed. If the
3366 upper bounds are present, we may do rank remapping. */
3367 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3369 if (!ref
->u
.ar
.start
[dim
]
3370 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3372 gfc_error ("Lower bound has to be present at %L",
3376 if (ref
->u
.ar
.stride
[dim
])
3378 gfc_error ("Stride must not be present at %L",
3384 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3387 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3388 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3390 gfc_error ("Either all or none of the upper bounds"
3391 " must be specified at %L", &lvalue
->where
);
3399 is_pure
= gfc_pure (NULL
);
3400 is_implicit_pure
= gfc_implicit_pure (NULL
);
3402 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3403 kind, etc for lvalue and rvalue must match, and rvalue must be a
3404 pure variable if we're in a pure function. */
3405 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3408 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3409 if (lvalue
->expr_type
== EXPR_VARIABLE
3410 && gfc_is_coindexed (lvalue
))
3413 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3414 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3416 gfc_error ("Pointer object at %L shall not have a coindex",
3422 /* Checks on rvalue for procedure pointer assignments. */
3427 gfc_component
*comp1
, *comp2
;
3430 attr
= gfc_expr_attr (rvalue
);
3431 if (!((rvalue
->expr_type
== EXPR_NULL
)
3432 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3433 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3434 || (rvalue
->expr_type
== EXPR_VARIABLE
3435 && attr
.flavor
== FL_PROCEDURE
)))
3437 gfc_error ("Invalid procedure pointer assignment at %L",
3441 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3443 /* Check for intrinsics. */
3444 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3445 if (!sym
->attr
.intrinsic
3446 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3447 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3449 sym
->attr
.intrinsic
= 1;
3450 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3451 attr
= gfc_expr_attr (rvalue
);
3453 /* Check for result of embracing function. */
3454 if (sym
->attr
.function
&& sym
->result
== sym
)
3458 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3459 if (sym
== ns
->proc_name
)
3461 gfc_error ("Function result %qs is invalid as proc-target "
3462 "in procedure pointer assignment at %L",
3463 sym
->name
, &rvalue
->where
);
3470 gfc_error ("Abstract interface %qs is invalid "
3471 "in procedure pointer assignment at %L",
3472 rvalue
->symtree
->name
, &rvalue
->where
);
3475 /* Check for F08:C729. */
3476 if (attr
.flavor
== FL_PROCEDURE
)
3478 if (attr
.proc
== PROC_ST_FUNCTION
)
3480 gfc_error ("Statement function %qs is invalid "
3481 "in procedure pointer assignment at %L",
3482 rvalue
->symtree
->name
, &rvalue
->where
);
3485 if (attr
.proc
== PROC_INTERNAL
&&
3486 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3487 "is invalid in procedure pointer assignment "
3488 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3490 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3491 attr
.subroutine
) == 0)
3493 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3494 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3498 /* Check for F08:C730. */
3499 if (attr
.elemental
&& !attr
.intrinsic
)
3501 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3502 "in procedure pointer assignment at %L",
3503 rvalue
->symtree
->name
, &rvalue
->where
);
3507 /* Ensure that the calling convention is the same. As other attributes
3508 such as DLLEXPORT may differ, one explicitly only tests for the
3509 calling conventions. */
3510 if (rvalue
->expr_type
== EXPR_VARIABLE
3511 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3512 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3514 symbol_attribute calls
;
3517 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3518 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3519 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3521 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3522 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3524 gfc_error ("Mismatch in the procedure pointer assignment "
3525 "at %L: mismatch in the calling convention",
3531 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3533 s1
= comp1
->ts
.interface
;
3536 s1
= lvalue
->symtree
->n
.sym
;
3537 if (s1
->ts
.interface
)
3538 s1
= s1
->ts
.interface
;
3541 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3544 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3546 s2
= comp2
->ts
.interface
->result
;
3551 s2
= comp2
->ts
.interface
;
3555 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3557 if (rvalue
->value
.function
.esym
)
3558 s2
= rvalue
->value
.function
.esym
->result
;
3560 s2
= rvalue
->symtree
->n
.sym
->result
;
3566 s2
= rvalue
->symtree
->n
.sym
;
3570 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3571 s2
= s2
->ts
.interface
;
3573 /* Special check for the case of absent interface on the lvalue.
3574 * All other interface checks are done below. */
3575 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
3577 gfc_error ("Interface mismatch in procedure pointer assignment "
3578 "at %L: '%s' is not a subroutine", &rvalue
->where
, name
);
3582 if (s1
== s2
|| !s1
|| !s2
)
3585 /* F08:7.2.2.4 (4) */
3586 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
3587 && gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3589 gfc_error ("Explicit interface required for %qs at %L: %s",
3590 s1
->name
, &lvalue
->where
, err
);
3593 if (s2
->attr
.if_source
== IFSRC_UNKNOWN
3594 && gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3596 gfc_error ("Explicit interface required for %qs at %L: %s",
3597 s2
->name
, &rvalue
->where
, err
);
3601 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3602 err
, sizeof(err
), NULL
, NULL
))
3604 gfc_error ("Interface mismatch in procedure pointer assignment "
3605 "at %L: %s", &rvalue
->where
, err
);
3609 /* Check F2008Cor2, C729. */
3610 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
3611 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
3613 gfc_error ("Procedure pointer target %qs at %L must be either an "
3614 "intrinsic, host or use associated, referenced or have "
3615 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
3622 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3624 /* Check for F03:C717. */
3625 if (UNLIMITED_POLY (rvalue
)
3626 && !(UNLIMITED_POLY (lvalue
)
3627 || (lvalue
->ts
.type
== BT_DERIVED
3628 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3629 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3630 gfc_error ("Data-pointer-object at %L must be unlimited "
3631 "polymorphic, or of a type with the BIND or SEQUENCE "
3632 "attribute, to be compatible with an unlimited "
3633 "polymorphic target", &lvalue
->where
);
3635 gfc_error ("Different types in pointer assignment at %L; "
3636 "attempted assignment of %s to %s", &lvalue
->where
,
3637 gfc_typename (&rvalue
->ts
),
3638 gfc_typename (&lvalue
->ts
));
3642 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3644 gfc_error ("Different kind type parameters in pointer "
3645 "assignment at %L", &lvalue
->where
);
3649 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3651 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3655 /* Make sure the vtab is present. */
3656 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
3657 gfc_find_vtab (&rvalue
->ts
);
3659 /* Check rank remapping. */
3664 /* If this can be determined, check that the target must be at least as
3665 large as the pointer assigned to it is. */
3666 if (gfc_array_size (lvalue
, &lsize
)
3667 && gfc_array_size (rvalue
, &rsize
)
3668 && mpz_cmp (rsize
, lsize
) < 0)
3670 gfc_error ("Rank remapping target is smaller than size of the"
3671 " pointer (%ld < %ld) at %L",
3672 mpz_get_si (rsize
), mpz_get_si (lsize
),
3677 /* The target must be either rank one or it must be simply contiguous
3678 and F2008 must be allowed. */
3679 if (rvalue
->rank
!= 1)
3681 if (!gfc_is_simply_contiguous (rvalue
, true, false))
3683 gfc_error ("Rank remapping target must be rank 1 or"
3684 " simply contiguous at %L", &rvalue
->where
);
3687 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
3688 "rank 1 at %L", &rvalue
->where
))
3693 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3694 if (rvalue
->expr_type
== EXPR_NULL
)
3697 if (lvalue
->ts
.type
== BT_CHARACTER
)
3699 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3704 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3705 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3707 attr
= gfc_expr_attr (rvalue
);
3709 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3711 gfc_error ("Target expression in pointer assignment "
3712 "at %L must deliver a pointer result",
3717 if (!attr
.target
&& !attr
.pointer
)
3719 gfc_error ("Pointer assignment target is neither TARGET "
3720 "nor POINTER at %L", &rvalue
->where
);
3724 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3726 gfc_error ("Bad target in pointer assignment in PURE "
3727 "procedure at %L", &rvalue
->where
);
3730 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3731 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3733 if (gfc_has_vector_index (rvalue
))
3735 gfc_error ("Pointer assignment with vector subscript "
3736 "on rhs at %L", &rvalue
->where
);
3740 if (attr
.is_protected
&& attr
.use_assoc
3741 && !(attr
.pointer
|| attr
.proc_pointer
))
3743 gfc_error ("Pointer assignment target has PROTECTED "
3744 "attribute at %L", &rvalue
->where
);
3748 /* F2008, C725. For PURE also C1283. */
3749 if (rvalue
->expr_type
== EXPR_VARIABLE
3750 && gfc_is_coindexed (rvalue
))
3753 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3754 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3756 gfc_error ("Data target at %L shall not have a coindex",
3762 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3763 if (warn_target_lifetime
3764 && rvalue
->expr_type
== EXPR_VARIABLE
3765 && !rvalue
->symtree
->n
.sym
->attr
.save
3766 && !attr
.pointer
&& !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3767 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3768 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3769 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3774 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3775 || lvalue
->symtree
->n
.sym
->attr
.result
3776 || lvalue
->symtree
->n
.sym
->attr
.function
3777 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3778 && lvalue
->symtree
->n
.sym
->ns
3779 != rvalue
->symtree
->n
.sym
->ns
)
3780 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3781 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3783 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3784 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3785 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3786 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3787 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3789 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3796 gfc_warning (OPT_Wtarget_lifetime
,
3797 "Pointer at %L in pointer assignment might outlive the "
3798 "pointer target", &lvalue
->where
);
3805 /* Relative of gfc_check_assign() except that the lvalue is a single
3806 symbol. Used for initialization assignments. */
3809 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3813 bool pointer
, proc_pointer
;
3815 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3817 lvalue
.expr_type
= EXPR_VARIABLE
;
3818 lvalue
.ts
= sym
->ts
;
3820 lvalue
.rank
= sym
->as
->rank
;
3821 lvalue
.symtree
= XCNEW (gfc_symtree
);
3822 lvalue
.symtree
->n
.sym
= sym
;
3823 lvalue
.where
= sym
->declared_at
;
3827 lvalue
.ref
= gfc_get_ref ();
3828 lvalue
.ref
->type
= REF_COMPONENT
;
3829 lvalue
.ref
->u
.c
.component
= comp
;
3830 lvalue
.ref
->u
.c
.sym
= sym
;
3831 lvalue
.ts
= comp
->ts
;
3832 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
3833 lvalue
.where
= comp
->loc
;
3834 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3835 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
3836 proc_pointer
= comp
->attr
.proc_pointer
;
3840 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3841 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
3842 proc_pointer
= sym
->attr
.proc_pointer
;
3845 if (pointer
|| proc_pointer
)
3846 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3849 /* If a conversion function, e.g., __convert_i8_i4, was inserted
3850 into an array constructor, we should check if it can be reduced
3851 as an initialization expression. */
3852 if (rvalue
->expr_type
== EXPR_FUNCTION
3853 && rvalue
->value
.function
.isym
3854 && (rvalue
->value
.function
.isym
->conversion
== 1))
3855 gfc_check_init_expr (rvalue
);
3857 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3860 free (lvalue
.symtree
);
3866 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3868 /* F08:C461. Additional checks for pointer initialization. */
3869 symbol_attribute attr
;
3870 attr
= gfc_expr_attr (rvalue
);
3871 if (attr
.allocatable
)
3873 gfc_error ("Pointer initialization target at %L "
3874 "must not be ALLOCATABLE", &rvalue
->where
);
3877 if (!attr
.target
|| attr
.pointer
)
3879 gfc_error ("Pointer initialization target at %L "
3880 "must have the TARGET attribute", &rvalue
->where
);
3884 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
3885 && rvalue
->symtree
->n
.sym
->ns
->proc_name
3886 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
3888 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
3889 attr
.save
= SAVE_IMPLICIT
;
3894 gfc_error ("Pointer initialization target at %L "
3895 "must have the SAVE attribute", &rvalue
->where
);
3900 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3902 /* F08:C1220. Additional checks for procedure pointer initialization. */
3903 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3904 if (attr
.proc_pointer
)
3906 gfc_error ("Procedure pointer initialization target at %L "
3907 "may not be a procedure pointer", &rvalue
->where
);
3916 /* Build an initializer for a local integer, real, complex, logical, or
3917 character variable, based on the command line flags finit-local-zero,
3918 finit-integer=, finit-real=, finit-logical=, and finit-character=. */
3921 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
3924 gfc_expr
*init_expr
;
3927 /* Try to build an initializer expression. */
3928 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
3930 /* We will only initialize integers, reals, complex, logicals, and
3931 characters, and only if the corresponding command-line flags
3932 were set. Otherwise, we free init_expr and return null. */
3936 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
3937 mpz_set_si (init_expr
->value
.integer
,
3938 gfc_option
.flag_init_integer_value
);
3941 gfc_free_expr (init_expr
);
3947 switch (flag_init_real
)
3949 case GFC_INIT_REAL_SNAN
:
3950 init_expr
->is_snan
= 1;
3952 case GFC_INIT_REAL_NAN
:
3953 mpfr_set_nan (init_expr
->value
.real
);
3956 case GFC_INIT_REAL_INF
:
3957 mpfr_set_inf (init_expr
->value
.real
, 1);
3960 case GFC_INIT_REAL_NEG_INF
:
3961 mpfr_set_inf (init_expr
->value
.real
, -1);
3964 case GFC_INIT_REAL_ZERO
:
3965 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
3969 gfc_free_expr (init_expr
);
3976 switch (flag_init_real
)
3978 case GFC_INIT_REAL_SNAN
:
3979 init_expr
->is_snan
= 1;
3981 case GFC_INIT_REAL_NAN
:
3982 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
3983 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
3986 case GFC_INIT_REAL_INF
:
3987 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
3988 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
3991 case GFC_INIT_REAL_NEG_INF
:
3992 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
3993 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
3996 case GFC_INIT_REAL_ZERO
:
3997 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4001 gfc_free_expr (init_expr
);
4008 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
4009 init_expr
->value
.logical
= 0;
4010 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
4011 init_expr
->value
.logical
= 1;
4014 gfc_free_expr (init_expr
);
4020 /* For characters, the length must be constant in order to
4021 create a default initializer. */
4022 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
4024 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4026 char_len
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
4027 init_expr
->value
.character
.length
= char_len
;
4028 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4029 for (i
= 0; i
< char_len
; i
++)
4030 init_expr
->value
.character
.string
[i
]
4031 = (unsigned char) gfc_option
.flag_init_character_value
;
4035 gfc_free_expr (init_expr
);
4038 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
4039 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4041 gfc_actual_arglist
*arg
;
4042 init_expr
= gfc_get_expr ();
4043 init_expr
->where
= *where
;
4044 init_expr
->ts
= *ts
;
4045 init_expr
->expr_type
= EXPR_FUNCTION
;
4046 init_expr
->value
.function
.isym
=
4047 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4048 init_expr
->value
.function
.name
= "repeat";
4049 arg
= gfc_get_actual_arglist ();
4050 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4051 arg
->expr
->value
.character
.string
[0] =
4052 gfc_option
.flag_init_character_value
;
4053 arg
->next
= gfc_get_actual_arglist ();
4054 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4055 init_expr
->value
.function
.actual
= arg
;
4060 gfc_free_expr (init_expr
);
4067 /* Apply an initialization expression to a typespec. Can be used for symbols or
4068 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4069 combined with some effort. */
4072 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4074 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4076 && ts
->u
.cl
->length
&& ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4080 gcc_assert (ts
->u
.cl
&& ts
->u
.cl
->length
);
4081 gcc_assert (ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
4082 gcc_assert (ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
);
4084 len
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
4086 if (init
->expr_type
== EXPR_CONSTANT
)
4087 gfc_set_constant_character_len (len
, init
, -1);
4090 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4091 init
->ts
.u
.cl
->length
->value
.integer
))
4093 gfc_constructor
*ctor
;
4094 ctor
= gfc_constructor_first (init
->value
.constructor
);
4099 bool has_ts
= (init
->ts
.u
.cl
4100 && init
->ts
.u
.cl
->length_from_typespec
);
4102 /* Remember the length of the first element for checking
4103 that all elements *in the constructor* have the same
4104 length. This need not be the length of the LHS! */
4105 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4106 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4107 first_len
= ctor
->expr
->value
.character
.length
;
4109 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4110 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4112 gfc_set_constant_character_len (len
, ctor
->expr
,
4113 has_ts
? -1 : first_len
);
4114 if (!ctor
->expr
->ts
.u
.cl
)
4116 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4118 ctor
->expr
->ts
.u
.cl
->length
4119 = gfc_copy_expr (ts
->u
.cl
->length
);
4127 /* Check whether an expression is a structure constructor and whether it has
4128 other values than NULL. */
4131 is_non_empty_structure_constructor (gfc_expr
* e
)
4133 if (e
->expr_type
!= EXPR_STRUCTURE
)
4136 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4139 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4141 cons
= gfc_constructor_next (cons
);
4147 /* Check for default initializer; sym->value is not enough
4148 as it is also set for EXPR_NULL of allocatables. */
4151 gfc_has_default_initializer (gfc_symbol
*der
)
4155 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4156 for (c
= der
->components
; c
; c
= c
->next
)
4157 if (gfc_bt_struct (c
->ts
.type
))
4159 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4160 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4162 && is_non_empty_structure_constructor (c
->initializer
))
4163 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4165 if (c
->attr
.pointer
&& c
->initializer
)
4179 Generate an initializer expression which initializes the entirety of a union.
4180 A normal structure constructor is insufficient without undue effort, because
4181 components of maps may be oddly aligned/overlapped. (For example if a
4182 character is initialized from one map overtop a real from the other, only one
4183 byte of the real is actually initialized.) Unfortunately we don't know the
4184 size of the union right now, so we can't generate a proper initializer, but
4185 we use a NULL expr as a placeholder and do the right thing later in
4186 gfc_trans_subcomponent_assign.
4189 generate_union_initializer (gfc_component
*un
)
4191 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4194 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4195 placeholder
->ts
= un
->ts
;
4200 /* Get the user-specified initializer for a union, if any. This means the user
4201 has said to initialize component(s) of a map. For simplicity's sake we
4202 only allow the user to initialize the first map. We don't have to worry
4203 about overlapping initializers as they are released early in resolution (see
4204 resolve_fl_struct). */
4207 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4210 gfc_expr
*init
=NULL
;
4212 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4215 for (map
= union_type
->components
; map
; map
= map
->next
)
4217 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4219 init
= gfc_default_initializer (&map
->ts
);
4232 /* Fetch or generate an initializer for the given component.
4233 Only generate an initializer if generate is true. */
4236 component_initializer (gfc_typespec
*ts
, gfc_component
*c
, bool generate
)
4238 gfc_expr
*init
= NULL
;
4240 /* See if we can find the initializer immediately. */
4241 if (c
->initializer
|| !generate
4242 || (ts
->type
== BT_CLASS
&& !c
->attr
.allocatable
))
4243 return c
->initializer
;
4245 /* Recursively handle derived type components. */
4246 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4247 init
= gfc_generate_initializer (&c
->ts
, true);
4249 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4251 gfc_component
*map
= NULL
;
4252 gfc_constructor
*ctor
;
4253 gfc_expr
*user_init
;
4255 /* If we don't have a user initializer and we aren't generating one, this
4256 union has no initializer. */
4257 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4258 if (!user_init
&& !generate
)
4261 /* Otherwise use a structure constructor. */
4262 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4266 /* If we are to generate an initializer for the union, add a constructor
4267 which initializes the whole union first. */
4270 ctor
= gfc_constructor_get ();
4271 ctor
->expr
= generate_union_initializer (c
);
4272 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4275 /* If we found an initializer in one of our maps, apply it. Note this
4276 is applied _after_ the entire-union initializer above if any. */
4279 ctor
= gfc_constructor_get ();
4280 ctor
->expr
= user_init
;
4281 ctor
->n
.component
= map
;
4282 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4286 /* Treat simple components like locals. */
4289 init
= gfc_build_default_init_expr (&c
->ts
, &c
->loc
);
4290 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4297 /* Get an expression for a default initializer of a derived type. */
4300 gfc_default_initializer (gfc_typespec
*ts
)
4302 return gfc_generate_initializer (ts
, false);
4306 /* Get or generate an expression for a default initializer of a derived type.
4307 If -finit-derived is specified, generate default initialization expressions
4308 for components that lack them when generate is set. */
4311 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4313 gfc_expr
*init
, *tmp
;
4314 gfc_component
*comp
;
4315 generate
= flag_init_derived
&& generate
;
4317 /* See if we have a default initializer in this, but not in nested
4318 types (otherwise we could use gfc_has_default_initializer()).
4319 We don't need to check if we are going to generate them. */
4320 comp
= ts
->u
.derived
->components
;
4323 for (; comp
; comp
= comp
->next
)
4324 if (comp
->initializer
|| comp
->attr
.allocatable
4325 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4326 && CLASS_DATA (comp
)->attr
.allocatable
))
4333 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4334 &ts
->u
.derived
->declared_at
);
4337 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4339 gfc_constructor
*ctor
= gfc_constructor_get();
4341 /* Fetch or generate an initializer for the component. */
4342 tmp
= component_initializer (ts
, comp
, generate
);
4345 /* Save the component ref for STRUCTUREs and UNIONs. */
4346 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4347 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4348 ctor
->n
.component
= comp
;
4350 /* If the initializer was not generated, we need a copy. */
4351 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4352 if ((comp
->ts
.type
!= tmp
->ts
.type
4353 || comp
->ts
.kind
!= tmp
->ts
.kind
)
4354 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4355 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
4358 if (comp
->attr
.allocatable
4359 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
4361 ctor
->expr
= gfc_get_expr ();
4362 ctor
->expr
->expr_type
= EXPR_NULL
;
4363 ctor
->expr
->where
= init
->where
;
4364 ctor
->expr
->ts
= comp
->ts
;
4367 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4374 /* Given a symbol, create an expression node with that symbol as a
4375 variable. If the symbol is array valued, setup a reference of the
4379 gfc_get_variable_expr (gfc_symtree
*var
)
4383 e
= gfc_get_expr ();
4384 e
->expr_type
= EXPR_VARIABLE
;
4386 e
->ts
= var
->n
.sym
->ts
;
4388 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
4389 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
4390 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
4391 && CLASS_DATA (var
->n
.sym
)->as
)))
4393 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
4394 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
4395 e
->ref
= gfc_get_ref ();
4396 e
->ref
->type
= REF_ARRAY
;
4397 e
->ref
->u
.ar
.type
= AR_FULL
;
4398 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
4399 ? CLASS_DATA (var
->n
.sym
)->as
4407 /* Adds a full array reference to an expression, as needed. */
4410 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4413 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4418 ref
->next
= gfc_get_ref ();
4423 e
->ref
= gfc_get_ref ();
4426 ref
->type
= REF_ARRAY
;
4427 ref
->u
.ar
.type
= AR_FULL
;
4428 ref
->u
.ar
.dimen
= e
->rank
;
4429 ref
->u
.ar
.where
= e
->where
;
4435 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4439 lval
= gfc_get_expr ();
4440 lval
->expr_type
= EXPR_VARIABLE
;
4441 lval
->where
= sym
->declared_at
;
4443 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4445 /* It will always be a full array. */
4446 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
4447 lval
->rank
= as
? as
->rank
: 0;
4449 gfc_add_full_array_ref (lval
, as
);
4454 /* Returns the array_spec of a full array expression. A NULL is
4455 returned otherwise. */
4457 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4462 if (expr
->rank
== 0)
4465 /* Follow any component references. */
4466 if (expr
->expr_type
== EXPR_VARIABLE
4467 || expr
->expr_type
== EXPR_CONSTANT
)
4469 as
= expr
->symtree
->n
.sym
->as
;
4470 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4475 as
= ref
->u
.c
.component
->as
;
4483 switch (ref
->u
.ar
.type
)
4506 /* General expression traversal function. */
4509 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4510 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4515 gfc_actual_arglist
*args
;
4522 if ((*func
) (expr
, sym
, &f
))
4525 if (expr
->ts
.type
== BT_CHARACTER
4527 && expr
->ts
.u
.cl
->length
4528 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4529 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4532 switch (expr
->expr_type
)
4537 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4539 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4547 case EXPR_SUBSTRING
:
4550 case EXPR_STRUCTURE
:
4552 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4553 c
; c
= gfc_constructor_next (c
))
4555 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4559 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4561 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4563 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4565 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4572 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4574 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4590 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4592 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4594 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4596 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4602 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4604 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4609 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4610 && ref
->u
.c
.component
->ts
.u
.cl
4611 && ref
->u
.c
.component
->ts
.u
.cl
->length
4612 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4614 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4618 if (ref
->u
.c
.component
->as
)
4619 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4620 + ref
->u
.c
.component
->as
->corank
; i
++)
4622 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4625 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4639 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4642 expr_set_symbols_referenced (gfc_expr
*expr
,
4643 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4644 int *f ATTRIBUTE_UNUSED
)
4646 if (expr
->expr_type
!= EXPR_VARIABLE
)
4648 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4653 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4655 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4659 /* Determine if an expression is a procedure pointer component and return
4660 the component in that case. Otherwise return NULL. */
4663 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4667 if (!expr
|| !expr
->ref
)
4674 if (ref
->type
== REF_COMPONENT
4675 && ref
->u
.c
.component
->attr
.proc_pointer
)
4676 return ref
->u
.c
.component
;
4682 /* Determine if an expression is a procedure pointer component. */
4685 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4687 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4691 /* Determine if an expression is a function with an allocatable class scalar
4694 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
4696 if (expr
->expr_type
== EXPR_FUNCTION
4697 && expr
->value
.function
.esym
4698 && expr
->value
.function
.esym
->result
4699 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4700 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4701 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4708 /* Determine if an expression is a function with an allocatable class array
4711 gfc_is_alloc_class_array_function (gfc_expr
*expr
)
4713 if (expr
->expr_type
== EXPR_FUNCTION
4714 && expr
->value
.function
.esym
4715 && expr
->value
.function
.esym
->result
4716 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4717 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4718 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4725 /* Walk an expression tree and check each variable encountered for being typed.
4726 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4727 mode as is a basic arithmetic expression using those; this is for things in
4730 INTEGER :: arr(n), n
4731 INTEGER :: arr(n + 1), n
4733 The namespace is needed for IMPLICIT typing. */
4735 static gfc_namespace
* check_typed_ns
;
4738 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4739 int* f ATTRIBUTE_UNUSED
)
4743 if (e
->expr_type
!= EXPR_VARIABLE
)
4746 gcc_assert (e
->symtree
);
4747 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4754 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4758 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4762 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4763 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4765 if (e
->expr_type
== EXPR_OP
)
4769 gcc_assert (e
->value
.op
.op1
);
4770 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4772 if (t
&& e
->value
.op
.op2
)
4773 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4779 /* Otherwise, walk the expression and do it strictly. */
4780 check_typed_ns
= ns
;
4781 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4783 return error_found
? false : true;
4788 gfc_ref_this_image (gfc_ref
*ref
)
4792 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4794 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4795 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4802 gfc_find_stat_co(gfc_expr
*e
)
4806 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4807 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4808 return ref
->u
.ar
.stat
;
4810 if (e
->value
.function
.actual
->expr
)
4811 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
4813 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4814 return ref
->u
.ar
.stat
;
4820 gfc_is_coindexed (gfc_expr
*e
)
4824 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4825 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4826 return !gfc_ref_this_image (ref
);
4832 /* Coarrays are variables with a corank but not being coindexed. However, also
4833 the following is a coarray: A subobject of a coarray is a coarray if it does
4834 not have any cosubscripts, vector subscripts, allocatable component
4835 selection, or pointer component selection. (F2008, 2.4.7) */
4838 gfc_is_coarray (gfc_expr
*e
)
4842 gfc_component
*comp
;
4847 if (e
->expr_type
!= EXPR_VARIABLE
)
4851 sym
= e
->symtree
->n
.sym
;
4853 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4854 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4856 coarray
= sym
->attr
.codimension
;
4858 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4862 comp
= ref
->u
.c
.component
;
4863 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4864 && (CLASS_DATA (comp
)->attr
.class_pointer
4865 || CLASS_DATA (comp
)->attr
.allocatable
))
4868 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4870 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4873 coarray
= comp
->attr
.codimension
;
4881 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4887 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4888 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4899 return coarray
&& !coindexed
;
4904 gfc_get_corank (gfc_expr
*e
)
4909 if (!gfc_is_coarray (e
))
4912 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4913 corank
= e
->ts
.u
.derived
->components
->as
4914 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4916 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4918 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4920 if (ref
->type
== REF_ARRAY
)
4921 corank
= ref
->u
.ar
.as
->corank
;
4922 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4929 /* Check whether the expression has an ultimate allocatable component.
4930 Being itself allocatable does not count. */
4932 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4934 gfc_ref
*ref
, *last
= NULL
;
4936 if (e
->expr_type
!= EXPR_VARIABLE
)
4939 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4940 if (ref
->type
== REF_COMPONENT
)
4943 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4944 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4945 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4946 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4950 if (e
->ts
.type
== BT_CLASS
)
4951 return CLASS_DATA (e
)->attr
.alloc_comp
;
4952 else if (e
->ts
.type
== BT_DERIVED
)
4953 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4959 /* Check whether the expression has an pointer component.
4960 Being itself a pointer does not count. */
4962 gfc_has_ultimate_pointer (gfc_expr
*e
)
4964 gfc_ref
*ref
, *last
= NULL
;
4966 if (e
->expr_type
!= EXPR_VARIABLE
)
4969 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4970 if (ref
->type
== REF_COMPONENT
)
4973 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4974 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4975 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4976 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4980 if (e
->ts
.type
== BT_CLASS
)
4981 return CLASS_DATA (e
)->attr
.pointer_comp
;
4982 else if (e
->ts
.type
== BT_DERIVED
)
4983 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4989 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4990 Note: A scalar is not regarded as "simply contiguous" by the standard.
4991 if bool is not strict, some further checks are done - for instance,
4992 a "(::1)" is accepted. */
4995 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
4999 gfc_array_ref
*ar
= NULL
;
5000 gfc_ref
*ref
, *part_ref
= NULL
;
5003 if (expr
->expr_type
== EXPR_FUNCTION
)
5004 return expr
->value
.function
.esym
5005 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
5006 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5009 if (!permit_element
&& expr
->rank
== 0)
5012 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5015 return false; /* Array shall be last part-ref. */
5017 if (ref
->type
== REF_COMPONENT
)
5019 else if (ref
->type
== REF_SUBSTRING
)
5021 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5025 sym
= expr
->symtree
->n
.sym
;
5026 if (expr
->ts
.type
!= BT_CLASS
5028 && !part_ref
->u
.c
.component
->attr
.contiguous
5029 && part_ref
->u
.c
.component
->attr
.pointer
)
5031 && !sym
->attr
.contiguous
5032 && (sym
->attr
.pointer
5033 || sym
->as
->type
== AS_ASSUMED_RANK
5034 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
5037 if (!ar
|| ar
->type
== AR_FULL
)
5040 gcc_assert (ar
->type
== AR_SECTION
);
5042 /* Check for simply contiguous array */
5044 for (i
= 0; i
< ar
->dimen
; i
++)
5046 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5049 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5055 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5058 /* If the previous section was not contiguous, that's an error,
5059 unless we have effective only one element and checking is not
5061 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5062 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5063 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5064 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5065 ar
->end
[i
]->value
.integer
) != 0))
5068 /* Following the standard, "(::1)" or - if known at compile time -
5069 "(lbound:ubound)" are not simply contiguous; if strict
5070 is false, they are regarded as simply contiguous. */
5071 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5072 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5073 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5077 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5078 || !ar
->as
->lower
[i
]
5079 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5080 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5081 ar
->as
->lower
[i
]->value
.integer
) != 0))
5085 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5086 || !ar
->as
->upper
[i
]
5087 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5088 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5089 ar
->as
->upper
[i
]->value
.integer
) != 0))
5097 /* Build call to an intrinsic procedure. The number of arguments has to be
5098 passed (rather than ending the list with a NULL value) because we may
5099 want to add arguments but with a NULL-expression. */
5102 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5103 locus where
, unsigned numarg
, ...)
5106 gfc_actual_arglist
* atail
;
5107 gfc_intrinsic_sym
* isym
;
5110 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5112 isym
= gfc_intrinsic_function_by_id (id
);
5115 result
= gfc_get_expr ();
5116 result
->expr_type
= EXPR_FUNCTION
;
5117 result
->ts
= isym
->ts
;
5118 result
->where
= where
;
5119 result
->value
.function
.name
= mangled_name
;
5120 result
->value
.function
.isym
= isym
;
5122 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5123 gfc_commit_symbol (result
->symtree
->n
.sym
);
5124 gcc_assert (result
->symtree
5125 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5126 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5127 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5128 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5129 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5130 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5132 va_start (ap
, numarg
);
5134 for (i
= 0; i
< numarg
; ++i
)
5138 atail
->next
= gfc_get_actual_arglist ();
5139 atail
= atail
->next
;
5142 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5144 atail
->expr
= va_arg (ap
, gfc_expr
*);
5152 /* Check if an expression may appear in a variable definition context
5153 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5154 This is called from the various places when resolving
5155 the pieces that make up such a context.
5156 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5157 variables), some checks are not performed.
5159 Optionally, a possible error message can be suppressed if context is NULL
5160 and just the return status (true / false) be requested. */
5163 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5164 bool own_scope
, const char* context
)
5166 gfc_symbol
* sym
= NULL
;
5168 bool check_intentin
;
5170 symbol_attribute attr
;
5174 if (e
->expr_type
== EXPR_VARIABLE
)
5176 gcc_assert (e
->symtree
);
5177 sym
= e
->symtree
->n
.sym
;
5179 else if (e
->expr_type
== EXPR_FUNCTION
)
5181 gcc_assert (e
->symtree
);
5182 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5185 attr
= gfc_expr_attr (e
);
5186 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5188 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5191 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5192 " context (%s) at %L", context
, &e
->where
);
5196 else if (e
->expr_type
!= EXPR_VARIABLE
)
5199 gfc_error ("Non-variable expression in variable definition context (%s)"
5200 " at %L", context
, &e
->where
);
5204 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
5207 gfc_error ("Named constant %qs in variable definition context (%s)"
5208 " at %L", sym
->name
, context
, &e
->where
);
5211 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
5212 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
5213 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5216 gfc_error ("%qs in variable definition context (%s) at %L is not"
5217 " a variable", sym
->name
, context
, &e
->where
);
5221 /* Find out whether the expr is a pointer; this also means following
5222 component references to the last one. */
5223 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
5224 if (pointer
&& !is_pointer
)
5227 gfc_error ("Non-POINTER in pointer association context (%s)"
5228 " at %L", context
, &e
->where
);
5232 if (e
->ts
.type
== BT_DERIVED
5233 && e
->ts
.u
.derived
== NULL
)
5236 gfc_error ("Type inaccessible in variable definition context (%s) "
5237 "at %L", context
, &e
->where
);
5244 || (e
->ts
.type
== BT_DERIVED
5245 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5246 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
5249 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5250 context
, &e
->where
);
5254 /* TS18508, C702/C203. */
5257 || (e
->ts
.type
== BT_DERIVED
5258 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5259 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
5262 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5263 context
, &e
->where
);
5267 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5268 component of sub-component of a pointer; we need to distinguish
5269 assignment to a pointer component from pointer-assignment to a pointer
5270 component. Note that (normal) assignment to procedure pointers is not
5272 check_intentin
= !own_scope
;
5273 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5274 && CLASS_DATA (sym
))
5275 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
5276 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
5278 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
5279 check_intentin
= false;
5280 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
5282 ptr_component
= true;
5284 check_intentin
= false;
5287 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
5289 if (pointer
&& is_pointer
)
5292 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5293 " association context (%s) at %L",
5294 sym
->name
, context
, &e
->where
);
5297 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
5300 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5301 " definition context (%s) at %L",
5302 sym
->name
, context
, &e
->where
);
5307 /* PROTECTED and use-associated. */
5308 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
5310 if (pointer
&& is_pointer
)
5313 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5314 " pointer association context (%s) at %L",
5315 sym
->name
, context
, &e
->where
);
5318 if (!pointer
&& !is_pointer
)
5321 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5322 " variable definition context (%s) at %L",
5323 sym
->name
, context
, &e
->where
);
5328 /* Variable not assignable from a PURE procedure but appears in
5329 variable definition context. */
5330 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
5333 gfc_error ("Variable %qs can not appear in a variable definition"
5334 " context (%s) at %L in PURE procedure",
5335 sym
->name
, context
, &e
->where
);
5339 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
5340 && gfc_impure_variable (sym
))
5345 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5347 sym
= ns
->proc_name
;
5350 if (sym
->attr
.flavor
== FL_PROCEDURE
)
5352 sym
->attr
.implicit_pure
= 0;
5357 /* Check variable definition context for associate-names. */
5358 if (!pointer
&& sym
->assoc
)
5361 gfc_association_list
* assoc
;
5363 gcc_assert (sym
->assoc
->target
);
5365 /* If this is a SELECT TYPE temporary (the association is used internally
5366 for SELECT TYPE), silently go over to the target. */
5367 if (sym
->attr
.select_type_temporary
)
5369 gfc_expr
* t
= sym
->assoc
->target
;
5371 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
5372 name
= t
->symtree
->name
;
5374 if (t
->symtree
->n
.sym
->assoc
)
5375 assoc
= t
->symtree
->n
.sym
->assoc
;
5384 gcc_assert (name
&& assoc
);
5386 /* Is association to a valid variable? */
5387 if (!assoc
->variable
)
5391 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
5392 gfc_error ("%qs at %L associated to vector-indexed target can"
5393 " not be used in a variable definition context (%s)",
5394 name
, &e
->where
, context
);
5396 gfc_error ("%qs at %L associated to expression can"
5397 " not be used in a variable definition context (%s)",
5398 name
, &e
->where
, context
);
5403 /* Target must be allowed to appear in a variable definition context. */
5404 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
5407 gfc_error ("Associate-name %qs can not appear in a variable"
5408 " definition context (%s) at %L because its target"
5409 " at %L can not, either",
5410 name
, context
, &e
->where
,
5411 &assoc
->target
->where
);
5416 /* Check for same value in vector expression subscript. */
5419 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
5420 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5421 for (i
= 0; i
< GFC_MAX_DIMENSIONS
5422 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
5423 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5425 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
5426 if (arr
->expr_type
== EXPR_ARRAY
)
5428 gfc_constructor
*c
, *n
;
5431 for (c
= gfc_constructor_first (arr
->value
.constructor
);
5432 c
!= NULL
; c
= gfc_constructor_next (c
))
5434 if (c
== NULL
|| c
->iterator
!= NULL
)
5439 for (n
= gfc_constructor_next (c
); n
!= NULL
;
5440 n
= gfc_constructor_next (n
))
5442 if (n
->iterator
!= NULL
)
5446 if (gfc_dep_compare_expr (ec
, en
) == 0)
5449 gfc_error_now ("Elements with the same value "
5450 "at %L and %L in vector "
5451 "subscript in a variable "
5452 "definition context (%s)",
5453 &(ec
->where
), &(en
->where
),