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, 59 Temple Place - Suite 330, 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. */
92 gfc_build_cstring_const (const char *s
)
94 return gfc_build_string_const (strlen (s
) + 1, s
);
97 /* Return a string constant with the given length. Used for static
98 initializers. The constant will be padded or truncated to match
102 gfc_conv_string_init (tree length
, gfc_expr
* expr
)
109 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
110 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
111 gcc_assert (INTEGER_CST_P (length
));
112 gcc_assert (TREE_INT_CST_HIGH (length
) == 0);
114 len
= TREE_INT_CST_LOW (length
);
115 slen
= expr
->value
.character
.length
;
119 s
= gfc_getmem (len
);
120 memcpy (s
, expr
->value
.character
.string
, slen
);
121 memset (&s
[slen
], ' ', len
- slen
);
122 str
= gfc_build_string_const (len
, s
);
126 str
= gfc_build_string_const (len
, expr
->value
.character
.string
);
132 /* Create a tree node for the string length if it is constant. */
135 gfc_conv_const_charlen (gfc_charlen
* cl
)
137 if (cl
->backend_decl
)
140 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
)
142 cl
->backend_decl
= gfc_conv_mpz_to_tree (cl
->length
->value
.integer
,
143 cl
->length
->ts
.kind
);
148 gfc_init_constants (void)
152 for (n
= 0; n
<= GFC_MAX_DIMENSIONS
; n
++)
153 gfc_rank_cst
[n
] = build_int_cst (gfc_array_index_type
, n
);
155 gfc_strconst_bounds
= gfc_build_cstring_const ("Array bound mismatch");
158 gfc_build_cstring_const ("Array reference out of bounds");
160 gfc_strconst_wrong_return
=
161 gfc_build_cstring_const ("Incorrect function return value");
163 gfc_strconst_current_filename
=
164 gfc_build_cstring_const (gfc_option
.source
);
167 /* Converts a GMP integer into a backend tree node. */
169 gfc_conv_mpz_to_tree (mpz_t i
, int kind
)
172 unsigned HOST_WIDE_INT low
;
174 if (mpz_fits_slong_p (i
))
176 /* Note that HOST_WIDE_INT is never smaller than long. */
177 low
= mpz_get_si (i
);
178 high
= mpz_sgn (i
) < 0 ? -1 : 0;
182 unsigned HOST_WIDE_INT words
[2];
185 /* Since we know that the value is not zero (mpz_fits_slong_p),
186 we know that at one word will be written, but we don't know
187 about the second. It's quicker to zero the second word before
188 that conditionally clear it later. */
191 /* Extract the absolute value into words. */
192 mpz_export (words
, &count
, -1, sizeof (HOST_WIDE_INT
), 0, 0, i
);
194 /* We assume that all numbers are in range for its type, and that
195 we never create a type larger than 2*HWI, which is the largest
196 that the middle-end can handle. */
197 gcc_assert (count
== 1 || count
== 2);
202 /* Negate if necessary. */
208 low
= -low
, high
= ~high
;
212 return build_int_cst_wide (gfc_get_int_type (kind
), low
, high
);
215 /* Converts a real constant into backend form. Uses an intermediate string
219 gfc_conv_mpfr_to_tree (mpfr_t f
, int kind
)
229 for (n
= 0; gfc_real_kinds
[n
].kind
!= 0; n
++)
231 if (gfc_real_kinds
[n
].kind
== kind
)
234 gcc_assert (gfc_real_kinds
[n
].kind
);
236 n
= MAX (abs (gfc_real_kinds
[n
].min_exponent
),
237 abs (gfc_real_kinds
[n
].max_exponent
));
246 if (kind
== gfc_default_double_kind
)
247 p
= mpfr_get_str (NULL
, &exp
, 10, 17, f
, GFC_RND_MODE
);
249 p
= mpfr_get_str (NULL
, &exp
, 10, 8, f
, GFC_RND_MODE
);
252 /* We also have one minus sign, "e", "." and a null terminator. */
253 q
= (char *) gfc_getmem (strlen (p
) + edigits
+ 4);
259 strcpy (&q
[2], &p
[1]);
269 sprintf (&q
[strlen (q
)], "%d", (int) exp
);
276 type
= gfc_get_real_type (kind
);
277 res
= build_real (type
, REAL_VALUE_ATOF (q
, TYPE_MODE (type
)));
286 /* Translate any literal constant to a tree. Constants never have
287 pre or post chains. Character literal constants are special
288 special because they have a value and a length, so they cannot be
289 returned as a single tree. It is up to the caller to set the
290 length somewhere if necessary.
292 Returns the translated constant, or aborts if it gets a type it
296 gfc_conv_constant_to_tree (gfc_expr
* expr
)
298 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
300 switch (expr
->ts
.type
)
303 return gfc_conv_mpz_to_tree (expr
->value
.integer
, expr
->ts
.kind
);
306 return gfc_conv_mpfr_to_tree (expr
->value
.real
, expr
->ts
.kind
);
309 return build_int_cst (gfc_get_logical_type (expr
->ts
.kind
),
310 expr
->value
.logical
);
314 tree real
= gfc_conv_mpfr_to_tree (expr
->value
.complex.r
,
316 tree imag
= gfc_conv_mpfr_to_tree (expr
->value
.complex.i
,
319 return build_complex (NULL_TREE
, real
, imag
);
323 return gfc_build_string_const (expr
->value
.character
.length
,
324 expr
->value
.character
.string
);
327 fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
328 gfc_typename (&expr
->ts
));
333 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
334 We can handle character literal constants here as well. */
337 gfc_conv_constant (gfc_se
* se
, gfc_expr
* expr
)
339 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
343 gcc_assert (se
->ss
!= gfc_ss_terminator
);
344 gcc_assert (se
->ss
->type
== GFC_SS_SCALAR
);
345 gcc_assert (se
->ss
->expr
== expr
);
347 se
->expr
= se
->ss
->data
.scalar
.expr
;
348 se
->string_length
= se
->ss
->string_length
;
349 gfc_advance_se_ss_chain (se
);
353 /* Translate the constant and put it in the simplifier structure. */
354 se
->expr
= gfc_conv_constant_to_tree (expr
);
356 /* If this is a CHARACTER string, set its length in the simplifier
358 if (expr
->ts
.type
== BT_CHARACTER
)
359 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));