1 /* Translation of constants
2 Copyright (C) 2002, 2003, 2004, 2005 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 2, 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 COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
22 /* trans-const.c -- convert constant values */
26 #include "coretypes.h"
33 #include "trans-const.h"
34 #include "trans-types.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
);
69 gfc_build_string_const (int length
, const char *s
)
74 str
= build_string (length
, s
);
75 len
= build_int_cst (NULL_TREE
, length
);
77 build_array_type (gfc_character1_type_node
,
78 build_range_type (gfc_charlen_type_node
,
79 integer_one_node
, len
));
83 /* Build a Fortran character constant from a zero-terminated string.
84 Since this is mainly used for error messages, the string will get
87 gfc_build_cstring_const (const char *msgid
)
89 return gfc_build_string_const (strlen (msgid
) + 1, _(msgid
));
92 /* Return a string constant with the given length. Used for static
93 initializers. The constant will be padded or truncated to match
97 gfc_conv_string_init (tree length
, gfc_expr
* expr
)
104 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
105 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
106 gcc_assert (INTEGER_CST_P (length
));
107 gcc_assert (TREE_INT_CST_HIGH (length
) == 0);
109 len
= TREE_INT_CST_LOW (length
);
110 slen
= expr
->value
.character
.length
;
114 s
= gfc_getmem (len
);
115 memcpy (s
, expr
->value
.character
.string
, slen
);
116 memset (&s
[slen
], ' ', len
- slen
);
117 str
= gfc_build_string_const (len
, s
);
121 str
= gfc_build_string_const (len
, expr
->value
.character
.string
);
127 /* Create a tree node for the string length if it is constant. */
130 gfc_conv_const_charlen (gfc_charlen
* cl
)
132 if (cl
->backend_decl
)
135 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
)
137 cl
->backend_decl
= gfc_conv_mpz_to_tree (cl
->length
->value
.integer
,
138 cl
->length
->ts
.kind
);
139 cl
->backend_decl
= fold_convert (gfc_charlen_type_node
,
145 gfc_init_constants (void)
149 for (n
= 0; n
<= GFC_MAX_DIMENSIONS
; n
++)
150 gfc_rank_cst
[n
] = build_int_cst (gfc_array_index_type
, n
);
153 /* Converts a GMP integer into a backend tree node. */
155 gfc_conv_mpz_to_tree (mpz_t i
, int kind
)
158 unsigned HOST_WIDE_INT low
;
160 if (mpz_fits_slong_p (i
))
162 /* Note that HOST_WIDE_INT is never smaller than long. */
163 low
= mpz_get_si (i
);
164 high
= mpz_sgn (i
) < 0 ? -1 : 0;
168 unsigned HOST_WIDE_INT words
[2];
171 /* Since we know that the value is not zero (mpz_fits_slong_p),
172 we know that at least one word will be written, but we don't know
173 about the second. It's quicker to zero the second word before
174 than conditionally clear it later. */
177 /* Extract the absolute value into words. */
178 mpz_export (words
, &count
, -1, sizeof (HOST_WIDE_INT
), 0, 0, i
);
180 /* We assume that all numbers are in range for its type, and that
181 we never create a type larger than 2*HWI, which is the largest
182 that the middle-end can handle. */
183 gcc_assert (count
== 1 || count
== 2);
188 /* Negate if necessary. */
194 low
= -low
, high
= ~high
;
198 return build_int_cst_wide (gfc_get_int_type (kind
), low
, high
);
201 /* Converts a real constant into backend form. Uses an intermediate string
205 gfc_conv_mpfr_to_tree (mpfr_t f
, int kind
)
212 REAL_VALUE_TYPE real
;
214 n
= gfc_validate_kind (BT_REAL
, kind
, false);
216 gcc_assert (gfc_real_kinds
[n
].radix
== 2);
218 type
= gfc_get_real_type (kind
);
220 /* Take care of Infinity and NaN. */
224 if (mpfr_sgn (f
) < 0)
225 real
= REAL_VALUE_NEGATE(real
);
226 res
= build_real (type
, real
);
232 real_nan (&real
, "", 0, TYPE_MODE (type
));
233 res
= build_real (type
, real
);
237 /* mpfr chooses too small a number of hexadecimal digits if the
238 number of binary digits is not divisible by four, therefore we
239 have to explicitly request a sufficient number of digits here. */
240 p
= mpfr_get_str (NULL
, &exp
, 16, gfc_real_kinds
[n
].digits
/ 4 + 1,
243 /* REAL_VALUE_ATOF expects the exponent for mantissa * 2**exp,
244 mpfr_get_str returns the exponent for mantissa * 16**exp, adjust
248 /* The additional 12 characters add space for the sprintf below.
249 This leaves 6 digits for the exponent which is certainly enough. */
250 q
= (char *) gfc_getmem (strlen (p
) + 12);
253 sprintf (q
, "-0x.%sp%d", &p
[1], (int) exp
);
255 sprintf (q
, "0x.%sp%d", p
, (int) exp
);
257 res
= build_real (type
, REAL_VALUE_ATOF (q
, TYPE_MODE (type
)));
266 /* Translate any literal constant to a tree. Constants never have
267 pre or post chains. Character literal constants are special
268 special because they have a value and a length, so they cannot be
269 returned as a single tree. It is up to the caller to set the
270 length somewhere if necessary.
272 Returns the translated constant, or aborts if it gets a type it
276 gfc_conv_constant_to_tree (gfc_expr
* expr
)
278 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
280 /* If it is converted from Hollerith constant, we build string constant
281 and VIEW_CONVERT to its type. */
283 switch (expr
->ts
.type
)
287 return build1 (VIEW_CONVERT_EXPR
,
288 gfc_get_int_type (expr
->ts
.kind
),
289 gfc_build_string_const (expr
->value
.character
.length
,
290 expr
->value
.character
.string
));
292 return gfc_conv_mpz_to_tree (expr
->value
.integer
, expr
->ts
.kind
);
296 return build1 (VIEW_CONVERT_EXPR
,
297 gfc_get_real_type (expr
->ts
.kind
),
298 gfc_build_string_const (expr
->value
.character
.length
,
299 expr
->value
.character
.string
));
301 return gfc_conv_mpfr_to_tree (expr
->value
.real
, expr
->ts
.kind
);
305 return build1 (VIEW_CONVERT_EXPR
,
306 gfc_get_logical_type (expr
->ts
.kind
),
307 gfc_build_string_const (expr
->value
.character
.length
,
308 expr
->value
.character
.string
));
310 return build_int_cst (gfc_get_logical_type (expr
->ts
.kind
),
311 expr
->value
.logical
);
315 return build1 (VIEW_CONVERT_EXPR
,
316 gfc_get_complex_type (expr
->ts
.kind
),
317 gfc_build_string_const (expr
->value
.character
.length
,
318 expr
->value
.character
.string
));
321 tree real
= gfc_conv_mpfr_to_tree (expr
->value
.complex.r
,
323 tree imag
= gfc_conv_mpfr_to_tree (expr
->value
.complex.i
,
326 return build_complex (gfc_typenode_for_spec (&expr
->ts
),
332 return gfc_build_string_const (expr
->value
.character
.length
,
333 expr
->value
.character
.string
);
336 fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
337 gfc_typename (&expr
->ts
));
342 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
343 We can handle character literal constants here as well. */
346 gfc_conv_constant (gfc_se
* se
, gfc_expr
* expr
)
348 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
352 gcc_assert (se
->ss
!= gfc_ss_terminator
);
353 gcc_assert (se
->ss
->type
== GFC_SS_SCALAR
);
354 gcc_assert (se
->ss
->expr
== expr
);
356 se
->expr
= se
->ss
->data
.scalar
.expr
;
357 se
->string_length
= se
->ss
->string_length
;
358 gfc_advance_se_ss_chain (se
);
362 /* Translate the constant and put it in the simplifier structure. */
363 se
->expr
= gfc_conv_constant_to_tree (expr
);
365 /* If this is a CHARACTER string, set its length in the simplifier
367 if (expr
->ts
.type
== BT_CHARACTER
)
368 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));