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 /* String constants. */
37 tree gfc_strconst_bounds
;
38 tree gfc_strconst_fault
;
39 tree gfc_strconst_wrong_return
;
40 tree gfc_strconst_current_filename
;
42 tree gfc_rank_cst
[GFC_MAX_DIMENSIONS
+ 1];
44 /* Build a constant with given type from an int_cst. */
47 gfc_build_const (tree type
, tree intval
)
52 switch (TREE_CODE (type
))
55 val
= convert (type
, intval
);
59 val
= build_real_from_int_cst (type
, intval
);
63 val
= build_real_from_int_cst (TREE_TYPE (type
), intval
);
64 zero
= build_real_from_int_cst (TREE_TYPE (type
), integer_zero_node
);
65 val
= build_complex (type
, val
, zero
);
75 gfc_build_string_const (int length
, const char *s
)
80 str
= build_string (length
, s
);
81 len
= build_int_cst (NULL_TREE
, length
);
83 build_array_type (gfc_character1_type_node
,
84 build_range_type (gfc_charlen_type_node
,
85 integer_one_node
, len
));
89 /* Build a Fortran character constant from a zero-terminated string.
90 Since this is mainly used for error messages, the string will get
93 gfc_build_cstring_const (const char *msgid
)
95 return gfc_build_string_const (strlen (msgid
) + 1, _(msgid
));
98 /* Return a string constant with the given length. Used for static
99 initializers. The constant will be padded or truncated to match
103 gfc_conv_string_init (tree length
, gfc_expr
* expr
)
110 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
111 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
112 gcc_assert (INTEGER_CST_P (length
));
113 gcc_assert (TREE_INT_CST_HIGH (length
) == 0);
115 len
= TREE_INT_CST_LOW (length
);
116 slen
= expr
->value
.character
.length
;
120 s
= gfc_getmem (len
);
121 memcpy (s
, expr
->value
.character
.string
, slen
);
122 memset (&s
[slen
], ' ', len
- slen
);
123 str
= gfc_build_string_const (len
, s
);
127 str
= gfc_build_string_const (len
, expr
->value
.character
.string
);
133 /* Create a tree node for the string length if it is constant. */
136 gfc_conv_const_charlen (gfc_charlen
* cl
)
138 if (cl
->backend_decl
)
141 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
)
143 cl
->backend_decl
= gfc_conv_mpz_to_tree (cl
->length
->value
.integer
,
144 cl
->length
->ts
.kind
);
145 cl
->backend_decl
= fold_convert (gfc_charlen_type_node
,
151 gfc_init_constants (void)
155 for (n
= 0; n
<= GFC_MAX_DIMENSIONS
; n
++)
156 gfc_rank_cst
[n
] = build_int_cst (gfc_array_index_type
, n
);
158 gfc_strconst_bounds
= gfc_build_cstring_const ("Array bound mismatch");
161 gfc_build_cstring_const ("Array reference out of bounds");
163 gfc_strconst_wrong_return
=
164 gfc_build_cstring_const ("Incorrect function return value");
166 gfc_strconst_current_filename
=
167 gfc_build_cstring_const (gfc_source_file
);
170 /* Converts a GMP integer into a backend tree node. */
172 gfc_conv_mpz_to_tree (mpz_t i
, int kind
)
175 unsigned HOST_WIDE_INT low
;
177 if (mpz_fits_slong_p (i
))
179 /* Note that HOST_WIDE_INT is never smaller than long. */
180 low
= mpz_get_si (i
);
181 high
= mpz_sgn (i
) < 0 ? -1 : 0;
185 unsigned HOST_WIDE_INT words
[2];
188 /* Since we know that the value is not zero (mpz_fits_slong_p),
189 we know that at least one word will be written, but we don't know
190 about the second. It's quicker to zero the second word before
191 than conditionally clear it later. */
194 /* Extract the absolute value into words. */
195 mpz_export (words
, &count
, -1, sizeof (HOST_WIDE_INT
), 0, 0, i
);
197 /* We assume that all numbers are in range for its type, and that
198 we never create a type larger than 2*HWI, which is the largest
199 that the middle-end can handle. */
200 gcc_assert (count
== 1 || count
== 2);
205 /* Negate if necessary. */
211 low
= -low
, high
= ~high
;
215 return build_int_cst_wide (gfc_get_int_type (kind
), low
, high
);
218 /* Converts a real constant into backend form. Uses an intermediate string
222 gfc_conv_mpfr_to_tree (mpfr_t f
, int kind
)
230 n
= gfc_validate_kind (BT_REAL
, kind
, false);
232 gcc_assert (gfc_real_kinds
[n
].radix
== 2);
234 /* mpfr chooses too small a number of hexadecimal digits if the
235 number of binary digits is not divisible by four, therefore we
236 have to explicitly request a sufficient number of digits here. */
237 p
= mpfr_get_str (NULL
, &exp
, 16, gfc_real_kinds
[n
].digits
/ 4 + 1,
240 /* REAL_VALUE_ATOF expects the exponent for mantissa * 2**exp,
241 mpfr_get_str returns the exponent for mantissa * 16**exp, adjust
245 /* The additional 12 characters add space for the sprintf below.
246 This leaves 6 digits for the exponent which is certainly enough. */
247 q
= (char *) gfc_getmem (strlen (p
) + 12);
250 sprintf (q
, "-0x.%sp%d", &p
[1], (int) exp
);
252 sprintf (q
, "0x.%sp%d", p
, (int) exp
);
254 type
= gfc_get_real_type (kind
);
255 res
= build_real (type
, REAL_VALUE_ATOF (q
, TYPE_MODE (type
)));
264 /* Translate any literal constant to a tree. Constants never have
265 pre or post chains. Character literal constants are special
266 special because they have a value and a length, so they cannot be
267 returned as a single tree. It is up to the caller to set the
268 length somewhere if necessary.
270 Returns the translated constant, or aborts if it gets a type it
274 gfc_conv_constant_to_tree (gfc_expr
* expr
)
276 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
278 /* If it is converted from Hollerith constant, we build string constant
279 and VIEW_CONVERT to its type. */
281 switch (expr
->ts
.type
)
285 return build1 (VIEW_CONVERT_EXPR
,
286 gfc_get_int_type (expr
->ts
.kind
),
287 gfc_build_string_const (expr
->value
.character
.length
,
288 expr
->value
.character
.string
));
290 return gfc_conv_mpz_to_tree (expr
->value
.integer
, expr
->ts
.kind
);
294 return build1 (VIEW_CONVERT_EXPR
,
295 gfc_get_real_type (expr
->ts
.kind
),
296 gfc_build_string_const (expr
->value
.character
.length
,
297 expr
->value
.character
.string
));
299 return gfc_conv_mpfr_to_tree (expr
->value
.real
, expr
->ts
.kind
);
303 return build1 (VIEW_CONVERT_EXPR
,
304 gfc_get_logical_type (expr
->ts
.kind
),
305 gfc_build_string_const (expr
->value
.character
.length
,
306 expr
->value
.character
.string
));
308 return build_int_cst (gfc_get_logical_type (expr
->ts
.kind
),
309 expr
->value
.logical
);
313 return build1 (VIEW_CONVERT_EXPR
,
314 gfc_get_complex_type (expr
->ts
.kind
),
315 gfc_build_string_const (expr
->value
.character
.length
,
316 expr
->value
.character
.string
));
319 tree real
= gfc_conv_mpfr_to_tree (expr
->value
.complex.r
,
321 tree imag
= gfc_conv_mpfr_to_tree (expr
->value
.complex.i
,
324 return build_complex (gfc_typenode_for_spec (&expr
->ts
),
330 return gfc_build_string_const (expr
->value
.character
.length
,
331 expr
->value
.character
.string
);
334 fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
335 gfc_typename (&expr
->ts
));
340 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
341 We can handle character literal constants here as well. */
344 gfc_conv_constant (gfc_se
* se
, gfc_expr
* expr
)
346 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
350 gcc_assert (se
->ss
!= gfc_ss_terminator
);
351 gcc_assert (se
->ss
->type
== GFC_SS_SCALAR
);
352 gcc_assert (se
->ss
->expr
== expr
);
354 se
->expr
= se
->ss
->data
.scalar
.expr
;
355 se
->string_length
= se
->ss
->string_length
;
356 gfc_advance_se_ss_chain (se
);
360 /* Translate the constant and put it in the simplifier structure. */
361 se
->expr
= gfc_conv_constant_to_tree (expr
);
363 /* If this is a CHARACTER string, set its length in the simplifier
365 if (expr
->ts
.type
== BT_CHARACTER
)
366 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));