/* Translation of constants
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
/* trans-const.c -- convert constant values */
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include <stdio.h>
#include "ggc.h"
#include "toplev.h"
#include "real.h"
-#include <gmp.h>
-#include <assert.h>
-#include <math.h>
#include "gfortran.h"
#include "trans.h"
#include "trans-const.h"
break;
default:
- abort ();
+ gcc_unreachable ();
}
return val;
}
len = build_int_cst (NULL_TREE, length);
TREE_TYPE (str) =
build_array_type (gfc_character1_type_node,
- build_range_type (gfc_strlen_type_node,
+ build_range_type (gfc_charlen_type_node,
integer_one_node, len));
return str;
}
+/* Build a Fortran character constant from a zero-terminated string. */
+
+tree
+gfc_build_cstring_const (const char *s)
+{
+ return gfc_build_string_const (strlen (s) + 1, s);
+}
+
/* Return a string constant with the given length. Used for static
initializers. The constant will be padded or truncated to match
length. */
int slen;
tree str;
- assert (expr->expr_type == EXPR_CONSTANT);
- assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
- assert (INTEGER_CST_P (length));
- assert (TREE_INT_CST_HIGH (length) == 0);
+ gcc_assert (expr->expr_type == EXPR_CONSTANT);
+ gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
+ gcc_assert (INTEGER_CST_P (length));
+ gcc_assert (TREE_INT_CST_HIGH (length) == 0);
len = TREE_INT_CST_LOW (length);
slen = expr->value.character.length;
{
cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
cl->length->ts.kind);
+ cl->backend_decl = fold_convert (gfc_charlen_type_node,
+ cl->backend_decl);
}
}
for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
- gfc_strconst_bounds = gfc_build_string_const (21, "Array bound mismatch");
+ gfc_strconst_bounds = gfc_build_cstring_const ("Array bound mismatch");
gfc_strconst_fault =
- gfc_build_string_const (30, "Array reference out of bounds");
+ gfc_build_cstring_const ("Array reference out of bounds");
gfc_strconst_wrong_return =
- gfc_build_string_const (32, "Incorrect function return value");
+ gfc_build_cstring_const ("Incorrect function return value");
gfc_strconst_current_filename =
- gfc_build_string_const (strlen (gfc_option.source) + 1,
- gfc_option.source);
+ gfc_build_cstring_const (gfc_option.source);
}
/* Converts a GMP integer into a backend tree node. */
}
else
{
- /* Note that mp_limb_t can be anywhere from short to long long,
- which gives us a nice variety of cases to choose from. */
+ unsigned HOST_WIDE_INT words[2];
+ size_t count;
- if (sizeof (mp_limb_t) == sizeof (HOST_WIDE_INT))
- {
- low = mpz_getlimbn (i, 0);
- high = mpz_getlimbn (i, 1);
- }
- else if (sizeof (mp_limb_t) == 2 * sizeof (HOST_WIDE_INT))
- {
- mp_limb_t limb0 = mpz_getlimbn (i, 0);
- int shift = (sizeof (mp_limb_t) - sizeof (HOST_WIDE_INT)) * CHAR_BIT;
- low = limb0;
- high = limb0 >> shift;
- }
- else if (sizeof (mp_limb_t) < sizeof (HOST_WIDE_INT))
- {
- int shift = sizeof (mp_limb_t) * CHAR_BIT;
- int n, count = sizeof (HOST_WIDE_INT) / sizeof (mp_limb_t);
- for (low = n = 0; n < count; ++n)
- {
- low <<= shift;
- low |= mpz_getlimbn (i, n);
- }
- for (high = 0, n = count; n < 2*count; ++n)
- {
- high <<= shift;
- high |= mpz_getlimbn (i, n);
- }
- }
+ /* Since we know that the value is not zero (mpz_fits_slong_p),
+ we know that at least one word will be written, but we don't know
+ about the second. It's quicker to zero the second word before
+ than conditionally clear it later. */
+ words[1] = 0;
+
+ /* Extract the absolute value into words. */
+ mpz_export (words, &count, -1, sizeof (HOST_WIDE_INT), 0, 0, i);
+
+ /* We assume that all numbers are in range for its type, and that
+ we never create a type larger than 2*HWI, which is the largest
+ that the middle-end can handle. */
+ gcc_assert (count == 1 || count == 2);
+
+ low = words[0];
+ high = words[1];
- /* By extracting limbs we constructed the absolute value of the
- desired number. Negate if necessary. */
+ /* Negate if necessary. */
if (mpz_sgn (i) < 0)
{
if (low == 0)
tree res;
tree type;
mp_exp_t exp;
- char *p;
- char *q;
+ char *p, *q;
int n;
- int edigits;
- for (n = 0; gfc_real_kinds[n].kind != 0; n++)
- {
- if (gfc_real_kinds[n].kind == kind)
- break;
- }
- assert (gfc_real_kinds[n].kind);
+ n = gfc_validate_kind (BT_REAL, kind, false);
- n = MAX (abs (gfc_real_kinds[n].min_exponent),
- abs (gfc_real_kinds[n].max_exponent));
+ gcc_assert (gfc_real_kinds[n].radix == 2);
- edigits = 1;
- while (n > 0)
- {
- n = n / 10;
- edigits += 3;
- }
-
- if (kind == gfc_default_double_kind)
- p = mpfr_get_str (NULL, &exp, 10, 17, f, GFC_RND_MODE);
- else
- p = mpfr_get_str (NULL, &exp, 10, 8, f, GFC_RND_MODE);
+ /* mpfr chooses too small a number of hexadecimal digits if the
+ number of binary digits is not divisible by four, therefore we
+ have to explicitly request a sufficient number of digits here. */
+ p = mpfr_get_str (NULL, &exp, 16, gfc_real_kinds[n].digits / 4 + 1,
+ f, GFC_RND_MODE);
+ /* REAL_VALUE_ATOF expects the exponent for mantissa * 2**exp,
+ mpfr_get_str returns the exponent for mantissa * 16**exp, adjust
+ for that. */
+ exp *= 4;
- /* We also have one minus sign, "e", "." and a null terminator. */
- q = (char *) gfc_getmem (strlen (p) + edigits + 4);
+ /* The additional 12 characters add space for the sprintf below.
+ This leaves 6 digits for the exponent which is certainly enough. */
+ q = (char *) gfc_getmem (strlen (p) + 12);
- if (p[0])
- {
- if (p[0] == '-')
- {
- strcpy (&q[2], &p[1]);
- q[0] = '-';
- q[1] = '.';
- }
- else
- {
- strcpy (&q[1], p);
- q[0] = '.';
- }
- strcat (q, "e");
- sprintf (&q[strlen (q)], "%d", (int) exp);
- }
+ if (p[0] == '-')
+ sprintf (q, "-0x.%sp%d", &p[1], (int) exp);
else
- {
- strcpy (q, "0");
- }
+ sprintf (q, "0x.%sp%d", p, (int) exp);
type = gfc_get_real_type (kind);
res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
tree
gfc_conv_constant_to_tree (gfc_expr * expr)
{
- assert (expr->expr_type == EXPR_CONSTANT);
+ gcc_assert (expr->expr_type == EXPR_CONSTANT);
+ /* If it is converted from Hollerith constant, we build string constant
+ and VIEW_CONVERT to its type. */
+
switch (expr->ts.type)
{
case BT_INTEGER:
- return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
+ if (expr->from_H)
+ return build1 (VIEW_CONVERT_EXPR,
+ gfc_get_int_type (expr->ts.kind),
+ gfc_build_string_const (expr->value.character.length,
+ expr->value.character.string));
+ else
+ return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
case BT_REAL:
- return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
+ if (expr->from_H)
+ return build1 (VIEW_CONVERT_EXPR,
+ gfc_get_real_type (expr->ts.kind),
+ gfc_build_string_const (expr->value.character.length,
+ expr->value.character.string));
+ else
+ return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
case BT_LOGICAL:
- return build_int_cst (NULL_TREE, expr->value.logical);
+ if (expr->from_H)
+ return build1 (VIEW_CONVERT_EXPR,
+ gfc_get_logical_type (expr->ts.kind),
+ gfc_build_string_const (expr->value.character.length,
+ expr->value.character.string));
+ else
+ return build_int_cst (gfc_get_logical_type (expr->ts.kind),
+ expr->value.logical);
case BT_COMPLEX:
- {
- tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
+ if (expr->from_H)
+ return build1 (VIEW_CONVERT_EXPR,
+ gfc_get_complex_type (expr->ts.kind),
+ gfc_build_string_const (expr->value.character.length,
+ expr->value.character.string));
+ else
+ {
+ tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
expr->ts.kind);
- tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
+ tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
expr->ts.kind);
- return build_complex (NULL_TREE, real, imag);
- }
+ return build_complex (gfc_typenode_for_spec (&expr->ts),
+ real, imag);
+ }
case BT_CHARACTER:
+ case BT_HOLLERITH:
return gfc_build_string_const (expr->value.character.length,
expr->value.character.string);
void
gfc_conv_constant (gfc_se * se, gfc_expr * expr)
{
- assert (expr->expr_type == EXPR_CONSTANT);
+ gcc_assert (expr->expr_type == EXPR_CONSTANT);
if (se->ss != NULL)
{
- assert (se->ss != gfc_ss_terminator);
- assert (se->ss->type == GFC_SS_SCALAR);
- assert (se->ss->expr == expr);
+ gcc_assert (se->ss != gfc_ss_terminator);
+ gcc_assert (se->ss->type == GFC_SS_SCALAR);
+ gcc_assert (se->ss->expr == expr);
se->expr = se->ss->data.scalar.expr;
se->string_length = se->ss->string_length;
OSDN Git Service
