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"
33 /* The following set of functions provide access to gfc_expr* of
34 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
36 There are two functions available elsewhere that provide
37 slightly different flavours of variables. Namely:
38 expr.c (gfc_get_variable_expr)
39 symbol.c (gfc_lval_expr_from_sym)
40 TODO: Merge these functions, if possible. */
42 /* Get a new expression node. */
50 gfc_clear_ts (&e
->ts
);
58 /* Get a new expression node that is an array constructor
59 of given type and kind. */
62 gfc_get_array_expr (bt type
, int kind
, locus
*where
)
67 e
->expr_type
= EXPR_ARRAY
;
68 e
->value
.constructor
= NULL
;
81 /* Get a new expression node that is the NULL expression. */
84 gfc_get_null_expr (locus
*where
)
89 e
->expr_type
= EXPR_NULL
;
90 e
->ts
.type
= BT_UNKNOWN
;
99 /* Get a new expression node that is an operator expression node. */
102 gfc_get_operator_expr (locus
*where
, gfc_intrinsic_op op
,
103 gfc_expr
*op1
, gfc_expr
*op2
)
108 e
->expr_type
= EXPR_OP
;
110 e
->value
.op
.op1
= op1
;
111 e
->value
.op
.op2
= op2
;
120 /* Get a new expression node that is an structure constructor
121 of given type and kind. */
124 gfc_get_structure_constructor_expr (bt type
, int kind
, locus
*where
)
129 e
->expr_type
= EXPR_STRUCTURE
;
130 e
->value
.constructor
= NULL
;
141 /* Get a new expression node that is an constant of given type and kind. */
144 gfc_get_constant_expr (bt type
, int kind
, locus
*where
)
149 gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
154 e
->expr_type
= EXPR_CONSTANT
;
162 mpz_init (e
->value
.integer
);
166 gfc_set_model_kind (kind
);
167 mpfr_init (e
->value
.real
);
171 gfc_set_model_kind (kind
);
172 mpc_init2 (e
->value
.complex, mpfr_get_default_prec());
183 /* Get a new expression node that is an string constant.
184 If no string is passed, a string of len is allocated,
185 blanked and null-terminated. */
188 gfc_get_character_expr (int kind
, locus
*where
, const char *src
, gfc_charlen_t len
)
195 dest
= gfc_get_wide_string (len
+ 1);
196 gfc_wide_memset (dest
, ' ', len
);
200 dest
= gfc_char_to_widechar (src
);
202 e
= gfc_get_constant_expr (BT_CHARACTER
, kind
,
203 where
? where
: &gfc_current_locus
);
204 e
->value
.character
.string
= dest
;
205 e
->value
.character
.length
= len
;
211 /* Get a new expression node that is an integer constant. */
214 gfc_get_int_expr (int kind
, locus
*where
, HOST_WIDE_INT value
)
217 p
= gfc_get_constant_expr (BT_INTEGER
, kind
,
218 where
? where
: &gfc_current_locus
);
220 const wide_int w
= wi::shwi (value
, kind
* BITS_PER_UNIT
);
221 wi::to_mpz (w
, p
->value
.integer
, SIGNED
);
227 /* Get a new expression node that is a logical constant. */
230 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
233 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
234 where
? where
: &gfc_current_locus
);
236 p
->value
.logical
= value
;
243 gfc_get_iokind_expr (locus
*where
, io_kind k
)
247 /* Set the types to something compatible with iokind. This is needed to
248 get through gfc_free_expr later since iokind really has no Basic Type,
252 e
->expr_type
= EXPR_CONSTANT
;
253 e
->ts
.type
= BT_LOGICAL
;
261 /* Given an expression pointer, return a copy of the expression. This
262 subroutine is recursive. */
265 gfc_copy_expr (gfc_expr
*p
)
277 switch (q
->expr_type
)
280 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
281 q
->value
.character
.string
= s
;
282 memcpy (s
, p
->value
.character
.string
,
283 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
287 /* Copy target representation, if it exists. */
288 if (p
->representation
.string
)
290 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
291 q
->representation
.string
= c
;
292 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
295 /* Copy the values of any pointer components of p->value. */
299 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
303 gfc_set_model_kind (q
->ts
.kind
);
304 mpfr_init (q
->value
.real
);
305 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
309 gfc_set_model_kind (q
->ts
.kind
);
310 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
311 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
315 if (p
->representation
.string
)
316 q
->value
.character
.string
317 = gfc_char_to_widechar (q
->representation
.string
);
320 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
321 q
->value
.character
.string
= s
;
323 /* This is the case for the C_NULL_CHAR named constant. */
324 if (p
->value
.character
.length
== 0
325 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
328 /* Need to set the length to 1 to make sure the NUL
329 terminator is copied. */
330 q
->value
.character
.length
= 1;
333 memcpy (s
, p
->value
.character
.string
,
334 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
343 break; /* Already done. */
347 /* Should never be reached. */
349 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
356 switch (q
->value
.op
.op
)
359 case INTRINSIC_PARENTHESES
:
360 case INTRINSIC_UPLUS
:
361 case INTRINSIC_UMINUS
:
362 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
365 default: /* Binary operators. */
366 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
367 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
374 q
->value
.function
.actual
=
375 gfc_copy_actual_arglist (p
->value
.function
.actual
);
380 q
->value
.compcall
.actual
=
381 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
382 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
387 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
395 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
397 q
->ref
= gfc_copy_ref (p
->ref
);
404 gfc_clear_shape (mpz_t
*shape
, int rank
)
408 for (i
= 0; i
< rank
; i
++)
409 mpz_clear (shape
[i
]);
414 gfc_free_shape (mpz_t
**shape
, int rank
)
419 gfc_clear_shape (*shape
, rank
);
425 /* Workhorse function for gfc_free_expr() that frees everything
426 beneath an expression node, but not the node itself. This is
427 useful when we want to simplify a node and replace it with
428 something else or the expression node belongs to another structure. */
431 free_expr0 (gfc_expr
*e
)
433 switch (e
->expr_type
)
436 /* Free any parts of the value that need freeing. */
440 mpz_clear (e
->value
.integer
);
444 mpfr_clear (e
->value
.real
);
448 free (e
->value
.character
.string
);
452 mpc_clear (e
->value
.complex);
459 /* Free the representation. */
460 free (e
->representation
.string
);
465 if (e
->value
.op
.op1
!= NULL
)
466 gfc_free_expr (e
->value
.op
.op1
);
467 if (e
->value
.op
.op2
!= NULL
)
468 gfc_free_expr (e
->value
.op
.op2
);
472 gfc_free_actual_arglist (e
->value
.function
.actual
);
477 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
485 gfc_constructor_free (e
->value
.constructor
);
489 free (e
->value
.character
.string
);
496 gfc_internal_error ("free_expr0(): Bad expr type");
499 /* Free a shape array. */
500 gfc_free_shape (&e
->shape
, e
->rank
);
502 gfc_free_ref_list (e
->ref
);
504 memset (e
, '\0', sizeof (gfc_expr
));
508 /* Free an expression node and everything beneath it. */
511 gfc_free_expr (gfc_expr
*e
)
520 /* Free an argument list and everything below it. */
523 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
525 gfc_actual_arglist
*a2
;
530 gfc_free_expr (a1
->expr
);
537 /* Copy an arglist structure and all of the arguments. */
540 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
542 gfc_actual_arglist
*head
, *tail
, *new_arg
;
546 for (; p
; p
= p
->next
)
548 new_arg
= gfc_get_actual_arglist ();
551 new_arg
->expr
= gfc_copy_expr (p
->expr
);
552 new_arg
->next
= NULL
;
557 tail
->next
= new_arg
;
566 /* Free a list of reference structures. */
569 gfc_free_ref_list (gfc_ref
*p
)
581 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
583 gfc_free_expr (p
->u
.ar
.start
[i
]);
584 gfc_free_expr (p
->u
.ar
.end
[i
]);
585 gfc_free_expr (p
->u
.ar
.stride
[i
]);
591 gfc_free_expr (p
->u
.ss
.start
);
592 gfc_free_expr (p
->u
.ss
.end
);
604 /* Graft the *src expression onto the *dest subexpression. */
607 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
615 /* Try to extract an integer constant from the passed expression node.
616 Returns an error message or NULL if the result is set. It is
617 tempting to generate an error and return true or false, but
618 failure is OK for some callers. */
621 gfc_extract_int (gfc_expr
*expr
, int *result
)
623 if (expr
->expr_type
!= EXPR_CONSTANT
)
624 return _("Constant expression required at %C");
626 if (expr
->ts
.type
!= BT_INTEGER
)
627 return _("Integer expression required at %C");
629 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
630 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
632 return _("Integer value too large in expression at %C");
635 *result
= (int) mpz_get_si (expr
->value
.integer
);
641 /* Same as gfc_extract_int, but use a HWI. */
644 gfc_extract_hwi (gfc_expr
*expr
, HOST_WIDE_INT
*result
)
646 if (expr
->expr_type
!= EXPR_CONSTANT
)
647 return _("Constant expression required at %C");
649 if (expr
->ts
.type
!= BT_INTEGER
)
650 return _("Integer expression required at %C");
652 /* Use long_long_integer_type_node to determine when to saturate. */
653 const wide_int val
= wi::from_mpz (long_long_integer_type_node
,
654 expr
->value
.integer
, false);
656 if (!wi::fits_shwi_p (val
))
658 return _("Integer value too large in expression at %C");
661 *result
= val
.to_shwi ();
667 /* Recursively copy a list of reference structures. */
670 gfc_copy_ref (gfc_ref
*src
)
678 dest
= gfc_get_ref ();
679 dest
->type
= src
->type
;
684 ar
= gfc_copy_array_ref (&src
->u
.ar
);
690 dest
->u
.c
= src
->u
.c
;
694 dest
->u
.ss
= src
->u
.ss
;
695 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
696 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
700 dest
->next
= gfc_copy_ref (src
->next
);
706 /* Detect whether an expression has any vector index array references. */
709 gfc_has_vector_index (gfc_expr
*e
)
713 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
714 if (ref
->type
== REF_ARRAY
)
715 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
716 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
722 /* Copy a shape array. */
725 gfc_copy_shape (mpz_t
*shape
, int rank
)
733 new_shape
= gfc_get_shape (rank
);
735 for (n
= 0; n
< rank
; n
++)
736 mpz_init_set (new_shape
[n
], shape
[n
]);
742 /* Copy a shape array excluding dimension N, where N is an integer
743 constant expression. Dimensions are numbered in Fortran style --
746 So, if the original shape array contains R elements
747 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
748 the result contains R-1 elements:
749 { s1 ... sN-1 sN+1 ... sR-1}
751 If anything goes wrong -- N is not a constant, its value is out
752 of range -- or anything else, just returns NULL. */
755 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
757 mpz_t
*new_shape
, *s
;
763 || dim
->expr_type
!= EXPR_CONSTANT
764 || dim
->ts
.type
!= BT_INTEGER
)
767 n
= mpz_get_si (dim
->value
.integer
);
768 n
--; /* Convert to zero based index. */
769 if (n
< 0 || n
>= rank
)
772 s
= new_shape
= gfc_get_shape (rank
- 1);
774 for (i
= 0; i
< rank
; i
++)
778 mpz_init_set (*s
, shape
[i
]);
786 /* Return the maximum kind of two expressions. In general, higher
787 kind numbers mean more precision for numeric types. */
790 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
792 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
796 /* Returns nonzero if the type is numeric, zero otherwise. */
799 numeric_type (bt type
)
801 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
805 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
808 gfc_numeric_ts (gfc_typespec
*ts
)
810 return numeric_type (ts
->type
);
814 /* Return an expression node with an optional argument list attached.
815 A variable number of gfc_expr pointers are strung together in an
816 argument list with a NULL pointer terminating the list. */
819 gfc_build_conversion (gfc_expr
*e
)
824 p
->expr_type
= EXPR_FUNCTION
;
826 p
->value
.function
.actual
= gfc_get_actual_arglist ();
827 p
->value
.function
.actual
->expr
= e
;
833 /* Given an expression node with some sort of numeric binary
834 expression, insert type conversions required to make the operands
835 have the same type. Conversion warnings are disabled if wconversion
838 The exception is that the operands of an exponential don't have to
839 have the same type. If possible, the base is promoted to the type
840 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
841 1.0**2 stays as it is. */
844 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
848 op1
= e
->value
.op
.op1
;
849 op2
= e
->value
.op
.op2
;
851 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
853 gfc_clear_ts (&e
->ts
);
857 /* Kind conversions of same type. */
858 if (op1
->ts
.type
== op2
->ts
.type
)
860 if (op1
->ts
.kind
== op2
->ts
.kind
)
862 /* No type conversions. */
867 if (op1
->ts
.kind
> op2
->ts
.kind
)
868 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
870 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
876 /* Integer combined with real or complex. */
877 if (op2
->ts
.type
== BT_INTEGER
)
881 /* Special case for ** operator. */
882 if (e
->value
.op
.op
== INTRINSIC_POWER
)
885 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
889 if (op1
->ts
.type
== BT_INTEGER
)
892 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
896 /* Real combined with complex. */
897 e
->ts
.type
= BT_COMPLEX
;
898 if (op1
->ts
.kind
> op2
->ts
.kind
)
899 e
->ts
.kind
= op1
->ts
.kind
;
901 e
->ts
.kind
= op2
->ts
.kind
;
902 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
903 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
904 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
905 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
912 /* Determine if an expression is constant in the sense of F08:7.1.12.
913 * This function expects that the expression has already been simplified. */
916 gfc_is_constant_expr (gfc_expr
*e
)
919 gfc_actual_arglist
*arg
;
924 switch (e
->expr_type
)
927 return (gfc_is_constant_expr (e
->value
.op
.op1
)
928 && (e
->value
.op
.op2
== NULL
929 || gfc_is_constant_expr (e
->value
.op
.op2
)));
937 gcc_assert (e
->symtree
|| e
->value
.function
.esym
938 || e
->value
.function
.isym
);
940 /* Call to intrinsic with at least one argument. */
941 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
943 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
944 if (!gfc_is_constant_expr (arg
->expr
))
948 if (e
->value
.function
.isym
949 && (e
->value
.function
.isym
->elemental
950 || e
->value
.function
.isym
->pure
951 || e
->value
.function
.isym
->inquiry
952 || e
->value
.function
.isym
->transformational
))
962 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
963 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
967 c
= gfc_constructor_first (e
->value
.constructor
);
968 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
969 return gfc_constant_ac (e
);
971 for (; c
; c
= gfc_constructor_next (c
))
972 if (!gfc_is_constant_expr (c
->expr
))
979 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
985 /* Is true if an array reference is followed by a component or substring
988 is_subref_array (gfc_expr
* e
)
993 if (e
->expr_type
!= EXPR_VARIABLE
)
996 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
1000 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1002 if (ref
->type
== REF_ARRAY
1003 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1007 && ref
->type
!= REF_ARRAY
)
1014 /* Try to collapse intrinsic expressions. */
1017 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1019 gfc_intrinsic_op op
;
1020 gfc_expr
*op1
, *op2
, *result
;
1022 if (p
->value
.op
.op
== INTRINSIC_USER
)
1025 op1
= p
->value
.op
.op1
;
1026 op2
= p
->value
.op
.op2
;
1027 op
= p
->value
.op
.op
;
1029 if (!gfc_simplify_expr (op1
, type
))
1031 if (!gfc_simplify_expr (op2
, type
))
1034 if (!gfc_is_constant_expr (op1
)
1035 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1039 p
->value
.op
.op1
= NULL
;
1040 p
->value
.op
.op2
= NULL
;
1044 case INTRINSIC_PARENTHESES
:
1045 result
= gfc_parentheses (op1
);
1048 case INTRINSIC_UPLUS
:
1049 result
= gfc_uplus (op1
);
1052 case INTRINSIC_UMINUS
:
1053 result
= gfc_uminus (op1
);
1056 case INTRINSIC_PLUS
:
1057 result
= gfc_add (op1
, op2
);
1060 case INTRINSIC_MINUS
:
1061 result
= gfc_subtract (op1
, op2
);
1064 case INTRINSIC_TIMES
:
1065 result
= gfc_multiply (op1
, op2
);
1068 case INTRINSIC_DIVIDE
:
1069 result
= gfc_divide (op1
, op2
);
1072 case INTRINSIC_POWER
:
1073 result
= gfc_power (op1
, op2
);
1076 case INTRINSIC_CONCAT
:
1077 result
= gfc_concat (op1
, op2
);
1081 case INTRINSIC_EQ_OS
:
1082 result
= gfc_eq (op1
, op2
, op
);
1086 case INTRINSIC_NE_OS
:
1087 result
= gfc_ne (op1
, op2
, op
);
1091 case INTRINSIC_GT_OS
:
1092 result
= gfc_gt (op1
, op2
, op
);
1096 case INTRINSIC_GE_OS
:
1097 result
= gfc_ge (op1
, op2
, op
);
1101 case INTRINSIC_LT_OS
:
1102 result
= gfc_lt (op1
, op2
, op
);
1106 case INTRINSIC_LE_OS
:
1107 result
= gfc_le (op1
, op2
, op
);
1111 result
= gfc_not (op1
);
1115 result
= gfc_and (op1
, op2
);
1119 result
= gfc_or (op1
, op2
);
1123 result
= gfc_eqv (op1
, op2
);
1126 case INTRINSIC_NEQV
:
1127 result
= gfc_neqv (op1
, op2
);
1131 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1136 gfc_free_expr (op1
);
1137 gfc_free_expr (op2
);
1141 result
->rank
= p
->rank
;
1142 result
->where
= p
->where
;
1143 gfc_replace_expr (p
, result
);
1149 /* Subroutine to simplify constructor expressions. Mutually recursive
1150 with gfc_simplify_expr(). */
1153 simplify_constructor (gfc_constructor_base base
, int type
)
1158 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1161 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1162 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1163 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1168 /* Try and simplify a copy. Replace the original if successful
1169 but keep going through the constructor at all costs. Not
1170 doing so can make a dog's dinner of complicated things. */
1171 p
= gfc_copy_expr (c
->expr
);
1173 if (!gfc_simplify_expr (p
, type
))
1179 gfc_replace_expr (c
->expr
, p
);
1187 /* Pull a single array element out of an array constructor. */
1190 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1191 gfc_constructor
**rval
)
1193 unsigned long nelemen
;
1199 gfc_constructor
*cons
;
1206 mpz_init_set_ui (offset
, 0);
1209 mpz_init_set_ui (span
, 1);
1210 for (i
= 0; i
< ar
->dimen
; i
++)
1212 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1213 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1221 if (e
->expr_type
!= EXPR_CONSTANT
)
1227 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1228 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1230 /* Check the bounds. */
1231 if ((ar
->as
->upper
[i
]
1232 && mpz_cmp (e
->value
.integer
,
1233 ar
->as
->upper
[i
]->value
.integer
) > 0)
1234 || (mpz_cmp (e
->value
.integer
,
1235 ar
->as
->lower
[i
]->value
.integer
) < 0))
1237 gfc_error ("Index in dimension %d is out of bounds "
1238 "at %L", i
+ 1, &ar
->c_where
[i
]);
1244 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1245 mpz_mul (delta
, delta
, span
);
1246 mpz_add (offset
, offset
, delta
);
1248 mpz_set_ui (tmp
, 1);
1249 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1250 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1251 mpz_mul (span
, span
, tmp
);
1254 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1255 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1274 /* Find a component of a structure constructor. */
1276 static gfc_constructor
*
1277 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1279 gfc_component
*pick
= ref
->u
.c
.component
;
1280 gfc_constructor
*c
= gfc_constructor_first (base
);
1282 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1283 int ext
= dt
->attr
.extension
;
1285 /* For extended types, check if the desired component is in one of the
1287 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1288 pick
->name
, true, true, NULL
))
1290 dt
= dt
->components
->ts
.u
.derived
;
1291 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1295 gfc_component
*comp
= dt
->components
;
1296 while (comp
!= pick
)
1299 c
= gfc_constructor_next (c
);
1306 /* Replace an expression with the contents of a constructor, removing
1307 the subobject reference in the process. */
1310 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1320 e
= gfc_copy_expr (p
);
1321 e
->ref
= p
->ref
->next
;
1322 p
->ref
->next
= NULL
;
1323 gfc_replace_expr (p
, e
);
1327 /* Pull an array section out of an array constructor. */
1330 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1337 long unsigned one
= 1;
1339 mpz_t start
[GFC_MAX_DIMENSIONS
];
1340 mpz_t end
[GFC_MAX_DIMENSIONS
];
1341 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1342 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1343 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1348 gfc_constructor_base base
;
1349 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1359 base
= expr
->value
.constructor
;
1360 expr
->value
.constructor
= NULL
;
1362 rank
= ref
->u
.ar
.as
->rank
;
1364 if (expr
->shape
== NULL
)
1365 expr
->shape
= gfc_get_shape (rank
);
1367 mpz_init_set_ui (delta_mpz
, one
);
1368 mpz_init_set_ui (nelts
, one
);
1371 /* Do the initialization now, so that we can cleanup without
1372 keeping track of where we were. */
1373 for (d
= 0; d
< rank
; d
++)
1375 mpz_init (delta
[d
]);
1376 mpz_init (start
[d
]);
1379 mpz_init (stride
[d
]);
1383 /* Build the counters to clock through the array reference. */
1385 for (d
= 0; d
< rank
; d
++)
1387 /* Make this stretch of code easier on the eye! */
1388 begin
= ref
->u
.ar
.start
[d
];
1389 finish
= ref
->u
.ar
.end
[d
];
1390 step
= ref
->u
.ar
.stride
[d
];
1391 lower
= ref
->u
.ar
.as
->lower
[d
];
1392 upper
= ref
->u
.ar
.as
->upper
[d
];
1394 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1396 gfc_constructor
*ci
;
1399 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1405 gcc_assert (begin
->rank
== 1);
1406 /* Zero-sized arrays have no shape and no elements, stop early. */
1409 mpz_init_set_ui (nelts
, 0);
1413 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1414 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1415 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1416 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1419 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1421 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1422 || mpz_cmp (ci
->expr
->value
.integer
,
1423 lower
->value
.integer
) < 0)
1425 gfc_error ("index in dimension %d is out of bounds "
1426 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1434 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1435 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1436 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1442 /* Obtain the stride. */
1444 mpz_set (stride
[d
], step
->value
.integer
);
1446 mpz_set_ui (stride
[d
], one
);
1448 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1449 mpz_set_ui (stride
[d
], one
);
1451 /* Obtain the start value for the index. */
1453 mpz_set (start
[d
], begin
->value
.integer
);
1455 mpz_set (start
[d
], lower
->value
.integer
);
1457 mpz_set (ctr
[d
], start
[d
]);
1459 /* Obtain the end value for the index. */
1461 mpz_set (end
[d
], finish
->value
.integer
);
1463 mpz_set (end
[d
], upper
->value
.integer
);
1465 /* Separate 'if' because elements sometimes arrive with
1467 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1468 mpz_set (end
[d
], begin
->value
.integer
);
1470 /* Check the bounds. */
1471 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1472 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1473 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1474 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1476 gfc_error ("index in dimension %d is out of bounds "
1477 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1482 /* Calculate the number of elements and the shape. */
1483 mpz_set (tmp_mpz
, stride
[d
]);
1484 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1485 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1486 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1487 mpz_mul (nelts
, nelts
, tmp_mpz
);
1489 /* An element reference reduces the rank of the expression; don't
1490 add anything to the shape array. */
1491 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1492 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1495 /* Calculate the 'stride' (=delta) for conversion of the
1496 counter values into the index along the constructor. */
1497 mpz_set (delta
[d
], delta_mpz
);
1498 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1499 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1500 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1504 cons
= gfc_constructor_first (base
);
1506 /* Now clock through the array reference, calculating the index in
1507 the source constructor and transferring the elements to the new
1509 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1511 mpz_init_set_ui (ptr
, 0);
1514 for (d
= 0; d
< rank
; d
++)
1516 mpz_set (tmp_mpz
, ctr
[d
]);
1517 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1518 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1519 mpz_add (ptr
, ptr
, tmp_mpz
);
1521 if (!incr_ctr
) continue;
1523 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1525 gcc_assert(vecsub
[d
]);
1527 if (!gfc_constructor_next (vecsub
[d
]))
1528 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1531 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1534 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1538 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1540 if (mpz_cmp_ui (stride
[d
], 0) > 0
1541 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1542 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1543 mpz_set (ctr
[d
], start
[d
]);
1549 limit
= mpz_get_ui (ptr
);
1550 if (limit
>= flag_max_array_constructor
)
1552 gfc_error ("The number of elements in the array constructor "
1553 "at %L requires an increase of the allowed %d "
1554 "upper limit. See -fmax-array-constructor "
1555 "option", &expr
->where
, flag_max_array_constructor
);
1559 cons
= gfc_constructor_lookup (base
, limit
);
1561 gfc_constructor_append_expr (&expr
->value
.constructor
,
1562 gfc_copy_expr (cons
->expr
), NULL
);
1569 mpz_clear (delta_mpz
);
1570 mpz_clear (tmp_mpz
);
1572 for (d
= 0; d
< rank
; d
++)
1574 mpz_clear (delta
[d
]);
1575 mpz_clear (start
[d
]);
1578 mpz_clear (stride
[d
]);
1580 gfc_constructor_free (base
);
1584 /* Pull a substring out of an expression. */
1587 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1594 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1595 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1598 *newp
= gfc_copy_expr (p
);
1599 free ((*newp
)->value
.character
.string
);
1601 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1602 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1603 length
= end
- start
+ 1;
1605 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1606 (*newp
)->value
.character
.length
= length
;
1607 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1608 length
* sizeof (gfc_char_t
));
1615 /* Simplify a subobject reference of a constructor. This occurs when
1616 parameter variable values are substituted. */
1619 simplify_const_ref (gfc_expr
*p
)
1621 gfc_constructor
*cons
, *c
;
1627 switch (p
->ref
->type
)
1630 switch (p
->ref
->u
.ar
.type
)
1633 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1634 will generate this. */
1635 if (p
->expr_type
!= EXPR_ARRAY
)
1637 remove_subobject_ref (p
, NULL
);
1640 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1646 remove_subobject_ref (p
, cons
);
1650 if (!find_array_section (p
, p
->ref
))
1652 p
->ref
->u
.ar
.type
= AR_FULL
;
1657 if (p
->ref
->next
!= NULL
1658 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1660 for (c
= gfc_constructor_first (p
->value
.constructor
);
1661 c
; c
= gfc_constructor_next (c
))
1663 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1664 if (!simplify_const_ref (c
->expr
))
1668 if (gfc_bt_struct (p
->ts
.type
)
1670 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1672 /* There may have been component references. */
1673 p
->ts
= c
->expr
->ts
;
1677 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1679 if (p
->ts
.type
== BT_CHARACTER
1680 && last_ref
->type
== REF_SUBSTRING
)
1682 /* If this is a CHARACTER array and we possibly took
1683 a substring out of it, update the type-spec's
1684 character length according to the first element
1685 (as all should have the same length). */
1686 gfc_charlen_t string_len
;
1687 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1689 const gfc_expr
* first
= c
->expr
;
1690 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1691 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1692 string_len
= first
->value
.character
.length
;
1698 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1701 gfc_free_expr (p
->ts
.u
.cl
->length
);
1704 = gfc_get_int_expr (gfc_default_integer_kind
,
1708 gfc_free_ref_list (p
->ref
);
1719 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1720 remove_subobject_ref (p
, cons
);
1724 if (!find_substring_ref (p
, &newp
))
1727 gfc_replace_expr (p
, newp
);
1728 gfc_free_ref_list (p
->ref
);
1738 /* Simplify a chain of references. */
1741 simplify_ref_chain (gfc_ref
*ref
, int type
)
1745 for (; ref
; ref
= ref
->next
)
1750 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1752 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1754 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1756 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1762 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1764 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1776 /* Try to substitute the value of a parameter variable. */
1779 simplify_parameter_variable (gfc_expr
*p
, int type
)
1784 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1790 /* Do not copy subobject refs for constant. */
1791 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1792 e
->ref
= gfc_copy_ref (p
->ref
);
1793 t
= gfc_simplify_expr (e
, type
);
1795 /* Only use the simplification if it eliminated all subobject references. */
1797 gfc_replace_expr (p
, e
);
1804 /* Given an expression, simplify it by collapsing constant
1805 expressions. Most simplification takes place when the expression
1806 tree is being constructed. If an intrinsic function is simplified
1807 at some point, we get called again to collapse the result against
1810 We work by recursively simplifying expression nodes, simplifying
1811 intrinsic functions where possible, which can lead to further
1812 constant collapsing. If an operator has constant operand(s), we
1813 rip the expression apart, and rebuild it, hoping that it becomes
1816 The expression type is defined for:
1817 0 Basic expression parsing
1818 1 Simplifying array constructors -- will substitute
1820 Returns false on error, true otherwise.
1821 NOTE: Will return true even if the expression can not be simplified. */
1824 gfc_simplify_expr (gfc_expr
*p
, int type
)
1826 gfc_actual_arglist
*ap
;
1831 switch (p
->expr_type
)
1838 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1839 if (!gfc_simplify_expr (ap
->expr
, type
))
1842 if (p
->value
.function
.isym
!= NULL
1843 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1848 case EXPR_SUBSTRING
:
1849 if (!simplify_ref_chain (p
->ref
, type
))
1852 if (gfc_is_constant_expr (p
))
1855 HOST_WIDE_INT start
, end
;
1858 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1860 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
1861 start
--; /* Convert from one-based to zero-based. */
1864 end
= p
->value
.character
.length
;
1865 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1866 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
1871 s
= gfc_get_wide_string (end
- start
+ 2);
1872 memcpy (s
, p
->value
.character
.string
+ start
,
1873 (end
- start
) * sizeof (gfc_char_t
));
1874 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1875 free (p
->value
.character
.string
);
1876 p
->value
.character
.string
= s
;
1877 p
->value
.character
.length
= end
- start
;
1878 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1879 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1881 p
->value
.character
.length
);
1882 gfc_free_ref_list (p
->ref
);
1884 p
->expr_type
= EXPR_CONSTANT
;
1889 if (!simplify_intrinsic_op (p
, type
))
1894 /* Only substitute array parameter variables if we are in an
1895 initialization expression, or we want a subsection. */
1896 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1897 && (gfc_init_expr_flag
|| p
->ref
1898 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1900 if (!simplify_parameter_variable (p
, type
))
1907 gfc_simplify_iterator_var (p
);
1910 /* Simplify subcomponent references. */
1911 if (!simplify_ref_chain (p
->ref
, type
))
1916 case EXPR_STRUCTURE
:
1918 if (!simplify_ref_chain (p
->ref
, type
))
1921 if (!simplify_constructor (p
->value
.constructor
, type
))
1924 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1925 && p
->ref
->u
.ar
.type
== AR_FULL
)
1926 gfc_expand_constructor (p
, false);
1928 if (!simplify_const_ref (p
))
1942 /* Returns the type of an expression with the exception that iterator
1943 variables are automatically integers no matter what else they may
1949 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
1956 /* Scalarize an expression for an elemental intrinsic call. */
1959 scalarize_intrinsic_call (gfc_expr
*e
)
1961 gfc_actual_arglist
*a
, *b
;
1962 gfc_constructor_base ctor
;
1963 gfc_constructor
*args
[5];
1964 gfc_constructor
*ci
, *new_ctor
;
1965 gfc_expr
*expr
, *old
;
1966 int n
, i
, rank
[5], array_arg
;
1968 /* Find which, if any, arguments are arrays. Assume that the old
1969 expression carries the type information and that the first arg
1970 that is an array expression carries all the shape information.*/
1972 a
= e
->value
.function
.actual
;
1973 for (; a
; a
= a
->next
)
1976 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
1979 expr
= gfc_copy_expr (a
->expr
);
1986 old
= gfc_copy_expr (e
);
1988 gfc_constructor_free (expr
->value
.constructor
);
1989 expr
->value
.constructor
= NULL
;
1991 expr
->where
= old
->where
;
1992 expr
->expr_type
= EXPR_ARRAY
;
1994 /* Copy the array argument constructors into an array, with nulls
1997 a
= old
->value
.function
.actual
;
1998 for (; a
; a
= a
->next
)
2000 /* Check that this is OK for an initialization expression. */
2001 if (a
->expr
&& !gfc_check_init_expr (a
->expr
))
2005 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2007 rank
[n
] = a
->expr
->rank
;
2008 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2009 args
[n
] = gfc_constructor_first (ctor
);
2011 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2014 rank
[n
] = a
->expr
->rank
;
2017 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2018 args
[n
] = gfc_constructor_first (ctor
);
2027 /* Using the array argument as the master, step through the array
2028 calling the function for each element and advancing the array
2029 constructors together. */
2030 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2032 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2033 gfc_copy_expr (old
), NULL
);
2035 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2037 b
= old
->value
.function
.actual
;
2038 for (i
= 0; i
< n
; i
++)
2041 new_ctor
->expr
->value
.function
.actual
2042 = a
= gfc_get_actual_arglist ();
2045 a
->next
= gfc_get_actual_arglist ();
2050 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2052 a
->expr
= gfc_copy_expr (b
->expr
);
2057 /* Simplify the function calls. If the simplification fails, the
2058 error will be flagged up down-stream or the library will deal
2060 gfc_simplify_expr (new_ctor
->expr
, 0);
2062 for (i
= 0; i
< n
; i
++)
2064 args
[i
] = gfc_constructor_next (args
[i
]);
2066 for (i
= 1; i
< n
; i
++)
2067 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2068 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2074 /* Free "expr" but not the pointers it contains. */
2076 gfc_free_expr (old
);
2080 gfc_error_now ("elemental function arguments at %C are not compliant");
2083 gfc_free_expr (expr
);
2084 gfc_free_expr (old
);
2090 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2092 gfc_expr
*op1
= e
->value
.op
.op1
;
2093 gfc_expr
*op2
= e
->value
.op
.op2
;
2095 if (!(*check_function
)(op1
))
2098 switch (e
->value
.op
.op
)
2100 case INTRINSIC_UPLUS
:
2101 case INTRINSIC_UMINUS
:
2102 if (!numeric_type (et0 (op1
)))
2107 case INTRINSIC_EQ_OS
:
2109 case INTRINSIC_NE_OS
:
2111 case INTRINSIC_GT_OS
:
2113 case INTRINSIC_GE_OS
:
2115 case INTRINSIC_LT_OS
:
2117 case INTRINSIC_LE_OS
:
2118 if (!(*check_function
)(op2
))
2121 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2122 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2124 gfc_error ("Numeric or CHARACTER operands are required in "
2125 "expression at %L", &e
->where
);
2130 case INTRINSIC_PLUS
:
2131 case INTRINSIC_MINUS
:
2132 case INTRINSIC_TIMES
:
2133 case INTRINSIC_DIVIDE
:
2134 case INTRINSIC_POWER
:
2135 if (!(*check_function
)(op2
))
2138 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2143 case INTRINSIC_CONCAT
:
2144 if (!(*check_function
)(op2
))
2147 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2149 gfc_error ("Concatenation operator in expression at %L "
2150 "must have two CHARACTER operands", &op1
->where
);
2154 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2156 gfc_error ("Concat operator at %L must concatenate strings of the "
2157 "same kind", &e
->where
);
2164 if (et0 (op1
) != BT_LOGICAL
)
2166 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2167 "operand", &op1
->where
);
2176 case INTRINSIC_NEQV
:
2177 if (!(*check_function
)(op2
))
2180 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2182 gfc_error ("LOGICAL operands are required in expression at %L",
2189 case INTRINSIC_PARENTHESES
:
2193 gfc_error ("Only intrinsic operators can be used in expression at %L",
2201 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2206 /* F2003, 7.1.7 (3): In init expression, allocatable components
2207 must not be data-initialized. */
2209 check_alloc_comp_init (gfc_expr
*e
)
2211 gfc_component
*comp
;
2212 gfc_constructor
*ctor
;
2214 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2215 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2217 for (comp
= e
->ts
.u
.derived
->components
,
2218 ctor
= gfc_constructor_first (e
->value
.constructor
);
2219 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2221 if (comp
->attr
.allocatable
&& ctor
->expr
2222 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2224 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2225 "component %qs in structure constructor at %L",
2226 comp
->name
, &ctor
->expr
->where
);
2235 check_init_expr_arguments (gfc_expr
*e
)
2237 gfc_actual_arglist
*ap
;
2239 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2240 if (!gfc_check_init_expr (ap
->expr
))
2246 static bool check_restricted (gfc_expr
*);
2248 /* F95, 7.1.6.1, Initialization expressions, (7)
2249 F2003, 7.1.7 Initialization expression, (8) */
2252 check_inquiry (gfc_expr
*e
, int not_restricted
)
2255 const char *const *functions
;
2257 static const char *const inquiry_func_f95
[] = {
2258 "lbound", "shape", "size", "ubound",
2259 "bit_size", "len", "kind",
2260 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2261 "precision", "radix", "range", "tiny",
2265 static const char *const inquiry_func_f2003
[] = {
2266 "lbound", "shape", "size", "ubound",
2267 "bit_size", "len", "kind",
2268 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2269 "precision", "radix", "range", "tiny",
2274 gfc_actual_arglist
*ap
;
2276 if (!e
->value
.function
.isym
2277 || !e
->value
.function
.isym
->inquiry
)
2280 /* An undeclared parameter will get us here (PR25018). */
2281 if (e
->symtree
== NULL
)
2284 if (e
->symtree
->n
.sym
->from_intmod
)
2286 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2287 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2288 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2291 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2292 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2297 name
= e
->symtree
->n
.sym
->name
;
2299 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2300 ? inquiry_func_f2003
: inquiry_func_f95
;
2302 for (i
= 0; functions
[i
]; i
++)
2303 if (strcmp (functions
[i
], name
) == 0)
2306 if (functions
[i
] == NULL
)
2310 /* At this point we have an inquiry function with a variable argument. The
2311 type of the variable might be undefined, but we need it now, because the
2312 arguments of these functions are not allowed to be undefined. */
2314 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2319 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2321 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2322 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2325 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2328 /* Assumed character length will not reduce to a constant expression
2329 with LEN, as required by the standard. */
2330 if (i
== 5 && not_restricted
2331 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2332 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2333 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2335 gfc_error ("Assumed or deferred character length variable %qs "
2336 " in constant expression at %L",
2337 ap
->expr
->symtree
->n
.sym
->name
,
2341 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2344 if (not_restricted
== 0
2345 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2346 && !check_restricted (ap
->expr
))
2349 if (not_restricted
== 0
2350 && ap
->expr
->expr_type
== EXPR_VARIABLE
2351 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2352 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2360 /* F95, 7.1.6.1, Initialization expressions, (5)
2361 F2003, 7.1.7 Initialization expression, (5) */
2364 check_transformational (gfc_expr
*e
)
2366 static const char * const trans_func_f95
[] = {
2367 "repeat", "reshape", "selected_int_kind",
2368 "selected_real_kind", "transfer", "trim", NULL
2371 static const char * const trans_func_f2003
[] = {
2372 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2373 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2374 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2375 "trim", "unpack", NULL
2380 const char *const *functions
;
2382 if (!e
->value
.function
.isym
2383 || !e
->value
.function
.isym
->transformational
)
2386 name
= e
->symtree
->n
.sym
->name
;
2388 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2389 ? trans_func_f2003
: trans_func_f95
;
2391 /* NULL() is dealt with below. */
2392 if (strcmp ("null", name
) == 0)
2395 for (i
= 0; functions
[i
]; i
++)
2396 if (strcmp (functions
[i
], name
) == 0)
2399 if (functions
[i
] == NULL
)
2401 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2402 "in an initialization expression", name
, &e
->where
);
2406 return check_init_expr_arguments (e
);
2410 /* F95, 7.1.6.1, Initialization expressions, (6)
2411 F2003, 7.1.7 Initialization expression, (6) */
2414 check_null (gfc_expr
*e
)
2416 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2419 return check_init_expr_arguments (e
);
2424 check_elemental (gfc_expr
*e
)
2426 if (!e
->value
.function
.isym
2427 || !e
->value
.function
.isym
->elemental
)
2430 if (e
->ts
.type
!= BT_INTEGER
2431 && e
->ts
.type
!= BT_CHARACTER
2432 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2433 "initialization expression at %L", &e
->where
))
2436 return check_init_expr_arguments (e
);
2441 check_conversion (gfc_expr
*e
)
2443 if (!e
->value
.function
.isym
2444 || !e
->value
.function
.isym
->conversion
)
2447 return check_init_expr_arguments (e
);
2451 /* Verify that an expression is an initialization expression. A side
2452 effect is that the expression tree is reduced to a single constant
2453 node if all goes well. This would normally happen when the
2454 expression is constructed but function references are assumed to be
2455 intrinsics in the context of initialization expressions. If
2456 false is returned an error message has been generated. */
2459 gfc_check_init_expr (gfc_expr
*e
)
2467 switch (e
->expr_type
)
2470 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2472 t
= gfc_simplify_expr (e
, 0);
2481 gfc_intrinsic_sym
* isym
= NULL
;
2482 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2484 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2485 IEEE_EXCEPTIONS modules. */
2486 int mod
= sym
->from_intmod
;
2487 if (mod
== INTMOD_NONE
&& sym
->generic
)
2488 mod
= sym
->generic
->sym
->from_intmod
;
2489 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2491 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2494 gfc_replace_expr (e
, new_expr
);
2500 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2501 into an array constructor, we need to skip the error check here.
2502 Conversion errors are caught below in scalarize_intrinsic_call. */
2503 conversion
= e
->value
.function
.isym
2504 && (e
->value
.function
.isym
->conversion
== 1);
2506 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2507 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2509 gfc_error ("Function %qs in initialization expression at %L "
2510 "must be an intrinsic function",
2511 e
->symtree
->n
.sym
->name
, &e
->where
);
2515 if ((m
= check_conversion (e
)) == MATCH_NO
2516 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2517 && (m
= check_null (e
)) == MATCH_NO
2518 && (m
= check_transformational (e
)) == MATCH_NO
2519 && (m
= check_elemental (e
)) == MATCH_NO
)
2521 gfc_error ("Intrinsic function %qs at %L is not permitted "
2522 "in an initialization expression",
2523 e
->symtree
->n
.sym
->name
, &e
->where
);
2527 if (m
== MATCH_ERROR
)
2530 /* Try to scalarize an elemental intrinsic function that has an
2532 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2533 if (isym
&& isym
->elemental
2534 && (t
= scalarize_intrinsic_call (e
)))
2539 t
= gfc_simplify_expr (e
, 0);
2546 if (gfc_check_iter_variable (e
))
2549 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2551 /* A PARAMETER shall not be used to define itself, i.e.
2552 REAL, PARAMETER :: x = transfer(0, x)
2554 if (!e
->symtree
->n
.sym
->value
)
2556 gfc_error ("PARAMETER %qs is used at %L before its definition "
2557 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2561 t
= simplify_parameter_variable (e
, 0);
2566 if (gfc_in_match_data ())
2571 if (e
->symtree
->n
.sym
->as
)
2573 switch (e
->symtree
->n
.sym
->as
->type
)
2575 case AS_ASSUMED_SIZE
:
2576 gfc_error ("Assumed size array %qs at %L is not permitted "
2577 "in an initialization expression",
2578 e
->symtree
->n
.sym
->name
, &e
->where
);
2581 case AS_ASSUMED_SHAPE
:
2582 gfc_error ("Assumed shape array %qs at %L is not permitted "
2583 "in an initialization expression",
2584 e
->symtree
->n
.sym
->name
, &e
->where
);
2588 gfc_error ("Deferred array %qs at %L is not permitted "
2589 "in an initialization expression",
2590 e
->symtree
->n
.sym
->name
, &e
->where
);
2594 gfc_error ("Array %qs at %L is a variable, which does "
2595 "not reduce to a constant expression",
2596 e
->symtree
->n
.sym
->name
, &e
->where
);
2604 gfc_error ("Parameter %qs at %L has not been declared or is "
2605 "a variable, which does not reduce to a constant "
2606 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2615 case EXPR_SUBSTRING
:
2618 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2622 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2624 t
= gfc_simplify_expr (e
, 0);
2630 case EXPR_STRUCTURE
:
2631 t
= e
->ts
.is_iso_c
? true : false;
2635 t
= check_alloc_comp_init (e
);
2639 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2646 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2650 t
= gfc_expand_constructor (e
, true);
2654 t
= gfc_check_constructor_type (e
);
2658 gfc_internal_error ("check_init_expr(): Unknown expression type");
2664 /* Reduces a general expression to an initialization expression (a constant).
2665 This used to be part of gfc_match_init_expr.
2666 Note that this function doesn't free the given expression on false. */
2669 gfc_reduce_init_expr (gfc_expr
*expr
)
2673 gfc_init_expr_flag
= true;
2674 t
= gfc_resolve_expr (expr
);
2676 t
= gfc_check_init_expr (expr
);
2677 gfc_init_expr_flag
= false;
2682 if (expr
->expr_type
== EXPR_ARRAY
)
2684 if (!gfc_check_constructor_type (expr
))
2686 if (!gfc_expand_constructor (expr
, true))
2694 /* Match an initialization expression. We work by first matching an
2695 expression, then reducing it to a constant. */
2698 gfc_match_init_expr (gfc_expr
**result
)
2706 gfc_init_expr_flag
= true;
2708 m
= gfc_match_expr (&expr
);
2711 gfc_init_expr_flag
= false;
2715 t
= gfc_reduce_init_expr (expr
);
2718 gfc_free_expr (expr
);
2719 gfc_init_expr_flag
= false;
2724 gfc_init_expr_flag
= false;
2730 /* Given an actual argument list, test to see that each argument is a
2731 restricted expression and optionally if the expression type is
2732 integer or character. */
2735 restricted_args (gfc_actual_arglist
*a
)
2737 for (; a
; a
= a
->next
)
2739 if (!check_restricted (a
->expr
))
2747 /************* Restricted/specification expressions *************/
2750 /* Make sure a non-intrinsic function is a specification function,
2751 * see F08:7.1.11.5. */
2754 external_spec_function (gfc_expr
*e
)
2758 f
= e
->value
.function
.esym
;
2760 /* IEEE functions allowed are "a reference to a transformational function
2761 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
2762 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
2763 IEEE_EXCEPTIONS". */
2764 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
2765 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
2767 if (!strcmp (f
->name
, "ieee_selected_real_kind")
2768 || !strcmp (f
->name
, "ieee_support_rounding")
2769 || !strcmp (f
->name
, "ieee_support_flag")
2770 || !strcmp (f
->name
, "ieee_support_halting")
2771 || !strcmp (f
->name
, "ieee_support_datatype")
2772 || !strcmp (f
->name
, "ieee_support_denormal")
2773 || !strcmp (f
->name
, "ieee_support_divide")
2774 || !strcmp (f
->name
, "ieee_support_inf")
2775 || !strcmp (f
->name
, "ieee_support_io")
2776 || !strcmp (f
->name
, "ieee_support_nan")
2777 || !strcmp (f
->name
, "ieee_support_sqrt")
2778 || !strcmp (f
->name
, "ieee_support_standard")
2779 || !strcmp (f
->name
, "ieee_support_underflow_control"))
2780 goto function_allowed
;
2783 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2785 gfc_error ("Specification function %qs at %L cannot be a statement "
2786 "function", f
->name
, &e
->where
);
2790 if (f
->attr
.proc
== PROC_INTERNAL
)
2792 gfc_error ("Specification function %qs at %L cannot be an internal "
2793 "function", f
->name
, &e
->where
);
2797 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2799 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
2805 if (f
->attr
.recursive
2806 && !gfc_notify_std (GFC_STD_F2003
,
2807 "Specification function '%s' "
2808 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
2812 return restricted_args (e
->value
.function
.actual
);
2816 /* Check to see that a function reference to an intrinsic is a
2817 restricted expression. */
2820 restricted_intrinsic (gfc_expr
*e
)
2822 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2823 if (check_inquiry (e
, 0) == MATCH_YES
)
2826 return restricted_args (e
->value
.function
.actual
);
2830 /* Check the expressions of an actual arglist. Used by check_restricted. */
2833 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
2835 for (; arg
; arg
= arg
->next
)
2836 if (!checker (arg
->expr
))
2843 /* Check the subscription expressions of a reference chain with a checking
2844 function; used by check_restricted. */
2847 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
2857 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2859 if (!checker (ref
->u
.ar
.start
[dim
]))
2861 if (!checker (ref
->u
.ar
.end
[dim
]))
2863 if (!checker (ref
->u
.ar
.stride
[dim
]))
2869 /* Nothing needed, just proceed to next reference. */
2873 if (!checker (ref
->u
.ss
.start
))
2875 if (!checker (ref
->u
.ss
.end
))
2884 return check_references (ref
->next
, checker
);
2887 /* Return true if ns is a parent of the current ns. */
2890 is_parent_of_current_ns (gfc_namespace
*ns
)
2893 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
2900 /* Verify that an expression is a restricted expression. Like its
2901 cousin check_init_expr(), an error message is generated if we
2905 check_restricted (gfc_expr
*e
)
2913 switch (e
->expr_type
)
2916 t
= check_intrinsic_op (e
, check_restricted
);
2918 t
= gfc_simplify_expr (e
, 0);
2923 if (e
->value
.function
.esym
)
2925 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2927 t
= external_spec_function (e
);
2931 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2934 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2937 t
= restricted_intrinsic (e
);
2942 sym
= e
->symtree
->n
.sym
;
2945 /* If a dummy argument appears in a context that is valid for a
2946 restricted expression in an elemental procedure, it will have
2947 already been simplified away once we get here. Therefore we
2948 don't need to jump through hoops to distinguish valid from
2950 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2951 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2953 gfc_error ("Dummy argument %qs not allowed in expression at %L",
2954 sym
->name
, &e
->where
);
2958 if (sym
->attr
.optional
)
2960 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
2961 sym
->name
, &e
->where
);
2965 if (sym
->attr
.intent
== INTENT_OUT
)
2967 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
2968 sym
->name
, &e
->where
);
2972 /* Check reference chain if any. */
2973 if (!check_references (e
->ref
, &check_restricted
))
2976 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2977 processed in resolve.c(resolve_formal_arglist). This is done so
2978 that host associated dummy array indices are accepted (PR23446).
2979 This mechanism also does the same for the specification expressions
2980 of array-valued functions. */
2982 || sym
->attr
.in_common
2983 || sym
->attr
.use_assoc
2985 || sym
->attr
.implied_index
2986 || sym
->attr
.flavor
== FL_PARAMETER
2987 || is_parent_of_current_ns (sym
->ns
)
2988 || (sym
->ns
->proc_name
!= NULL
2989 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2990 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2996 gfc_error ("Variable %qs cannot appear in the expression at %L",
2997 sym
->name
, &e
->where
);
2998 /* Prevent a repetition of the error. */
3007 case EXPR_SUBSTRING
:
3008 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3012 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3014 t
= gfc_simplify_expr (e
, 0);
3018 case EXPR_STRUCTURE
:
3019 t
= gfc_check_constructor (e
, check_restricted
);
3023 t
= gfc_check_constructor (e
, check_restricted
);
3027 gfc_internal_error ("check_restricted(): Unknown expression type");
3034 /* Check to see that an expression is a specification expression. If
3035 we return false, an error has been generated. */
3038 gfc_specification_expr (gfc_expr
*e
)
3040 gfc_component
*comp
;
3045 if (e
->ts
.type
!= BT_INTEGER
)
3047 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3048 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3052 comp
= gfc_get_proc_ptr_comp (e
);
3053 if (e
->expr_type
== EXPR_FUNCTION
3054 && !e
->value
.function
.isym
3055 && !e
->value
.function
.esym
3056 && !gfc_pure (e
->symtree
->n
.sym
)
3057 && (!comp
|| !comp
->attr
.pure
))
3059 gfc_error ("Function %qs at %L must be PURE",
3060 e
->symtree
->n
.sym
->name
, &e
->where
);
3061 /* Prevent repeat error messages. */
3062 e
->symtree
->n
.sym
->attr
.pure
= 1;
3068 gfc_error ("Expression at %L must be scalar", &e
->where
);
3072 if (!gfc_simplify_expr (e
, 0))
3075 return check_restricted (e
);
3079 /************** Expression conformance checks. *************/
3081 /* Given two expressions, make sure that the arrays are conformable. */
3084 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3086 int op1_flag
, op2_flag
, d
;
3087 mpz_t op1_size
, op2_size
;
3093 if (op1
->rank
== 0 || op2
->rank
== 0)
3096 va_start (argp
, optype_msgid
);
3097 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3100 if (op1
->rank
!= op2
->rank
)
3102 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3103 op1
->rank
, op2
->rank
, &op1
->where
);
3109 for (d
= 0; d
< op1
->rank
; d
++)
3111 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3112 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3114 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3116 gfc_error ("Different shape for %s at %L on dimension %d "
3117 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3118 (int) mpz_get_si (op1_size
),
3119 (int) mpz_get_si (op2_size
));
3125 mpz_clear (op1_size
);
3127 mpz_clear (op2_size
);
3137 /* Given an assignable expression and an arbitrary expression, make
3138 sure that the assignment can take place. Only add a call to the intrinsic
3139 conversion routines, when allow_convert is set. When this assign is a
3140 coarray call, then the convert is done by the coarray routine implictly and
3141 adding the intrinsic conversion would do harm in most cases. */
3144 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3151 sym
= lvalue
->symtree
->n
.sym
;
3153 /* See if this is the component or subcomponent of a pointer. */
3154 has_pointer
= sym
->attr
.pointer
;
3155 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3156 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3162 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3163 variable local to a function subprogram. Its existence begins when
3164 execution of the function is initiated and ends when execution of the
3165 function is terminated...
3166 Therefore, the left hand side is no longer a variable, when it is: */
3167 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3168 && !sym
->attr
.external
)
3173 /* (i) Use associated; */
3174 if (sym
->attr
.use_assoc
)
3177 /* (ii) The assignment is in the main program; or */
3178 if (gfc_current_ns
->proc_name
3179 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3182 /* (iii) A module or internal procedure... */
3183 if (gfc_current_ns
->proc_name
3184 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3185 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3186 && gfc_current_ns
->parent
3187 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3188 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3189 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3191 /* ... that is not a function... */
3192 if (gfc_current_ns
->proc_name
3193 && !gfc_current_ns
->proc_name
->attr
.function
)
3196 /* ... or is not an entry and has a different name. */
3197 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3201 /* (iv) Host associated and not the function symbol or the
3202 parent result. This picks up sibling references, which
3203 cannot be entries. */
3204 if (!sym
->attr
.entry
3205 && sym
->ns
== gfc_current_ns
->parent
3206 && sym
!= gfc_current_ns
->proc_name
3207 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3212 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3217 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3219 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3220 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3224 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3226 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3231 if (rvalue
->expr_type
== EXPR_NULL
)
3233 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3234 && lvalue
->symtree
->n
.sym
->attr
.data
)
3238 gfc_error ("NULL appears on right-hand side in assignment at %L",
3244 /* This is possibly a typo: x = f() instead of x => f(). */
3246 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3247 gfc_warning (OPT_Wsurprising
,
3248 "POINTER-valued function appears on right-hand side of "
3249 "assignment at %L", &rvalue
->where
);
3251 /* Check size of array assignments. */
3252 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3253 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3256 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3257 && lvalue
->symtree
->n
.sym
->attr
.data
3258 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3259 "initialize non-integer variable %qs",
3260 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3262 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3263 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3264 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3268 /* Handle the case of a BOZ literal on the RHS. */
3269 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3272 if (warn_surprising
)
3273 gfc_warning (OPT_Wsurprising
,
3274 "BOZ literal at %L is bitwise transferred "
3275 "non-integer symbol %qs", &rvalue
->where
,
3276 lvalue
->symtree
->n
.sym
->name
);
3277 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3279 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3281 if (rc
== ARITH_UNDERFLOW
)
3282 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3283 ". This check can be disabled with the option "
3284 "%<-fno-range-check%>", &rvalue
->where
);
3285 else if (rc
== ARITH_OVERFLOW
)
3286 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3287 ". This check can be disabled with the option "
3288 "%<-fno-range-check%>", &rvalue
->where
);
3289 else if (rc
== ARITH_NAN
)
3290 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3291 ". This check can be disabled with the option "
3292 "%<-fno-range-check%>", &rvalue
->where
);
3297 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3300 /* Only DATA Statements come here. */
3303 /* Numeric can be converted to any other numeric. And Hollerith can be
3304 converted to any other type. */
3305 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3306 || rvalue
->ts
.type
== BT_HOLLERITH
)
3309 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3312 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3313 "conversion of %s to %s", &lvalue
->where
,
3314 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3319 /* Assignment is the only case where character variables of different
3320 kind values can be converted into one another. */
3321 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3323 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3324 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3332 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3336 /* Check that a pointer assignment is OK. We first check lvalue, and
3337 we only check rvalue if it's not an assignment to NULL() or a
3338 NULLIFY statement. */
3341 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3343 symbol_attribute attr
, lhs_attr
;
3345 bool is_pure
, is_implicit_pure
, rank_remap
;
3348 lhs_attr
= gfc_expr_attr (lvalue
);
3349 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3351 gfc_error ("Pointer assignment target is not a POINTER at %L",
3356 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3357 && !lhs_attr
.proc_pointer
)
3359 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3360 "l-value since it is a procedure",
3361 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3365 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3368 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3370 if (ref
->type
== REF_COMPONENT
)
3371 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3373 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3377 if (ref
->u
.ar
.type
== AR_FULL
)
3380 if (ref
->u
.ar
.type
!= AR_SECTION
)
3382 gfc_error ("Expected bounds specification for %qs at %L",
3383 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3387 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3388 "for %qs in pointer assignment at %L",
3389 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3392 /* When bounds are given, all lbounds are necessary and either all
3393 or none of the upper bounds; no strides are allowed. If the
3394 upper bounds are present, we may do rank remapping. */
3395 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3397 if (!ref
->u
.ar
.start
[dim
]
3398 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3400 gfc_error ("Lower bound has to be present at %L",
3404 if (ref
->u
.ar
.stride
[dim
])
3406 gfc_error ("Stride must not be present at %L",
3412 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3415 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3416 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3418 gfc_error ("Either all or none of the upper bounds"
3419 " must be specified at %L", &lvalue
->where
);
3427 is_pure
= gfc_pure (NULL
);
3428 is_implicit_pure
= gfc_implicit_pure (NULL
);
3430 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3431 kind, etc for lvalue and rvalue must match, and rvalue must be a
3432 pure variable if we're in a pure function. */
3433 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3436 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3437 if (lvalue
->expr_type
== EXPR_VARIABLE
3438 && gfc_is_coindexed (lvalue
))
3441 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3442 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3444 gfc_error ("Pointer object at %L shall not have a coindex",
3450 /* Checks on rvalue for procedure pointer assignments. */
3455 gfc_component
*comp1
, *comp2
;
3458 attr
= gfc_expr_attr (rvalue
);
3459 if (!((rvalue
->expr_type
== EXPR_NULL
)
3460 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3461 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3462 || (rvalue
->expr_type
== EXPR_VARIABLE
3463 && attr
.flavor
== FL_PROCEDURE
)))
3465 gfc_error ("Invalid procedure pointer assignment at %L",
3469 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3471 /* Check for intrinsics. */
3472 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3473 if (!sym
->attr
.intrinsic
3474 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3475 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3477 sym
->attr
.intrinsic
= 1;
3478 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3479 attr
= gfc_expr_attr (rvalue
);
3481 /* Check for result of embracing function. */
3482 if (sym
->attr
.function
&& sym
->result
== sym
)
3486 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3487 if (sym
== ns
->proc_name
)
3489 gfc_error ("Function result %qs is invalid as proc-target "
3490 "in procedure pointer assignment at %L",
3491 sym
->name
, &rvalue
->where
);
3498 gfc_error ("Abstract interface %qs is invalid "
3499 "in procedure pointer assignment at %L",
3500 rvalue
->symtree
->name
, &rvalue
->where
);
3503 /* Check for F08:C729. */
3504 if (attr
.flavor
== FL_PROCEDURE
)
3506 if (attr
.proc
== PROC_ST_FUNCTION
)
3508 gfc_error ("Statement function %qs is invalid "
3509 "in procedure pointer assignment at %L",
3510 rvalue
->symtree
->name
, &rvalue
->where
);
3513 if (attr
.proc
== PROC_INTERNAL
&&
3514 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3515 "is invalid in procedure pointer assignment "
3516 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3518 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3519 attr
.subroutine
) == 0)
3521 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3522 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3526 /* Check for F08:C730. */
3527 if (attr
.elemental
&& !attr
.intrinsic
)
3529 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3530 "in procedure pointer assignment at %L",
3531 rvalue
->symtree
->name
, &rvalue
->where
);
3535 /* Ensure that the calling convention is the same. As other attributes
3536 such as DLLEXPORT may differ, one explicitly only tests for the
3537 calling conventions. */
3538 if (rvalue
->expr_type
== EXPR_VARIABLE
3539 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3540 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3542 symbol_attribute calls
;
3545 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3546 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3547 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3549 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3550 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3552 gfc_error ("Mismatch in the procedure pointer assignment "
3553 "at %L: mismatch in the calling convention",
3559 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3561 s1
= comp1
->ts
.interface
;
3564 s1
= lvalue
->symtree
->n
.sym
;
3565 if (s1
->ts
.interface
)
3566 s1
= s1
->ts
.interface
;
3569 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3572 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3574 s2
= comp2
->ts
.interface
->result
;
3579 s2
= comp2
->ts
.interface
;
3583 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3585 if (rvalue
->value
.function
.esym
)
3586 s2
= rvalue
->value
.function
.esym
->result
;
3588 s2
= rvalue
->symtree
->n
.sym
->result
;
3594 s2
= rvalue
->symtree
->n
.sym
;
3598 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3599 s2
= s2
->ts
.interface
;
3601 /* Special check for the case of absent interface on the lvalue.
3602 * All other interface checks are done below. */
3603 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
3605 gfc_error ("Interface mismatch in procedure pointer assignment "
3606 "at %L: '%s' is not a subroutine", &rvalue
->where
, name
);
3610 if (s1
== s2
|| !s1
|| !s2
)
3613 /* F08:7.2.2.4 (4) */
3614 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
3615 && gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3617 gfc_error ("Explicit interface required for %qs at %L: %s",
3618 s1
->name
, &lvalue
->where
, err
);
3621 if (s2
->attr
.if_source
== IFSRC_UNKNOWN
3622 && gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3624 gfc_error ("Explicit interface required for %qs at %L: %s",
3625 s2
->name
, &rvalue
->where
, err
);
3629 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3630 err
, sizeof(err
), NULL
, NULL
))
3632 gfc_error ("Interface mismatch in procedure pointer assignment "
3633 "at %L: %s", &rvalue
->where
, err
);
3637 /* Check F2008Cor2, C729. */
3638 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
3639 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
3641 gfc_error ("Procedure pointer target %qs at %L must be either an "
3642 "intrinsic, host or use associated, referenced or have "
3643 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
3650 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3652 /* Check for F03:C717. */
3653 if (UNLIMITED_POLY (rvalue
)
3654 && !(UNLIMITED_POLY (lvalue
)
3655 || (lvalue
->ts
.type
== BT_DERIVED
3656 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3657 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3658 gfc_error ("Data-pointer-object at %L must be unlimited "
3659 "polymorphic, or of a type with the BIND or SEQUENCE "
3660 "attribute, to be compatible with an unlimited "
3661 "polymorphic target", &lvalue
->where
);
3663 gfc_error ("Different types in pointer assignment at %L; "
3664 "attempted assignment of %s to %s", &lvalue
->where
,
3665 gfc_typename (&rvalue
->ts
),
3666 gfc_typename (&lvalue
->ts
));
3670 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3672 gfc_error ("Different kind type parameters in pointer "
3673 "assignment at %L", &lvalue
->where
);
3677 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3679 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3683 /* Make sure the vtab is present. */
3684 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
3685 gfc_find_vtab (&rvalue
->ts
);
3687 /* Check rank remapping. */
3692 /* If this can be determined, check that the target must be at least as
3693 large as the pointer assigned to it is. */
3694 if (gfc_array_size (lvalue
, &lsize
)
3695 && gfc_array_size (rvalue
, &rsize
)
3696 && mpz_cmp (rsize
, lsize
) < 0)
3698 gfc_error ("Rank remapping target is smaller than size of the"
3699 " pointer (%ld < %ld) at %L",
3700 mpz_get_si (rsize
), mpz_get_si (lsize
),
3705 /* The target must be either rank one or it must be simply contiguous
3706 and F2008 must be allowed. */
3707 if (rvalue
->rank
!= 1)
3709 if (!gfc_is_simply_contiguous (rvalue
, true, false))
3711 gfc_error ("Rank remapping target must be rank 1 or"
3712 " simply contiguous at %L", &rvalue
->where
);
3715 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
3716 "rank 1 at %L", &rvalue
->where
))
3721 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3722 if (rvalue
->expr_type
== EXPR_NULL
)
3725 if (lvalue
->ts
.type
== BT_CHARACTER
)
3727 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3732 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3733 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3735 attr
= gfc_expr_attr (rvalue
);
3737 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3739 gfc_error ("Target expression in pointer assignment "
3740 "at %L must deliver a pointer result",
3745 if (!attr
.target
&& !attr
.pointer
)
3747 gfc_error ("Pointer assignment target is neither TARGET "
3748 "nor POINTER at %L", &rvalue
->where
);
3752 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3754 gfc_error ("Bad target in pointer assignment in PURE "
3755 "procedure at %L", &rvalue
->where
);
3758 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3759 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3761 if (gfc_has_vector_index (rvalue
))
3763 gfc_error ("Pointer assignment with vector subscript "
3764 "on rhs at %L", &rvalue
->where
);
3768 if (attr
.is_protected
&& attr
.use_assoc
3769 && !(attr
.pointer
|| attr
.proc_pointer
))
3771 gfc_error ("Pointer assignment target has PROTECTED "
3772 "attribute at %L", &rvalue
->where
);
3776 /* F2008, C725. For PURE also C1283. */
3777 if (rvalue
->expr_type
== EXPR_VARIABLE
3778 && gfc_is_coindexed (rvalue
))
3781 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3782 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3784 gfc_error ("Data target at %L shall not have a coindex",
3790 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3791 if (warn_target_lifetime
3792 && rvalue
->expr_type
== EXPR_VARIABLE
3793 && !rvalue
->symtree
->n
.sym
->attr
.save
3794 && !attr
.pointer
&& !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3795 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3796 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3797 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3802 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3803 || lvalue
->symtree
->n
.sym
->attr
.result
3804 || lvalue
->symtree
->n
.sym
->attr
.function
3805 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3806 && lvalue
->symtree
->n
.sym
->ns
3807 != rvalue
->symtree
->n
.sym
->ns
)
3808 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3809 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3811 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3812 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3813 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3814 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3815 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3817 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3824 gfc_warning (OPT_Wtarget_lifetime
,
3825 "Pointer at %L in pointer assignment might outlive the "
3826 "pointer target", &lvalue
->where
);
3833 /* Relative of gfc_check_assign() except that the lvalue is a single
3834 symbol. Used for initialization assignments. */
3837 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3841 bool pointer
, proc_pointer
;
3843 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3845 lvalue
.expr_type
= EXPR_VARIABLE
;
3846 lvalue
.ts
= sym
->ts
;
3848 lvalue
.rank
= sym
->as
->rank
;
3849 lvalue
.symtree
= XCNEW (gfc_symtree
);
3850 lvalue
.symtree
->n
.sym
= sym
;
3851 lvalue
.where
= sym
->declared_at
;
3855 lvalue
.ref
= gfc_get_ref ();
3856 lvalue
.ref
->type
= REF_COMPONENT
;
3857 lvalue
.ref
->u
.c
.component
= comp
;
3858 lvalue
.ref
->u
.c
.sym
= sym
;
3859 lvalue
.ts
= comp
->ts
;
3860 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
3861 lvalue
.where
= comp
->loc
;
3862 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3863 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
3864 proc_pointer
= comp
->attr
.proc_pointer
;
3868 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3869 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
3870 proc_pointer
= sym
->attr
.proc_pointer
;
3873 if (pointer
|| proc_pointer
)
3874 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3877 /* If a conversion function, e.g., __convert_i8_i4, was inserted
3878 into an array constructor, we should check if it can be reduced
3879 as an initialization expression. */
3880 if (rvalue
->expr_type
== EXPR_FUNCTION
3881 && rvalue
->value
.function
.isym
3882 && (rvalue
->value
.function
.isym
->conversion
== 1))
3883 gfc_check_init_expr (rvalue
);
3885 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3888 free (lvalue
.symtree
);
3894 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3896 /* F08:C461. Additional checks for pointer initialization. */
3897 symbol_attribute attr
;
3898 attr
= gfc_expr_attr (rvalue
);
3899 if (attr
.allocatable
)
3901 gfc_error ("Pointer initialization target at %L "
3902 "must not be ALLOCATABLE", &rvalue
->where
);
3905 if (!attr
.target
|| attr
.pointer
)
3907 gfc_error ("Pointer initialization target at %L "
3908 "must have the TARGET attribute", &rvalue
->where
);
3912 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
3913 && rvalue
->symtree
->n
.sym
->ns
->proc_name
3914 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
3916 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
3917 attr
.save
= SAVE_IMPLICIT
;
3922 gfc_error ("Pointer initialization target at %L "
3923 "must have the SAVE attribute", &rvalue
->where
);
3928 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3930 /* F08:C1220. Additional checks for procedure pointer initialization. */
3931 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3932 if (attr
.proc_pointer
)
3934 gfc_error ("Procedure pointer initialization target at %L "
3935 "may not be a procedure pointer", &rvalue
->where
);
3944 /* Build an initializer for a local integer, real, complex, logical, or
3945 character variable, based on the command line flags finit-local-zero,
3946 finit-integer=, finit-real=, finit-logical=, and finit-character=. */
3949 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
3952 gfc_expr
*init_expr
;
3955 /* Try to build an initializer expression. */
3956 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
3958 /* We will only initialize integers, reals, complex, logicals, and
3959 characters, and only if the corresponding command-line flags
3960 were set. Otherwise, we free init_expr and return null. */
3964 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
3965 mpz_set_si (init_expr
->value
.integer
,
3966 gfc_option
.flag_init_integer_value
);
3969 gfc_free_expr (init_expr
);
3975 switch (flag_init_real
)
3977 case GFC_INIT_REAL_SNAN
:
3978 init_expr
->is_snan
= 1;
3980 case GFC_INIT_REAL_NAN
:
3981 mpfr_set_nan (init_expr
->value
.real
);
3984 case GFC_INIT_REAL_INF
:
3985 mpfr_set_inf (init_expr
->value
.real
, 1);
3988 case GFC_INIT_REAL_NEG_INF
:
3989 mpfr_set_inf (init_expr
->value
.real
, -1);
3992 case GFC_INIT_REAL_ZERO
:
3993 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
3997 gfc_free_expr (init_expr
);
4004 switch (flag_init_real
)
4006 case GFC_INIT_REAL_SNAN
:
4007 init_expr
->is_snan
= 1;
4009 case GFC_INIT_REAL_NAN
:
4010 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4011 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4014 case GFC_INIT_REAL_INF
:
4015 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4016 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4019 case GFC_INIT_REAL_NEG_INF
:
4020 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4021 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4024 case GFC_INIT_REAL_ZERO
:
4025 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4029 gfc_free_expr (init_expr
);
4036 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
4037 init_expr
->value
.logical
= 0;
4038 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
4039 init_expr
->value
.logical
= 1;
4042 gfc_free_expr (init_expr
);
4048 /* For characters, the length must be constant in order to
4049 create a default initializer. */
4050 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
4052 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4054 char_len
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
4055 init_expr
->value
.character
.length
= char_len
;
4056 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4057 for (i
= 0; i
< char_len
; i
++)
4058 init_expr
->value
.character
.string
[i
]
4059 = (unsigned char) gfc_option
.flag_init_character_value
;
4063 gfc_free_expr (init_expr
);
4066 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
4067 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4069 gfc_actual_arglist
*arg
;
4070 init_expr
= gfc_get_expr ();
4071 init_expr
->where
= *where
;
4072 init_expr
->ts
= *ts
;
4073 init_expr
->expr_type
= EXPR_FUNCTION
;
4074 init_expr
->value
.function
.isym
=
4075 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4076 init_expr
->value
.function
.name
= "repeat";
4077 arg
= gfc_get_actual_arglist ();
4078 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4079 arg
->expr
->value
.character
.string
[0] =
4080 gfc_option
.flag_init_character_value
;
4081 arg
->next
= gfc_get_actual_arglist ();
4082 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4083 init_expr
->value
.function
.actual
= arg
;
4088 gfc_free_expr (init_expr
);
4095 /* Apply an initialization expression to a typespec. Can be used for symbols or
4096 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4097 combined with some effort. */
4100 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4102 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4104 && ts
->u
.cl
->length
&& ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4108 gcc_assert (ts
->u
.cl
&& ts
->u
.cl
->length
);
4109 gcc_assert (ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
4110 gcc_assert (ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
);
4112 len
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
4114 if (init
->expr_type
== EXPR_CONSTANT
)
4115 gfc_set_constant_character_len (len
, init
, -1);
4118 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4119 init
->ts
.u
.cl
->length
->value
.integer
))
4121 gfc_constructor
*ctor
;
4122 ctor
= gfc_constructor_first (init
->value
.constructor
);
4127 bool has_ts
= (init
->ts
.u
.cl
4128 && init
->ts
.u
.cl
->length_from_typespec
);
4130 /* Remember the length of the first element for checking
4131 that all elements *in the constructor* have the same
4132 length. This need not be the length of the LHS! */
4133 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4134 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4135 first_len
= ctor
->expr
->value
.character
.length
;
4137 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4138 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4140 gfc_set_constant_character_len (len
, ctor
->expr
,
4141 has_ts
? -1 : first_len
);
4142 if (!ctor
->expr
->ts
.u
.cl
)
4144 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4146 ctor
->expr
->ts
.u
.cl
->length
4147 = gfc_copy_expr (ts
->u
.cl
->length
);
4155 /* Check whether an expression is a structure constructor and whether it has
4156 other values than NULL. */
4159 is_non_empty_structure_constructor (gfc_expr
* e
)
4161 if (e
->expr_type
!= EXPR_STRUCTURE
)
4164 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4167 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4169 cons
= gfc_constructor_next (cons
);
4175 /* Check for default initializer; sym->value is not enough
4176 as it is also set for EXPR_NULL of allocatables. */
4179 gfc_has_default_initializer (gfc_symbol
*der
)
4183 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4184 for (c
= der
->components
; c
; c
= c
->next
)
4185 if (gfc_bt_struct (c
->ts
.type
))
4187 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4188 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4190 && is_non_empty_structure_constructor (c
->initializer
))
4191 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4193 if (c
->attr
.pointer
&& c
->initializer
)
4207 Generate an initializer expression which initializes the entirety of a union.
4208 A normal structure constructor is insufficient without undue effort, because
4209 components of maps may be oddly aligned/overlapped. (For example if a
4210 character is initialized from one map overtop a real from the other, only one
4211 byte of the real is actually initialized.) Unfortunately we don't know the
4212 size of the union right now, so we can't generate a proper initializer, but
4213 we use a NULL expr as a placeholder and do the right thing later in
4214 gfc_trans_subcomponent_assign.
4217 generate_union_initializer (gfc_component
*un
)
4219 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4222 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4223 placeholder
->ts
= un
->ts
;
4228 /* Get the user-specified initializer for a union, if any. This means the user
4229 has said to initialize component(s) of a map. For simplicity's sake we
4230 only allow the user to initialize the first map. We don't have to worry
4231 about overlapping initializers as they are released early in resolution (see
4232 resolve_fl_struct). */
4235 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4238 gfc_expr
*init
=NULL
;
4240 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4243 for (map
= union_type
->components
; map
; map
= map
->next
)
4245 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4247 init
= gfc_default_initializer (&map
->ts
);
4260 /* Fetch or generate an initializer for the given component.
4261 Only generate an initializer if generate is true. */
4264 component_initializer (gfc_typespec
*ts
, gfc_component
*c
, bool generate
)
4266 gfc_expr
*init
= NULL
;
4268 /* See if we can find the initializer immediately. */
4269 if (c
->initializer
|| !generate
4270 || (ts
->type
== BT_CLASS
&& !c
->attr
.allocatable
))
4271 return c
->initializer
;
4273 /* Recursively handle derived type components. */
4274 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4275 init
= gfc_generate_initializer (&c
->ts
, true);
4277 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4279 gfc_component
*map
= NULL
;
4280 gfc_constructor
*ctor
;
4281 gfc_expr
*user_init
;
4283 /* If we don't have a user initializer and we aren't generating one, this
4284 union has no initializer. */
4285 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4286 if (!user_init
&& !generate
)
4289 /* Otherwise use a structure constructor. */
4290 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4294 /* If we are to generate an initializer for the union, add a constructor
4295 which initializes the whole union first. */
4298 ctor
= gfc_constructor_get ();
4299 ctor
->expr
= generate_union_initializer (c
);
4300 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4303 /* If we found an initializer in one of our maps, apply it. Note this
4304 is applied _after_ the entire-union initializer above if any. */
4307 ctor
= gfc_constructor_get ();
4308 ctor
->expr
= user_init
;
4309 ctor
->n
.component
= map
;
4310 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4314 /* Treat simple components like locals. */
4317 init
= gfc_build_default_init_expr (&c
->ts
, &c
->loc
);
4318 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4325 /* Get an expression for a default initializer of a derived type. */
4328 gfc_default_initializer (gfc_typespec
*ts
)
4330 return gfc_generate_initializer (ts
, false);
4334 /* Get or generate an expression for a default initializer of a derived type.
4335 If -finit-derived is specified, generate default initialization expressions
4336 for components that lack them when generate is set. */
4339 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4341 gfc_expr
*init
, *tmp
;
4342 gfc_component
*comp
;
4343 generate
= flag_init_derived
&& generate
;
4345 /* See if we have a default initializer in this, but not in nested
4346 types (otherwise we could use gfc_has_default_initializer()).
4347 We don't need to check if we are going to generate them. */
4348 comp
= ts
->u
.derived
->components
;
4351 for (; comp
; comp
= comp
->next
)
4352 if (comp
->initializer
|| comp
->attr
.allocatable
4353 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4354 && CLASS_DATA (comp
)->attr
.allocatable
))
4361 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4362 &ts
->u
.derived
->declared_at
);
4365 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4367 gfc_constructor
*ctor
= gfc_constructor_get();
4369 /* Fetch or generate an initializer for the component. */
4370 tmp
= component_initializer (ts
, comp
, generate
);
4373 /* Save the component ref for STRUCTUREs and UNIONs. */
4374 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4375 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4376 ctor
->n
.component
= comp
;
4378 /* If the initializer was not generated, we need a copy. */
4379 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4380 if ((comp
->ts
.type
!= tmp
->ts
.type
4381 || comp
->ts
.kind
!= tmp
->ts
.kind
)
4382 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4383 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
4386 if (comp
->attr
.allocatable
4387 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
4389 ctor
->expr
= gfc_get_expr ();
4390 ctor
->expr
->expr_type
= EXPR_NULL
;
4391 ctor
->expr
->where
= init
->where
;
4392 ctor
->expr
->ts
= comp
->ts
;
4395 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4402 /* Given a symbol, create an expression node with that symbol as a
4403 variable. If the symbol is array valued, setup a reference of the
4407 gfc_get_variable_expr (gfc_symtree
*var
)
4411 e
= gfc_get_expr ();
4412 e
->expr_type
= EXPR_VARIABLE
;
4414 e
->ts
= var
->n
.sym
->ts
;
4416 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
4417 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
4418 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
4419 && CLASS_DATA (var
->n
.sym
)->as
)))
4421 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
4422 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
4423 e
->ref
= gfc_get_ref ();
4424 e
->ref
->type
= REF_ARRAY
;
4425 e
->ref
->u
.ar
.type
= AR_FULL
;
4426 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
4427 ? CLASS_DATA (var
->n
.sym
)->as
4435 /* Adds a full array reference to an expression, as needed. */
4438 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4441 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4446 ref
->next
= gfc_get_ref ();
4451 e
->ref
= gfc_get_ref ();
4454 ref
->type
= REF_ARRAY
;
4455 ref
->u
.ar
.type
= AR_FULL
;
4456 ref
->u
.ar
.dimen
= e
->rank
;
4457 ref
->u
.ar
.where
= e
->where
;
4463 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4467 lval
= gfc_get_expr ();
4468 lval
->expr_type
= EXPR_VARIABLE
;
4469 lval
->where
= sym
->declared_at
;
4471 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4473 /* It will always be a full array. */
4474 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
4475 lval
->rank
= as
? as
->rank
: 0;
4477 gfc_add_full_array_ref (lval
, as
);
4482 /* Returns the array_spec of a full array expression. A NULL is
4483 returned otherwise. */
4485 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4490 if (expr
->rank
== 0)
4493 /* Follow any component references. */
4494 if (expr
->expr_type
== EXPR_VARIABLE
4495 || expr
->expr_type
== EXPR_CONSTANT
)
4497 as
= expr
->symtree
->n
.sym
->as
;
4498 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4503 as
= ref
->u
.c
.component
->as
;
4511 switch (ref
->u
.ar
.type
)
4534 /* General expression traversal function. */
4537 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4538 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4543 gfc_actual_arglist
*args
;
4550 if ((*func
) (expr
, sym
, &f
))
4553 if (expr
->ts
.type
== BT_CHARACTER
4555 && expr
->ts
.u
.cl
->length
4556 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4557 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4560 switch (expr
->expr_type
)
4565 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4567 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4575 case EXPR_SUBSTRING
:
4578 case EXPR_STRUCTURE
:
4580 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4581 c
; c
= gfc_constructor_next (c
))
4583 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4587 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4589 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4591 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4593 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4600 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4602 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4618 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4620 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4622 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4624 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4630 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4632 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4637 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4638 && ref
->u
.c
.component
->ts
.u
.cl
4639 && ref
->u
.c
.component
->ts
.u
.cl
->length
4640 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4642 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4646 if (ref
->u
.c
.component
->as
)
4647 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4648 + ref
->u
.c
.component
->as
->corank
; i
++)
4650 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4653 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4667 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4670 expr_set_symbols_referenced (gfc_expr
*expr
,
4671 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4672 int *f ATTRIBUTE_UNUSED
)
4674 if (expr
->expr_type
!= EXPR_VARIABLE
)
4676 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4681 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4683 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4687 /* Determine if an expression is a procedure pointer component and return
4688 the component in that case. Otherwise return NULL. */
4691 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4695 if (!expr
|| !expr
->ref
)
4702 if (ref
->type
== REF_COMPONENT
4703 && ref
->u
.c
.component
->attr
.proc_pointer
)
4704 return ref
->u
.c
.component
;
4710 /* Determine if an expression is a procedure pointer component. */
4713 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4715 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4719 /* Determine if an expression is a function with an allocatable class scalar
4722 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
4724 if (expr
->expr_type
== EXPR_FUNCTION
4725 && expr
->value
.function
.esym
4726 && expr
->value
.function
.esym
->result
4727 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4728 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4729 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4736 /* Determine if an expression is a function with an allocatable class array
4739 gfc_is_alloc_class_array_function (gfc_expr
*expr
)
4741 if (expr
->expr_type
== EXPR_FUNCTION
4742 && expr
->value
.function
.esym
4743 && expr
->value
.function
.esym
->result
4744 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4745 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4746 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4753 /* Walk an expression tree and check each variable encountered for being typed.
4754 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4755 mode as is a basic arithmetic expression using those; this is for things in
4758 INTEGER :: arr(n), n
4759 INTEGER :: arr(n + 1), n
4761 The namespace is needed for IMPLICIT typing. */
4763 static gfc_namespace
* check_typed_ns
;
4766 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4767 int* f ATTRIBUTE_UNUSED
)
4771 if (e
->expr_type
!= EXPR_VARIABLE
)
4774 gcc_assert (e
->symtree
);
4775 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4782 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4786 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4790 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4791 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4793 if (e
->expr_type
== EXPR_OP
)
4797 gcc_assert (e
->value
.op
.op1
);
4798 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4800 if (t
&& e
->value
.op
.op2
)
4801 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4807 /* Otherwise, walk the expression and do it strictly. */
4808 check_typed_ns
= ns
;
4809 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4811 return error_found
? false : true;
4816 gfc_ref_this_image (gfc_ref
*ref
)
4820 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4822 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4823 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4830 gfc_find_stat_co(gfc_expr
*e
)
4834 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4835 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4836 return ref
->u
.ar
.stat
;
4838 if (e
->value
.function
.actual
->expr
)
4839 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
4841 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4842 return ref
->u
.ar
.stat
;
4848 gfc_is_coindexed (gfc_expr
*e
)
4852 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4853 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4854 return !gfc_ref_this_image (ref
);
4860 /* Coarrays are variables with a corank but not being coindexed. However, also
4861 the following is a coarray: A subobject of a coarray is a coarray if it does
4862 not have any cosubscripts, vector subscripts, allocatable component
4863 selection, or pointer component selection. (F2008, 2.4.7) */
4866 gfc_is_coarray (gfc_expr
*e
)
4870 gfc_component
*comp
;
4875 if (e
->expr_type
!= EXPR_VARIABLE
)
4879 sym
= e
->symtree
->n
.sym
;
4881 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4882 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4884 coarray
= sym
->attr
.codimension
;
4886 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4890 comp
= ref
->u
.c
.component
;
4891 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4892 && (CLASS_DATA (comp
)->attr
.class_pointer
4893 || CLASS_DATA (comp
)->attr
.allocatable
))
4896 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4898 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4901 coarray
= comp
->attr
.codimension
;
4909 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4915 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4916 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4927 return coarray
&& !coindexed
;
4932 gfc_get_corank (gfc_expr
*e
)
4937 if (!gfc_is_coarray (e
))
4940 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4941 corank
= e
->ts
.u
.derived
->components
->as
4942 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4944 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4946 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4948 if (ref
->type
== REF_ARRAY
)
4949 corank
= ref
->u
.ar
.as
->corank
;
4950 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4957 /* Check whether the expression has an ultimate allocatable component.
4958 Being itself allocatable does not count. */
4960 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4962 gfc_ref
*ref
, *last
= NULL
;
4964 if (e
->expr_type
!= EXPR_VARIABLE
)
4967 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4968 if (ref
->type
== REF_COMPONENT
)
4971 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4972 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4973 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4974 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4978 if (e
->ts
.type
== BT_CLASS
)
4979 return CLASS_DATA (e
)->attr
.alloc_comp
;
4980 else if (e
->ts
.type
== BT_DERIVED
)
4981 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4987 /* Check whether the expression has an pointer component.
4988 Being itself a pointer does not count. */
4990 gfc_has_ultimate_pointer (gfc_expr
*e
)
4992 gfc_ref
*ref
, *last
= NULL
;
4994 if (e
->expr_type
!= EXPR_VARIABLE
)
4997 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4998 if (ref
->type
== REF_COMPONENT
)
5001 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5002 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5003 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5004 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5008 if (e
->ts
.type
== BT_CLASS
)
5009 return CLASS_DATA (e
)->attr
.pointer_comp
;
5010 else if (e
->ts
.type
== BT_DERIVED
)
5011 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5017 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5018 Note: A scalar is not regarded as "simply contiguous" by the standard.
5019 if bool is not strict, some further checks are done - for instance,
5020 a "(::1)" is accepted. */
5023 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5027 gfc_array_ref
*ar
= NULL
;
5028 gfc_ref
*ref
, *part_ref
= NULL
;
5031 if (expr
->expr_type
== EXPR_FUNCTION
)
5032 return expr
->value
.function
.esym
5033 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
5034 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5037 if (!permit_element
&& expr
->rank
== 0)
5040 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5043 return false; /* Array shall be last part-ref. */
5045 if (ref
->type
== REF_COMPONENT
)
5047 else if (ref
->type
== REF_SUBSTRING
)
5049 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5053 sym
= expr
->symtree
->n
.sym
;
5054 if (expr
->ts
.type
!= BT_CLASS
5056 && !part_ref
->u
.c
.component
->attr
.contiguous
5057 && part_ref
->u
.c
.component
->attr
.pointer
)
5059 && !sym
->attr
.contiguous
5060 && (sym
->attr
.pointer
5061 || sym
->as
->type
== AS_ASSUMED_RANK
5062 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
5065 if (!ar
|| ar
->type
== AR_FULL
)
5068 gcc_assert (ar
->type
== AR_SECTION
);
5070 /* Check for simply contiguous array */
5072 for (i
= 0; i
< ar
->dimen
; i
++)
5074 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5077 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5083 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5086 /* If the previous section was not contiguous, that's an error,
5087 unless we have effective only one element and checking is not
5089 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5090 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5091 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5092 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5093 ar
->end
[i
]->value
.integer
) != 0))
5096 /* Following the standard, "(::1)" or - if known at compile time -
5097 "(lbound:ubound)" are not simply contiguous; if strict
5098 is false, they are regarded as simply contiguous. */
5099 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5100 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5101 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5105 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5106 || !ar
->as
->lower
[i
]
5107 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5108 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5109 ar
->as
->lower
[i
]->value
.integer
) != 0))
5113 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5114 || !ar
->as
->upper
[i
]
5115 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5116 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5117 ar
->as
->upper
[i
]->value
.integer
) != 0))
5125 /* Build call to an intrinsic procedure. The number of arguments has to be
5126 passed (rather than ending the list with a NULL value) because we may
5127 want to add arguments but with a NULL-expression. */
5130 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5131 locus where
, unsigned numarg
, ...)
5134 gfc_actual_arglist
* atail
;
5135 gfc_intrinsic_sym
* isym
;
5138 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5140 isym
= gfc_intrinsic_function_by_id (id
);
5143 result
= gfc_get_expr ();
5144 result
->expr_type
= EXPR_FUNCTION
;
5145 result
->ts
= isym
->ts
;
5146 result
->where
= where
;
5147 result
->value
.function
.name
= mangled_name
;
5148 result
->value
.function
.isym
= isym
;
5150 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5151 gfc_commit_symbol (result
->symtree
->n
.sym
);
5152 gcc_assert (result
->symtree
5153 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5154 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5155 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5156 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5157 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5158 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5160 va_start (ap
, numarg
);
5162 for (i
= 0; i
< numarg
; ++i
)
5166 atail
->next
= gfc_get_actual_arglist ();
5167 atail
= atail
->next
;
5170 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5172 atail
->expr
= va_arg (ap
, gfc_expr
*);
5180 /* Check if an expression may appear in a variable definition context
5181 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5182 This is called from the various places when resolving
5183 the pieces that make up such a context.
5184 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5185 variables), some checks are not performed.
5187 Optionally, a possible error message can be suppressed if context is NULL
5188 and just the return status (true / false) be requested. */
5191 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5192 bool own_scope
, const char* context
)
5194 gfc_symbol
* sym
= NULL
;
5196 bool check_intentin
;
5198 symbol_attribute attr
;
5202 if (e
->expr_type
== EXPR_VARIABLE
)
5204 gcc_assert (e
->symtree
);
5205 sym
= e
->symtree
->n
.sym
;
5207 else if (e
->expr_type
== EXPR_FUNCTION
)
5209 gcc_assert (e
->symtree
);
5210 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5213 attr
= gfc_expr_attr (e
);
5214 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5216 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5219 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5220 " context (%s) at %L", context
, &e
->where
);
5224 else if (e
->expr_type
!= EXPR_VARIABLE
)
5227 gfc_error ("Non-variable expression in variable definition context (%s)"
5228 " at %L", context
, &e
->where
);
5232 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
5235 gfc_error ("Named constant %qs in variable definition context (%s)"
5236 " at %L", sym
->name
, context
, &e
->where
);
5239 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
5240 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
5241 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5244 gfc_error ("%qs in variable definition context (%s) at %L is not"
5245 " a variable", sym
->name
, context
, &e
->where
);
5249 /* Find out whether the expr is a pointer; this also means following
5250 component references to the last one. */
5251 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
5252 if (pointer
&& !is_pointer
)
5255 gfc_error ("Non-POINTER in pointer association context (%s)"
5256 " at %L", context
, &e
->where
);
5260 if (e
->ts
.type
== BT_DERIVED
5261 && e
->ts
.u
.derived
== NULL
)
5264 gfc_error ("Type inaccessible in variable definition context (%s) "
5265 "at %L", context
, &e
->where
);
5272 || (e
->ts
.type
== BT_DERIVED
5273 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5274 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
5277 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5278 context
, &e
->where
);
5282 /* TS18508, C702/C203. */
5285 || (e
->ts
.type
== BT_DERIVED
5286 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5287 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
5290 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5291 context
, &e
->where
);
5295 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5296 component of sub-component of a pointer; we need to distinguish
5297 assignment to a pointer component from pointer-assignment to a pointer
5298 component. Note that (normal) assignment to procedure pointers is not
5300 check_intentin
= !own_scope
;
5301 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5302 && CLASS_DATA (sym
))
5303 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
5304 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
5306 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
5307 check_intentin
= false;
5308 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
5310 ptr_component
= true;
5312 check_intentin
= false;
5315 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
5317 if (pointer
&& is_pointer
)
5320 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5321 " association context (%s) at %L",
5322 sym
->name
, context
, &e
->where
);
5325 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
5328 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5329 " definition context (%s) at %L",
5330 sym
->name
, context
, &e
->where
);
5335 /* PROTECTED and use-associated. */
5336 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
5338 if (pointer
&& is_pointer
)
5341 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5342 " pointer association context (%s) at %L",
5343 sym
->name
, context
, &e
->where
);
5346 if (!pointer
&& !is_pointer
)
5349 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5350 " variable definition context (%s) at %L",
5351 sym
->name
, context
, &e
->where
);
5356 /* Variable not assignable from a PURE procedure but appears in
5357 variable definition context. */
5358 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
5361 gfc_error ("Variable %qs can not appear in a variable definition"
5362 " context (%s) at %L in PURE procedure",
5363 sym
->name
, context
, &e
->where
);
5367 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
5368 && gfc_impure_variable (sym
))
5373 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5375 sym
= ns
->proc_name
;
5378 if (sym
->attr
.flavor
== FL_PROCEDURE
)
5380 sym
->attr
.implicit_pure
= 0;
5385 /* Check variable definition context for associate-names. */
5386 if (!pointer
&& sym
->assoc
)
5389 gfc_association_list
* assoc
;
5391 gcc_assert (sym
->assoc
->target
);
5393 /* If this is a SELECT TYPE temporary (the association is used internally
5394 for SELECT TYPE), silently go over to the target. */
5395 if (sym
->attr
.select_type_temporary
)
5397 gfc_expr
* t
= sym
->assoc
->target
;
5399 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
5400 name
= t
->symtree
->name
;
5402 if (t
->symtree
->n
.sym
->assoc
)
5403 assoc
= t
->symtree
->n
.sym
->assoc
;
5412 gcc_assert (name
&& assoc
);
5414 /* Is association to a valid variable? */
5415 if (!assoc
->variable
)
5419 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
5420 gfc_error ("%qs at %L associated to vector-indexed target can"
5421 " not be used in a variable definition context (%s)",
5422 name
, &e
->where
, context
);
5424 gfc_error ("%qs at %L associated to expression can"
5425 " not be used in a variable definition context (%s)",
5426 name
, &e
->where
, context
);
5431 /* Target must be allowed to appear in a variable definition context. */
5432 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
5435 gfc_error ("Associate-name %qs can not appear in a variable"
5436 " definition context (%s) at %L because its target"
5437 " at %L can not, either",
5438 name
, context
, &e
->where
,
5439 &assoc
->target
->where
);
5444 /* Check for same value in vector expression subscript. */
5447 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
5448 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5449 for (i
= 0; i
< GFC_MAX_DIMENSIONS
5450 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
5451 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5453 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
5454 if (arr
->expr_type
== EXPR_ARRAY
)
5456 gfc_constructor
*c
, *n
;
5459 for (c
= gfc_constructor_first (arr
->value
.constructor
);
5460 c
!= NULL
; c
= gfc_constructor_next (c
))
5462 if (c
== NULL
|| c
->iterator
!= NULL
)
5467 for (n
= gfc_constructor_next (c
); n
!= NULL
;
5468 n
= gfc_constructor_next (n
))
5470 if (n
->iterator
!= NULL
)
5474 if (gfc_dep_compare_expr (ec
, en
) == 0)
5477 gfc_error_now ("Elements with the same value "
5478 "at %L and %L in vector "
5479 "subscript in a variable "
5480 "definition context (%s)",
5481 &(ec
->where
), &(en
->where
),