e2cd40bc954d81c37b1cf2e3b9df0d7b9e6834e2
1 /* Translation of constants
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
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"
31 #include "double-int.h"
34 #include "trans-const.h"
35 #include "trans-types.h"
36 #include "target-memory.h"
38 tree gfc_rank_cst
[GFC_MAX_DIMENSIONS
+ 1];
40 /* Build a constant with given type from an int_cst. */
43 gfc_build_const (tree type
, tree intval
)
48 switch (TREE_CODE (type
))
51 val
= convert (type
, intval
);
55 val
= build_real_from_int_cst (type
, intval
);
59 val
= build_real_from_int_cst (TREE_TYPE (type
), intval
);
60 zero
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
61 val
= build_complex (type
, val
, zero
);
70 /* Build a string constant with C char type. */
73 gfc_build_string_const (int length
, const char *s
)
78 str
= build_string (length
, s
);
79 len
= build_int_cst (NULL_TREE
, length
);
81 build_array_type (gfc_character1_type_node
,
82 build_range_type (gfc_charlen_type_node
,
83 integer_one_node
, len
));
88 /* Build a string constant with a type given by its kind; take care of
89 non-default character kinds. */
92 gfc_build_wide_string_const (int kind
, int length
, const gfc_char_t
*string
)
99 i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
100 size
= length
* gfc_character_kinds
[i
].bit_size
/ 8;
102 s
= XCNEWVAR (char, size
);
103 gfc_encode_character (kind
, length
, string
, (unsigned char *) s
, size
);
105 str
= build_string (size
, s
);
108 len
= build_int_cst (NULL_TREE
, length
);
110 build_array_type (gfc_get_char_type (kind
),
111 build_range_type (gfc_charlen_type_node
,
112 integer_one_node
, len
));
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 (INTEGER_CST_P (length
));
150 gcc_assert (TREE_INT_CST_HIGH (length
) == 0);
152 len
= TREE_INT_CST_LOW (length
);
153 slen
= expr
->value
.character
.length
;
157 s
= gfc_get_wide_string (len
);
158 memcpy (s
, expr
->value
.character
.string
, slen
* sizeof (gfc_char_t
));
159 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
163 s
= expr
->value
.character
.string
;
165 str
= gfc_build_wide_string_const (expr
->ts
.kind
, len
, s
);
174 /* Create a tree node for the string length if it is constant. */
177 gfc_conv_const_charlen (gfc_charlen
* cl
)
179 if (!cl
|| cl
->backend_decl
)
182 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
)
184 cl
->backend_decl
= gfc_conv_mpz_to_tree (cl
->length
->value
.integer
,
185 cl
->length
->ts
.kind
);
186 cl
->backend_decl
= fold_convert (gfc_charlen_type_node
,
192 gfc_init_constants (void)
196 for (n
= 0; n
<= GFC_MAX_DIMENSIONS
; n
++)
197 gfc_rank_cst
[n
] = build_int_cst (gfc_array_index_type
, n
);
200 /* Converts a GMP integer into a backend tree node. */
203 gfc_conv_mpz_to_tree (mpz_t i
, int kind
)
205 double_int val
= mpz_get_double_int (gfc_get_int_type (kind
), i
, true);
206 return double_int_to_tree (gfc_get_int_type (kind
), val
);
209 /* Converts a backend tree into a GMP integer. */
212 gfc_conv_tree_to_mpz (mpz_t i
, tree source
)
214 double_int val
= tree_to_double_int (source
);
215 mpz_set_double_int (i
, val
, TYPE_UNSIGNED (TREE_TYPE (source
)));
218 /* Converts a real constant into backend form. */
221 gfc_conv_mpfr_to_tree (mpfr_t f
, int kind
, int is_snan
)
225 REAL_VALUE_TYPE real
;
227 n
= gfc_validate_kind (BT_REAL
, kind
, false);
228 gcc_assert (gfc_real_kinds
[n
].radix
== 2);
230 type
= gfc_get_real_type (kind
);
231 if (mpfr_nan_p (f
) && is_snan
)
232 real_from_string (&real
, "SNaN");
234 real_from_mpfr (&real
, f
, type
, GFC_RND_MODE
);
236 return build_real (type
, real
);
239 /* Converts a backend tree into a real constant. */
242 gfc_conv_tree_to_mpfr (mpfr_ptr f
, tree source
)
244 mpfr_from_real (f
, TREE_REAL_CST_PTR (source
), GFC_RND_MODE
);
247 /* Translate any literal constant to a tree. Constants never have
248 pre or post chains. Character literal constants are special
249 special because they have a value and a length, so they cannot be
250 returned as a single tree. It is up to the caller to set the
251 length somewhere if necessary.
253 Returns the translated constant, or aborts if it gets a type it
257 gfc_conv_constant_to_tree (gfc_expr
* expr
)
261 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
263 /* If it is has a prescribed memory representation, we build a string
264 constant and VIEW_CONVERT to its type. */
266 switch (expr
->ts
.type
)
269 if (expr
->representation
.string
)
270 return fold_build1 (VIEW_CONVERT_EXPR
,
271 gfc_get_int_type (expr
->ts
.kind
),
272 gfc_build_string_const (expr
->representation
.length
,
273 expr
->representation
.string
));
275 return gfc_conv_mpz_to_tree (expr
->value
.integer
, expr
->ts
.kind
);
278 if (expr
->representation
.string
)
279 return fold_build1 (VIEW_CONVERT_EXPR
,
280 gfc_get_real_type (expr
->ts
.kind
),
281 gfc_build_string_const (expr
->representation
.length
,
282 expr
->representation
.string
));
284 return gfc_conv_mpfr_to_tree (expr
->value
.real
, expr
->ts
.kind
, expr
->is_snan
);
287 if (expr
->representation
.string
)
289 tree tmp
= fold_build1 (VIEW_CONVERT_EXPR
,
290 gfc_get_int_type (expr
->ts
.kind
),
291 gfc_build_string_const (expr
->representation
.length
,
292 expr
->representation
.string
));
293 if (!integer_zerop (tmp
) && !integer_onep (tmp
))
294 gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
295 " has undefined result at %L", &expr
->where
);
296 return fold_convert (gfc_get_logical_type (expr
->ts
.kind
), tmp
);
299 return build_int_cst (gfc_get_logical_type (expr
->ts
.kind
),
300 expr
->value
.logical
);
303 if (expr
->representation
.string
)
304 return fold_build1 (VIEW_CONVERT_EXPR
,
305 gfc_get_complex_type (expr
->ts
.kind
),
306 gfc_build_string_const (expr
->representation
.length
,
307 expr
->representation
.string
));
310 tree real
= gfc_conv_mpfr_to_tree (mpc_realref (expr
->value
.complex),
311 expr
->ts
.kind
, expr
->is_snan
);
312 tree imag
= gfc_conv_mpfr_to_tree (mpc_imagref (expr
->value
.complex),
313 expr
->ts
.kind
, expr
->is_snan
);
315 return build_complex (gfc_typenode_for_spec (&expr
->ts
),
320 res
= gfc_build_wide_string_const (expr
->ts
.kind
,
321 expr
->value
.character
.length
,
322 expr
->value
.character
.string
);
326 return gfc_build_string_const (expr
->representation
.length
,
327 expr
->representation
.string
);
330 fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
331 gfc_typename (&expr
->ts
));
336 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
337 We can handle character literal constants here as well. */
340 gfc_conv_constant (gfc_se
* se
, gfc_expr
* expr
)
342 /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If
343 so, the expr_type will not yet be an EXPR_CONSTANT. We need to make
345 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
346 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
348 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
349 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
351 /* Create a new EXPR_CONSTANT expression for our local uses. */
352 expr
= gfc_int_expr (0);
356 if (expr
->expr_type
!= EXPR_CONSTANT
)
358 gfc_error ("non-constant initialization expression at %L", &expr
->where
);
364 gcc_assert (se
->ss
!= gfc_ss_terminator
);
365 gcc_assert (se
->ss
->type
== GFC_SS_SCALAR
);
366 gcc_assert (se
->ss
->expr
== expr
);
368 se
->expr
= se
->ss
->data
.scalar
.expr
;
369 se
->string_length
= se
->ss
->string_length
;
370 gfc_advance_se_ss_chain (se
);
374 /* Translate the constant and put it in the simplifier structure. */
375 se
->expr
= gfc_conv_constant_to_tree (expr
);
377 /* If this is a CHARACTER string, set its length in the simplifier
379 if (expr
->ts
.type
== BT_CHARACTER
)
380 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));