1 /* Translation of constants
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook
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/>. */
21 /* trans-const.c -- convert constant values */
25 #include "coretypes.h"
29 #include "fold-const.h"
30 #include "stor-layout.h"
32 #include "trans-const.h"
33 #include "trans-types.h"
34 #include "target-memory.h"
36 tree gfc_rank_cst
[GFC_MAX_DIMENSIONS
+ 1];
38 /* Build a constant with given type from an int_cst. */
41 gfc_build_const (tree type
, tree intval
)
46 switch (TREE_CODE (type
))
49 val
= convert (type
, intval
);
53 val
= build_real_from_int_cst (type
, intval
);
57 val
= build_real_from_int_cst (TREE_TYPE (type
), intval
);
58 zero
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
59 val
= build_complex (type
, val
, zero
);
68 /* Build a string constant with C char type. */
71 gfc_build_string_const (size_t length
, const char *s
)
76 str
= build_string (length
, s
);
77 len
= size_int (length
);
79 build_array_type (gfc_character1_type_node
,
80 build_range_type (gfc_charlen_type_node
,
82 TYPE_STRING_FLAG (TREE_TYPE (str
)) = 1;
87 /* Build a string constant with a type given by its kind; take care of
88 non-default character kinds. */
91 gfc_build_wide_string_const (int kind
, size_t length
, const gfc_char_t
*string
)
98 i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
99 size
= length
* gfc_character_kinds
[i
].bit_size
/ 8;
101 s
= XCNEWVAR (char, size
);
102 gfc_encode_character (kind
, length
, string
, (unsigned char *) s
, size
);
104 str
= build_string (size
, s
);
107 len
= size_int (length
);
109 build_array_type (gfc_get_char_type (kind
),
110 build_range_type (gfc_charlen_type_node
,
111 size_one_node
, len
));
112 TYPE_STRING_FLAG (TREE_TYPE (str
)) = 1;
117 /* Build a Fortran character constant from a zero-terminated string.
118 There a two version of this function, one that translates the string
119 and one that doesn't. */
121 gfc_build_cstring_const (const char *string
)
123 return gfc_build_string_const (strlen (string
) + 1, string
);
127 gfc_build_localized_cstring_const (const char *msgid
)
129 const char *localized
= _(msgid
);
130 return gfc_build_string_const (strlen (localized
) + 1, localized
);
134 /* Return a string constant with the given length. Used for static
135 initializers. The constant will be padded or truncated to match
139 gfc_conv_string_init (tree length
, gfc_expr
* expr
)
147 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
148 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
149 gcc_assert (tree_fits_uhwi_p (length
));
151 len
= TREE_INT_CST_LOW (length
);
152 slen
= expr
->value
.character
.length
;
156 s
= gfc_get_wide_string (len
);
157 memcpy (s
, expr
->value
.character
.string
, slen
* sizeof (gfc_char_t
));
158 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
162 s
= expr
->value
.character
.string
;
164 str
= gfc_build_wide_string_const (expr
->ts
.kind
, len
, s
);
173 /* Create a tree node for the string length if it is constant. */
176 gfc_conv_const_charlen (gfc_charlen
* cl
)
178 if (!cl
|| cl
->backend_decl
)
181 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
)
183 cl
->backend_decl
= gfc_conv_mpz_to_tree (cl
->length
->value
.integer
,
184 cl
->length
->ts
.kind
);
185 cl
->backend_decl
= fold_convert (gfc_charlen_type_node
,
191 gfc_init_constants (void)
195 for (n
= 0; n
<= GFC_MAX_DIMENSIONS
; n
++)
196 gfc_rank_cst
[n
] = build_int_cst (gfc_array_index_type
, n
);
199 /* Converts a GMP integer into a backend tree node. */
202 gfc_conv_mpz_to_tree (mpz_t i
, int kind
)
204 wide_int val
= wi::from_mpz (gfc_get_int_type (kind
), i
, true);
205 return wide_int_to_tree (gfc_get_int_type (kind
), val
);
209 /* Convert a GMP integer into a tree node of type given by the type
213 gfc_conv_mpz_to_tree_type (mpz_t i
, const tree type
)
215 const wide_int val
= wi::from_mpz (type
, i
, true);
216 return wide_int_to_tree (type
, val
);
220 /* Converts a backend tree into a GMP integer. */
223 gfc_conv_tree_to_mpz (mpz_t i
, tree source
)
225 wi::to_mpz (wi::to_wide (source
), i
, TYPE_SIGN (TREE_TYPE (source
)));
228 /* Converts a real constant into backend form. */
231 gfc_conv_mpfr_to_tree (mpfr_t f
, int kind
, int is_snan
)
235 REAL_VALUE_TYPE real
;
237 n
= gfc_validate_kind (BT_REAL
, kind
, false);
238 gcc_assert (gfc_real_kinds
[n
].radix
== 2);
240 type
= gfc_get_real_type (kind
);
241 if (mpfr_nan_p (f
) && is_snan
)
242 real_from_string (&real
, "SNaN");
244 real_from_mpfr (&real
, f
, type
, GFC_RND_MODE
);
246 return build_real (type
, real
);
249 /* Returns a real constant that is +Infinity if the target
250 supports infinities for this floating-point mode, and
251 +HUGE_VAL otherwise (the largest representable number). */
254 gfc_build_inf_or_huge (tree type
, int kind
)
256 if (HONOR_INFINITIES (TYPE_MODE (type
)))
258 REAL_VALUE_TYPE real
;
260 return build_real (type
, real
);
264 int k
= gfc_validate_kind (BT_REAL
, kind
, false);
265 return gfc_conv_mpfr_to_tree (gfc_real_kinds
[k
].huge
, kind
, 0);
269 /* Returns a floating-point NaN of a given type. */
272 gfc_build_nan (tree type
, const char *str
)
274 REAL_VALUE_TYPE real
;
275 real_nan (&real
, str
, 1, TYPE_MODE (type
));
276 return build_real (type
, real
);
279 /* Converts a backend tree into a real constant. */
282 gfc_conv_tree_to_mpfr (mpfr_ptr f
, tree source
)
284 mpfr_from_real (f
, TREE_REAL_CST_PTR (source
), GFC_RND_MODE
);
287 /* Translate any literal constant to a tree. Constants never have
288 pre or post chains. Character literal constants are special
289 special because they have a value and a length, so they cannot be
290 returned as a single tree. It is up to the caller to set the
291 length somewhere if necessary.
293 Returns the translated constant, or aborts if it gets a type it
297 gfc_conv_constant_to_tree (gfc_expr
* expr
)
301 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
303 /* If it is has a prescribed memory representation, we build a string
304 constant and VIEW_CONVERT to its type. */
306 switch (expr
->ts
.type
)
309 if (expr
->representation
.string
)
310 return fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
311 gfc_get_int_type (expr
->ts
.kind
),
312 gfc_build_string_const (expr
->representation
.length
,
313 expr
->representation
.string
));
315 return gfc_conv_mpz_to_tree (expr
->value
.integer
, expr
->ts
.kind
);
318 if (expr
->representation
.string
)
319 return fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
320 gfc_get_real_type (expr
->ts
.kind
),
321 gfc_build_string_const (expr
->representation
.length
,
322 expr
->representation
.string
));
324 return gfc_conv_mpfr_to_tree (expr
->value
.real
, expr
->ts
.kind
, expr
->is_snan
);
327 if (expr
->representation
.string
)
329 tree tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
330 gfc_get_int_type (expr
->ts
.kind
),
331 gfc_build_string_const (expr
->representation
.length
,
332 expr
->representation
.string
));
333 if (!integer_zerop (tmp
) && !integer_onep (tmp
))
334 gfc_warning (0, "Assigning value other than 0 or 1 to LOGICAL"
335 " has undefined result at %L", &expr
->where
);
336 return fold_convert (gfc_get_logical_type (expr
->ts
.kind
), tmp
);
339 return build_int_cst (gfc_get_logical_type (expr
->ts
.kind
),
340 expr
->value
.logical
);
343 if (expr
->representation
.string
)
344 return fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
345 gfc_get_complex_type (expr
->ts
.kind
),
346 gfc_build_string_const (expr
->representation
.length
,
347 expr
->representation
.string
));
350 tree real
= gfc_conv_mpfr_to_tree (mpc_realref (expr
->value
.complex),
351 expr
->ts
.kind
, expr
->is_snan
);
352 tree imag
= gfc_conv_mpfr_to_tree (mpc_imagref (expr
->value
.complex),
353 expr
->ts
.kind
, expr
->is_snan
);
355 return build_complex (gfc_typenode_for_spec (&expr
->ts
),
360 res
= gfc_build_wide_string_const (expr
->ts
.kind
,
361 expr
->value
.character
.length
,
362 expr
->value
.character
.string
);
366 return gfc_build_string_const (expr
->representation
.length
,
367 expr
->representation
.string
);
375 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
376 We can handle character literal constants here as well. */
379 gfc_conv_constant (gfc_se
* se
, gfc_expr
* expr
)
383 /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If
384 so, the expr_type will not yet be an EXPR_CONSTANT. We need to make
386 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
387 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
389 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
390 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
392 /* Create a new EXPR_CONSTANT expression for our local uses. */
393 expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
397 if (expr
->expr_type
!= EXPR_CONSTANT
)
399 gfc_expr
*e
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
400 gfc_error ("non-constant initialization expression at %L", &expr
->where
);
401 se
->expr
= gfc_conv_constant_to_tree (e
);
408 gfc_ss_info
*ss_info
;
411 gcc_assert (ss
!= gfc_ss_terminator
);
412 gcc_assert (ss_info
->type
== GFC_SS_SCALAR
);
413 gcc_assert (ss_info
->expr
== expr
);
415 se
->expr
= ss_info
->data
.scalar
.value
;
416 se
->string_length
= ss_info
->string_length
;
417 gfc_advance_se_ss_chain (se
);
421 /* Translate the constant and put it in the simplifier structure. */
422 se
->expr
= gfc_conv_constant_to_tree (expr
);
424 /* If this is a CHARACTER string, set its length in the simplifier
426 if (expr
->ts
.type
== BT_CHARACTER
)
427 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));