1 /* Translation of constants
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-const.c -- convert constant values */
26 #include "coretypes.h"
29 #include "diagnostic-core.h" /* For fatal_error. */
30 #include "double-int.h"
33 #include "trans-const.h"
34 #include "trans-types.h"
35 #include "target-memory.h"
37 tree gfc_rank_cst
[GFC_MAX_DIMENSIONS
+ 1];
39 /* Build a constant with given type from an int_cst. */
42 gfc_build_const (tree type
, tree intval
)
47 switch (TREE_CODE (type
))
50 val
= convert (type
, intval
);
54 val
= build_real_from_int_cst (type
, intval
);
58 val
= build_real_from_int_cst (TREE_TYPE (type
), intval
);
59 zero
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
60 val
= build_complex (type
, val
, zero
);
69 /* Build a string constant with C char type. */
72 gfc_build_string_const (int length
, const char *s
)
77 str
= build_string (length
, s
);
78 len
= build_int_cst (NULL_TREE
, length
);
80 build_array_type (gfc_character1_type_node
,
81 build_range_type (gfc_charlen_type_node
,
82 integer_one_node
, len
));
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
, int 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
= build_int_cst (NULL_TREE
, length
);
109 build_array_type (gfc_get_char_type (kind
),
110 build_range_type (gfc_charlen_type_node
,
111 integer_one_node
, len
));
116 /* Build a Fortran character constant from a zero-terminated string.
117 There a two version of this function, one that translates the string
118 and one that doesn't. */
120 gfc_build_cstring_const (const char *string
)
122 return gfc_build_string_const (strlen (string
) + 1, string
);
126 gfc_build_localized_cstring_const (const char *msgid
)
128 const char *localized
= _(msgid
);
129 return gfc_build_string_const (strlen (localized
) + 1, localized
);
133 /* Return a string constant with the given length. Used for static
134 initializers. The constant will be padded or truncated to match
138 gfc_conv_string_init (tree length
, gfc_expr
* expr
)
146 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
147 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
148 gcc_assert (INTEGER_CST_P (length
));
149 gcc_assert (TREE_INT_CST_HIGH (length
) == 0);
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 double_int val
= mpz_get_double_int (gfc_get_int_type (kind
), i
, true);
205 return double_int_to_tree (gfc_get_int_type (kind
), val
);
208 /* Converts a backend tree into a GMP integer. */
211 gfc_conv_tree_to_mpz (mpz_t i
, tree source
)
213 double_int val
= tree_to_double_int (source
);
214 mpz_set_double_int (i
, val
, TYPE_UNSIGNED (TREE_TYPE (source
)));
217 /* Converts a real constant into backend form. */
220 gfc_conv_mpfr_to_tree (mpfr_t f
, int kind
, int is_snan
)
224 REAL_VALUE_TYPE real
;
226 n
= gfc_validate_kind (BT_REAL
, kind
, false);
227 gcc_assert (gfc_real_kinds
[n
].radix
== 2);
229 type
= gfc_get_real_type (kind
);
230 if (mpfr_nan_p (f
) && is_snan
)
231 real_from_string (&real
, "SNaN");
233 real_from_mpfr (&real
, f
, type
, GFC_RND_MODE
);
235 return build_real (type
, real
);
238 /* Converts a backend tree into a real constant. */
241 gfc_conv_tree_to_mpfr (mpfr_ptr f
, tree source
)
243 mpfr_from_real (f
, TREE_REAL_CST_PTR (source
), GFC_RND_MODE
);
246 /* Translate any literal constant to a tree. Constants never have
247 pre or post chains. Character literal constants are special
248 special because they have a value and a length, so they cannot be
249 returned as a single tree. It is up to the caller to set the
250 length somewhere if necessary.
252 Returns the translated constant, or aborts if it gets a type it
256 gfc_conv_constant_to_tree (gfc_expr
* expr
)
260 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
262 /* If it is has a prescribed memory representation, we build a string
263 constant and VIEW_CONVERT to its type. */
265 switch (expr
->ts
.type
)
268 if (expr
->representation
.string
)
269 return fold_build1 (VIEW_CONVERT_EXPR
,
270 gfc_get_int_type (expr
->ts
.kind
),
271 gfc_build_string_const (expr
->representation
.length
,
272 expr
->representation
.string
));
274 return gfc_conv_mpz_to_tree (expr
->value
.integer
, expr
->ts
.kind
);
277 if (expr
->representation
.string
)
278 return fold_build1 (VIEW_CONVERT_EXPR
,
279 gfc_get_real_type (expr
->ts
.kind
),
280 gfc_build_string_const (expr
->representation
.length
,
281 expr
->representation
.string
));
283 return gfc_conv_mpfr_to_tree (expr
->value
.real
, expr
->ts
.kind
, expr
->is_snan
);
286 if (expr
->representation
.string
)
288 tree tmp
= fold_build1 (VIEW_CONVERT_EXPR
,
289 gfc_get_int_type (expr
->ts
.kind
),
290 gfc_build_string_const (expr
->representation
.length
,
291 expr
->representation
.string
));
292 if (!integer_zerop (tmp
) && !integer_onep (tmp
))
293 gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
294 " has undefined result at %L", &expr
->where
);
295 return fold_convert (gfc_get_logical_type (expr
->ts
.kind
), tmp
);
298 return build_int_cst (gfc_get_logical_type (expr
->ts
.kind
),
299 expr
->value
.logical
);
302 if (expr
->representation
.string
)
303 return fold_build1 (VIEW_CONVERT_EXPR
,
304 gfc_get_complex_type (expr
->ts
.kind
),
305 gfc_build_string_const (expr
->representation
.length
,
306 expr
->representation
.string
));
309 tree real
= gfc_conv_mpfr_to_tree (mpc_realref (expr
->value
.complex),
310 expr
->ts
.kind
, expr
->is_snan
);
311 tree imag
= gfc_conv_mpfr_to_tree (mpc_imagref (expr
->value
.complex),
312 expr
->ts
.kind
, expr
->is_snan
);
314 return build_complex (gfc_typenode_for_spec (&expr
->ts
),
319 res
= gfc_build_wide_string_const (expr
->ts
.kind
,
320 expr
->value
.character
.length
,
321 expr
->value
.character
.string
);
325 return gfc_build_string_const (expr
->representation
.length
,
326 expr
->representation
.string
);
329 fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
330 gfc_typename (&expr
->ts
));
335 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
336 We can handle character literal constants here as well. */
339 gfc_conv_constant (gfc_se
* se
, gfc_expr
* expr
)
341 /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If
342 so, the expr_type will not yet be an EXPR_CONSTANT. We need to make
344 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
345 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
347 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
348 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
350 /* Create a new EXPR_CONSTANT expression for our local uses. */
351 expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
355 if (expr
->expr_type
!= EXPR_CONSTANT
)
357 gfc_expr
*e
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
358 gfc_error ("non-constant initialization expression at %L", &expr
->where
);
359 se
->expr
= gfc_conv_constant_to_tree (e
);
365 gcc_assert (se
->ss
!= gfc_ss_terminator
);
366 gcc_assert (se
->ss
->type
== GFC_SS_SCALAR
);
367 gcc_assert (se
->ss
->expr
== expr
);
369 se
->expr
= se
->ss
->data
.scalar
.expr
;
370 se
->string_length
= se
->ss
->string_length
;
371 gfc_advance_se_ss_chain (se
);
375 /* Translate the constant and put it in the simplifier structure. */
376 se
->expr
= gfc_conv_constant_to_tree (expr
);
378 /* If this is a CHARACTER string, set its length in the simplifier
380 if (expr
->ts
.type
== BT_CHARACTER
)
381 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));