* c-common.c (get_priority): Add check for
[official-gcc.git] / gcc / fortran / trans-const.c
blobc1c966197155d4603b6b7982f14c4ea304541651
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
10 version.
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
15 for more details.
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
20 02110-1301, USA. */
22 /* trans-const.c -- convert constant values */
24 #include "config.h"
25 #include "system.h"
26 #include "coretypes.h"
27 #include "tree.h"
28 #include "ggc.h"
29 #include "toplev.h"
30 #include "real.h"
31 #include "gfortran.h"
32 #include "trans.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. */
40 tree
41 gfc_build_const (tree type, tree intval)
43 tree val;
44 tree zero;
46 switch (TREE_CODE (type))
48 case INTEGER_TYPE:
49 val = convert (type, intval);
50 break;
52 case REAL_TYPE:
53 val = build_real_from_int_cst (type, intval);
54 break;
56 case COMPLEX_TYPE:
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);
60 break;
62 default:
63 gcc_unreachable ();
65 return val;
68 tree
69 gfc_build_string_const (int length, const char *s)
71 tree str;
72 tree len;
74 str = build_string (length, s);
75 len = build_int_cst (NULL_TREE, length);
76 TREE_TYPE (str) =
77 build_array_type (gfc_character1_type_node,
78 build_range_type (gfc_charlen_type_node,
79 integer_one_node, len));
80 return str;
83 /* Build a Fortran character constant from a zero-terminated string.
84 Since this is mainly used for error messages, the string will get
85 translated. */
86 tree
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
94 length. */
96 tree
97 gfc_conv_string_init (tree length, gfc_expr * expr)
99 char *s;
100 HOST_WIDE_INT len;
101 int slen;
102 tree str;
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;
112 if (len > slen)
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);
118 gfc_free (s);
120 else
121 str = gfc_build_string_const (len, expr->value.character.string);
123 return str;
127 /* Create a tree node for the string length if it is constant. */
129 void
130 gfc_conv_const_charlen (gfc_charlen * cl)
132 if (cl->backend_decl)
133 return;
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,
140 cl->backend_decl);
144 void
145 gfc_init_constants (void)
147 int n;
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. */
154 tree
155 gfc_conv_mpz_to_tree (mpz_t i, int kind)
157 HOST_WIDE_INT high;
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;
166 else
168 unsigned HOST_WIDE_INT words[2];
169 size_t count;
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. */
175 words[1] = 0;
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);
185 low = words[0];
186 high = words[1];
188 /* Negate if necessary. */
189 if (mpz_sgn (i) < 0)
191 if (low == 0)
192 high = -high;
193 else
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
202 representation. */
204 tree
205 gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
207 tree res;
208 tree type;
209 mp_exp_t exp;
210 char *p, *q;
211 int n;
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. */
221 if (mpfr_inf_p (f))
223 real_inf (&real);
224 if (mpfr_sgn (f) < 0)
225 real = REAL_VALUE_NEGATE(real);
226 res = build_real (type , real);
227 return res;
230 if (mpfr_nan_p (f))
232 real_nan (&real, "", 0, TYPE_MODE (type));
233 res = build_real (type , real);
234 return res;
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,
241 f, GFC_RND_MODE);
243 /* REAL_VALUE_ATOF expects the exponent for mantissa * 2**exp,
244 mpfr_get_str returns the exponent for mantissa * 16**exp, adjust
245 for that. */
246 exp *= 4;
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);
252 if (p[0] == '-')
253 sprintf (q, "-0x.%sp%d", &p[1], (int) exp);
254 else
255 sprintf (q, "0x.%sp%d", p, (int) exp);
257 res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
259 gfc_free (q);
260 gfc_free (p);
262 return res;
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
273 can't handle. */
275 tree
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)
285 case BT_INTEGER:
286 if (expr->from_H)
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));
291 else
292 return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
294 case BT_REAL:
295 if (expr->from_H)
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));
300 else
301 return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
303 case BT_LOGICAL:
304 if (expr->from_H)
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));
309 else
310 return build_int_cst (gfc_get_logical_type (expr->ts.kind),
311 expr->value.logical);
313 case BT_COMPLEX:
314 if (expr->from_H)
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));
319 else
321 tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
322 expr->ts.kind);
323 tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
324 expr->ts.kind);
326 return build_complex (gfc_typenode_for_spec (&expr->ts),
327 real, imag);
330 case BT_CHARACTER:
331 case BT_HOLLERITH:
332 return gfc_build_string_const (expr->value.character.length,
333 expr->value.character.string);
335 default:
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. */
345 void
346 gfc_conv_constant (gfc_se * se, gfc_expr * expr)
348 gcc_assert (expr->expr_type == EXPR_CONSTANT);
350 if (se->ss != NULL)
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);
359 return;
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
366 structure, too. */
367 if (expr->ts.type == BT_CHARACTER)
368 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));