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
= NULL
;
800 p
->value
.function
.actual
= gfc_get_actual_arglist ();
801 p
->value
.function
.actual
->expr
= e
;
807 /* Given an expression node with some sort of numeric binary
808 expression, insert type conversions required to make the operands
809 have the same type. Conversion warnings are disabled if wconversion
812 The exception is that the operands of an exponential don't have to
813 have the same type. If possible, the base is promoted to the type
814 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
815 1.0**2 stays as it is. */
818 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
822 op1
= e
->value
.op
.op1
;
823 op2
= e
->value
.op
.op2
;
825 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
827 gfc_clear_ts (&e
->ts
);
831 /* Kind conversions of same type. */
832 if (op1
->ts
.type
== op2
->ts
.type
)
834 if (op1
->ts
.kind
== op2
->ts
.kind
)
836 /* No type conversions. */
841 if (op1
->ts
.kind
> op2
->ts
.kind
)
842 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
844 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
850 /* Integer combined with real or complex. */
851 if (op2
->ts
.type
== BT_INTEGER
)
855 /* Special case for ** operator. */
856 if (e
->value
.op
.op
== INTRINSIC_POWER
)
859 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
863 if (op1
->ts
.type
== BT_INTEGER
)
866 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
870 /* Real combined with complex. */
871 e
->ts
.type
= BT_COMPLEX
;
872 if (op1
->ts
.kind
> op2
->ts
.kind
)
873 e
->ts
.kind
= op1
->ts
.kind
;
875 e
->ts
.kind
= op2
->ts
.kind
;
876 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
877 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
878 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
879 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
886 /* Function to determine if an expression is constant or not. This
887 function expects that the expression has already been simplified. */
890 gfc_is_constant_expr (gfc_expr
*e
)
893 gfc_actual_arglist
*arg
;
899 switch (e
->expr_type
)
902 return (gfc_is_constant_expr (e
->value
.op
.op1
)
903 && (e
->value
.op
.op2
== NULL
904 || gfc_is_constant_expr (e
->value
.op
.op2
)));
912 gcc_assert (e
->symtree
|| e
->value
.function
.esym
913 || e
->value
.function
.isym
);
915 /* Call to intrinsic with at least one argument. */
916 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
918 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
919 if (!gfc_is_constant_expr (arg
->expr
))
923 /* Specification functions are constant. */
924 /* F95, 7.1.6.2; F2003, 7.1.7 */
927 sym
= e
->symtree
->n
.sym
;
928 if (e
->value
.function
.esym
)
929 sym
= e
->value
.function
.esym
;
932 && sym
->attr
.function
934 && !sym
->attr
.intrinsic
935 && !sym
->attr
.recursive
936 && sym
->attr
.proc
!= PROC_INTERNAL
937 && sym
->attr
.proc
!= PROC_ST_FUNCTION
938 && sym
->attr
.proc
!= PROC_UNKNOWN
939 && gfc_sym_get_dummy_args (sym
) == NULL
)
942 if (e
->value
.function
.isym
943 && (e
->value
.function
.isym
->elemental
944 || e
->value
.function
.isym
->pure
945 || e
->value
.function
.isym
->inquiry
946 || e
->value
.function
.isym
->transformational
))
956 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
957 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
961 c
= gfc_constructor_first (e
->value
.constructor
);
962 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
963 return gfc_constant_ac (e
);
965 for (; c
; c
= gfc_constructor_next (c
))
966 if (!gfc_is_constant_expr (c
->expr
))
973 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
979 /* Is true if an array reference is followed by a component or substring
982 is_subref_array (gfc_expr
* e
)
987 if (e
->expr_type
!= EXPR_VARIABLE
)
990 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
994 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
996 if (ref
->type
== REF_ARRAY
997 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1001 && ref
->type
!= REF_ARRAY
)
1008 /* Try to collapse intrinsic expressions. */
1011 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1013 gfc_intrinsic_op op
;
1014 gfc_expr
*op1
, *op2
, *result
;
1016 if (p
->value
.op
.op
== INTRINSIC_USER
)
1019 op1
= p
->value
.op
.op1
;
1020 op2
= p
->value
.op
.op2
;
1021 op
= p
->value
.op
.op
;
1023 if (!gfc_simplify_expr (op1
, type
))
1025 if (!gfc_simplify_expr (op2
, type
))
1028 if (!gfc_is_constant_expr (op1
)
1029 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1033 p
->value
.op
.op1
= NULL
;
1034 p
->value
.op
.op2
= NULL
;
1038 case INTRINSIC_PARENTHESES
:
1039 result
= gfc_parentheses (op1
);
1042 case INTRINSIC_UPLUS
:
1043 result
= gfc_uplus (op1
);
1046 case INTRINSIC_UMINUS
:
1047 result
= gfc_uminus (op1
);
1050 case INTRINSIC_PLUS
:
1051 result
= gfc_add (op1
, op2
);
1054 case INTRINSIC_MINUS
:
1055 result
= gfc_subtract (op1
, op2
);
1058 case INTRINSIC_TIMES
:
1059 result
= gfc_multiply (op1
, op2
);
1062 case INTRINSIC_DIVIDE
:
1063 result
= gfc_divide (op1
, op2
);
1066 case INTRINSIC_POWER
:
1067 result
= gfc_power (op1
, op2
);
1070 case INTRINSIC_CONCAT
:
1071 result
= gfc_concat (op1
, op2
);
1075 case INTRINSIC_EQ_OS
:
1076 result
= gfc_eq (op1
, op2
, op
);
1080 case INTRINSIC_NE_OS
:
1081 result
= gfc_ne (op1
, op2
, op
);
1085 case INTRINSIC_GT_OS
:
1086 result
= gfc_gt (op1
, op2
, op
);
1090 case INTRINSIC_GE_OS
:
1091 result
= gfc_ge (op1
, op2
, op
);
1095 case INTRINSIC_LT_OS
:
1096 result
= gfc_lt (op1
, op2
, op
);
1100 case INTRINSIC_LE_OS
:
1101 result
= gfc_le (op1
, op2
, op
);
1105 result
= gfc_not (op1
);
1109 result
= gfc_and (op1
, op2
);
1113 result
= gfc_or (op1
, op2
);
1117 result
= gfc_eqv (op1
, op2
);
1120 case INTRINSIC_NEQV
:
1121 result
= gfc_neqv (op1
, op2
);
1125 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1130 gfc_free_expr (op1
);
1131 gfc_free_expr (op2
);
1135 result
->rank
= p
->rank
;
1136 result
->where
= p
->where
;
1137 gfc_replace_expr (p
, result
);
1143 /* Subroutine to simplify constructor expressions. Mutually recursive
1144 with gfc_simplify_expr(). */
1147 simplify_constructor (gfc_constructor_base base
, int type
)
1152 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1155 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1156 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1157 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1162 /* Try and simplify a copy. Replace the original if successful
1163 but keep going through the constructor at all costs. Not
1164 doing so can make a dog's dinner of complicated things. */
1165 p
= gfc_copy_expr (c
->expr
);
1167 if (!gfc_simplify_expr (p
, type
))
1173 gfc_replace_expr (c
->expr
, p
);
1181 /* Pull a single array element out of an array constructor. */
1184 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1185 gfc_constructor
**rval
)
1187 unsigned long nelemen
;
1193 gfc_constructor
*cons
;
1200 mpz_init_set_ui (offset
, 0);
1203 mpz_init_set_ui (span
, 1);
1204 for (i
= 0; i
< ar
->dimen
; i
++)
1206 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1207 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1215 if (e
->expr_type
!= EXPR_CONSTANT
)
1221 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1222 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1224 /* Check the bounds. */
1225 if ((ar
->as
->upper
[i
]
1226 && mpz_cmp (e
->value
.integer
,
1227 ar
->as
->upper
[i
]->value
.integer
) > 0)
1228 || (mpz_cmp (e
->value
.integer
,
1229 ar
->as
->lower
[i
]->value
.integer
) < 0))
1231 gfc_error ("Index in dimension %d is out of bounds "
1232 "at %L", i
+ 1, &ar
->c_where
[i
]);
1238 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1239 mpz_mul (delta
, delta
, span
);
1240 mpz_add (offset
, offset
, delta
);
1242 mpz_set_ui (tmp
, 1);
1243 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1244 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1245 mpz_mul (span
, span
, tmp
);
1248 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1249 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1268 /* Find a component of a structure constructor. */
1270 static gfc_constructor
*
1271 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1273 gfc_component
*pick
= ref
->u
.c
.component
;
1274 gfc_constructor
*c
= gfc_constructor_first (base
);
1276 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1277 int ext
= dt
->attr
.extension
;
1279 /* For extended types, check if the desired component is in one of the
1281 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1282 pick
->name
, true, true, NULL
))
1284 dt
= dt
->components
->ts
.u
.derived
;
1285 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1289 gfc_component
*comp
= dt
->components
;
1290 while (comp
!= pick
)
1293 c
= gfc_constructor_next (c
);
1300 /* Replace an expression with the contents of a constructor, removing
1301 the subobject reference in the process. */
1304 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1314 e
= gfc_copy_expr (p
);
1315 e
->ref
= p
->ref
->next
;
1316 p
->ref
->next
= NULL
;
1317 gfc_replace_expr (p
, e
);
1321 /* Pull an array section out of an array constructor. */
1324 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1331 long unsigned one
= 1;
1333 mpz_t start
[GFC_MAX_DIMENSIONS
];
1334 mpz_t end
[GFC_MAX_DIMENSIONS
];
1335 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1336 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1337 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1342 gfc_constructor_base base
;
1343 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1353 base
= expr
->value
.constructor
;
1354 expr
->value
.constructor
= NULL
;
1356 rank
= ref
->u
.ar
.as
->rank
;
1358 if (expr
->shape
== NULL
)
1359 expr
->shape
= gfc_get_shape (rank
);
1361 mpz_init_set_ui (delta_mpz
, one
);
1362 mpz_init_set_ui (nelts
, one
);
1365 /* Do the initialization now, so that we can cleanup without
1366 keeping track of where we were. */
1367 for (d
= 0; d
< rank
; d
++)
1369 mpz_init (delta
[d
]);
1370 mpz_init (start
[d
]);
1373 mpz_init (stride
[d
]);
1377 /* Build the counters to clock through the array reference. */
1379 for (d
= 0; d
< rank
; d
++)
1381 /* Make this stretch of code easier on the eye! */
1382 begin
= ref
->u
.ar
.start
[d
];
1383 finish
= ref
->u
.ar
.end
[d
];
1384 step
= ref
->u
.ar
.stride
[d
];
1385 lower
= ref
->u
.ar
.as
->lower
[d
];
1386 upper
= ref
->u
.ar
.as
->upper
[d
];
1388 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1390 gfc_constructor
*ci
;
1393 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1399 gcc_assert (begin
->rank
== 1);
1400 /* Zero-sized arrays have no shape and no elements, stop early. */
1403 mpz_init_set_ui (nelts
, 0);
1407 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1408 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1409 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1410 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1413 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1415 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1416 || mpz_cmp (ci
->expr
->value
.integer
,
1417 lower
->value
.integer
) < 0)
1419 gfc_error ("index in dimension %d is out of bounds "
1420 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1428 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1429 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1430 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1436 /* Obtain the stride. */
1438 mpz_set (stride
[d
], step
->value
.integer
);
1440 mpz_set_ui (stride
[d
], one
);
1442 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1443 mpz_set_ui (stride
[d
], one
);
1445 /* Obtain the start value for the index. */
1447 mpz_set (start
[d
], begin
->value
.integer
);
1449 mpz_set (start
[d
], lower
->value
.integer
);
1451 mpz_set (ctr
[d
], start
[d
]);
1453 /* Obtain the end value for the index. */
1455 mpz_set (end
[d
], finish
->value
.integer
);
1457 mpz_set (end
[d
], upper
->value
.integer
);
1459 /* Separate 'if' because elements sometimes arrive with
1461 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1462 mpz_set (end
[d
], begin
->value
.integer
);
1464 /* Check the bounds. */
1465 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1466 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1467 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1468 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1470 gfc_error ("index in dimension %d is out of bounds "
1471 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1476 /* Calculate the number of elements and the shape. */
1477 mpz_set (tmp_mpz
, stride
[d
]);
1478 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1479 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1480 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1481 mpz_mul (nelts
, nelts
, tmp_mpz
);
1483 /* An element reference reduces the rank of the expression; don't
1484 add anything to the shape array. */
1485 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1486 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1489 /* Calculate the 'stride' (=delta) for conversion of the
1490 counter values into the index along the constructor. */
1491 mpz_set (delta
[d
], delta_mpz
);
1492 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1493 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1494 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1498 cons
= gfc_constructor_first (base
);
1500 /* Now clock through the array reference, calculating the index in
1501 the source constructor and transferring the elements to the new
1503 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1505 mpz_init_set_ui (ptr
, 0);
1508 for (d
= 0; d
< rank
; d
++)
1510 mpz_set (tmp_mpz
, ctr
[d
]);
1511 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1512 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1513 mpz_add (ptr
, ptr
, tmp_mpz
);
1515 if (!incr_ctr
) continue;
1517 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1519 gcc_assert(vecsub
[d
]);
1521 if (!gfc_constructor_next (vecsub
[d
]))
1522 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1525 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1528 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1532 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1534 if (mpz_cmp_ui (stride
[d
], 0) > 0
1535 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1536 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1537 mpz_set (ctr
[d
], start
[d
]);
1543 limit
= mpz_get_ui (ptr
);
1544 if (limit
>= flag_max_array_constructor
)
1546 gfc_error ("The number of elements in the array constructor "
1547 "at %L requires an increase of the allowed %d "
1548 "upper limit. See -fmax-array-constructor "
1549 "option", &expr
->where
, flag_max_array_constructor
);
1553 cons
= gfc_constructor_lookup (base
, limit
);
1555 gfc_constructor_append_expr (&expr
->value
.constructor
,
1556 gfc_copy_expr (cons
->expr
), NULL
);
1563 mpz_clear (delta_mpz
);
1564 mpz_clear (tmp_mpz
);
1566 for (d
= 0; d
< rank
; d
++)
1568 mpz_clear (delta
[d
]);
1569 mpz_clear (start
[d
]);
1572 mpz_clear (stride
[d
]);
1574 gfc_constructor_free (base
);
1578 /* Pull a substring out of an expression. */
1581 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1588 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1589 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1592 *newp
= gfc_copy_expr (p
);
1593 free ((*newp
)->value
.character
.string
);
1595 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1596 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1597 length
= end
- start
+ 1;
1599 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1600 (*newp
)->value
.character
.length
= length
;
1601 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1602 length
* sizeof (gfc_char_t
));
1609 /* Simplify a subobject reference of a constructor. This occurs when
1610 parameter variable values are substituted. */
1613 simplify_const_ref (gfc_expr
*p
)
1615 gfc_constructor
*cons
, *c
;
1621 switch (p
->ref
->type
)
1624 switch (p
->ref
->u
.ar
.type
)
1627 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1628 will generate this. */
1629 if (p
->expr_type
!= EXPR_ARRAY
)
1631 remove_subobject_ref (p
, NULL
);
1634 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1640 remove_subobject_ref (p
, cons
);
1644 if (!find_array_section (p
, p
->ref
))
1646 p
->ref
->u
.ar
.type
= AR_FULL
;
1651 if (p
->ref
->next
!= NULL
1652 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1654 for (c
= gfc_constructor_first (p
->value
.constructor
);
1655 c
; c
= gfc_constructor_next (c
))
1657 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1658 if (!simplify_const_ref (c
->expr
))
1662 if (gfc_bt_struct (p
->ts
.type
)
1664 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1666 /* There may have been component references. */
1667 p
->ts
= c
->expr
->ts
;
1671 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1673 if (p
->ts
.type
== BT_CHARACTER
1674 && last_ref
->type
== REF_SUBSTRING
)
1676 /* If this is a CHARACTER array and we possibly took
1677 a substring out of it, update the type-spec's
1678 character length according to the first element
1679 (as all should have the same length). */
1681 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1683 const gfc_expr
* first
= c
->expr
;
1684 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1685 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1686 string_len
= first
->value
.character
.length
;
1692 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1695 gfc_free_expr (p
->ts
.u
.cl
->length
);
1698 = gfc_get_int_expr (gfc_default_integer_kind
,
1702 gfc_free_ref_list (p
->ref
);
1713 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1714 remove_subobject_ref (p
, cons
);
1718 if (!find_substring_ref (p
, &newp
))
1721 gfc_replace_expr (p
, newp
);
1722 gfc_free_ref_list (p
->ref
);
1732 /* Simplify a chain of references. */
1735 simplify_ref_chain (gfc_ref
*ref
, int type
)
1739 for (; ref
; ref
= ref
->next
)
1744 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1746 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1748 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1750 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1756 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1758 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1770 /* Try to substitute the value of a parameter variable. */
1773 simplify_parameter_variable (gfc_expr
*p
, int type
)
1778 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1784 /* Do not copy subobject refs for constant. */
1785 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1786 e
->ref
= gfc_copy_ref (p
->ref
);
1787 t
= gfc_simplify_expr (e
, type
);
1789 /* Only use the simplification if it eliminated all subobject references. */
1791 gfc_replace_expr (p
, e
);
1798 /* Given an expression, simplify it by collapsing constant
1799 expressions. Most simplification takes place when the expression
1800 tree is being constructed. If an intrinsic function is simplified
1801 at some point, we get called again to collapse the result against
1804 We work by recursively simplifying expression nodes, simplifying
1805 intrinsic functions where possible, which can lead to further
1806 constant collapsing. If an operator has constant operand(s), we
1807 rip the expression apart, and rebuild it, hoping that it becomes
1810 The expression type is defined for:
1811 0 Basic expression parsing
1812 1 Simplifying array constructors -- will substitute
1814 Returns false on error, true otherwise.
1815 NOTE: Will return true even if the expression can not be simplified. */
1818 gfc_simplify_expr (gfc_expr
*p
, int type
)
1820 gfc_actual_arglist
*ap
;
1825 switch (p
->expr_type
)
1832 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1833 if (!gfc_simplify_expr (ap
->expr
, type
))
1836 if (p
->value
.function
.isym
!= NULL
1837 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1842 case EXPR_SUBSTRING
:
1843 if (!simplify_ref_chain (p
->ref
, type
))
1846 if (gfc_is_constant_expr (p
))
1852 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1854 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1855 start
--; /* Convert from one-based to zero-based. */
1858 end
= p
->value
.character
.length
;
1859 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1860 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1865 s
= gfc_get_wide_string (end
- start
+ 2);
1866 memcpy (s
, p
->value
.character
.string
+ start
,
1867 (end
- start
) * sizeof (gfc_char_t
));
1868 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1869 free (p
->value
.character
.string
);
1870 p
->value
.character
.string
= s
;
1871 p
->value
.character
.length
= end
- start
;
1872 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1873 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1875 p
->value
.character
.length
);
1876 gfc_free_ref_list (p
->ref
);
1878 p
->expr_type
= EXPR_CONSTANT
;
1883 if (!simplify_intrinsic_op (p
, type
))
1888 /* Only substitute array parameter variables if we are in an
1889 initialization expression, or we want a subsection. */
1890 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1891 && (gfc_init_expr_flag
|| p
->ref
1892 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1894 if (!simplify_parameter_variable (p
, type
))
1901 gfc_simplify_iterator_var (p
);
1904 /* Simplify subcomponent references. */
1905 if (!simplify_ref_chain (p
->ref
, type
))
1910 case EXPR_STRUCTURE
:
1912 if (!simplify_ref_chain (p
->ref
, type
))
1915 if (!simplify_constructor (p
->value
.constructor
, type
))
1918 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1919 && p
->ref
->u
.ar
.type
== AR_FULL
)
1920 gfc_expand_constructor (p
, false);
1922 if (!simplify_const_ref (p
))
1936 /* Returns the type of an expression with the exception that iterator
1937 variables are automatically integers no matter what else they may
1943 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
1950 /* Scalarize an expression for an elemental intrinsic call. */
1953 scalarize_intrinsic_call (gfc_expr
*e
)
1955 gfc_actual_arglist
*a
, *b
;
1956 gfc_constructor_base ctor
;
1957 gfc_constructor
*args
[5];
1958 gfc_constructor
*ci
, *new_ctor
;
1959 gfc_expr
*expr
, *old
;
1960 int n
, i
, rank
[5], array_arg
;
1962 /* Find which, if any, arguments are arrays. Assume that the old
1963 expression carries the type information and that the first arg
1964 that is an array expression carries all the shape information.*/
1966 a
= e
->value
.function
.actual
;
1967 for (; a
; a
= a
->next
)
1970 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
1973 expr
= gfc_copy_expr (a
->expr
);
1980 old
= gfc_copy_expr (e
);
1982 gfc_constructor_free (expr
->value
.constructor
);
1983 expr
->value
.constructor
= NULL
;
1985 expr
->where
= old
->where
;
1986 expr
->expr_type
= EXPR_ARRAY
;
1988 /* Copy the array argument constructors into an array, with nulls
1991 a
= old
->value
.function
.actual
;
1992 for (; a
; a
= a
->next
)
1994 /* Check that this is OK for an initialization expression. */
1995 if (a
->expr
&& !gfc_check_init_expr (a
->expr
))
1999 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2001 rank
[n
] = a
->expr
->rank
;
2002 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2003 args
[n
] = gfc_constructor_first (ctor
);
2005 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2008 rank
[n
] = a
->expr
->rank
;
2011 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2012 args
[n
] = gfc_constructor_first (ctor
);
2021 /* Using the array argument as the master, step through the array
2022 calling the function for each element and advancing the array
2023 constructors together. */
2024 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2026 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2027 gfc_copy_expr (old
), NULL
);
2029 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2031 b
= old
->value
.function
.actual
;
2032 for (i
= 0; i
< n
; i
++)
2035 new_ctor
->expr
->value
.function
.actual
2036 = a
= gfc_get_actual_arglist ();
2039 a
->next
= gfc_get_actual_arglist ();
2044 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2046 a
->expr
= gfc_copy_expr (b
->expr
);
2051 /* Simplify the function calls. If the simplification fails, the
2052 error will be flagged up down-stream or the library will deal
2054 gfc_simplify_expr (new_ctor
->expr
, 0);
2056 for (i
= 0; i
< n
; i
++)
2058 args
[i
] = gfc_constructor_next (args
[i
]);
2060 for (i
= 1; i
< n
; i
++)
2061 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2062 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2068 /* Free "expr" but not the pointers it contains. */
2070 gfc_free_expr (old
);
2074 gfc_error_now ("elemental function arguments at %C are not compliant");
2077 gfc_free_expr (expr
);
2078 gfc_free_expr (old
);
2084 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2086 gfc_expr
*op1
= e
->value
.op
.op1
;
2087 gfc_expr
*op2
= e
->value
.op
.op2
;
2089 if (!(*check_function
)(op1
))
2092 switch (e
->value
.op
.op
)
2094 case INTRINSIC_UPLUS
:
2095 case INTRINSIC_UMINUS
:
2096 if (!numeric_type (et0 (op1
)))
2101 case INTRINSIC_EQ_OS
:
2103 case INTRINSIC_NE_OS
:
2105 case INTRINSIC_GT_OS
:
2107 case INTRINSIC_GE_OS
:
2109 case INTRINSIC_LT_OS
:
2111 case INTRINSIC_LE_OS
:
2112 if (!(*check_function
)(op2
))
2115 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2116 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2118 gfc_error ("Numeric or CHARACTER operands are required in "
2119 "expression at %L", &e
->where
);
2124 case INTRINSIC_PLUS
:
2125 case INTRINSIC_MINUS
:
2126 case INTRINSIC_TIMES
:
2127 case INTRINSIC_DIVIDE
:
2128 case INTRINSIC_POWER
:
2129 if (!(*check_function
)(op2
))
2132 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2137 case INTRINSIC_CONCAT
:
2138 if (!(*check_function
)(op2
))
2141 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2143 gfc_error ("Concatenation operator in expression at %L "
2144 "must have two CHARACTER operands", &op1
->where
);
2148 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2150 gfc_error ("Concat operator at %L must concatenate strings of the "
2151 "same kind", &e
->where
);
2158 if (et0 (op1
) != BT_LOGICAL
)
2160 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2161 "operand", &op1
->where
);
2170 case INTRINSIC_NEQV
:
2171 if (!(*check_function
)(op2
))
2174 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2176 gfc_error ("LOGICAL operands are required in expression at %L",
2183 case INTRINSIC_PARENTHESES
:
2187 gfc_error ("Only intrinsic operators can be used in expression at %L",
2195 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2200 /* F2003, 7.1.7 (3): In init expression, allocatable components
2201 must not be data-initialized. */
2203 check_alloc_comp_init (gfc_expr
*e
)
2205 gfc_component
*comp
;
2206 gfc_constructor
*ctor
;
2208 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2209 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2211 for (comp
= e
->ts
.u
.derived
->components
,
2212 ctor
= gfc_constructor_first (e
->value
.constructor
);
2213 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2215 if (comp
->attr
.allocatable
&& ctor
->expr
2216 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2218 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2219 "component %qs in structure constructor at %L",
2220 comp
->name
, &ctor
->expr
->where
);
2229 check_init_expr_arguments (gfc_expr
*e
)
2231 gfc_actual_arglist
*ap
;
2233 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2234 if (!gfc_check_init_expr (ap
->expr
))
2240 static bool check_restricted (gfc_expr
*);
2242 /* F95, 7.1.6.1, Initialization expressions, (7)
2243 F2003, 7.1.7 Initialization expression, (8) */
2246 check_inquiry (gfc_expr
*e
, int not_restricted
)
2249 const char *const *functions
;
2251 static const char *const inquiry_func_f95
[] = {
2252 "lbound", "shape", "size", "ubound",
2253 "bit_size", "len", "kind",
2254 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2255 "precision", "radix", "range", "tiny",
2259 static const char *const inquiry_func_f2003
[] = {
2260 "lbound", "shape", "size", "ubound",
2261 "bit_size", "len", "kind",
2262 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2263 "precision", "radix", "range", "tiny",
2268 gfc_actual_arglist
*ap
;
2270 if (!e
->value
.function
.isym
2271 || !e
->value
.function
.isym
->inquiry
)
2274 /* An undeclared parameter will get us here (PR25018). */
2275 if (e
->symtree
== NULL
)
2278 if (e
->symtree
->n
.sym
->from_intmod
)
2280 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2281 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2282 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2285 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2286 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2291 name
= e
->symtree
->n
.sym
->name
;
2293 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2294 ? inquiry_func_f2003
: inquiry_func_f95
;
2296 for (i
= 0; functions
[i
]; i
++)
2297 if (strcmp (functions
[i
], name
) == 0)
2300 if (functions
[i
] == NULL
)
2304 /* At this point we have an inquiry function with a variable argument. The
2305 type of the variable might be undefined, but we need it now, because the
2306 arguments of these functions are not allowed to be undefined. */
2308 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2313 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2315 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2316 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2319 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2322 /* Assumed character length will not reduce to a constant expression
2323 with LEN, as required by the standard. */
2324 if (i
== 5 && not_restricted
2325 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2326 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2327 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2329 gfc_error ("Assumed or deferred character length variable %qs "
2330 " in constant expression at %L",
2331 ap
->expr
->symtree
->n
.sym
->name
,
2335 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2338 if (not_restricted
== 0
2339 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2340 && !check_restricted (ap
->expr
))
2343 if (not_restricted
== 0
2344 && ap
->expr
->expr_type
== EXPR_VARIABLE
2345 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2346 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2354 /* F95, 7.1.6.1, Initialization expressions, (5)
2355 F2003, 7.1.7 Initialization expression, (5) */
2358 check_transformational (gfc_expr
*e
)
2360 static const char * const trans_func_f95
[] = {
2361 "repeat", "reshape", "selected_int_kind",
2362 "selected_real_kind", "transfer", "trim", NULL
2365 static const char * const trans_func_f2003
[] = {
2366 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2367 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2368 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2369 "trim", "unpack", NULL
2374 const char *const *functions
;
2376 if (!e
->value
.function
.isym
2377 || !e
->value
.function
.isym
->transformational
)
2380 name
= e
->symtree
->n
.sym
->name
;
2382 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2383 ? trans_func_f2003
: trans_func_f95
;
2385 /* NULL() is dealt with below. */
2386 if (strcmp ("null", name
) == 0)
2389 for (i
= 0; functions
[i
]; i
++)
2390 if (strcmp (functions
[i
], name
) == 0)
2393 if (functions
[i
] == NULL
)
2395 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2396 "in an initialization expression", name
, &e
->where
);
2400 return check_init_expr_arguments (e
);
2404 /* F95, 7.1.6.1, Initialization expressions, (6)
2405 F2003, 7.1.7 Initialization expression, (6) */
2408 check_null (gfc_expr
*e
)
2410 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2413 return check_init_expr_arguments (e
);
2418 check_elemental (gfc_expr
*e
)
2420 if (!e
->value
.function
.isym
2421 || !e
->value
.function
.isym
->elemental
)
2424 if (e
->ts
.type
!= BT_INTEGER
2425 && e
->ts
.type
!= BT_CHARACTER
2426 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2427 "initialization expression at %L", &e
->where
))
2430 return check_init_expr_arguments (e
);
2435 check_conversion (gfc_expr
*e
)
2437 if (!e
->value
.function
.isym
2438 || !e
->value
.function
.isym
->conversion
)
2441 return check_init_expr_arguments (e
);
2445 /* Verify that an expression is an initialization expression. A side
2446 effect is that the expression tree is reduced to a single constant
2447 node if all goes well. This would normally happen when the
2448 expression is constructed but function references are assumed to be
2449 intrinsics in the context of initialization expressions. If
2450 false is returned an error message has been generated. */
2453 gfc_check_init_expr (gfc_expr
*e
)
2461 switch (e
->expr_type
)
2464 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2466 t
= gfc_simplify_expr (e
, 0);
2475 gfc_intrinsic_sym
* isym
= NULL
;
2476 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2478 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2479 IEEE_EXCEPTIONS modules. */
2480 int mod
= sym
->from_intmod
;
2481 if (mod
== INTMOD_NONE
&& sym
->generic
)
2482 mod
= sym
->generic
->sym
->from_intmod
;
2483 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2485 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2488 gfc_replace_expr (e
, new_expr
);
2494 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2495 into an array constructor, we need to skip the error check here.
2496 Conversion errors are caught below in scalarize_intrinsic_call. */
2497 conversion
= e
->value
.function
.isym
2498 && (e
->value
.function
.isym
->conversion
== 1);
2500 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2501 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2503 gfc_error ("Function %qs in initialization expression at %L "
2504 "must be an intrinsic function",
2505 e
->symtree
->n
.sym
->name
, &e
->where
);
2509 if ((m
= check_conversion (e
)) == MATCH_NO
2510 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2511 && (m
= check_null (e
)) == MATCH_NO
2512 && (m
= check_transformational (e
)) == MATCH_NO
2513 && (m
= check_elemental (e
)) == MATCH_NO
)
2515 gfc_error ("Intrinsic function %qs at %L is not permitted "
2516 "in an initialization expression",
2517 e
->symtree
->n
.sym
->name
, &e
->where
);
2521 if (m
== MATCH_ERROR
)
2524 /* Try to scalarize an elemental intrinsic function that has an
2526 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2527 if (isym
&& isym
->elemental
2528 && (t
= scalarize_intrinsic_call (e
)))
2533 t
= gfc_simplify_expr (e
, 0);
2540 if (gfc_check_iter_variable (e
))
2543 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2545 /* A PARAMETER shall not be used to define itself, i.e.
2546 REAL, PARAMETER :: x = transfer(0, x)
2548 if (!e
->symtree
->n
.sym
->value
)
2550 gfc_error ("PARAMETER %qs is used at %L before its definition "
2551 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2555 t
= simplify_parameter_variable (e
, 0);
2560 if (gfc_in_match_data ())
2565 if (e
->symtree
->n
.sym
->as
)
2567 switch (e
->symtree
->n
.sym
->as
->type
)
2569 case AS_ASSUMED_SIZE
:
2570 gfc_error ("Assumed size array %qs at %L is not permitted "
2571 "in an initialization expression",
2572 e
->symtree
->n
.sym
->name
, &e
->where
);
2575 case AS_ASSUMED_SHAPE
:
2576 gfc_error ("Assumed shape array %qs at %L is not permitted "
2577 "in an initialization expression",
2578 e
->symtree
->n
.sym
->name
, &e
->where
);
2582 gfc_error ("Deferred array %qs at %L is not permitted "
2583 "in an initialization expression",
2584 e
->symtree
->n
.sym
->name
, &e
->where
);
2588 gfc_error ("Array %qs at %L is a variable, which does "
2589 "not reduce to a constant expression",
2590 e
->symtree
->n
.sym
->name
, &e
->where
);
2598 gfc_error ("Parameter %qs at %L has not been declared or is "
2599 "a variable, which does not reduce to a constant "
2600 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2609 case EXPR_SUBSTRING
:
2612 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2616 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2618 t
= gfc_simplify_expr (e
, 0);
2624 case EXPR_STRUCTURE
:
2625 t
= e
->ts
.is_iso_c
? true : false;
2629 t
= check_alloc_comp_init (e
);
2633 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2640 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2644 t
= gfc_expand_constructor (e
, true);
2648 t
= gfc_check_constructor_type (e
);
2652 gfc_internal_error ("check_init_expr(): Unknown expression type");
2658 /* Reduces a general expression to an initialization expression (a constant).
2659 This used to be part of gfc_match_init_expr.
2660 Note that this function doesn't free the given expression on false. */
2663 gfc_reduce_init_expr (gfc_expr
*expr
)
2667 gfc_init_expr_flag
= true;
2668 t
= gfc_resolve_expr (expr
);
2670 t
= gfc_check_init_expr (expr
);
2671 gfc_init_expr_flag
= false;
2676 if (expr
->expr_type
== EXPR_ARRAY
)
2678 if (!gfc_check_constructor_type (expr
))
2680 if (!gfc_expand_constructor (expr
, true))
2688 /* Match an initialization expression. We work by first matching an
2689 expression, then reducing it to a constant. */
2692 gfc_match_init_expr (gfc_expr
**result
)
2700 gfc_init_expr_flag
= true;
2702 m
= gfc_match_expr (&expr
);
2705 gfc_init_expr_flag
= false;
2709 t
= gfc_reduce_init_expr (expr
);
2712 gfc_free_expr (expr
);
2713 gfc_init_expr_flag
= false;
2718 gfc_init_expr_flag
= false;
2724 /* Given an actual argument list, test to see that each argument is a
2725 restricted expression and optionally if the expression type is
2726 integer or character. */
2729 restricted_args (gfc_actual_arglist
*a
)
2731 for (; a
; a
= a
->next
)
2733 if (!check_restricted (a
->expr
))
2741 /************* Restricted/specification expressions *************/
2744 /* Make sure a non-intrinsic function is a specification function. */
2747 external_spec_function (gfc_expr
*e
)
2751 f
= e
->value
.function
.esym
;
2753 /* IEEE functions allowed are "a reference to a transformational function
2754 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
2755 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
2756 IEEE_EXCEPTIONS". */
2757 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
2758 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
2760 if (!strcmp (f
->name
, "ieee_selected_real_kind")
2761 || !strcmp (f
->name
, "ieee_support_rounding")
2762 || !strcmp (f
->name
, "ieee_support_flag")
2763 || !strcmp (f
->name
, "ieee_support_halting")
2764 || !strcmp (f
->name
, "ieee_support_datatype")
2765 || !strcmp (f
->name
, "ieee_support_denormal")
2766 || !strcmp (f
->name
, "ieee_support_divide")
2767 || !strcmp (f
->name
, "ieee_support_inf")
2768 || !strcmp (f
->name
, "ieee_support_io")
2769 || !strcmp (f
->name
, "ieee_support_nan")
2770 || !strcmp (f
->name
, "ieee_support_sqrt")
2771 || !strcmp (f
->name
, "ieee_support_standard")
2772 || !strcmp (f
->name
, "ieee_support_underflow_control"))
2773 goto function_allowed
;
2776 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2778 gfc_error ("Specification function %qs at %L cannot be a statement "
2779 "function", f
->name
, &e
->where
);
2783 if (f
->attr
.proc
== PROC_INTERNAL
)
2785 gfc_error ("Specification function %qs at %L cannot be an internal "
2786 "function", f
->name
, &e
->where
);
2790 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2792 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
2798 if (f
->attr
.recursive
2799 && !gfc_notify_std (GFC_STD_F2003
,
2800 "Specification function '%s' "
2801 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
2805 return restricted_args (e
->value
.function
.actual
);
2809 /* Check to see that a function reference to an intrinsic is a
2810 restricted expression. */
2813 restricted_intrinsic (gfc_expr
*e
)
2815 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2816 if (check_inquiry (e
, 0) == MATCH_YES
)
2819 return restricted_args (e
->value
.function
.actual
);
2823 /* Check the expressions of an actual arglist. Used by check_restricted. */
2826 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
2828 for (; arg
; arg
= arg
->next
)
2829 if (!checker (arg
->expr
))
2836 /* Check the subscription expressions of a reference chain with a checking
2837 function; used by check_restricted. */
2840 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
2850 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2852 if (!checker (ref
->u
.ar
.start
[dim
]))
2854 if (!checker (ref
->u
.ar
.end
[dim
]))
2856 if (!checker (ref
->u
.ar
.stride
[dim
]))
2862 /* Nothing needed, just proceed to next reference. */
2866 if (!checker (ref
->u
.ss
.start
))
2868 if (!checker (ref
->u
.ss
.end
))
2877 return check_references (ref
->next
, checker
);
2880 /* Return true if ns is a parent of the current ns. */
2883 is_parent_of_current_ns (gfc_namespace
*ns
)
2886 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
2893 /* Verify that an expression is a restricted expression. Like its
2894 cousin check_init_expr(), an error message is generated if we
2898 check_restricted (gfc_expr
*e
)
2906 switch (e
->expr_type
)
2909 t
= check_intrinsic_op (e
, check_restricted
);
2911 t
= gfc_simplify_expr (e
, 0);
2916 if (e
->value
.function
.esym
)
2918 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2920 t
= external_spec_function (e
);
2924 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2927 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2930 t
= restricted_intrinsic (e
);
2935 sym
= e
->symtree
->n
.sym
;
2938 /* If a dummy argument appears in a context that is valid for a
2939 restricted expression in an elemental procedure, it will have
2940 already been simplified away once we get here. Therefore we
2941 don't need to jump through hoops to distinguish valid from
2943 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2944 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2946 gfc_error ("Dummy argument %qs not allowed in expression at %L",
2947 sym
->name
, &e
->where
);
2951 if (sym
->attr
.optional
)
2953 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
2954 sym
->name
, &e
->where
);
2958 if (sym
->attr
.intent
== INTENT_OUT
)
2960 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
2961 sym
->name
, &e
->where
);
2965 /* Check reference chain if any. */
2966 if (!check_references (e
->ref
, &check_restricted
))
2969 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2970 processed in resolve.c(resolve_formal_arglist). This is done so
2971 that host associated dummy array indices are accepted (PR23446).
2972 This mechanism also does the same for the specification expressions
2973 of array-valued functions. */
2975 || sym
->attr
.in_common
2976 || sym
->attr
.use_assoc
2978 || sym
->attr
.implied_index
2979 || sym
->attr
.flavor
== FL_PARAMETER
2980 || is_parent_of_current_ns (sym
->ns
)
2981 || (sym
->ns
->proc_name
!= NULL
2982 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2983 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2989 gfc_error ("Variable %qs cannot appear in the expression at %L",
2990 sym
->name
, &e
->where
);
2991 /* Prevent a repetition of the error. */
3000 case EXPR_SUBSTRING
:
3001 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3005 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3007 t
= gfc_simplify_expr (e
, 0);
3011 case EXPR_STRUCTURE
:
3012 t
= gfc_check_constructor (e
, check_restricted
);
3016 t
= gfc_check_constructor (e
, check_restricted
);
3020 gfc_internal_error ("check_restricted(): Unknown expression type");
3027 /* Check to see that an expression is a specification expression. If
3028 we return false, an error has been generated. */
3031 gfc_specification_expr (gfc_expr
*e
)
3033 gfc_component
*comp
;
3038 if (e
->ts
.type
!= BT_INTEGER
)
3040 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3041 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3045 comp
= gfc_get_proc_ptr_comp (e
);
3046 if (e
->expr_type
== EXPR_FUNCTION
3047 && !e
->value
.function
.isym
3048 && !e
->value
.function
.esym
3049 && !gfc_pure (e
->symtree
->n
.sym
)
3050 && (!comp
|| !comp
->attr
.pure
))
3052 gfc_error ("Function %qs at %L must be PURE",
3053 e
->symtree
->n
.sym
->name
, &e
->where
);
3054 /* Prevent repeat error messages. */
3055 e
->symtree
->n
.sym
->attr
.pure
= 1;
3061 gfc_error ("Expression at %L must be scalar", &e
->where
);
3065 if (!gfc_simplify_expr (e
, 0))
3068 return check_restricted (e
);
3072 /************** Expression conformance checks. *************/
3074 /* Given two expressions, make sure that the arrays are conformable. */
3077 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3079 int op1_flag
, op2_flag
, d
;
3080 mpz_t op1_size
, op2_size
;
3086 if (op1
->rank
== 0 || op2
->rank
== 0)
3089 va_start (argp
, optype_msgid
);
3090 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3093 if (op1
->rank
!= op2
->rank
)
3095 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3096 op1
->rank
, op2
->rank
, &op1
->where
);
3102 for (d
= 0; d
< op1
->rank
; d
++)
3104 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3105 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3107 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3109 gfc_error ("Different shape for %s at %L on dimension %d "
3110 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3111 (int) mpz_get_si (op1_size
),
3112 (int) mpz_get_si (op2_size
));
3118 mpz_clear (op1_size
);
3120 mpz_clear (op2_size
);
3130 /* Given an assignable expression and an arbitrary expression, make
3131 sure that the assignment can take place. Only add a call to the intrinsic
3132 conversion routines, when allow_convert is set. When this assign is a
3133 coarray call, then the convert is done by the coarray routine implictly and
3134 adding the intrinsic conversion would do harm in most cases. */
3137 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3144 sym
= lvalue
->symtree
->n
.sym
;
3146 /* See if this is the component or subcomponent of a pointer. */
3147 has_pointer
= sym
->attr
.pointer
;
3148 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3149 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3155 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3156 variable local to a function subprogram. Its existence begins when
3157 execution of the function is initiated and ends when execution of the
3158 function is terminated...
3159 Therefore, the left hand side is no longer a variable, when it is: */
3160 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3161 && !sym
->attr
.external
)
3166 /* (i) Use associated; */
3167 if (sym
->attr
.use_assoc
)
3170 /* (ii) The assignment is in the main program; or */
3171 if (gfc_current_ns
->proc_name
3172 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3175 /* (iii) A module or internal procedure... */
3176 if (gfc_current_ns
->proc_name
3177 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3178 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3179 && gfc_current_ns
->parent
3180 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3181 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3182 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3184 /* ... that is not a function... */
3185 if (gfc_current_ns
->proc_name
3186 && !gfc_current_ns
->proc_name
->attr
.function
)
3189 /* ... or is not an entry and has a different name. */
3190 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3194 /* (iv) Host associated and not the function symbol or the
3195 parent result. This picks up sibling references, which
3196 cannot be entries. */
3197 if (!sym
->attr
.entry
3198 && sym
->ns
== gfc_current_ns
->parent
3199 && sym
!= gfc_current_ns
->proc_name
3200 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3205 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3210 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3212 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3213 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3217 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3219 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3224 if (rvalue
->expr_type
== EXPR_NULL
)
3226 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3227 && lvalue
->symtree
->n
.sym
->attr
.data
)
3231 gfc_error ("NULL appears on right-hand side in assignment at %L",
3237 /* This is possibly a typo: x = f() instead of x => f(). */
3239 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3240 gfc_warning (OPT_Wsurprising
,
3241 "POINTER-valued function appears on right-hand side of "
3242 "assignment at %L", &rvalue
->where
);
3244 /* Check size of array assignments. */
3245 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3246 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3249 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3250 && lvalue
->symtree
->n
.sym
->attr
.data
3251 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3252 "initialize non-integer variable %qs",
3253 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3255 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3256 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3257 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3261 /* Handle the case of a BOZ literal on the RHS. */
3262 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3265 if (warn_surprising
)
3266 gfc_warning (OPT_Wsurprising
,
3267 "BOZ literal at %L is bitwise transferred "
3268 "non-integer symbol %qs", &rvalue
->where
,
3269 lvalue
->symtree
->n
.sym
->name
);
3270 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3272 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3274 if (rc
== ARITH_UNDERFLOW
)
3275 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3276 ". This check can be disabled with the option "
3277 "%<-fno-range-check%>", &rvalue
->where
);
3278 else if (rc
== ARITH_OVERFLOW
)
3279 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3280 ". This check can be disabled with the option "
3281 "%<-fno-range-check%>", &rvalue
->where
);
3282 else if (rc
== ARITH_NAN
)
3283 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3284 ". This check can be disabled with the option "
3285 "%<-fno-range-check%>", &rvalue
->where
);
3290 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3293 /* Only DATA Statements come here. */
3296 /* Numeric can be converted to any other numeric. And Hollerith can be
3297 converted to any other type. */
3298 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3299 || rvalue
->ts
.type
== BT_HOLLERITH
)
3302 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3305 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3306 "conversion of %s to %s", &lvalue
->where
,
3307 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3312 /* Assignment is the only case where character variables of different
3313 kind values can be converted into one another. */
3314 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3316 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3317 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3325 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3329 /* Check that a pointer assignment is OK. We first check lvalue, and
3330 we only check rvalue if it's not an assignment to NULL() or a
3331 NULLIFY statement. */
3334 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3336 symbol_attribute attr
, lhs_attr
;
3338 bool is_pure
, is_implicit_pure
, rank_remap
;
3341 lhs_attr
= gfc_expr_attr (lvalue
);
3342 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3344 gfc_error ("Pointer assignment target is not a POINTER at %L",
3349 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3350 && !lhs_attr
.proc_pointer
)
3352 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3353 "l-value since it is a procedure",
3354 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3358 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3361 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3363 if (ref
->type
== REF_COMPONENT
)
3364 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3366 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3370 if (ref
->u
.ar
.type
== AR_FULL
)
3373 if (ref
->u
.ar
.type
!= AR_SECTION
)
3375 gfc_error ("Expected bounds specification for %qs at %L",
3376 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3380 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3381 "for %qs in pointer assignment at %L",
3382 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3385 /* When bounds are given, all lbounds are necessary and either all
3386 or none of the upper bounds; no strides are allowed. If the
3387 upper bounds are present, we may do rank remapping. */
3388 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3390 if (!ref
->u
.ar
.start
[dim
]
3391 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3393 gfc_error ("Lower bound has to be present at %L",
3397 if (ref
->u
.ar
.stride
[dim
])
3399 gfc_error ("Stride must not be present at %L",
3405 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3408 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3409 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3411 gfc_error ("Either all or none of the upper bounds"
3412 " must be specified at %L", &lvalue
->where
);
3420 is_pure
= gfc_pure (NULL
);
3421 is_implicit_pure
= gfc_implicit_pure (NULL
);
3423 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3424 kind, etc for lvalue and rvalue must match, and rvalue must be a
3425 pure variable if we're in a pure function. */
3426 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3429 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3430 if (lvalue
->expr_type
== EXPR_VARIABLE
3431 && gfc_is_coindexed (lvalue
))
3434 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3435 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3437 gfc_error ("Pointer object at %L shall not have a coindex",
3443 /* Checks on rvalue for procedure pointer assignments. */
3448 gfc_component
*comp1
, *comp2
;
3451 attr
= gfc_expr_attr (rvalue
);
3452 if (!((rvalue
->expr_type
== EXPR_NULL
)
3453 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3454 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3455 || (rvalue
->expr_type
== EXPR_VARIABLE
3456 && attr
.flavor
== FL_PROCEDURE
)))
3458 gfc_error ("Invalid procedure pointer assignment at %L",
3462 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3464 /* Check for intrinsics. */
3465 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3466 if (!sym
->attr
.intrinsic
3467 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3468 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3470 sym
->attr
.intrinsic
= 1;
3471 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3472 attr
= gfc_expr_attr (rvalue
);
3474 /* Check for result of embracing function. */
3475 if (sym
->attr
.function
&& sym
->result
== sym
)
3479 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3480 if (sym
== ns
->proc_name
)
3482 gfc_error ("Function result %qs is invalid as proc-target "
3483 "in procedure pointer assignment at %L",
3484 sym
->name
, &rvalue
->where
);
3491 gfc_error ("Abstract interface %qs is invalid "
3492 "in procedure pointer assignment at %L",
3493 rvalue
->symtree
->name
, &rvalue
->where
);
3496 /* Check for F08:C729. */
3497 if (attr
.flavor
== FL_PROCEDURE
)
3499 if (attr
.proc
== PROC_ST_FUNCTION
)
3501 gfc_error ("Statement function %qs is invalid "
3502 "in procedure pointer assignment at %L",
3503 rvalue
->symtree
->name
, &rvalue
->where
);
3506 if (attr
.proc
== PROC_INTERNAL
&&
3507 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3508 "is invalid in procedure pointer assignment "
3509 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3511 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3512 attr
.subroutine
) == 0)
3514 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3515 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3519 /* Check for F08:C730. */
3520 if (attr
.elemental
&& !attr
.intrinsic
)
3522 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3523 "in procedure pointer assignment at %L",
3524 rvalue
->symtree
->name
, &rvalue
->where
);
3528 /* Ensure that the calling convention is the same. As other attributes
3529 such as DLLEXPORT may differ, one explicitly only tests for the
3530 calling conventions. */
3531 if (rvalue
->expr_type
== EXPR_VARIABLE
3532 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3533 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3535 symbol_attribute calls
;
3538 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3539 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3540 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3542 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3543 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3545 gfc_error ("Mismatch in the procedure pointer assignment "
3546 "at %L: mismatch in the calling convention",
3552 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3554 s1
= comp1
->ts
.interface
;
3557 s1
= lvalue
->symtree
->n
.sym
;
3558 if (s1
->ts
.interface
)
3559 s1
= s1
->ts
.interface
;
3562 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3565 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3567 s2
= comp2
->ts
.interface
->result
;
3572 s2
= comp2
->ts
.interface
;
3576 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3578 if (rvalue
->value
.function
.esym
)
3579 s2
= rvalue
->value
.function
.esym
->result
;
3581 s2
= rvalue
->symtree
->n
.sym
->result
;
3587 s2
= rvalue
->symtree
->n
.sym
;
3591 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3592 s2
= s2
->ts
.interface
;
3594 /* Special check for the case of absent interface on the lvalue.
3595 * All other interface checks are done below. */
3596 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
3598 gfc_error ("Interface mismatch in procedure pointer assignment "
3599 "at %L: '%s' is not a subroutine", &rvalue
->where
, name
);
3603 if (s1
== s2
|| !s1
|| !s2
)
3606 /* F08:7.2.2.4 (4) */
3607 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
3608 && gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3610 gfc_error ("Explicit interface required for %qs at %L: %s",
3611 s1
->name
, &lvalue
->where
, err
);
3614 if (s2
->attr
.if_source
== IFSRC_UNKNOWN
3615 && gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3617 gfc_error ("Explicit interface required for %qs at %L: %s",
3618 s2
->name
, &rvalue
->where
, err
);
3622 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3623 err
, sizeof(err
), NULL
, NULL
))
3625 gfc_error ("Interface mismatch in procedure pointer assignment "
3626 "at %L: %s", &rvalue
->where
, err
);
3630 /* Check F2008Cor2, C729. */
3631 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
3632 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
3634 gfc_error ("Procedure pointer target %qs at %L must be either an "
3635 "intrinsic, host or use associated, referenced or have "
3636 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
3643 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3645 /* Check for F03:C717. */
3646 if (UNLIMITED_POLY (rvalue
)
3647 && !(UNLIMITED_POLY (lvalue
)
3648 || (lvalue
->ts
.type
== BT_DERIVED
3649 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3650 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3651 gfc_error ("Data-pointer-object at %L must be unlimited "
3652 "polymorphic, or of a type with the BIND or SEQUENCE "
3653 "attribute, to be compatible with an unlimited "
3654 "polymorphic target", &lvalue
->where
);
3656 gfc_error ("Different types in pointer assignment at %L; "
3657 "attempted assignment of %s to %s", &lvalue
->where
,
3658 gfc_typename (&rvalue
->ts
),
3659 gfc_typename (&lvalue
->ts
));
3663 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3665 gfc_error ("Different kind type parameters in pointer "
3666 "assignment at %L", &lvalue
->where
);
3670 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3672 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3676 /* Make sure the vtab is present. */
3677 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
3678 gfc_find_vtab (&rvalue
->ts
);
3680 /* Check rank remapping. */
3685 /* If this can be determined, check that the target must be at least as
3686 large as the pointer assigned to it is. */
3687 if (gfc_array_size (lvalue
, &lsize
)
3688 && gfc_array_size (rvalue
, &rsize
)
3689 && mpz_cmp (rsize
, lsize
) < 0)
3691 gfc_error ("Rank remapping target is smaller than size of the"
3692 " pointer (%ld < %ld) at %L",
3693 mpz_get_si (rsize
), mpz_get_si (lsize
),
3698 /* The target must be either rank one or it must be simply contiguous
3699 and F2008 must be allowed. */
3700 if (rvalue
->rank
!= 1)
3702 if (!gfc_is_simply_contiguous (rvalue
, true, false))
3704 gfc_error ("Rank remapping target must be rank 1 or"
3705 " simply contiguous at %L", &rvalue
->where
);
3708 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
3709 "rank 1 at %L", &rvalue
->where
))
3714 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3715 if (rvalue
->expr_type
== EXPR_NULL
)
3718 if (lvalue
->ts
.type
== BT_CHARACTER
)
3720 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3725 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3726 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3728 attr
= gfc_expr_attr (rvalue
);
3730 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3732 gfc_error ("Target expression in pointer assignment "
3733 "at %L must deliver a pointer result",
3738 if (!attr
.target
&& !attr
.pointer
)
3740 gfc_error ("Pointer assignment target is neither TARGET "
3741 "nor POINTER at %L", &rvalue
->where
);
3745 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3747 gfc_error ("Bad target in pointer assignment in PURE "
3748 "procedure at %L", &rvalue
->where
);
3751 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3752 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3754 if (gfc_has_vector_index (rvalue
))
3756 gfc_error ("Pointer assignment with vector subscript "
3757 "on rhs at %L", &rvalue
->where
);
3761 if (attr
.is_protected
&& attr
.use_assoc
3762 && !(attr
.pointer
|| attr
.proc_pointer
))
3764 gfc_error ("Pointer assignment target has PROTECTED "
3765 "attribute at %L", &rvalue
->where
);
3769 /* F2008, C725. For PURE also C1283. */
3770 if (rvalue
->expr_type
== EXPR_VARIABLE
3771 && gfc_is_coindexed (rvalue
))
3774 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3775 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3777 gfc_error ("Data target at %L shall not have a coindex",
3783 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3784 if (warn_target_lifetime
3785 && rvalue
->expr_type
== EXPR_VARIABLE
3786 && !rvalue
->symtree
->n
.sym
->attr
.save
3787 && !attr
.pointer
&& !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3788 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3789 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3790 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3795 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3796 || lvalue
->symtree
->n
.sym
->attr
.result
3797 || lvalue
->symtree
->n
.sym
->attr
.function
3798 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3799 && lvalue
->symtree
->n
.sym
->ns
3800 != rvalue
->symtree
->n
.sym
->ns
)
3801 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3802 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3804 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3805 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3806 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3807 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3808 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3810 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3817 gfc_warning (OPT_Wtarget_lifetime
,
3818 "Pointer at %L in pointer assignment might outlive the "
3819 "pointer target", &lvalue
->where
);
3826 /* Relative of gfc_check_assign() except that the lvalue is a single
3827 symbol. Used for initialization assignments. */
3830 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3834 bool pointer
, proc_pointer
;
3836 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3838 lvalue
.expr_type
= EXPR_VARIABLE
;
3839 lvalue
.ts
= sym
->ts
;
3841 lvalue
.rank
= sym
->as
->rank
;
3842 lvalue
.symtree
= XCNEW (gfc_symtree
);
3843 lvalue
.symtree
->n
.sym
= sym
;
3844 lvalue
.where
= sym
->declared_at
;
3848 lvalue
.ref
= gfc_get_ref ();
3849 lvalue
.ref
->type
= REF_COMPONENT
;
3850 lvalue
.ref
->u
.c
.component
= comp
;
3851 lvalue
.ref
->u
.c
.sym
= sym
;
3852 lvalue
.ts
= comp
->ts
;
3853 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
3854 lvalue
.where
= comp
->loc
;
3855 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3856 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
3857 proc_pointer
= comp
->attr
.proc_pointer
;
3861 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3862 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
3863 proc_pointer
= sym
->attr
.proc_pointer
;
3866 if (pointer
|| proc_pointer
)
3867 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3870 /* If a conversion function, e.g., __convert_i8_i4, was inserted
3871 into an array constructor, we should check if it can be reduced
3872 as an initialization expression. */
3873 if (rvalue
->expr_type
== EXPR_FUNCTION
3874 && rvalue
->value
.function
.isym
3875 && (rvalue
->value
.function
.isym
->conversion
== 1))
3876 gfc_check_init_expr (rvalue
);
3878 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3881 free (lvalue
.symtree
);
3887 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3889 /* F08:C461. Additional checks for pointer initialization. */
3890 symbol_attribute attr
;
3891 attr
= gfc_expr_attr (rvalue
);
3892 if (attr
.allocatable
)
3894 gfc_error ("Pointer initialization target at %L "
3895 "must not be ALLOCATABLE", &rvalue
->where
);
3898 if (!attr
.target
|| attr
.pointer
)
3900 gfc_error ("Pointer initialization target at %L "
3901 "must have the TARGET attribute", &rvalue
->where
);
3905 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
3906 && rvalue
->symtree
->n
.sym
->ns
->proc_name
3907 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
3909 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
3910 attr
.save
= SAVE_IMPLICIT
;
3915 gfc_error ("Pointer initialization target at %L "
3916 "must have the SAVE attribute", &rvalue
->where
);
3921 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3923 /* F08:C1220. Additional checks for procedure pointer initialization. */
3924 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3925 if (attr
.proc_pointer
)
3927 gfc_error ("Procedure pointer initialization target at %L "
3928 "may not be a procedure pointer", &rvalue
->where
);
3937 /* Build an initializer for a local integer, real, complex, logical, or
3938 character variable, based on the command line flags finit-local-zero,
3939 finit-integer=, finit-real=, finit-logical=, and finit-character=. */
3942 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
3945 gfc_expr
*init_expr
;
3948 /* Try to build an initializer expression. */
3949 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
3951 /* We will only initialize integers, reals, complex, logicals, and
3952 characters, and only if the corresponding command-line flags
3953 were set. Otherwise, we free init_expr and return null. */
3957 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
3958 mpz_set_si (init_expr
->value
.integer
,
3959 gfc_option
.flag_init_integer_value
);
3962 gfc_free_expr (init_expr
);
3968 switch (flag_init_real
)
3970 case GFC_INIT_REAL_SNAN
:
3971 init_expr
->is_snan
= 1;
3973 case GFC_INIT_REAL_NAN
:
3974 mpfr_set_nan (init_expr
->value
.real
);
3977 case GFC_INIT_REAL_INF
:
3978 mpfr_set_inf (init_expr
->value
.real
, 1);
3981 case GFC_INIT_REAL_NEG_INF
:
3982 mpfr_set_inf (init_expr
->value
.real
, -1);
3985 case GFC_INIT_REAL_ZERO
:
3986 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
3990 gfc_free_expr (init_expr
);
3997 switch (flag_init_real
)
3999 case GFC_INIT_REAL_SNAN
:
4000 init_expr
->is_snan
= 1;
4002 case GFC_INIT_REAL_NAN
:
4003 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4004 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4007 case GFC_INIT_REAL_INF
:
4008 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4009 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4012 case GFC_INIT_REAL_NEG_INF
:
4013 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4014 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4017 case GFC_INIT_REAL_ZERO
:
4018 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4022 gfc_free_expr (init_expr
);
4029 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
4030 init_expr
->value
.logical
= 0;
4031 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
4032 init_expr
->value
.logical
= 1;
4035 gfc_free_expr (init_expr
);
4041 /* For characters, the length must be constant in order to
4042 create a default initializer. */
4043 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
4045 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4047 char_len
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
4048 init_expr
->value
.character
.length
= char_len
;
4049 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4050 for (i
= 0; i
< char_len
; i
++)
4051 init_expr
->value
.character
.string
[i
]
4052 = (unsigned char) gfc_option
.flag_init_character_value
;
4056 gfc_free_expr (init_expr
);
4059 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
4060 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4062 gfc_actual_arglist
*arg
;
4063 init_expr
= gfc_get_expr ();
4064 init_expr
->where
= *where
;
4065 init_expr
->ts
= *ts
;
4066 init_expr
->expr_type
= EXPR_FUNCTION
;
4067 init_expr
->value
.function
.isym
=
4068 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4069 init_expr
->value
.function
.name
= "repeat";
4070 arg
= gfc_get_actual_arglist ();
4071 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4072 arg
->expr
->value
.character
.string
[0] =
4073 gfc_option
.flag_init_character_value
;
4074 arg
->next
= gfc_get_actual_arglist ();
4075 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4076 init_expr
->value
.function
.actual
= arg
;
4081 gfc_free_expr (init_expr
);
4088 /* Apply an initialization expression to a typespec. Can be used for symbols or
4089 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4090 combined with some effort. */
4093 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4095 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4097 && ts
->u
.cl
->length
&& ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4101 gcc_assert (ts
->u
.cl
&& ts
->u
.cl
->length
);
4102 gcc_assert (ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
4103 gcc_assert (ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
);
4105 len
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
4107 if (init
->expr_type
== EXPR_CONSTANT
)
4108 gfc_set_constant_character_len (len
, init
, -1);
4111 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4112 init
->ts
.u
.cl
->length
->value
.integer
))
4114 gfc_constructor
*ctor
;
4115 ctor
= gfc_constructor_first (init
->value
.constructor
);
4120 bool has_ts
= (init
->ts
.u
.cl
4121 && init
->ts
.u
.cl
->length_from_typespec
);
4123 /* Remember the length of the first element for checking
4124 that all elements *in the constructor* have the same
4125 length. This need not be the length of the LHS! */
4126 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4127 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4128 first_len
= ctor
->expr
->value
.character
.length
;
4130 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4131 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4133 gfc_set_constant_character_len (len
, ctor
->expr
,
4134 has_ts
? -1 : first_len
);
4135 if (!ctor
->expr
->ts
.u
.cl
)
4137 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4139 ctor
->expr
->ts
.u
.cl
->length
4140 = gfc_copy_expr (ts
->u
.cl
->length
);
4148 /* Check whether an expression is a structure constructor and whether it has
4149 other values than NULL. */
4152 is_non_empty_structure_constructor (gfc_expr
* e
)
4154 if (e
->expr_type
!= EXPR_STRUCTURE
)
4157 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4160 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4162 cons
= gfc_constructor_next (cons
);
4168 /* Check for default initializer; sym->value is not enough
4169 as it is also set for EXPR_NULL of allocatables. */
4172 gfc_has_default_initializer (gfc_symbol
*der
)
4176 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4177 for (c
= der
->components
; c
; c
= c
->next
)
4178 if (gfc_bt_struct (c
->ts
.type
))
4180 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4181 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4183 && is_non_empty_structure_constructor (c
->initializer
))
4184 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4186 if (c
->attr
.pointer
&& c
->initializer
)
4200 Generate an initializer expression which initializes the entirety of a union.
4201 A normal structure constructor is insufficient without undue effort, because
4202 components of maps may be oddly aligned/overlapped. (For example if a
4203 character is initialized from one map overtop a real from the other, only one
4204 byte of the real is actually initialized.) Unfortunately we don't know the
4205 size of the union right now, so we can't generate a proper initializer, but
4206 we use a NULL expr as a placeholder and do the right thing later in
4207 gfc_trans_subcomponent_assign.
4210 generate_union_initializer (gfc_component
*un
)
4212 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4215 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4216 placeholder
->ts
= un
->ts
;
4221 /* Get the user-specified initializer for a union, if any. This means the user
4222 has said to initialize component(s) of a map. For simplicity's sake we
4223 only allow the user to initialize the first map. We don't have to worry
4224 about overlapping initializers as they are released early in resolution (see
4225 resolve_fl_struct). */
4228 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4231 gfc_expr
*init
=NULL
;
4233 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4236 for (map
= union_type
->components
; map
; map
= map
->next
)
4238 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4240 init
= gfc_default_initializer (&map
->ts
);
4253 /* Fetch or generate an initializer for the given component.
4254 Only generate an initializer if generate is true. */
4257 component_initializer (gfc_typespec
*ts
, gfc_component
*c
, bool generate
)
4259 gfc_expr
*init
= NULL
;
4261 /* See if we can find the initializer immediately. */
4262 if (c
->initializer
|| !generate
4263 || (ts
->type
== BT_CLASS
&& !c
->attr
.allocatable
))
4264 return c
->initializer
;
4266 /* Recursively handle derived type components. */
4267 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4268 init
= gfc_generate_initializer (&c
->ts
, true);
4270 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4272 gfc_component
*map
= NULL
;
4273 gfc_constructor
*ctor
;
4274 gfc_expr
*user_init
;
4276 /* If we don't have a user initializer and we aren't generating one, this
4277 union has no initializer. */
4278 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4279 if (!user_init
&& !generate
)
4282 /* Otherwise use a structure constructor. */
4283 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4287 /* If we are to generate an initializer for the union, add a constructor
4288 which initializes the whole union first. */
4291 ctor
= gfc_constructor_get ();
4292 ctor
->expr
= generate_union_initializer (c
);
4293 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4296 /* If we found an initializer in one of our maps, apply it. Note this
4297 is applied _after_ the entire-union initializer above if any. */
4300 ctor
= gfc_constructor_get ();
4301 ctor
->expr
= user_init
;
4302 ctor
->n
.component
= map
;
4303 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4307 /* Treat simple components like locals. */
4310 init
= gfc_build_default_init_expr (&c
->ts
, &c
->loc
);
4311 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4318 /* Get an expression for a default initializer of a derived type. */
4321 gfc_default_initializer (gfc_typespec
*ts
)
4323 return gfc_generate_initializer (ts
, false);
4327 /* Get or generate an expression for a default initializer of a derived type.
4328 If -finit-derived is specified, generate default initialization expressions
4329 for components that lack them when generate is set. */
4332 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4334 gfc_expr
*init
, *tmp
;
4335 gfc_component
*comp
;
4336 generate
= flag_init_derived
&& generate
;
4338 /* See if we have a default initializer in this, but not in nested
4339 types (otherwise we could use gfc_has_default_initializer()).
4340 We don't need to check if we are going to generate them. */
4341 comp
= ts
->u
.derived
->components
;
4344 for (; comp
; comp
= comp
->next
)
4345 if (comp
->initializer
|| comp
->attr
.allocatable
4346 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4347 && CLASS_DATA (comp
)->attr
.allocatable
))
4354 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4355 &ts
->u
.derived
->declared_at
);
4358 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4360 gfc_constructor
*ctor
= gfc_constructor_get();
4362 /* Fetch or generate an initializer for the component. */
4363 tmp
= component_initializer (ts
, comp
, generate
);
4366 /* Save the component ref for STRUCTUREs and UNIONs. */
4367 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4368 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4369 ctor
->n
.component
= comp
;
4371 /* If the initializer was not generated, we need a copy. */
4372 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4373 if ((comp
->ts
.type
!= tmp
->ts
.type
4374 || comp
->ts
.kind
!= tmp
->ts
.kind
)
4375 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4376 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
4379 if (comp
->attr
.allocatable
4380 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
4382 ctor
->expr
= gfc_get_expr ();
4383 ctor
->expr
->expr_type
= EXPR_NULL
;
4384 ctor
->expr
->where
= init
->where
;
4385 ctor
->expr
->ts
= comp
->ts
;
4388 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4395 /* Given a symbol, create an expression node with that symbol as a
4396 variable. If the symbol is array valued, setup a reference of the
4400 gfc_get_variable_expr (gfc_symtree
*var
)
4404 e
= gfc_get_expr ();
4405 e
->expr_type
= EXPR_VARIABLE
;
4407 e
->ts
= var
->n
.sym
->ts
;
4409 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
4410 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
4411 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
4412 && CLASS_DATA (var
->n
.sym
)->as
)))
4414 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
4415 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
4416 e
->ref
= gfc_get_ref ();
4417 e
->ref
->type
= REF_ARRAY
;
4418 e
->ref
->u
.ar
.type
= AR_FULL
;
4419 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
4420 ? CLASS_DATA (var
->n
.sym
)->as
4428 /* Adds a full array reference to an expression, as needed. */
4431 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4434 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4439 ref
->next
= gfc_get_ref ();
4444 e
->ref
= gfc_get_ref ();
4447 ref
->type
= REF_ARRAY
;
4448 ref
->u
.ar
.type
= AR_FULL
;
4449 ref
->u
.ar
.dimen
= e
->rank
;
4450 ref
->u
.ar
.where
= e
->where
;
4456 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4460 lval
= gfc_get_expr ();
4461 lval
->expr_type
= EXPR_VARIABLE
;
4462 lval
->where
= sym
->declared_at
;
4464 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4466 /* It will always be a full array. */
4467 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
4468 lval
->rank
= as
? as
->rank
: 0;
4470 gfc_add_full_array_ref (lval
, as
);
4475 /* Returns the array_spec of a full array expression. A NULL is
4476 returned otherwise. */
4478 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4483 if (expr
->rank
== 0)
4486 /* Follow any component references. */
4487 if (expr
->expr_type
== EXPR_VARIABLE
4488 || expr
->expr_type
== EXPR_CONSTANT
)
4490 as
= expr
->symtree
->n
.sym
->as
;
4491 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4496 as
= ref
->u
.c
.component
->as
;
4504 switch (ref
->u
.ar
.type
)
4527 /* General expression traversal function. */
4530 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4531 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4536 gfc_actual_arglist
*args
;
4543 if ((*func
) (expr
, sym
, &f
))
4546 if (expr
->ts
.type
== BT_CHARACTER
4548 && expr
->ts
.u
.cl
->length
4549 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4550 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4553 switch (expr
->expr_type
)
4558 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4560 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4568 case EXPR_SUBSTRING
:
4571 case EXPR_STRUCTURE
:
4573 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4574 c
; c
= gfc_constructor_next (c
))
4576 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4580 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4582 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4584 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4586 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4593 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4595 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4611 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4613 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4615 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4617 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4623 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4625 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4630 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4631 && ref
->u
.c
.component
->ts
.u
.cl
4632 && ref
->u
.c
.component
->ts
.u
.cl
->length
4633 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4635 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4639 if (ref
->u
.c
.component
->as
)
4640 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4641 + ref
->u
.c
.component
->as
->corank
; i
++)
4643 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4646 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4660 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4663 expr_set_symbols_referenced (gfc_expr
*expr
,
4664 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4665 int *f ATTRIBUTE_UNUSED
)
4667 if (expr
->expr_type
!= EXPR_VARIABLE
)
4669 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4674 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4676 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4680 /* Determine if an expression is a procedure pointer component and return
4681 the component in that case. Otherwise return NULL. */
4684 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4688 if (!expr
|| !expr
->ref
)
4695 if (ref
->type
== REF_COMPONENT
4696 && ref
->u
.c
.component
->attr
.proc_pointer
)
4697 return ref
->u
.c
.component
;
4703 /* Determine if an expression is a procedure pointer component. */
4706 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4708 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4712 /* Determine if an expression is a function with an allocatable class scalar
4715 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
4717 if (expr
->expr_type
== EXPR_FUNCTION
4718 && expr
->value
.function
.esym
4719 && expr
->value
.function
.esym
->result
4720 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4721 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4722 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4729 /* Determine if an expression is a function with an allocatable class array
4732 gfc_is_alloc_class_array_function (gfc_expr
*expr
)
4734 if (expr
->expr_type
== EXPR_FUNCTION
4735 && expr
->value
.function
.esym
4736 && expr
->value
.function
.esym
->result
4737 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4738 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4739 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4746 /* Walk an expression tree and check each variable encountered for being typed.
4747 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4748 mode as is a basic arithmetic expression using those; this is for things in
4751 INTEGER :: arr(n), n
4752 INTEGER :: arr(n + 1), n
4754 The namespace is needed for IMPLICIT typing. */
4756 static gfc_namespace
* check_typed_ns
;
4759 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4760 int* f ATTRIBUTE_UNUSED
)
4764 if (e
->expr_type
!= EXPR_VARIABLE
)
4767 gcc_assert (e
->symtree
);
4768 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4775 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4779 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4783 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4784 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4786 if (e
->expr_type
== EXPR_OP
)
4790 gcc_assert (e
->value
.op
.op1
);
4791 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4793 if (t
&& e
->value
.op
.op2
)
4794 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4800 /* Otherwise, walk the expression and do it strictly. */
4801 check_typed_ns
= ns
;
4802 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4804 return error_found
? false : true;
4809 gfc_ref_this_image (gfc_ref
*ref
)
4813 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4815 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4816 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4823 gfc_find_stat_co(gfc_expr
*e
)
4827 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4828 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4829 return ref
->u
.ar
.stat
;
4831 if (e
->value
.function
.actual
->expr
)
4832 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
4834 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4835 return ref
->u
.ar
.stat
;
4841 gfc_is_coindexed (gfc_expr
*e
)
4845 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4846 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4847 return !gfc_ref_this_image (ref
);
4853 /* Coarrays are variables with a corank but not being coindexed. However, also
4854 the following is a coarray: A subobject of a coarray is a coarray if it does
4855 not have any cosubscripts, vector subscripts, allocatable component
4856 selection, or pointer component selection. (F2008, 2.4.7) */
4859 gfc_is_coarray (gfc_expr
*e
)
4863 gfc_component
*comp
;
4868 if (e
->expr_type
!= EXPR_VARIABLE
)
4872 sym
= e
->symtree
->n
.sym
;
4874 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4875 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4877 coarray
= sym
->attr
.codimension
;
4879 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4883 comp
= ref
->u
.c
.component
;
4884 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4885 && (CLASS_DATA (comp
)->attr
.class_pointer
4886 || CLASS_DATA (comp
)->attr
.allocatable
))
4889 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4891 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4894 coarray
= comp
->attr
.codimension
;
4902 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4908 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4909 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4920 return coarray
&& !coindexed
;
4925 gfc_get_corank (gfc_expr
*e
)
4930 if (!gfc_is_coarray (e
))
4933 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4934 corank
= e
->ts
.u
.derived
->components
->as
4935 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4937 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4939 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4941 if (ref
->type
== REF_ARRAY
)
4942 corank
= ref
->u
.ar
.as
->corank
;
4943 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4950 /* Check whether the expression has an ultimate allocatable component.
4951 Being itself allocatable does not count. */
4953 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4955 gfc_ref
*ref
, *last
= NULL
;
4957 if (e
->expr_type
!= EXPR_VARIABLE
)
4960 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4961 if (ref
->type
== REF_COMPONENT
)
4964 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4965 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4966 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4967 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4971 if (e
->ts
.type
== BT_CLASS
)
4972 return CLASS_DATA (e
)->attr
.alloc_comp
;
4973 else if (e
->ts
.type
== BT_DERIVED
)
4974 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4980 /* Check whether the expression has an pointer component.
4981 Being itself a pointer does not count. */
4983 gfc_has_ultimate_pointer (gfc_expr
*e
)
4985 gfc_ref
*ref
, *last
= NULL
;
4987 if (e
->expr_type
!= EXPR_VARIABLE
)
4990 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4991 if (ref
->type
== REF_COMPONENT
)
4994 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4995 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4996 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4997 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5001 if (e
->ts
.type
== BT_CLASS
)
5002 return CLASS_DATA (e
)->attr
.pointer_comp
;
5003 else if (e
->ts
.type
== BT_DERIVED
)
5004 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5010 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5011 Note: A scalar is not regarded as "simply contiguous" by the standard.
5012 if bool is not strict, some further checks are done - for instance,
5013 a "(::1)" is accepted. */
5016 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5020 gfc_array_ref
*ar
= NULL
;
5021 gfc_ref
*ref
, *part_ref
= NULL
;
5024 if (expr
->expr_type
== EXPR_FUNCTION
)
5025 return expr
->value
.function
.esym
5026 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
5027 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5030 if (!permit_element
&& expr
->rank
== 0)
5033 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5036 return false; /* Array shall be last part-ref. */
5038 if (ref
->type
== REF_COMPONENT
)
5040 else if (ref
->type
== REF_SUBSTRING
)
5042 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5046 sym
= expr
->symtree
->n
.sym
;
5047 if (expr
->ts
.type
!= BT_CLASS
5049 && !part_ref
->u
.c
.component
->attr
.contiguous
5050 && part_ref
->u
.c
.component
->attr
.pointer
)
5052 && !sym
->attr
.contiguous
5053 && (sym
->attr
.pointer
5054 || sym
->as
->type
== AS_ASSUMED_RANK
5055 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
5058 if (!ar
|| ar
->type
== AR_FULL
)
5061 gcc_assert (ar
->type
== AR_SECTION
);
5063 /* Check for simply contiguous array */
5065 for (i
= 0; i
< ar
->dimen
; i
++)
5067 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5070 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5076 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5079 /* If the previous section was not contiguous, that's an error,
5080 unless we have effective only one element and checking is not
5082 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5083 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5084 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5085 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5086 ar
->end
[i
]->value
.integer
) != 0))
5089 /* Following the standard, "(::1)" or - if known at compile time -
5090 "(lbound:ubound)" are not simply contiguous; if strict
5091 is false, they are regarded as simply contiguous. */
5092 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5093 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5094 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5098 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5099 || !ar
->as
->lower
[i
]
5100 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5101 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5102 ar
->as
->lower
[i
]->value
.integer
) != 0))
5106 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5107 || !ar
->as
->upper
[i
]
5108 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5109 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5110 ar
->as
->upper
[i
]->value
.integer
) != 0))
5118 /* Build call to an intrinsic procedure. The number of arguments has to be
5119 passed (rather than ending the list with a NULL value) because we may
5120 want to add arguments but with a NULL-expression. */
5123 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5124 locus where
, unsigned numarg
, ...)
5127 gfc_actual_arglist
* atail
;
5128 gfc_intrinsic_sym
* isym
;
5131 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5133 isym
= gfc_intrinsic_function_by_id (id
);
5136 result
= gfc_get_expr ();
5137 result
->expr_type
= EXPR_FUNCTION
;
5138 result
->ts
= isym
->ts
;
5139 result
->where
= where
;
5140 result
->value
.function
.name
= mangled_name
;
5141 result
->value
.function
.isym
= isym
;
5143 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5144 gfc_commit_symbol (result
->symtree
->n
.sym
);
5145 gcc_assert (result
->symtree
5146 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5147 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5148 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5149 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5150 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5151 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5153 va_start (ap
, numarg
);
5155 for (i
= 0; i
< numarg
; ++i
)
5159 atail
->next
= gfc_get_actual_arglist ();
5160 atail
= atail
->next
;
5163 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5165 atail
->expr
= va_arg (ap
, gfc_expr
*);
5173 /* Check if an expression may appear in a variable definition context
5174 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5175 This is called from the various places when resolving
5176 the pieces that make up such a context.
5177 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5178 variables), some checks are not performed.
5180 Optionally, a possible error message can be suppressed if context is NULL
5181 and just the return status (true / false) be requested. */
5184 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5185 bool own_scope
, const char* context
)
5187 gfc_symbol
* sym
= NULL
;
5189 bool check_intentin
;
5191 symbol_attribute attr
;
5195 if (e
->expr_type
== EXPR_VARIABLE
)
5197 gcc_assert (e
->symtree
);
5198 sym
= e
->symtree
->n
.sym
;
5200 else if (e
->expr_type
== EXPR_FUNCTION
)
5202 gcc_assert (e
->symtree
);
5203 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5206 attr
= gfc_expr_attr (e
);
5207 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5209 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5212 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5213 " context (%s) at %L", context
, &e
->where
);
5217 else if (e
->expr_type
!= EXPR_VARIABLE
)
5220 gfc_error ("Non-variable expression in variable definition context (%s)"
5221 " at %L", context
, &e
->where
);
5225 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
5228 gfc_error ("Named constant %qs in variable definition context (%s)"
5229 " at %L", sym
->name
, context
, &e
->where
);
5232 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
5233 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
5234 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5237 gfc_error ("%qs in variable definition context (%s) at %L is not"
5238 " a variable", sym
->name
, context
, &e
->where
);
5242 /* Find out whether the expr is a pointer; this also means following
5243 component references to the last one. */
5244 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
5245 if (pointer
&& !is_pointer
)
5248 gfc_error ("Non-POINTER in pointer association context (%s)"
5249 " at %L", context
, &e
->where
);
5253 if (e
->ts
.type
== BT_DERIVED
5254 && e
->ts
.u
.derived
== NULL
)
5257 gfc_error ("Type inaccessible in variable definition context (%s) "
5258 "at %L", context
, &e
->where
);
5265 || (e
->ts
.type
== BT_DERIVED
5266 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5267 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
5270 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5271 context
, &e
->where
);
5275 /* TS18508, C702/C203. */
5278 || (e
->ts
.type
== BT_DERIVED
5279 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5280 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
5283 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5284 context
, &e
->where
);
5288 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5289 component of sub-component of a pointer; we need to distinguish
5290 assignment to a pointer component from pointer-assignment to a pointer
5291 component. Note that (normal) assignment to procedure pointers is not
5293 check_intentin
= !own_scope
;
5294 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5295 && CLASS_DATA (sym
))
5296 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
5297 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
5299 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
5300 check_intentin
= false;
5301 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
5303 ptr_component
= true;
5305 check_intentin
= false;
5308 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
5310 if (pointer
&& is_pointer
)
5313 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5314 " association context (%s) at %L",
5315 sym
->name
, context
, &e
->where
);
5318 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
5321 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5322 " definition context (%s) at %L",
5323 sym
->name
, context
, &e
->where
);
5328 /* PROTECTED and use-associated. */
5329 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
5331 if (pointer
&& is_pointer
)
5334 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5335 " pointer association context (%s) at %L",
5336 sym
->name
, context
, &e
->where
);
5339 if (!pointer
&& !is_pointer
)
5342 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5343 " variable definition context (%s) at %L",
5344 sym
->name
, context
, &e
->where
);
5349 /* Variable not assignable from a PURE procedure but appears in
5350 variable definition context. */
5351 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
5354 gfc_error ("Variable %qs can not appear in a variable definition"
5355 " context (%s) at %L in PURE procedure",
5356 sym
->name
, context
, &e
->where
);
5360 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
5361 && gfc_impure_variable (sym
))
5366 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5368 sym
= ns
->proc_name
;
5371 if (sym
->attr
.flavor
== FL_PROCEDURE
)
5373 sym
->attr
.implicit_pure
= 0;
5378 /* Check variable definition context for associate-names. */
5379 if (!pointer
&& sym
->assoc
)
5382 gfc_association_list
* assoc
;
5384 gcc_assert (sym
->assoc
->target
);
5386 /* If this is a SELECT TYPE temporary (the association is used internally
5387 for SELECT TYPE), silently go over to the target. */
5388 if (sym
->attr
.select_type_temporary
)
5390 gfc_expr
* t
= sym
->assoc
->target
;
5392 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
5393 name
= t
->symtree
->name
;
5395 if (t
->symtree
->n
.sym
->assoc
)
5396 assoc
= t
->symtree
->n
.sym
->assoc
;
5405 gcc_assert (name
&& assoc
);
5407 /* Is association to a valid variable? */
5408 if (!assoc
->variable
)
5412 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
5413 gfc_error ("%qs at %L associated to vector-indexed target can"
5414 " not be used in a variable definition context (%s)",
5415 name
, &e
->where
, context
);
5417 gfc_error ("%qs at %L associated to expression can"
5418 " not be used in a variable definition context (%s)",
5419 name
, &e
->where
, context
);
5424 /* Target must be allowed to appear in a variable definition context. */
5425 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
5428 gfc_error ("Associate-name %qs can not appear in a variable"
5429 " definition context (%s) at %L because its target"
5430 " at %L can not, either",
5431 name
, context
, &e
->where
,
5432 &assoc
->target
->where
);
5437 /* Check for same value in vector expression subscript. */
5440 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
5441 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5442 for (i
= 0; i
< GFC_MAX_DIMENSIONS
5443 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
5444 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5446 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
5447 if (arr
->expr_type
== EXPR_ARRAY
)
5449 gfc_constructor
*c
, *n
;
5452 for (c
= gfc_constructor_first (arr
->value
.constructor
);
5453 c
!= NULL
; c
= gfc_constructor_next (c
))
5455 if (c
== NULL
|| c
->iterator
!= NULL
)
5460 for (n
= gfc_constructor_next (c
); n
!= NULL
;
5461 n
= gfc_constructor_next (n
))
5463 if (n
->iterator
!= NULL
)
5467 if (gfc_dep_compare_expr (ec
, en
) == 0)
5470 gfc_error_now ("Elements with the same value "
5471 "at %L and %L in vector "
5472 "subscript in a variable "
5473 "definition context (%s)",
5474 &(ec
->where
), &(en
->where
),