1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000-2017 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 Return true if some error occurred, false on success. If REPORT_ERROR
615 is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
616 for negative using gfc_error_now. */
619 gfc_extract_int (gfc_expr
*expr
, int *result
, int report_error
)
621 if (expr
->expr_type
!= EXPR_CONSTANT
)
623 if (report_error
> 0)
624 gfc_error ("Constant expression required at %C");
625 else if (report_error
< 0)
626 gfc_error_now ("Constant expression required at %C");
630 if (expr
->ts
.type
!= BT_INTEGER
)
632 if (report_error
> 0)
633 gfc_error ("Integer expression required at %C");
634 else if (report_error
< 0)
635 gfc_error_now ("Integer expression required at %C");
639 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
640 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
642 if (report_error
> 0)
643 gfc_error ("Integer value too large in expression at %C");
644 else if (report_error
< 0)
645 gfc_error_now ("Integer value too large in expression at %C");
649 *result
= (int) mpz_get_si (expr
->value
.integer
);
655 /* Recursively copy a list of reference structures. */
658 gfc_copy_ref (gfc_ref
*src
)
666 dest
= gfc_get_ref ();
667 dest
->type
= src
->type
;
672 ar
= gfc_copy_array_ref (&src
->u
.ar
);
678 dest
->u
.c
= src
->u
.c
;
682 dest
->u
.ss
= src
->u
.ss
;
683 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
684 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
688 dest
->next
= gfc_copy_ref (src
->next
);
694 /* Detect whether an expression has any vector index array references. */
697 gfc_has_vector_index (gfc_expr
*e
)
701 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
702 if (ref
->type
== REF_ARRAY
)
703 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
704 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
710 /* Copy a shape array. */
713 gfc_copy_shape (mpz_t
*shape
, int rank
)
721 new_shape
= gfc_get_shape (rank
);
723 for (n
= 0; n
< rank
; n
++)
724 mpz_init_set (new_shape
[n
], shape
[n
]);
730 /* Copy a shape array excluding dimension N, where N is an integer
731 constant expression. Dimensions are numbered in Fortran style --
734 So, if the original shape array contains R elements
735 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
736 the result contains R-1 elements:
737 { s1 ... sN-1 sN+1 ... sR-1}
739 If anything goes wrong -- N is not a constant, its value is out
740 of range -- or anything else, just returns NULL. */
743 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
745 mpz_t
*new_shape
, *s
;
751 || dim
->expr_type
!= EXPR_CONSTANT
752 || dim
->ts
.type
!= BT_INTEGER
)
755 n
= mpz_get_si (dim
->value
.integer
);
756 n
--; /* Convert to zero based index. */
757 if (n
< 0 || n
>= rank
)
760 s
= new_shape
= gfc_get_shape (rank
- 1);
762 for (i
= 0; i
< rank
; i
++)
766 mpz_init_set (*s
, shape
[i
]);
774 /* Return the maximum kind of two expressions. In general, higher
775 kind numbers mean more precision for numeric types. */
778 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
780 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
784 /* Returns nonzero if the type is numeric, zero otherwise. */
787 numeric_type (bt type
)
789 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
793 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
796 gfc_numeric_ts (gfc_typespec
*ts
)
798 return numeric_type (ts
->type
);
802 /* Return an expression node with an optional argument list attached.
803 A variable number of gfc_expr pointers are strung together in an
804 argument list with a NULL pointer terminating the list. */
807 gfc_build_conversion (gfc_expr
*e
)
812 p
->expr_type
= EXPR_FUNCTION
;
814 p
->value
.function
.actual
= gfc_get_actual_arglist ();
815 p
->value
.function
.actual
->expr
= e
;
821 /* Given an expression node with some sort of numeric binary
822 expression, insert type conversions required to make the operands
823 have the same type. Conversion warnings are disabled if wconversion
826 The exception is that the operands of an exponential don't have to
827 have the same type. If possible, the base is promoted to the type
828 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
829 1.0**2 stays as it is. */
832 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
836 op1
= e
->value
.op
.op1
;
837 op2
= e
->value
.op
.op2
;
839 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
841 gfc_clear_ts (&e
->ts
);
845 /* Kind conversions of same type. */
846 if (op1
->ts
.type
== op2
->ts
.type
)
848 if (op1
->ts
.kind
== op2
->ts
.kind
)
850 /* No type conversions. */
855 if (op1
->ts
.kind
> op2
->ts
.kind
)
856 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
858 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
864 /* Integer combined with real or complex. */
865 if (op2
->ts
.type
== BT_INTEGER
)
869 /* Special case for ** operator. */
870 if (e
->value
.op
.op
== INTRINSIC_POWER
)
873 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
877 if (op1
->ts
.type
== BT_INTEGER
)
880 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
884 /* Real combined with complex. */
885 e
->ts
.type
= BT_COMPLEX
;
886 if (op1
->ts
.kind
> op2
->ts
.kind
)
887 e
->ts
.kind
= op1
->ts
.kind
;
889 e
->ts
.kind
= op2
->ts
.kind
;
890 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
891 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
892 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
893 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
900 /* Determine if an expression is constant in the sense of F08:7.1.12.
901 * This function expects that the expression has already been simplified. */
904 gfc_is_constant_expr (gfc_expr
*e
)
907 gfc_actual_arglist
*arg
;
912 switch (e
->expr_type
)
915 return (gfc_is_constant_expr (e
->value
.op
.op1
)
916 && (e
->value
.op
.op2
== NULL
917 || gfc_is_constant_expr (e
->value
.op
.op2
)));
925 gcc_assert (e
->symtree
|| e
->value
.function
.esym
926 || e
->value
.function
.isym
);
928 /* Call to intrinsic with at least one argument. */
929 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
931 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
932 if (!gfc_is_constant_expr (arg
->expr
))
936 if (e
->value
.function
.isym
937 && (e
->value
.function
.isym
->elemental
938 || e
->value
.function
.isym
->pure
939 || e
->value
.function
.isym
->inquiry
940 || e
->value
.function
.isym
->transformational
))
950 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
951 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
955 c
= gfc_constructor_first (e
->value
.constructor
);
956 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
957 return gfc_constant_ac (e
);
959 for (; c
; c
= gfc_constructor_next (c
))
960 if (!gfc_is_constant_expr (c
->expr
))
967 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
973 /* Is true if an array reference is followed by a component or substring
976 is_subref_array (gfc_expr
* e
)
981 if (e
->expr_type
!= EXPR_VARIABLE
)
984 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
988 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
990 if (ref
->type
== REF_ARRAY
991 && ref
->u
.ar
.type
!= AR_ELEMENT
)
995 && ref
->type
!= REF_ARRAY
)
1002 /* Try to collapse intrinsic expressions. */
1005 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1007 gfc_intrinsic_op op
;
1008 gfc_expr
*op1
, *op2
, *result
;
1010 if (p
->value
.op
.op
== INTRINSIC_USER
)
1013 op1
= p
->value
.op
.op1
;
1014 op2
= p
->value
.op
.op2
;
1015 op
= p
->value
.op
.op
;
1017 if (!gfc_simplify_expr (op1
, type
))
1019 if (!gfc_simplify_expr (op2
, type
))
1022 if (!gfc_is_constant_expr (op1
)
1023 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1027 p
->value
.op
.op1
= NULL
;
1028 p
->value
.op
.op2
= NULL
;
1032 case INTRINSIC_PARENTHESES
:
1033 result
= gfc_parentheses (op1
);
1036 case INTRINSIC_UPLUS
:
1037 result
= gfc_uplus (op1
);
1040 case INTRINSIC_UMINUS
:
1041 result
= gfc_uminus (op1
);
1044 case INTRINSIC_PLUS
:
1045 result
= gfc_add (op1
, op2
);
1048 case INTRINSIC_MINUS
:
1049 result
= gfc_subtract (op1
, op2
);
1052 case INTRINSIC_TIMES
:
1053 result
= gfc_multiply (op1
, op2
);
1056 case INTRINSIC_DIVIDE
:
1057 result
= gfc_divide (op1
, op2
);
1060 case INTRINSIC_POWER
:
1061 result
= gfc_power (op1
, op2
);
1064 case INTRINSIC_CONCAT
:
1065 result
= gfc_concat (op1
, op2
);
1069 case INTRINSIC_EQ_OS
:
1070 result
= gfc_eq (op1
, op2
, op
);
1074 case INTRINSIC_NE_OS
:
1075 result
= gfc_ne (op1
, op2
, op
);
1079 case INTRINSIC_GT_OS
:
1080 result
= gfc_gt (op1
, op2
, op
);
1084 case INTRINSIC_GE_OS
:
1085 result
= gfc_ge (op1
, op2
, op
);
1089 case INTRINSIC_LT_OS
:
1090 result
= gfc_lt (op1
, op2
, op
);
1094 case INTRINSIC_LE_OS
:
1095 result
= gfc_le (op1
, op2
, op
);
1099 result
= gfc_not (op1
);
1103 result
= gfc_and (op1
, op2
);
1107 result
= gfc_or (op1
, op2
);
1111 result
= gfc_eqv (op1
, op2
);
1114 case INTRINSIC_NEQV
:
1115 result
= gfc_neqv (op1
, op2
);
1119 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1124 gfc_free_expr (op1
);
1125 gfc_free_expr (op2
);
1129 result
->rank
= p
->rank
;
1130 result
->where
= p
->where
;
1131 gfc_replace_expr (p
, result
);
1137 /* Subroutine to simplify constructor expressions. Mutually recursive
1138 with gfc_simplify_expr(). */
1141 simplify_constructor (gfc_constructor_base base
, int type
)
1146 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1149 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1150 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1151 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1156 /* Try and simplify a copy. Replace the original if successful
1157 but keep going through the constructor at all costs. Not
1158 doing so can make a dog's dinner of complicated things. */
1159 p
= gfc_copy_expr (c
->expr
);
1161 if (!gfc_simplify_expr (p
, type
))
1167 gfc_replace_expr (c
->expr
, p
);
1175 /* Pull a single array element out of an array constructor. */
1178 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1179 gfc_constructor
**rval
)
1181 unsigned long nelemen
;
1187 gfc_constructor
*cons
;
1194 mpz_init_set_ui (offset
, 0);
1197 mpz_init_set_ui (span
, 1);
1198 for (i
= 0; i
< ar
->dimen
; i
++)
1200 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1201 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1209 if (e
->expr_type
!= EXPR_CONSTANT
)
1215 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1216 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1218 /* Check the bounds. */
1219 if ((ar
->as
->upper
[i
]
1220 && mpz_cmp (e
->value
.integer
,
1221 ar
->as
->upper
[i
]->value
.integer
) > 0)
1222 || (mpz_cmp (e
->value
.integer
,
1223 ar
->as
->lower
[i
]->value
.integer
) < 0))
1225 gfc_error ("Index in dimension %d is out of bounds "
1226 "at %L", i
+ 1, &ar
->c_where
[i
]);
1232 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1233 mpz_mul (delta
, delta
, span
);
1234 mpz_add (offset
, offset
, delta
);
1236 mpz_set_ui (tmp
, 1);
1237 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1238 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1239 mpz_mul (span
, span
, tmp
);
1242 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1243 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1262 /* Find a component of a structure constructor. */
1264 static gfc_constructor
*
1265 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1267 gfc_component
*pick
= ref
->u
.c
.component
;
1268 gfc_constructor
*c
= gfc_constructor_first (base
);
1270 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1271 int ext
= dt
->attr
.extension
;
1273 /* For extended types, check if the desired component is in one of the
1275 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1276 pick
->name
, true, true, NULL
))
1278 dt
= dt
->components
->ts
.u
.derived
;
1279 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1283 gfc_component
*comp
= dt
->components
;
1284 while (comp
!= pick
)
1287 c
= gfc_constructor_next (c
);
1294 /* Replace an expression with the contents of a constructor, removing
1295 the subobject reference in the process. */
1298 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1308 e
= gfc_copy_expr (p
);
1309 e
->ref
= p
->ref
->next
;
1310 p
->ref
->next
= NULL
;
1311 gfc_replace_expr (p
, e
);
1315 /* Pull an array section out of an array constructor. */
1318 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1325 long unsigned one
= 1;
1327 mpz_t start
[GFC_MAX_DIMENSIONS
];
1328 mpz_t end
[GFC_MAX_DIMENSIONS
];
1329 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1330 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1331 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1336 gfc_constructor_base base
;
1337 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1347 base
= expr
->value
.constructor
;
1348 expr
->value
.constructor
= NULL
;
1350 rank
= ref
->u
.ar
.as
->rank
;
1352 if (expr
->shape
== NULL
)
1353 expr
->shape
= gfc_get_shape (rank
);
1355 mpz_init_set_ui (delta_mpz
, one
);
1356 mpz_init_set_ui (nelts
, one
);
1359 /* Do the initialization now, so that we can cleanup without
1360 keeping track of where we were. */
1361 for (d
= 0; d
< rank
; d
++)
1363 mpz_init (delta
[d
]);
1364 mpz_init (start
[d
]);
1367 mpz_init (stride
[d
]);
1371 /* Build the counters to clock through the array reference. */
1373 for (d
= 0; d
< rank
; d
++)
1375 /* Make this stretch of code easier on the eye! */
1376 begin
= ref
->u
.ar
.start
[d
];
1377 finish
= ref
->u
.ar
.end
[d
];
1378 step
= ref
->u
.ar
.stride
[d
];
1379 lower
= ref
->u
.ar
.as
->lower
[d
];
1380 upper
= ref
->u
.ar
.as
->upper
[d
];
1382 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1384 gfc_constructor
*ci
;
1387 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1393 gcc_assert (begin
->rank
== 1);
1394 /* Zero-sized arrays have no shape and no elements, stop early. */
1397 mpz_init_set_ui (nelts
, 0);
1401 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1402 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1403 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1404 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1407 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1409 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1410 || mpz_cmp (ci
->expr
->value
.integer
,
1411 lower
->value
.integer
) < 0)
1413 gfc_error ("index in dimension %d is out of bounds "
1414 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1422 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1423 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1424 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1430 /* Obtain the stride. */
1432 mpz_set (stride
[d
], step
->value
.integer
);
1434 mpz_set_ui (stride
[d
], one
);
1436 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1437 mpz_set_ui (stride
[d
], one
);
1439 /* Obtain the start value for the index. */
1441 mpz_set (start
[d
], begin
->value
.integer
);
1443 mpz_set (start
[d
], lower
->value
.integer
);
1445 mpz_set (ctr
[d
], start
[d
]);
1447 /* Obtain the end value for the index. */
1449 mpz_set (end
[d
], finish
->value
.integer
);
1451 mpz_set (end
[d
], upper
->value
.integer
);
1453 /* Separate 'if' because elements sometimes arrive with
1455 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1456 mpz_set (end
[d
], begin
->value
.integer
);
1458 /* Check the bounds. */
1459 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1460 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1461 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1462 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1464 gfc_error ("index in dimension %d is out of bounds "
1465 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1470 /* Calculate the number of elements and the shape. */
1471 mpz_set (tmp_mpz
, stride
[d
]);
1472 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1473 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1474 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1475 mpz_mul (nelts
, nelts
, tmp_mpz
);
1477 /* An element reference reduces the rank of the expression; don't
1478 add anything to the shape array. */
1479 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1480 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1483 /* Calculate the 'stride' (=delta) for conversion of the
1484 counter values into the index along the constructor. */
1485 mpz_set (delta
[d
], delta_mpz
);
1486 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1487 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1488 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1492 cons
= gfc_constructor_first (base
);
1494 /* Now clock through the array reference, calculating the index in
1495 the source constructor and transferring the elements to the new
1497 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1499 mpz_init_set_ui (ptr
, 0);
1502 for (d
= 0; d
< rank
; d
++)
1504 mpz_set (tmp_mpz
, ctr
[d
]);
1505 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1506 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1507 mpz_add (ptr
, ptr
, tmp_mpz
);
1509 if (!incr_ctr
) continue;
1511 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1513 gcc_assert(vecsub
[d
]);
1515 if (!gfc_constructor_next (vecsub
[d
]))
1516 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1519 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1522 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1526 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1528 if (mpz_cmp_ui (stride
[d
], 0) > 0
1529 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1530 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1531 mpz_set (ctr
[d
], start
[d
]);
1537 limit
= mpz_get_ui (ptr
);
1538 if (limit
>= flag_max_array_constructor
)
1540 gfc_error ("The number of elements in the array constructor "
1541 "at %L requires an increase of the allowed %d "
1542 "upper limit. See -fmax-array-constructor "
1543 "option", &expr
->where
, flag_max_array_constructor
);
1547 cons
= gfc_constructor_lookup (base
, limit
);
1549 gfc_constructor_append_expr (&expr
->value
.constructor
,
1550 gfc_copy_expr (cons
->expr
), NULL
);
1557 mpz_clear (delta_mpz
);
1558 mpz_clear (tmp_mpz
);
1560 for (d
= 0; d
< rank
; d
++)
1562 mpz_clear (delta
[d
]);
1563 mpz_clear (start
[d
]);
1566 mpz_clear (stride
[d
]);
1568 gfc_constructor_free (base
);
1572 /* Pull a substring out of an expression. */
1575 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1582 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1583 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1586 *newp
= gfc_copy_expr (p
);
1587 free ((*newp
)->value
.character
.string
);
1589 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1590 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1591 length
= end
- start
+ 1;
1593 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1594 (*newp
)->value
.character
.length
= length
;
1595 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1596 length
* sizeof (gfc_char_t
));
1603 /* Simplify a subobject reference of a constructor. This occurs when
1604 parameter variable values are substituted. */
1607 simplify_const_ref (gfc_expr
*p
)
1609 gfc_constructor
*cons
, *c
;
1615 switch (p
->ref
->type
)
1618 switch (p
->ref
->u
.ar
.type
)
1621 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1622 will generate this. */
1623 if (p
->expr_type
!= EXPR_ARRAY
)
1625 remove_subobject_ref (p
, NULL
);
1628 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1634 remove_subobject_ref (p
, cons
);
1638 if (!find_array_section (p
, p
->ref
))
1640 p
->ref
->u
.ar
.type
= AR_FULL
;
1645 if (p
->ref
->next
!= NULL
1646 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1648 for (c
= gfc_constructor_first (p
->value
.constructor
);
1649 c
; c
= gfc_constructor_next (c
))
1651 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1652 if (!simplify_const_ref (c
->expr
))
1656 if (gfc_bt_struct (p
->ts
.type
)
1658 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1660 /* There may have been component references. */
1661 p
->ts
= c
->expr
->ts
;
1665 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1667 if (p
->ts
.type
== BT_CHARACTER
1668 && last_ref
->type
== REF_SUBSTRING
)
1670 /* If this is a CHARACTER array and we possibly took
1671 a substring out of it, update the type-spec's
1672 character length according to the first element
1673 (as all should have the same length). */
1675 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1677 const gfc_expr
* first
= c
->expr
;
1678 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1679 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1680 string_len
= first
->value
.character
.length
;
1686 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1689 gfc_free_expr (p
->ts
.u
.cl
->length
);
1692 = gfc_get_int_expr (gfc_default_integer_kind
,
1696 gfc_free_ref_list (p
->ref
);
1707 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1708 remove_subobject_ref (p
, cons
);
1712 if (!find_substring_ref (p
, &newp
))
1715 gfc_replace_expr (p
, newp
);
1716 gfc_free_ref_list (p
->ref
);
1726 /* Simplify a chain of references. */
1729 simplify_ref_chain (gfc_ref
*ref
, int type
)
1733 for (; ref
; ref
= ref
->next
)
1738 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1740 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1742 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1744 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1750 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1752 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1764 /* Try to substitute the value of a parameter variable. */
1767 simplify_parameter_variable (gfc_expr
*p
, int type
)
1772 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1778 /* Do not copy subobject refs for constant. */
1779 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1780 e
->ref
= gfc_copy_ref (p
->ref
);
1781 t
= gfc_simplify_expr (e
, type
);
1783 /* Only use the simplification if it eliminated all subobject references. */
1785 gfc_replace_expr (p
, e
);
1792 /* Given an expression, simplify it by collapsing constant
1793 expressions. Most simplification takes place when the expression
1794 tree is being constructed. If an intrinsic function is simplified
1795 at some point, we get called again to collapse the result against
1798 We work by recursively simplifying expression nodes, simplifying
1799 intrinsic functions where possible, which can lead to further
1800 constant collapsing. If an operator has constant operand(s), we
1801 rip the expression apart, and rebuild it, hoping that it becomes
1804 The expression type is defined for:
1805 0 Basic expression parsing
1806 1 Simplifying array constructors -- will substitute
1808 Returns false on error, true otherwise.
1809 NOTE: Will return true even if the expression can not be simplified. */
1812 gfc_simplify_expr (gfc_expr
*p
, int type
)
1814 gfc_actual_arglist
*ap
;
1819 switch (p
->expr_type
)
1826 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1827 if (!gfc_simplify_expr (ap
->expr
, type
))
1830 if (p
->value
.function
.isym
!= NULL
1831 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1836 case EXPR_SUBSTRING
:
1837 if (!simplify_ref_chain (p
->ref
, type
))
1840 if (gfc_is_constant_expr (p
))
1846 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1848 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1849 start
--; /* Convert from one-based to zero-based. */
1852 end
= p
->value
.character
.length
;
1853 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1854 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1859 s
= gfc_get_wide_string (end
- start
+ 2);
1860 memcpy (s
, p
->value
.character
.string
+ start
,
1861 (end
- start
) * sizeof (gfc_char_t
));
1862 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1863 free (p
->value
.character
.string
);
1864 p
->value
.character
.string
= s
;
1865 p
->value
.character
.length
= end
- start
;
1866 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1867 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1869 p
->value
.character
.length
);
1870 gfc_free_ref_list (p
->ref
);
1872 p
->expr_type
= EXPR_CONSTANT
;
1877 if (!simplify_intrinsic_op (p
, type
))
1882 /* Only substitute array parameter variables if we are in an
1883 initialization expression, or we want a subsection. */
1884 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1885 && (gfc_init_expr_flag
|| p
->ref
1886 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1888 if (!simplify_parameter_variable (p
, type
))
1895 gfc_simplify_iterator_var (p
);
1898 /* Simplify subcomponent references. */
1899 if (!simplify_ref_chain (p
->ref
, type
))
1904 case EXPR_STRUCTURE
:
1906 if (!simplify_ref_chain (p
->ref
, type
))
1909 if (!simplify_constructor (p
->value
.constructor
, type
))
1912 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1913 && p
->ref
->u
.ar
.type
== AR_FULL
)
1914 gfc_expand_constructor (p
, false);
1916 if (!simplify_const_ref (p
))
1930 /* Returns the type of an expression with the exception that iterator
1931 variables are automatically integers no matter what else they may
1937 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
1944 /* Scalarize an expression for an elemental intrinsic call. */
1947 scalarize_intrinsic_call (gfc_expr
*e
)
1949 gfc_actual_arglist
*a
, *b
;
1950 gfc_constructor_base ctor
;
1951 gfc_constructor
*args
[5];
1952 gfc_constructor
*ci
, *new_ctor
;
1953 gfc_expr
*expr
, *old
;
1954 int n
, i
, rank
[5], array_arg
;
1956 /* Find which, if any, arguments are arrays. Assume that the old
1957 expression carries the type information and that the first arg
1958 that is an array expression carries all the shape information.*/
1960 a
= e
->value
.function
.actual
;
1961 for (; a
; a
= a
->next
)
1964 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
1967 expr
= gfc_copy_expr (a
->expr
);
1974 old
= gfc_copy_expr (e
);
1976 gfc_constructor_free (expr
->value
.constructor
);
1977 expr
->value
.constructor
= NULL
;
1979 expr
->where
= old
->where
;
1980 expr
->expr_type
= EXPR_ARRAY
;
1982 /* Copy the array argument constructors into an array, with nulls
1985 a
= old
->value
.function
.actual
;
1986 for (; a
; a
= a
->next
)
1988 /* Check that this is OK for an initialization expression. */
1989 if (a
->expr
&& !gfc_check_init_expr (a
->expr
))
1993 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1995 rank
[n
] = a
->expr
->rank
;
1996 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1997 args
[n
] = gfc_constructor_first (ctor
);
1999 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2002 rank
[n
] = a
->expr
->rank
;
2005 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2006 args
[n
] = gfc_constructor_first (ctor
);
2015 /* Using the array argument as the master, step through the array
2016 calling the function for each element and advancing the array
2017 constructors together. */
2018 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2020 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2021 gfc_copy_expr (old
), NULL
);
2023 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2025 b
= old
->value
.function
.actual
;
2026 for (i
= 0; i
< n
; i
++)
2029 new_ctor
->expr
->value
.function
.actual
2030 = a
= gfc_get_actual_arglist ();
2033 a
->next
= gfc_get_actual_arglist ();
2038 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2040 a
->expr
= gfc_copy_expr (b
->expr
);
2045 /* Simplify the function calls. If the simplification fails, the
2046 error will be flagged up down-stream or the library will deal
2048 gfc_simplify_expr (new_ctor
->expr
, 0);
2050 for (i
= 0; i
< n
; i
++)
2052 args
[i
] = gfc_constructor_next (args
[i
]);
2054 for (i
= 1; i
< n
; i
++)
2055 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2056 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2062 /* Free "expr" but not the pointers it contains. */
2064 gfc_free_expr (old
);
2068 gfc_error_now ("elemental function arguments at %C are not compliant");
2071 gfc_free_expr (expr
);
2072 gfc_free_expr (old
);
2078 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2080 gfc_expr
*op1
= e
->value
.op
.op1
;
2081 gfc_expr
*op2
= e
->value
.op
.op2
;
2083 if (!(*check_function
)(op1
))
2086 switch (e
->value
.op
.op
)
2088 case INTRINSIC_UPLUS
:
2089 case INTRINSIC_UMINUS
:
2090 if (!numeric_type (et0 (op1
)))
2095 case INTRINSIC_EQ_OS
:
2097 case INTRINSIC_NE_OS
:
2099 case INTRINSIC_GT_OS
:
2101 case INTRINSIC_GE_OS
:
2103 case INTRINSIC_LT_OS
:
2105 case INTRINSIC_LE_OS
:
2106 if (!(*check_function
)(op2
))
2109 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2110 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2112 gfc_error ("Numeric or CHARACTER operands are required in "
2113 "expression at %L", &e
->where
);
2118 case INTRINSIC_PLUS
:
2119 case INTRINSIC_MINUS
:
2120 case INTRINSIC_TIMES
:
2121 case INTRINSIC_DIVIDE
:
2122 case INTRINSIC_POWER
:
2123 if (!(*check_function
)(op2
))
2126 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2131 case INTRINSIC_CONCAT
:
2132 if (!(*check_function
)(op2
))
2135 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2137 gfc_error ("Concatenation operator in expression at %L "
2138 "must have two CHARACTER operands", &op1
->where
);
2142 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2144 gfc_error ("Concat operator at %L must concatenate strings of the "
2145 "same kind", &e
->where
);
2152 if (et0 (op1
) != BT_LOGICAL
)
2154 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2155 "operand", &op1
->where
);
2164 case INTRINSIC_NEQV
:
2165 if (!(*check_function
)(op2
))
2168 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2170 gfc_error ("LOGICAL operands are required in expression at %L",
2177 case INTRINSIC_PARENTHESES
:
2181 gfc_error ("Only intrinsic operators can be used in expression at %L",
2189 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2194 /* F2003, 7.1.7 (3): In init expression, allocatable components
2195 must not be data-initialized. */
2197 check_alloc_comp_init (gfc_expr
*e
)
2199 gfc_component
*comp
;
2200 gfc_constructor
*ctor
;
2202 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2203 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2205 for (comp
= e
->ts
.u
.derived
->components
,
2206 ctor
= gfc_constructor_first (e
->value
.constructor
);
2207 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2209 if (comp
->attr
.allocatable
&& ctor
->expr
2210 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2212 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2213 "component %qs in structure constructor at %L",
2214 comp
->name
, &ctor
->expr
->where
);
2223 check_init_expr_arguments (gfc_expr
*e
)
2225 gfc_actual_arglist
*ap
;
2227 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2228 if (!gfc_check_init_expr (ap
->expr
))
2234 static bool check_restricted (gfc_expr
*);
2236 /* F95, 7.1.6.1, Initialization expressions, (7)
2237 F2003, 7.1.7 Initialization expression, (8) */
2240 check_inquiry (gfc_expr
*e
, int not_restricted
)
2243 const char *const *functions
;
2245 static const char *const inquiry_func_f95
[] = {
2246 "lbound", "shape", "size", "ubound",
2247 "bit_size", "len", "kind",
2248 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2249 "precision", "radix", "range", "tiny",
2253 static const char *const inquiry_func_f2003
[] = {
2254 "lbound", "shape", "size", "ubound",
2255 "bit_size", "len", "kind",
2256 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2257 "precision", "radix", "range", "tiny",
2262 gfc_actual_arglist
*ap
;
2264 if (!e
->value
.function
.isym
2265 || !e
->value
.function
.isym
->inquiry
)
2268 /* An undeclared parameter will get us here (PR25018). */
2269 if (e
->symtree
== NULL
)
2272 if (e
->symtree
->n
.sym
->from_intmod
)
2274 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2275 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2276 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2279 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2280 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2285 name
= e
->symtree
->n
.sym
->name
;
2287 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2288 ? inquiry_func_f2003
: inquiry_func_f95
;
2290 for (i
= 0; functions
[i
]; i
++)
2291 if (strcmp (functions
[i
], name
) == 0)
2294 if (functions
[i
] == NULL
)
2298 /* At this point we have an inquiry function with a variable argument. The
2299 type of the variable might be undefined, but we need it now, because the
2300 arguments of these functions are not allowed to be undefined. */
2302 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2307 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2309 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2310 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2313 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2316 /* Assumed character length will not reduce to a constant expression
2317 with LEN, as required by the standard. */
2318 if (i
== 5 && not_restricted
2319 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2320 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2321 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2323 gfc_error ("Assumed or deferred character length variable %qs "
2324 " in constant expression at %L",
2325 ap
->expr
->symtree
->n
.sym
->name
,
2329 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2332 if (not_restricted
== 0
2333 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2334 && !check_restricted (ap
->expr
))
2337 if (not_restricted
== 0
2338 && ap
->expr
->expr_type
== EXPR_VARIABLE
2339 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2340 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2348 /* F95, 7.1.6.1, Initialization expressions, (5)
2349 F2003, 7.1.7 Initialization expression, (5) */
2352 check_transformational (gfc_expr
*e
)
2354 static const char * const trans_func_f95
[] = {
2355 "repeat", "reshape", "selected_int_kind",
2356 "selected_real_kind", "transfer", "trim", NULL
2359 static const char * const trans_func_f2003
[] = {
2360 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2361 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2362 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2363 "trim", "unpack", NULL
2368 const char *const *functions
;
2370 if (!e
->value
.function
.isym
2371 || !e
->value
.function
.isym
->transformational
)
2374 name
= e
->symtree
->n
.sym
->name
;
2376 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2377 ? trans_func_f2003
: trans_func_f95
;
2379 /* NULL() is dealt with below. */
2380 if (strcmp ("null", name
) == 0)
2383 for (i
= 0; functions
[i
]; i
++)
2384 if (strcmp (functions
[i
], name
) == 0)
2387 if (functions
[i
] == NULL
)
2389 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2390 "in an initialization expression", name
, &e
->where
);
2394 return check_init_expr_arguments (e
);
2398 /* F95, 7.1.6.1, Initialization expressions, (6)
2399 F2003, 7.1.7 Initialization expression, (6) */
2402 check_null (gfc_expr
*e
)
2404 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2407 return check_init_expr_arguments (e
);
2412 check_elemental (gfc_expr
*e
)
2414 if (!e
->value
.function
.isym
2415 || !e
->value
.function
.isym
->elemental
)
2418 if (e
->ts
.type
!= BT_INTEGER
2419 && e
->ts
.type
!= BT_CHARACTER
2420 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2421 "initialization expression at %L", &e
->where
))
2424 return check_init_expr_arguments (e
);
2429 check_conversion (gfc_expr
*e
)
2431 if (!e
->value
.function
.isym
2432 || !e
->value
.function
.isym
->conversion
)
2435 return check_init_expr_arguments (e
);
2439 /* Verify that an expression is an initialization expression. A side
2440 effect is that the expression tree is reduced to a single constant
2441 node if all goes well. This would normally happen when the
2442 expression is constructed but function references are assumed to be
2443 intrinsics in the context of initialization expressions. If
2444 false is returned an error message has been generated. */
2447 gfc_check_init_expr (gfc_expr
*e
)
2455 switch (e
->expr_type
)
2458 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2460 t
= gfc_simplify_expr (e
, 0);
2469 gfc_intrinsic_sym
* isym
= NULL
;
2470 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2472 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2473 IEEE_EXCEPTIONS modules. */
2474 int mod
= sym
->from_intmod
;
2475 if (mod
== INTMOD_NONE
&& sym
->generic
)
2476 mod
= sym
->generic
->sym
->from_intmod
;
2477 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2479 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2482 gfc_replace_expr (e
, new_expr
);
2488 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2489 into an array constructor, we need to skip the error check here.
2490 Conversion errors are caught below in scalarize_intrinsic_call. */
2491 conversion
= e
->value
.function
.isym
2492 && (e
->value
.function
.isym
->conversion
== 1);
2494 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2495 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2497 gfc_error ("Function %qs in initialization expression at %L "
2498 "must be an intrinsic function",
2499 e
->symtree
->n
.sym
->name
, &e
->where
);
2503 if ((m
= check_conversion (e
)) == MATCH_NO
2504 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2505 && (m
= check_null (e
)) == MATCH_NO
2506 && (m
= check_transformational (e
)) == MATCH_NO
2507 && (m
= check_elemental (e
)) == MATCH_NO
)
2509 gfc_error ("Intrinsic function %qs at %L is not permitted "
2510 "in an initialization expression",
2511 e
->symtree
->n
.sym
->name
, &e
->where
);
2515 if (m
== MATCH_ERROR
)
2518 /* Try to scalarize an elemental intrinsic function that has an
2520 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2521 if (isym
&& isym
->elemental
2522 && (t
= scalarize_intrinsic_call (e
)))
2527 t
= gfc_simplify_expr (e
, 0);
2534 if (gfc_check_iter_variable (e
))
2537 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2539 /* A PARAMETER shall not be used to define itself, i.e.
2540 REAL, PARAMETER :: x = transfer(0, x)
2542 if (!e
->symtree
->n
.sym
->value
)
2544 gfc_error ("PARAMETER %qs is used at %L before its definition "
2545 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2549 t
= simplify_parameter_variable (e
, 0);
2554 if (gfc_in_match_data ())
2559 if (e
->symtree
->n
.sym
->as
)
2561 switch (e
->symtree
->n
.sym
->as
->type
)
2563 case AS_ASSUMED_SIZE
:
2564 gfc_error ("Assumed size array %qs at %L is not permitted "
2565 "in an initialization expression",
2566 e
->symtree
->n
.sym
->name
, &e
->where
);
2569 case AS_ASSUMED_SHAPE
:
2570 gfc_error ("Assumed shape array %qs at %L is not permitted "
2571 "in an initialization expression",
2572 e
->symtree
->n
.sym
->name
, &e
->where
);
2576 gfc_error ("Deferred array %qs at %L is not permitted "
2577 "in an initialization expression",
2578 e
->symtree
->n
.sym
->name
, &e
->where
);
2582 gfc_error ("Array %qs at %L is a variable, which does "
2583 "not reduce to a constant expression",
2584 e
->symtree
->n
.sym
->name
, &e
->where
);
2592 gfc_error ("Parameter %qs at %L has not been declared or is "
2593 "a variable, which does not reduce to a constant "
2594 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2603 case EXPR_SUBSTRING
:
2606 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2610 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2612 t
= gfc_simplify_expr (e
, 0);
2618 case EXPR_STRUCTURE
:
2619 t
= e
->ts
.is_iso_c
? true : false;
2623 t
= check_alloc_comp_init (e
);
2627 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2634 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2638 t
= gfc_expand_constructor (e
, true);
2642 t
= gfc_check_constructor_type (e
);
2646 gfc_internal_error ("check_init_expr(): Unknown expression type");
2652 /* Reduces a general expression to an initialization expression (a constant).
2653 This used to be part of gfc_match_init_expr.
2654 Note that this function doesn't free the given expression on false. */
2657 gfc_reduce_init_expr (gfc_expr
*expr
)
2661 gfc_init_expr_flag
= true;
2662 t
= gfc_resolve_expr (expr
);
2664 t
= gfc_check_init_expr (expr
);
2665 gfc_init_expr_flag
= false;
2670 if (expr
->expr_type
== EXPR_ARRAY
)
2672 if (!gfc_check_constructor_type (expr
))
2674 if (!gfc_expand_constructor (expr
, true))
2682 /* Match an initialization expression. We work by first matching an
2683 expression, then reducing it to a constant. */
2686 gfc_match_init_expr (gfc_expr
**result
)
2694 gfc_init_expr_flag
= true;
2696 m
= gfc_match_expr (&expr
);
2699 gfc_init_expr_flag
= false;
2703 t
= gfc_reduce_init_expr (expr
);
2706 gfc_free_expr (expr
);
2707 gfc_init_expr_flag
= false;
2712 gfc_init_expr_flag
= false;
2718 /* Given an actual argument list, test to see that each argument is a
2719 restricted expression and optionally if the expression type is
2720 integer or character. */
2723 restricted_args (gfc_actual_arglist
*a
)
2725 for (; a
; a
= a
->next
)
2727 if (!check_restricted (a
->expr
))
2735 /************* Restricted/specification expressions *************/
2738 /* Make sure a non-intrinsic function is a specification function,
2739 * see F08:7.1.11.5. */
2742 external_spec_function (gfc_expr
*e
)
2746 f
= e
->value
.function
.esym
;
2748 /* IEEE functions allowed are "a reference to a transformational function
2749 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
2750 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
2751 IEEE_EXCEPTIONS". */
2752 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
2753 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
2755 if (!strcmp (f
->name
, "ieee_selected_real_kind")
2756 || !strcmp (f
->name
, "ieee_support_rounding")
2757 || !strcmp (f
->name
, "ieee_support_flag")
2758 || !strcmp (f
->name
, "ieee_support_halting")
2759 || !strcmp (f
->name
, "ieee_support_datatype")
2760 || !strcmp (f
->name
, "ieee_support_denormal")
2761 || !strcmp (f
->name
, "ieee_support_divide")
2762 || !strcmp (f
->name
, "ieee_support_inf")
2763 || !strcmp (f
->name
, "ieee_support_io")
2764 || !strcmp (f
->name
, "ieee_support_nan")
2765 || !strcmp (f
->name
, "ieee_support_sqrt")
2766 || !strcmp (f
->name
, "ieee_support_standard")
2767 || !strcmp (f
->name
, "ieee_support_underflow_control"))
2768 goto function_allowed
;
2771 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2773 gfc_error ("Specification function %qs at %L cannot be a statement "
2774 "function", f
->name
, &e
->where
);
2778 if (f
->attr
.proc
== PROC_INTERNAL
)
2780 gfc_error ("Specification function %qs at %L cannot be an internal "
2781 "function", f
->name
, &e
->where
);
2785 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2787 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
2793 if (f
->attr
.recursive
2794 && !gfc_notify_std (GFC_STD_F2003
,
2795 "Specification function '%s' "
2796 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
2800 return restricted_args (e
->value
.function
.actual
);
2804 /* Check to see that a function reference to an intrinsic is a
2805 restricted expression. */
2808 restricted_intrinsic (gfc_expr
*e
)
2810 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2811 if (check_inquiry (e
, 0) == MATCH_YES
)
2814 return restricted_args (e
->value
.function
.actual
);
2818 /* Check the expressions of an actual arglist. Used by check_restricted. */
2821 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
2823 for (; arg
; arg
= arg
->next
)
2824 if (!checker (arg
->expr
))
2831 /* Check the subscription expressions of a reference chain with a checking
2832 function; used by check_restricted. */
2835 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
2845 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2847 if (!checker (ref
->u
.ar
.start
[dim
]))
2849 if (!checker (ref
->u
.ar
.end
[dim
]))
2851 if (!checker (ref
->u
.ar
.stride
[dim
]))
2857 /* Nothing needed, just proceed to next reference. */
2861 if (!checker (ref
->u
.ss
.start
))
2863 if (!checker (ref
->u
.ss
.end
))
2872 return check_references (ref
->next
, checker
);
2875 /* Return true if ns is a parent of the current ns. */
2878 is_parent_of_current_ns (gfc_namespace
*ns
)
2881 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
2888 /* Verify that an expression is a restricted expression. Like its
2889 cousin check_init_expr(), an error message is generated if we
2893 check_restricted (gfc_expr
*e
)
2901 switch (e
->expr_type
)
2904 t
= check_intrinsic_op (e
, check_restricted
);
2906 t
= gfc_simplify_expr (e
, 0);
2911 if (e
->value
.function
.esym
)
2913 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2915 t
= external_spec_function (e
);
2919 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2922 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2925 t
= restricted_intrinsic (e
);
2930 sym
= e
->symtree
->n
.sym
;
2933 /* If a dummy argument appears in a context that is valid for a
2934 restricted expression in an elemental procedure, it will have
2935 already been simplified away once we get here. Therefore we
2936 don't need to jump through hoops to distinguish valid from
2938 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2939 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2941 gfc_error ("Dummy argument %qs not allowed in expression at %L",
2942 sym
->name
, &e
->where
);
2946 if (sym
->attr
.optional
)
2948 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
2949 sym
->name
, &e
->where
);
2953 if (sym
->attr
.intent
== INTENT_OUT
)
2955 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
2956 sym
->name
, &e
->where
);
2960 /* Check reference chain if any. */
2961 if (!check_references (e
->ref
, &check_restricted
))
2964 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2965 processed in resolve.c(resolve_formal_arglist). This is done so
2966 that host associated dummy array indices are accepted (PR23446).
2967 This mechanism also does the same for the specification expressions
2968 of array-valued functions. */
2970 || sym
->attr
.in_common
2971 || sym
->attr
.use_assoc
2973 || sym
->attr
.implied_index
2974 || sym
->attr
.flavor
== FL_PARAMETER
2975 || is_parent_of_current_ns (sym
->ns
)
2976 || (sym
->ns
->proc_name
!= NULL
2977 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2978 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2984 gfc_error ("Variable %qs cannot appear in the expression at %L",
2985 sym
->name
, &e
->where
);
2986 /* Prevent a repetition of the error. */
2995 case EXPR_SUBSTRING
:
2996 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3000 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3002 t
= gfc_simplify_expr (e
, 0);
3006 case EXPR_STRUCTURE
:
3007 t
= gfc_check_constructor (e
, check_restricted
);
3011 t
= gfc_check_constructor (e
, check_restricted
);
3015 gfc_internal_error ("check_restricted(): Unknown expression type");
3022 /* Check to see that an expression is a specification expression. If
3023 we return false, an error has been generated. */
3026 gfc_specification_expr (gfc_expr
*e
)
3028 gfc_component
*comp
;
3033 if (e
->ts
.type
!= BT_INTEGER
)
3035 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3036 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3040 comp
= gfc_get_proc_ptr_comp (e
);
3041 if (e
->expr_type
== EXPR_FUNCTION
3042 && !e
->value
.function
.isym
3043 && !e
->value
.function
.esym
3044 && !gfc_pure (e
->symtree
->n
.sym
)
3045 && (!comp
|| !comp
->attr
.pure
))
3047 gfc_error ("Function %qs at %L must be PURE",
3048 e
->symtree
->n
.sym
->name
, &e
->where
);
3049 /* Prevent repeat error messages. */
3050 e
->symtree
->n
.sym
->attr
.pure
= 1;
3056 gfc_error ("Expression at %L must be scalar", &e
->where
);
3060 if (!gfc_simplify_expr (e
, 0))
3063 return check_restricted (e
);
3067 /************** Expression conformance checks. *************/
3069 /* Given two expressions, make sure that the arrays are conformable. */
3072 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3074 int op1_flag
, op2_flag
, d
;
3075 mpz_t op1_size
, op2_size
;
3081 if (op1
->rank
== 0 || op2
->rank
== 0)
3084 va_start (argp
, optype_msgid
);
3085 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3088 if (op1
->rank
!= op2
->rank
)
3090 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3091 op1
->rank
, op2
->rank
, &op1
->where
);
3097 for (d
= 0; d
< op1
->rank
; d
++)
3099 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3100 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3102 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3104 gfc_error ("Different shape for %s at %L on dimension %d "
3105 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3106 (int) mpz_get_si (op1_size
),
3107 (int) mpz_get_si (op2_size
));
3113 mpz_clear (op1_size
);
3115 mpz_clear (op2_size
);
3125 /* Given an assignable expression and an arbitrary expression, make
3126 sure that the assignment can take place. Only add a call to the intrinsic
3127 conversion routines, when allow_convert is set. When this assign is a
3128 coarray call, then the convert is done by the coarray routine implictly and
3129 adding the intrinsic conversion would do harm in most cases. */
3132 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3139 sym
= lvalue
->symtree
->n
.sym
;
3141 /* See if this is the component or subcomponent of a pointer. */
3142 has_pointer
= sym
->attr
.pointer
;
3143 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3144 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3150 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3151 variable local to a function subprogram. Its existence begins when
3152 execution of the function is initiated and ends when execution of the
3153 function is terminated...
3154 Therefore, the left hand side is no longer a variable, when it is: */
3155 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3156 && !sym
->attr
.external
)
3161 /* (i) Use associated; */
3162 if (sym
->attr
.use_assoc
)
3165 /* (ii) The assignment is in the main program; or */
3166 if (gfc_current_ns
->proc_name
3167 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3170 /* (iii) A module or internal procedure... */
3171 if (gfc_current_ns
->proc_name
3172 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3173 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3174 && gfc_current_ns
->parent
3175 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3176 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3177 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3179 /* ... that is not a function... */
3180 if (gfc_current_ns
->proc_name
3181 && !gfc_current_ns
->proc_name
->attr
.function
)
3184 /* ... or is not an entry and has a different name. */
3185 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3189 /* (iv) Host associated and not the function symbol or the
3190 parent result. This picks up sibling references, which
3191 cannot be entries. */
3192 if (!sym
->attr
.entry
3193 && sym
->ns
== gfc_current_ns
->parent
3194 && sym
!= gfc_current_ns
->proc_name
3195 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3200 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3205 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3207 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3208 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3212 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3214 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3219 if (rvalue
->expr_type
== EXPR_NULL
)
3221 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3222 && lvalue
->symtree
->n
.sym
->attr
.data
)
3226 gfc_error ("NULL appears on right-hand side in assignment at %L",
3232 /* This is possibly a typo: x = f() instead of x => f(). */
3234 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3235 gfc_warning (OPT_Wsurprising
,
3236 "POINTER-valued function appears on right-hand side of "
3237 "assignment at %L", &rvalue
->where
);
3239 /* Check size of array assignments. */
3240 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3241 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3244 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3245 && lvalue
->symtree
->n
.sym
->attr
.data
3246 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3247 "initialize non-integer variable %qs",
3248 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3250 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3251 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3252 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3256 /* Handle the case of a BOZ literal on the RHS. */
3257 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3260 if (warn_surprising
)
3261 gfc_warning (OPT_Wsurprising
,
3262 "BOZ literal at %L is bitwise transferred "
3263 "non-integer symbol %qs", &rvalue
->where
,
3264 lvalue
->symtree
->n
.sym
->name
);
3265 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3267 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3269 if (rc
== ARITH_UNDERFLOW
)
3270 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3271 ". This check can be disabled with the option "
3272 "%<-fno-range-check%>", &rvalue
->where
);
3273 else if (rc
== ARITH_OVERFLOW
)
3274 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3275 ". This check can be disabled with the option "
3276 "%<-fno-range-check%>", &rvalue
->where
);
3277 else if (rc
== ARITH_NAN
)
3278 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3279 ". This check can be disabled with the option "
3280 "%<-fno-range-check%>", &rvalue
->where
);
3285 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3288 /* Only DATA Statements come here. */
3291 /* Numeric can be converted to any other numeric. And Hollerith can be
3292 converted to any other type. */
3293 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3294 || rvalue
->ts
.type
== BT_HOLLERITH
)
3297 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3300 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3301 "conversion of %s to %s", &lvalue
->where
,
3302 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3307 /* Assignment is the only case where character variables of different
3308 kind values can be converted into one another. */
3309 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3311 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3312 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3320 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3324 /* Check that a pointer assignment is OK. We first check lvalue, and
3325 we only check rvalue if it's not an assignment to NULL() or a
3326 NULLIFY statement. */
3329 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3331 symbol_attribute attr
, lhs_attr
;
3333 bool is_pure
, is_implicit_pure
, rank_remap
;
3336 lhs_attr
= gfc_expr_attr (lvalue
);
3337 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3339 gfc_error ("Pointer assignment target is not a POINTER at %L",
3344 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3345 && !lhs_attr
.proc_pointer
)
3347 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3348 "l-value since it is a procedure",
3349 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3353 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3356 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3358 if (ref
->type
== REF_COMPONENT
)
3359 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3361 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3365 if (ref
->u
.ar
.type
== AR_FULL
)
3368 if (ref
->u
.ar
.type
!= AR_SECTION
)
3370 gfc_error ("Expected bounds specification for %qs at %L",
3371 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3375 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3376 "for %qs in pointer assignment at %L",
3377 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3380 /* When bounds are given, all lbounds are necessary and either all
3381 or none of the upper bounds; no strides are allowed. If the
3382 upper bounds are present, we may do rank remapping. */
3383 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3385 if (!ref
->u
.ar
.start
[dim
]
3386 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3388 gfc_error ("Lower bound has to be present at %L",
3392 if (ref
->u
.ar
.stride
[dim
])
3394 gfc_error ("Stride must not be present at %L",
3400 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3403 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3404 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3406 gfc_error ("Either all or none of the upper bounds"
3407 " must be specified at %L", &lvalue
->where
);
3415 is_pure
= gfc_pure (NULL
);
3416 is_implicit_pure
= gfc_implicit_pure (NULL
);
3418 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3419 kind, etc for lvalue and rvalue must match, and rvalue must be a
3420 pure variable if we're in a pure function. */
3421 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3424 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3425 if (lvalue
->expr_type
== EXPR_VARIABLE
3426 && gfc_is_coindexed (lvalue
))
3429 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3430 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3432 gfc_error ("Pointer object at %L shall not have a coindex",
3438 /* Checks on rvalue for procedure pointer assignments. */
3443 gfc_component
*comp1
, *comp2
;
3446 attr
= gfc_expr_attr (rvalue
);
3447 if (!((rvalue
->expr_type
== EXPR_NULL
)
3448 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3449 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3450 || (rvalue
->expr_type
== EXPR_VARIABLE
3451 && attr
.flavor
== FL_PROCEDURE
)))
3453 gfc_error ("Invalid procedure pointer assignment at %L",
3457 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3459 /* Check for intrinsics. */
3460 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3461 if (!sym
->attr
.intrinsic
3462 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3463 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3465 sym
->attr
.intrinsic
= 1;
3466 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3467 attr
= gfc_expr_attr (rvalue
);
3469 /* Check for result of embracing function. */
3470 if (sym
->attr
.function
&& sym
->result
== sym
)
3474 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3475 if (sym
== ns
->proc_name
)
3477 gfc_error ("Function result %qs is invalid as proc-target "
3478 "in procedure pointer assignment at %L",
3479 sym
->name
, &rvalue
->where
);
3486 gfc_error ("Abstract interface %qs is invalid "
3487 "in procedure pointer assignment at %L",
3488 rvalue
->symtree
->name
, &rvalue
->where
);
3491 /* Check for F08:C729. */
3492 if (attr
.flavor
== FL_PROCEDURE
)
3494 if (attr
.proc
== PROC_ST_FUNCTION
)
3496 gfc_error ("Statement function %qs is invalid "
3497 "in procedure pointer assignment at %L",
3498 rvalue
->symtree
->name
, &rvalue
->where
);
3501 if (attr
.proc
== PROC_INTERNAL
&&
3502 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3503 "is invalid in procedure pointer assignment "
3504 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3506 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3507 attr
.subroutine
) == 0)
3509 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3510 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3514 /* Check for F08:C730. */
3515 if (attr
.elemental
&& !attr
.intrinsic
)
3517 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3518 "in procedure pointer assignment at %L",
3519 rvalue
->symtree
->name
, &rvalue
->where
);
3523 /* Ensure that the calling convention is the same. As other attributes
3524 such as DLLEXPORT may differ, one explicitly only tests for the
3525 calling conventions. */
3526 if (rvalue
->expr_type
== EXPR_VARIABLE
3527 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3528 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3530 symbol_attribute calls
;
3533 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3534 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3535 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3537 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3538 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3540 gfc_error ("Mismatch in the procedure pointer assignment "
3541 "at %L: mismatch in the calling convention",
3547 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3549 s1
= comp1
->ts
.interface
;
3552 s1
= lvalue
->symtree
->n
.sym
;
3553 if (s1
->ts
.interface
)
3554 s1
= s1
->ts
.interface
;
3557 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3560 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3562 s2
= comp2
->ts
.interface
->result
;
3567 s2
= comp2
->ts
.interface
;
3571 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3573 if (rvalue
->value
.function
.esym
)
3574 s2
= rvalue
->value
.function
.esym
->result
;
3576 s2
= rvalue
->symtree
->n
.sym
->result
;
3582 s2
= rvalue
->symtree
->n
.sym
;
3586 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3587 s2
= s2
->ts
.interface
;
3589 /* Special check for the case of absent interface on the lvalue.
3590 * All other interface checks are done below. */
3591 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
3593 gfc_error ("Interface mismatch in procedure pointer assignment "
3594 "at %L: '%s' is not a subroutine", &rvalue
->where
, name
);
3598 if (s1
== s2
|| !s1
|| !s2
)
3601 /* F08:7.2.2.4 (4) */
3602 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
3603 && gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3605 gfc_error ("Explicit interface required for %qs at %L: %s",
3606 s1
->name
, &lvalue
->where
, err
);
3609 if (s2
->attr
.if_source
== IFSRC_UNKNOWN
3610 && gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3612 gfc_error ("Explicit interface required for %qs at %L: %s",
3613 s2
->name
, &rvalue
->where
, err
);
3617 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3618 err
, sizeof(err
), NULL
, NULL
))
3620 gfc_error ("Interface mismatch in procedure pointer assignment "
3621 "at %L: %s", &rvalue
->where
, err
);
3625 /* Check F2008Cor2, C729. */
3626 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
3627 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
3629 gfc_error ("Procedure pointer target %qs at %L must be either an "
3630 "intrinsic, host or use associated, referenced or have "
3631 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
3638 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3640 /* Check for F03:C717. */
3641 if (UNLIMITED_POLY (rvalue
)
3642 && !(UNLIMITED_POLY (lvalue
)
3643 || (lvalue
->ts
.type
== BT_DERIVED
3644 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3645 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3646 gfc_error ("Data-pointer-object at %L must be unlimited "
3647 "polymorphic, or of a type with the BIND or SEQUENCE "
3648 "attribute, to be compatible with an unlimited "
3649 "polymorphic target", &lvalue
->where
);
3651 gfc_error ("Different types in pointer assignment at %L; "
3652 "attempted assignment of %s to %s", &lvalue
->where
,
3653 gfc_typename (&rvalue
->ts
),
3654 gfc_typename (&lvalue
->ts
));
3658 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3660 gfc_error ("Different kind type parameters in pointer "
3661 "assignment at %L", &lvalue
->where
);
3665 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3667 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3671 /* Make sure the vtab is present. */
3672 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
3673 gfc_find_vtab (&rvalue
->ts
);
3675 /* Check rank remapping. */
3680 /* If this can be determined, check that the target must be at least as
3681 large as the pointer assigned to it is. */
3682 if (gfc_array_size (lvalue
, &lsize
)
3683 && gfc_array_size (rvalue
, &rsize
)
3684 && mpz_cmp (rsize
, lsize
) < 0)
3686 gfc_error ("Rank remapping target is smaller than size of the"
3687 " pointer (%ld < %ld) at %L",
3688 mpz_get_si (rsize
), mpz_get_si (lsize
),
3693 /* The target must be either rank one or it must be simply contiguous
3694 and F2008 must be allowed. */
3695 if (rvalue
->rank
!= 1)
3697 if (!gfc_is_simply_contiguous (rvalue
, true, false))
3699 gfc_error ("Rank remapping target must be rank 1 or"
3700 " simply contiguous at %L", &rvalue
->where
);
3703 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
3704 "rank 1 at %L", &rvalue
->where
))
3709 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3710 if (rvalue
->expr_type
== EXPR_NULL
)
3713 if (lvalue
->ts
.type
== BT_CHARACTER
)
3715 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3720 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3721 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3723 attr
= gfc_expr_attr (rvalue
);
3725 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3727 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
3728 to caf_get. Map this to the same error message as below when it is
3729 still a variable expression. */
3730 if (rvalue
->value
.function
.isym
3731 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3732 /* The test above might need to be extend when F08, Note 5.4 has to be
3733 interpreted in the way that target and pointer with the same coindex
3735 gfc_error ("Data target at %L shall not have a coindex",
3738 gfc_error ("Target expression in pointer assignment "
3739 "at %L must deliver a pointer result",
3744 if (!attr
.target
&& !attr
.pointer
)
3746 gfc_error ("Pointer assignment target is neither TARGET "
3747 "nor POINTER at %L", &rvalue
->where
);
3751 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3753 gfc_error ("Bad target in pointer assignment in PURE "
3754 "procedure at %L", &rvalue
->where
);
3757 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3758 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3760 if (gfc_has_vector_index (rvalue
))
3762 gfc_error ("Pointer assignment with vector subscript "
3763 "on rhs at %L", &rvalue
->where
);
3767 if (attr
.is_protected
&& attr
.use_assoc
3768 && !(attr
.pointer
|| attr
.proc_pointer
))
3770 gfc_error ("Pointer assignment target has PROTECTED "
3771 "attribute at %L", &rvalue
->where
);
3775 /* F2008, C725. For PURE also C1283. */
3776 if (rvalue
->expr_type
== EXPR_VARIABLE
3777 && gfc_is_coindexed (rvalue
))
3780 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3781 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3783 gfc_error ("Data target at %L shall not have a coindex",
3789 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3790 if (warn_target_lifetime
3791 && rvalue
->expr_type
== EXPR_VARIABLE
3792 && !rvalue
->symtree
->n
.sym
->attr
.save
3793 && !attr
.pointer
&& !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3794 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3795 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3796 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3801 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3802 || lvalue
->symtree
->n
.sym
->attr
.result
3803 || lvalue
->symtree
->n
.sym
->attr
.function
3804 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3805 && lvalue
->symtree
->n
.sym
->ns
3806 != rvalue
->symtree
->n
.sym
->ns
)
3807 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3808 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3810 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3811 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3812 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3813 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3814 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3816 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3823 gfc_warning (OPT_Wtarget_lifetime
,
3824 "Pointer at %L in pointer assignment might outlive the "
3825 "pointer target", &lvalue
->where
);
3832 /* Relative of gfc_check_assign() except that the lvalue is a single
3833 symbol. Used for initialization assignments. */
3836 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3840 bool pointer
, proc_pointer
;
3842 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3844 lvalue
.expr_type
= EXPR_VARIABLE
;
3845 lvalue
.ts
= sym
->ts
;
3847 lvalue
.rank
= sym
->as
->rank
;
3848 lvalue
.symtree
= XCNEW (gfc_symtree
);
3849 lvalue
.symtree
->n
.sym
= sym
;
3850 lvalue
.where
= sym
->declared_at
;
3854 lvalue
.ref
= gfc_get_ref ();
3855 lvalue
.ref
->type
= REF_COMPONENT
;
3856 lvalue
.ref
->u
.c
.component
= comp
;
3857 lvalue
.ref
->u
.c
.sym
= sym
;
3858 lvalue
.ts
= comp
->ts
;
3859 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
3860 lvalue
.where
= comp
->loc
;
3861 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3862 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
3863 proc_pointer
= comp
->attr
.proc_pointer
;
3867 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3868 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
3869 proc_pointer
= sym
->attr
.proc_pointer
;
3872 if (pointer
|| proc_pointer
)
3873 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3876 /* If a conversion function, e.g., __convert_i8_i4, was inserted
3877 into an array constructor, we should check if it can be reduced
3878 as an initialization expression. */
3879 if (rvalue
->expr_type
== EXPR_FUNCTION
3880 && rvalue
->value
.function
.isym
3881 && (rvalue
->value
.function
.isym
->conversion
== 1))
3882 gfc_check_init_expr (rvalue
);
3884 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3887 free (lvalue
.symtree
);
3893 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3895 /* F08:C461. Additional checks for pointer initialization. */
3896 symbol_attribute attr
;
3897 attr
= gfc_expr_attr (rvalue
);
3898 if (attr
.allocatable
)
3900 gfc_error ("Pointer initialization target at %L "
3901 "must not be ALLOCATABLE", &rvalue
->where
);
3904 if (!attr
.target
|| attr
.pointer
)
3906 gfc_error ("Pointer initialization target at %L "
3907 "must have the TARGET attribute", &rvalue
->where
);
3911 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
3912 && rvalue
->symtree
->n
.sym
->ns
->proc_name
3913 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
3915 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
3916 attr
.save
= SAVE_IMPLICIT
;
3921 gfc_error ("Pointer initialization target at %L "
3922 "must have the SAVE attribute", &rvalue
->where
);
3927 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3929 /* F08:C1220. Additional checks for procedure pointer initialization. */
3930 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3931 if (attr
.proc_pointer
)
3933 gfc_error ("Procedure pointer initialization target at %L "
3934 "may not be a procedure pointer", &rvalue
->where
);
3943 /* Build an initializer for a local integer, real, complex, logical, or
3944 character variable, based on the command line flags finit-local-zero,
3945 finit-integer=, finit-real=, finit-logical=, and finit-character=. */
3948 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
3951 gfc_expr
*init_expr
;
3954 /* Try to build an initializer expression. */
3955 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
3957 /* We will only initialize integers, reals, complex, logicals, and
3958 characters, and only if the corresponding command-line flags
3959 were set. Otherwise, we free init_expr and return null. */
3963 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
3964 mpz_set_si (init_expr
->value
.integer
,
3965 gfc_option
.flag_init_integer_value
);
3968 gfc_free_expr (init_expr
);
3974 switch (flag_init_real
)
3976 case GFC_INIT_REAL_SNAN
:
3977 init_expr
->is_snan
= 1;
3979 case GFC_INIT_REAL_NAN
:
3980 mpfr_set_nan (init_expr
->value
.real
);
3983 case GFC_INIT_REAL_INF
:
3984 mpfr_set_inf (init_expr
->value
.real
, 1);
3987 case GFC_INIT_REAL_NEG_INF
:
3988 mpfr_set_inf (init_expr
->value
.real
, -1);
3991 case GFC_INIT_REAL_ZERO
:
3992 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
3996 gfc_free_expr (init_expr
);
4003 switch (flag_init_real
)
4005 case GFC_INIT_REAL_SNAN
:
4006 init_expr
->is_snan
= 1;
4008 case GFC_INIT_REAL_NAN
:
4009 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4010 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4013 case GFC_INIT_REAL_INF
:
4014 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4015 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4018 case GFC_INIT_REAL_NEG_INF
:
4019 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4020 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4023 case GFC_INIT_REAL_ZERO
:
4024 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4028 gfc_free_expr (init_expr
);
4035 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
4036 init_expr
->value
.logical
= 0;
4037 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
4038 init_expr
->value
.logical
= 1;
4041 gfc_free_expr (init_expr
);
4047 /* For characters, the length must be constant in order to
4048 create a default initializer. */
4049 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
4051 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4053 char_len
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
4054 init_expr
->value
.character
.length
= char_len
;
4055 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4056 for (i
= 0; i
< char_len
; i
++)
4057 init_expr
->value
.character
.string
[i
]
4058 = (unsigned char) gfc_option
.flag_init_character_value
;
4062 gfc_free_expr (init_expr
);
4065 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
4066 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4068 gfc_actual_arglist
*arg
;
4069 init_expr
= gfc_get_expr ();
4070 init_expr
->where
= *where
;
4071 init_expr
->ts
= *ts
;
4072 init_expr
->expr_type
= EXPR_FUNCTION
;
4073 init_expr
->value
.function
.isym
=
4074 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4075 init_expr
->value
.function
.name
= "repeat";
4076 arg
= gfc_get_actual_arglist ();
4077 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4078 arg
->expr
->value
.character
.string
[0] =
4079 gfc_option
.flag_init_character_value
;
4080 arg
->next
= gfc_get_actual_arglist ();
4081 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4082 init_expr
->value
.function
.actual
= arg
;
4087 gfc_free_expr (init_expr
);
4094 /* Apply an initialization expression to a typespec. Can be used for symbols or
4095 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4096 combined with some effort. */
4099 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4101 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4103 && ts
->u
.cl
->length
&& ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4107 gcc_assert (ts
->u
.cl
&& ts
->u
.cl
->length
);
4108 gcc_assert (ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
4109 gcc_assert (ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
);
4111 len
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
4113 if (init
->expr_type
== EXPR_CONSTANT
)
4114 gfc_set_constant_character_len (len
, init
, -1);
4117 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4118 init
->ts
.u
.cl
->length
->value
.integer
))
4120 gfc_constructor
*ctor
;
4121 ctor
= gfc_constructor_first (init
->value
.constructor
);
4126 bool has_ts
= (init
->ts
.u
.cl
4127 && init
->ts
.u
.cl
->length_from_typespec
);
4129 /* Remember the length of the first element for checking
4130 that all elements *in the constructor* have the same
4131 length. This need not be the length of the LHS! */
4132 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4133 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4134 first_len
= ctor
->expr
->value
.character
.length
;
4136 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4137 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4139 gfc_set_constant_character_len (len
, ctor
->expr
,
4140 has_ts
? -1 : first_len
);
4141 if (!ctor
->expr
->ts
.u
.cl
)
4143 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4145 ctor
->expr
->ts
.u
.cl
->length
4146 = gfc_copy_expr (ts
->u
.cl
->length
);
4154 /* Check whether an expression is a structure constructor and whether it has
4155 other values than NULL. */
4158 is_non_empty_structure_constructor (gfc_expr
* e
)
4160 if (e
->expr_type
!= EXPR_STRUCTURE
)
4163 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4166 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4168 cons
= gfc_constructor_next (cons
);
4174 /* Check for default initializer; sym->value is not enough
4175 as it is also set for EXPR_NULL of allocatables. */
4178 gfc_has_default_initializer (gfc_symbol
*der
)
4182 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4183 for (c
= der
->components
; c
; c
= c
->next
)
4184 if (gfc_bt_struct (c
->ts
.type
))
4186 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4187 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4189 && is_non_empty_structure_constructor (c
->initializer
))
4190 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4192 if (c
->attr
.pointer
&& c
->initializer
)
4206 Generate an initializer expression which initializes the entirety of a union.
4207 A normal structure constructor is insufficient without undue effort, because
4208 components of maps may be oddly aligned/overlapped. (For example if a
4209 character is initialized from one map overtop a real from the other, only one
4210 byte of the real is actually initialized.) Unfortunately we don't know the
4211 size of the union right now, so we can't generate a proper initializer, but
4212 we use a NULL expr as a placeholder and do the right thing later in
4213 gfc_trans_subcomponent_assign.
4216 generate_union_initializer (gfc_component
*un
)
4218 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4221 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4222 placeholder
->ts
= un
->ts
;
4227 /* Get the user-specified initializer for a union, if any. This means the user
4228 has said to initialize component(s) of a map. For simplicity's sake we
4229 only allow the user to initialize the first map. We don't have to worry
4230 about overlapping initializers as they are released early in resolution (see
4231 resolve_fl_struct). */
4234 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4237 gfc_expr
*init
=NULL
;
4239 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4242 for (map
= union_type
->components
; map
; map
= map
->next
)
4244 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4246 init
= gfc_default_initializer (&map
->ts
);
4259 /* Fetch or generate an initializer for the given component.
4260 Only generate an initializer if generate is true. */
4263 component_initializer (gfc_typespec
*ts
, gfc_component
*c
, bool generate
)
4265 gfc_expr
*init
= NULL
;
4267 /* See if we can find the initializer immediately. */
4268 if (c
->initializer
|| !generate
4269 || (ts
->type
== BT_CLASS
&& !c
->attr
.allocatable
))
4270 return c
->initializer
;
4272 /* Recursively handle derived type components. */
4273 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4274 init
= gfc_generate_initializer (&c
->ts
, true);
4276 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4278 gfc_component
*map
= NULL
;
4279 gfc_constructor
*ctor
;
4280 gfc_expr
*user_init
;
4282 /* If we don't have a user initializer and we aren't generating one, this
4283 union has no initializer. */
4284 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4285 if (!user_init
&& !generate
)
4288 /* Otherwise use a structure constructor. */
4289 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4293 /* If we are to generate an initializer for the union, add a constructor
4294 which initializes the whole union first. */
4297 ctor
= gfc_constructor_get ();
4298 ctor
->expr
= generate_union_initializer (c
);
4299 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4302 /* If we found an initializer in one of our maps, apply it. Note this
4303 is applied _after_ the entire-union initializer above if any. */
4306 ctor
= gfc_constructor_get ();
4307 ctor
->expr
= user_init
;
4308 ctor
->n
.component
= map
;
4309 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4313 /* Treat simple components like locals. */
4316 init
= gfc_build_default_init_expr (&c
->ts
, &c
->loc
);
4317 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4324 /* Get an expression for a default initializer of a derived type. */
4327 gfc_default_initializer (gfc_typespec
*ts
)
4329 return gfc_generate_initializer (ts
, false);
4333 /* Get or generate an expression for a default initializer of a derived type.
4334 If -finit-derived is specified, generate default initialization expressions
4335 for components that lack them when generate is set. */
4338 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4340 gfc_expr
*init
, *tmp
;
4341 gfc_component
*comp
;
4342 generate
= flag_init_derived
&& generate
;
4344 /* See if we have a default initializer in this, but not in nested
4345 types (otherwise we could use gfc_has_default_initializer()).
4346 We don't need to check if we are going to generate them. */
4347 comp
= ts
->u
.derived
->components
;
4350 for (; comp
; comp
= comp
->next
)
4351 if (comp
->initializer
|| comp
->attr
.allocatable
4352 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4353 && CLASS_DATA (comp
)->attr
.allocatable
))
4360 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4361 &ts
->u
.derived
->declared_at
);
4364 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4366 gfc_constructor
*ctor
= gfc_constructor_get();
4368 /* Fetch or generate an initializer for the component. */
4369 tmp
= component_initializer (ts
, comp
, generate
);
4372 /* Save the component ref for STRUCTUREs and UNIONs. */
4373 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4374 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4375 ctor
->n
.component
= comp
;
4377 /* If the initializer was not generated, we need a copy. */
4378 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4379 if ((comp
->ts
.type
!= tmp
->ts
.type
4380 || comp
->ts
.kind
!= tmp
->ts
.kind
)
4381 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4382 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
4385 if (comp
->attr
.allocatable
4386 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
4388 ctor
->expr
= gfc_get_expr ();
4389 ctor
->expr
->expr_type
= EXPR_NULL
;
4390 ctor
->expr
->where
= init
->where
;
4391 ctor
->expr
->ts
= comp
->ts
;
4394 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4401 /* Given a symbol, create an expression node with that symbol as a
4402 variable. If the symbol is array valued, setup a reference of the
4406 gfc_get_variable_expr (gfc_symtree
*var
)
4410 e
= gfc_get_expr ();
4411 e
->expr_type
= EXPR_VARIABLE
;
4413 e
->ts
= var
->n
.sym
->ts
;
4415 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
4416 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
4417 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
4418 && CLASS_DATA (var
->n
.sym
)->as
)))
4420 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
4421 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
4422 e
->ref
= gfc_get_ref ();
4423 e
->ref
->type
= REF_ARRAY
;
4424 e
->ref
->u
.ar
.type
= AR_FULL
;
4425 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
4426 ? CLASS_DATA (var
->n
.sym
)->as
4434 /* Adds a full array reference to an expression, as needed. */
4437 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4440 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4445 ref
->next
= gfc_get_ref ();
4450 e
->ref
= gfc_get_ref ();
4453 ref
->type
= REF_ARRAY
;
4454 ref
->u
.ar
.type
= AR_FULL
;
4455 ref
->u
.ar
.dimen
= e
->rank
;
4456 ref
->u
.ar
.where
= e
->where
;
4462 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4466 lval
= gfc_get_expr ();
4467 lval
->expr_type
= EXPR_VARIABLE
;
4468 lval
->where
= sym
->declared_at
;
4470 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4472 /* It will always be a full array. */
4473 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
4474 lval
->rank
= as
? as
->rank
: 0;
4476 gfc_add_full_array_ref (lval
, as
);
4481 /* Returns the array_spec of a full array expression. A NULL is
4482 returned otherwise. */
4484 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4489 if (expr
->rank
== 0)
4492 /* Follow any component references. */
4493 if (expr
->expr_type
== EXPR_VARIABLE
4494 || expr
->expr_type
== EXPR_CONSTANT
)
4496 as
= expr
->symtree
->n
.sym
->as
;
4497 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4502 as
= ref
->u
.c
.component
->as
;
4510 switch (ref
->u
.ar
.type
)
4533 /* General expression traversal function. */
4536 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4537 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4542 gfc_actual_arglist
*args
;
4549 if ((*func
) (expr
, sym
, &f
))
4552 if (expr
->ts
.type
== BT_CHARACTER
4554 && expr
->ts
.u
.cl
->length
4555 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4556 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4559 switch (expr
->expr_type
)
4564 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4566 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4574 case EXPR_SUBSTRING
:
4577 case EXPR_STRUCTURE
:
4579 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4580 c
; c
= gfc_constructor_next (c
))
4582 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4586 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4588 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4590 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4592 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4599 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4601 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4617 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4619 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4621 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4623 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4629 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4631 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4636 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4637 && ref
->u
.c
.component
->ts
.u
.cl
4638 && ref
->u
.c
.component
->ts
.u
.cl
->length
4639 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4641 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4645 if (ref
->u
.c
.component
->as
)
4646 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4647 + ref
->u
.c
.component
->as
->corank
; i
++)
4649 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4652 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4666 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4669 expr_set_symbols_referenced (gfc_expr
*expr
,
4670 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4671 int *f ATTRIBUTE_UNUSED
)
4673 if (expr
->expr_type
!= EXPR_VARIABLE
)
4675 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4680 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4682 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4686 /* Determine if an expression is a procedure pointer component and return
4687 the component in that case. Otherwise return NULL. */
4690 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4694 if (!expr
|| !expr
->ref
)
4701 if (ref
->type
== REF_COMPONENT
4702 && ref
->u
.c
.component
->attr
.proc_pointer
)
4703 return ref
->u
.c
.component
;
4709 /* Determine if an expression is a procedure pointer component. */
4712 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4714 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4718 /* Determine if an expression is a function with an allocatable class scalar
4721 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
4723 if (expr
->expr_type
== EXPR_FUNCTION
4724 && expr
->value
.function
.esym
4725 && expr
->value
.function
.esym
->result
4726 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4727 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4728 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4735 /* Determine if an expression is a function with an allocatable class array
4738 gfc_is_alloc_class_array_function (gfc_expr
*expr
)
4740 if (expr
->expr_type
== EXPR_FUNCTION
4741 && expr
->value
.function
.esym
4742 && expr
->value
.function
.esym
->result
4743 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4744 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4745 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4752 /* Walk an expression tree and check each variable encountered for being typed.
4753 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4754 mode as is a basic arithmetic expression using those; this is for things in
4757 INTEGER :: arr(n), n
4758 INTEGER :: arr(n + 1), n
4760 The namespace is needed for IMPLICIT typing. */
4762 static gfc_namespace
* check_typed_ns
;
4765 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4766 int* f ATTRIBUTE_UNUSED
)
4770 if (e
->expr_type
!= EXPR_VARIABLE
)
4773 gcc_assert (e
->symtree
);
4774 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4781 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4785 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4789 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4790 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4792 if (e
->expr_type
== EXPR_OP
)
4796 gcc_assert (e
->value
.op
.op1
);
4797 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4799 if (t
&& e
->value
.op
.op2
)
4800 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4806 /* Otherwise, walk the expression and do it strictly. */
4807 check_typed_ns
= ns
;
4808 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4810 return error_found
? false : true;
4815 gfc_ref_this_image (gfc_ref
*ref
)
4819 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4821 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4822 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4829 gfc_find_stat_co(gfc_expr
*e
)
4833 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4834 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4835 return ref
->u
.ar
.stat
;
4837 if (e
->value
.function
.actual
->expr
)
4838 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
4840 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4841 return ref
->u
.ar
.stat
;
4847 gfc_is_coindexed (gfc_expr
*e
)
4851 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4852 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4853 return !gfc_ref_this_image (ref
);
4859 /* Coarrays are variables with a corank but not being coindexed. However, also
4860 the following is a coarray: A subobject of a coarray is a coarray if it does
4861 not have any cosubscripts, vector subscripts, allocatable component
4862 selection, or pointer component selection. (F2008, 2.4.7) */
4865 gfc_is_coarray (gfc_expr
*e
)
4869 gfc_component
*comp
;
4874 if (e
->expr_type
!= EXPR_VARIABLE
)
4878 sym
= e
->symtree
->n
.sym
;
4880 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4881 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4883 coarray
= sym
->attr
.codimension
;
4885 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4889 comp
= ref
->u
.c
.component
;
4890 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4891 && (CLASS_DATA (comp
)->attr
.class_pointer
4892 || CLASS_DATA (comp
)->attr
.allocatable
))
4895 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4897 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4900 coarray
= comp
->attr
.codimension
;
4908 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4914 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4915 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4926 return coarray
&& !coindexed
;
4931 gfc_get_corank (gfc_expr
*e
)
4936 if (!gfc_is_coarray (e
))
4939 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4940 corank
= e
->ts
.u
.derived
->components
->as
4941 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4943 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4945 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4947 if (ref
->type
== REF_ARRAY
)
4948 corank
= ref
->u
.ar
.as
->corank
;
4949 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4956 /* Check whether the expression has an ultimate allocatable component.
4957 Being itself allocatable does not count. */
4959 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4961 gfc_ref
*ref
, *last
= NULL
;
4963 if (e
->expr_type
!= EXPR_VARIABLE
)
4966 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4967 if (ref
->type
== REF_COMPONENT
)
4970 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4971 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4972 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4973 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4977 if (e
->ts
.type
== BT_CLASS
)
4978 return CLASS_DATA (e
)->attr
.alloc_comp
;
4979 else if (e
->ts
.type
== BT_DERIVED
)
4980 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4986 /* Check whether the expression has an pointer component.
4987 Being itself a pointer does not count. */
4989 gfc_has_ultimate_pointer (gfc_expr
*e
)
4991 gfc_ref
*ref
, *last
= NULL
;
4993 if (e
->expr_type
!= EXPR_VARIABLE
)
4996 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4997 if (ref
->type
== REF_COMPONENT
)
5000 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5001 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5002 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5003 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5007 if (e
->ts
.type
== BT_CLASS
)
5008 return CLASS_DATA (e
)->attr
.pointer_comp
;
5009 else if (e
->ts
.type
== BT_DERIVED
)
5010 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5016 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5017 Note: A scalar is not regarded as "simply contiguous" by the standard.
5018 if bool is not strict, some further checks are done - for instance,
5019 a "(::1)" is accepted. */
5022 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5026 gfc_array_ref
*ar
= NULL
;
5027 gfc_ref
*ref
, *part_ref
= NULL
;
5030 if (expr
->expr_type
== EXPR_FUNCTION
)
5031 return expr
->value
.function
.esym
5032 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
5033 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5036 if (!permit_element
&& expr
->rank
== 0)
5039 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5042 return false; /* Array shall be last part-ref. */
5044 if (ref
->type
== REF_COMPONENT
)
5046 else if (ref
->type
== REF_SUBSTRING
)
5048 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5052 sym
= expr
->symtree
->n
.sym
;
5053 if (expr
->ts
.type
!= BT_CLASS
5055 && !part_ref
->u
.c
.component
->attr
.contiguous
5056 && part_ref
->u
.c
.component
->attr
.pointer
)
5058 && !sym
->attr
.contiguous
5059 && (sym
->attr
.pointer
5060 || sym
->as
->type
== AS_ASSUMED_RANK
5061 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
5064 if (!ar
|| ar
->type
== AR_FULL
)
5067 gcc_assert (ar
->type
== AR_SECTION
);
5069 /* Check for simply contiguous array */
5071 for (i
= 0; i
< ar
->dimen
; i
++)
5073 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5076 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5082 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5085 /* If the previous section was not contiguous, that's an error,
5086 unless we have effective only one element and checking is not
5088 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5089 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5090 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5091 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5092 ar
->end
[i
]->value
.integer
) != 0))
5095 /* Following the standard, "(::1)" or - if known at compile time -
5096 "(lbound:ubound)" are not simply contiguous; if strict
5097 is false, they are regarded as simply contiguous. */
5098 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5099 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5100 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5104 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5105 || !ar
->as
->lower
[i
]
5106 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5107 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5108 ar
->as
->lower
[i
]->value
.integer
) != 0))
5112 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5113 || !ar
->as
->upper
[i
]
5114 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5115 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5116 ar
->as
->upper
[i
]->value
.integer
) != 0))
5124 /* Build call to an intrinsic procedure. The number of arguments has to be
5125 passed (rather than ending the list with a NULL value) because we may
5126 want to add arguments but with a NULL-expression. */
5129 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5130 locus where
, unsigned numarg
, ...)
5133 gfc_actual_arglist
* atail
;
5134 gfc_intrinsic_sym
* isym
;
5137 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5139 isym
= gfc_intrinsic_function_by_id (id
);
5142 result
= gfc_get_expr ();
5143 result
->expr_type
= EXPR_FUNCTION
;
5144 result
->ts
= isym
->ts
;
5145 result
->where
= where
;
5146 result
->value
.function
.name
= mangled_name
;
5147 result
->value
.function
.isym
= isym
;
5149 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5150 gfc_commit_symbol (result
->symtree
->n
.sym
);
5151 gcc_assert (result
->symtree
5152 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5153 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5154 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5155 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5156 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5157 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5159 va_start (ap
, numarg
);
5161 for (i
= 0; i
< numarg
; ++i
)
5165 atail
->next
= gfc_get_actual_arglist ();
5166 atail
= atail
->next
;
5169 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5171 atail
->expr
= va_arg (ap
, gfc_expr
*);
5179 /* Check if an expression may appear in a variable definition context
5180 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5181 This is called from the various places when resolving
5182 the pieces that make up such a context.
5183 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5184 variables), some checks are not performed.
5186 Optionally, a possible error message can be suppressed if context is NULL
5187 and just the return status (true / false) be requested. */
5190 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5191 bool own_scope
, const char* context
)
5193 gfc_symbol
* sym
= NULL
;
5195 bool check_intentin
;
5197 symbol_attribute attr
;
5201 if (e
->expr_type
== EXPR_VARIABLE
)
5203 gcc_assert (e
->symtree
);
5204 sym
= e
->symtree
->n
.sym
;
5206 else if (e
->expr_type
== EXPR_FUNCTION
)
5208 gcc_assert (e
->symtree
);
5209 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5212 attr
= gfc_expr_attr (e
);
5213 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5215 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5218 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5219 " context (%s) at %L", context
, &e
->where
);
5223 else if (e
->expr_type
!= EXPR_VARIABLE
)
5226 gfc_error ("Non-variable expression in variable definition context (%s)"
5227 " at %L", context
, &e
->where
);
5231 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
5234 gfc_error ("Named constant %qs in variable definition context (%s)"
5235 " at %L", sym
->name
, context
, &e
->where
);
5238 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
5239 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
5240 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5243 gfc_error ("%qs in variable definition context (%s) at %L is not"
5244 " a variable", sym
->name
, context
, &e
->where
);
5248 /* Find out whether the expr is a pointer; this also means following
5249 component references to the last one. */
5250 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
5251 if (pointer
&& !is_pointer
)
5254 gfc_error ("Non-POINTER in pointer association context (%s)"
5255 " at %L", context
, &e
->where
);
5259 if (e
->ts
.type
== BT_DERIVED
5260 && e
->ts
.u
.derived
== NULL
)
5263 gfc_error ("Type inaccessible in variable definition context (%s) "
5264 "at %L", context
, &e
->where
);
5271 || (e
->ts
.type
== BT_DERIVED
5272 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5273 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
5276 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5277 context
, &e
->where
);
5281 /* TS18508, C702/C203. */
5284 || (e
->ts
.type
== BT_DERIVED
5285 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5286 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
5289 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5290 context
, &e
->where
);
5294 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5295 component of sub-component of a pointer; we need to distinguish
5296 assignment to a pointer component from pointer-assignment to a pointer
5297 component. Note that (normal) assignment to procedure pointers is not
5299 check_intentin
= !own_scope
;
5300 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5301 && CLASS_DATA (sym
))
5302 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
5303 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
5305 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
5306 check_intentin
= false;
5307 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
5309 ptr_component
= true;
5311 check_intentin
= false;
5314 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
5316 if (pointer
&& is_pointer
)
5319 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5320 " association context (%s) at %L",
5321 sym
->name
, context
, &e
->where
);
5324 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
5327 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5328 " definition context (%s) at %L",
5329 sym
->name
, context
, &e
->where
);
5334 /* PROTECTED and use-associated. */
5335 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
5337 if (pointer
&& is_pointer
)
5340 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5341 " pointer association context (%s) at %L",
5342 sym
->name
, context
, &e
->where
);
5345 if (!pointer
&& !is_pointer
)
5348 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5349 " variable definition context (%s) at %L",
5350 sym
->name
, context
, &e
->where
);
5355 /* Variable not assignable from a PURE procedure but appears in
5356 variable definition context. */
5357 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
5360 gfc_error ("Variable %qs can not appear in a variable definition"
5361 " context (%s) at %L in PURE procedure",
5362 sym
->name
, context
, &e
->where
);
5366 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
5367 && gfc_impure_variable (sym
))
5372 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5374 sym
= ns
->proc_name
;
5377 if (sym
->attr
.flavor
== FL_PROCEDURE
)
5379 sym
->attr
.implicit_pure
= 0;
5384 /* Check variable definition context for associate-names. */
5385 if (!pointer
&& sym
->assoc
)
5388 gfc_association_list
* assoc
;
5390 gcc_assert (sym
->assoc
->target
);
5392 /* If this is a SELECT TYPE temporary (the association is used internally
5393 for SELECT TYPE), silently go over to the target. */
5394 if (sym
->attr
.select_type_temporary
)
5396 gfc_expr
* t
= sym
->assoc
->target
;
5398 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
5399 name
= t
->symtree
->name
;
5401 if (t
->symtree
->n
.sym
->assoc
)
5402 assoc
= t
->symtree
->n
.sym
->assoc
;
5411 gcc_assert (name
&& assoc
);
5413 /* Is association to a valid variable? */
5414 if (!assoc
->variable
)
5418 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
5419 gfc_error ("%qs at %L associated to vector-indexed target can"
5420 " not be used in a variable definition context (%s)",
5421 name
, &e
->where
, context
);
5423 gfc_error ("%qs at %L associated to expression can"
5424 " not be used in a variable definition context (%s)",
5425 name
, &e
->where
, context
);
5430 /* Target must be allowed to appear in a variable definition context. */
5431 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
5434 gfc_error ("Associate-name %qs can not appear in a variable"
5435 " definition context (%s) at %L because its target"
5436 " at %L can not, either",
5437 name
, context
, &e
->where
,
5438 &assoc
->target
->where
);
5443 /* Check for same value in vector expression subscript. */
5446 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
5447 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5448 for (i
= 0; i
< GFC_MAX_DIMENSIONS
5449 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
5450 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5452 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
5453 if (arr
->expr_type
== EXPR_ARRAY
)
5455 gfc_constructor
*c
, *n
;
5458 for (c
= gfc_constructor_first (arr
->value
.constructor
);
5459 c
!= NULL
; c
= gfc_constructor_next (c
))
5461 if (c
== NULL
|| c
->iterator
!= NULL
)
5466 for (n
= gfc_constructor_next (c
); n
!= NULL
;
5467 n
= gfc_constructor_next (n
))
5469 if (n
->iterator
!= NULL
)
5473 if (gfc_dep_compare_expr (ec
, en
) == 0)
5476 gfc_error_now ("Elements with the same value "
5477 "at %L and %L in vector "
5478 "subscript in a variable "
5479 "definition context (%s)",
5480 &(ec
->where
), &(en
->where
),