/* Translation of constants
- Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Free Software Foundation, Inc.
Contributed by Paul Brook
-This file is part of GNU G95.
+This file is part of GCC.
-GNU G95 is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
-GNU G95 is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
You should have received a copy of the GNU General Public License
-along with GNU G95; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* trans-const.c -- convert constant values */
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include <stdio.h>
-#include "ggc.h"
+#include "realmpfr.h"
#include "toplev.h"
-#include "real.h"
-#include <gmp.h>
-#include <assert.h>
-#include <math.h>
+#include "double-int.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
-
-/* String constants. */
-tree gfc_strconst_bounds;
-tree gfc_strconst_fault;
-tree gfc_strconst_wrong_return;
-tree gfc_strconst_current_filename;
+#include "target-memory.h"
tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
/* Build a constant with given type from an int_cst. */
+
tree
gfc_build_const (tree type, tree intval)
{
break;
default:
- abort ();
+ gcc_unreachable ();
}
return val;
}
+/* Build a string constant with C char type. */
+
tree
gfc_build_string_const (int length, const char *s)
{
tree len;
str = build_string (length, s);
- len = build_int_2 (length, 0);
+ 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 string constant with a type given by its kind; take care of
+ non-default character kinds. */
+
+tree
+gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string)
+{
+ int i;
+ tree str, len;
+ size_t size;
+ char *s;
+
+ i = gfc_validate_kind (BT_CHARACTER, kind, false);
+ size = length * gfc_character_kinds[i].bit_size / 8;
+
+ s = XCNEWVAR (char, size);
+ gfc_encode_character (kind, length, string, (unsigned char *) s, size);
+
+ str = build_string (size, s);
+ gfc_free (s);
+
+ len = build_int_cst (NULL_TREE, length);
+ TREE_TYPE (str) =
+ build_array_type (gfc_get_char_type (kind),
+ build_range_type (gfc_charlen_type_node,
integer_one_node, len));
return str;
}
+
+/* Build a Fortran character constant from a zero-terminated string.
+ There a two version of this function, one that translates the string
+ and one that doesn't. */
+tree
+gfc_build_cstring_const (const char *string)
+{
+ return gfc_build_string_const (strlen (string) + 1, string);
+}
+
+tree
+gfc_build_localized_cstring_const (const char *msgid)
+{
+ const char *localized = _(msgid);
+ return gfc_build_string_const (strlen (localized) + 1, localized);
+}
+
+
/* Return a string constant with the given length. Used for static
- initializers. The constant will be padded to the full length. */
+ initializers. The constant will be padded or truncated to match
+ length. */
+
tree
gfc_conv_string_init (tree length, gfc_expr * expr)
{
- char *s;
+ gfc_char_t *s;
HOST_WIDE_INT len;
int slen;
tree str;
+ bool free_s = false;
- 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);
+ 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;
- assert (len >= slen);
- if (len != slen)
+
+ if (len > slen)
{
- s = gfc_getmem (len);
- memcpy (s, expr->value.character.string, slen);
- memset (&s[slen], ' ', len - slen);
- str = gfc_build_string_const (len, s);
- gfc_free (s);
+ s = gfc_get_wide_string (len);
+ memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));
+ gfc_wide_memset (&s[slen], ' ', len - slen);
+ free_s = true;
}
else
- str = gfc_build_string_const (len, expr->value.character.string);
+ s = expr->value.character.string;
+
+ str = gfc_build_wide_string_const (expr->ts.kind, len, s);
+
+ if (free_s)
+ gfc_free (s);
return str;
}
void
gfc_conv_const_charlen (gfc_charlen * cl)
{
- if (cl->backend_decl)
+ if (!cl || cl->backend_decl)
return;
if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
{
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);
}
}
int n;
for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
- {
- gfc_rank_cst[n] = build_int_2 (n, 0);
- TREE_TYPE (gfc_rank_cst[n]) = gfc_array_index_type;
- }
-
- gfc_strconst_bounds = gfc_build_string_const (21, "Array bound mismatch");
-
- gfc_strconst_fault =
- gfc_build_string_const (30, "Array reference out of bounds");
-
- gfc_strconst_wrong_return =
- gfc_build_string_const (32, "Incorrect function return value");
-
- gfc_strconst_current_filename =
- gfc_build_string_const (strlen (gfc_option.source) + 1,
- gfc_option.source);
+ gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
}
-#define BITS_PER_HOST_WIDE_INT (8 * sizeof (HOST_WIDE_INT))
/* Converts a GMP integer into a backend tree node. */
+
tree
gfc_conv_mpz_to_tree (mpz_t i, int kind)
{
- int val;
- tree res;
- HOST_WIDE_INT high;
- unsigned HOST_WIDE_INT low;
- int negate;
- char buff[10];
- char *p;
- char *q;
- int n;
-
- /* TODO: could be wrong if sizeof(HOST_WIDE_INT) |= SIZEOF (int). */
- if (mpz_fits_slong_p (i))
- {
- val = mpz_get_si (i);
- res = build_int_2 (val, (val < 0) ? (HOST_WIDE_INT)-1 : 0);
- TREE_TYPE (res) = gfc_get_int_type (kind);
- return (res);
- }
-
- n = mpz_sizeinbase (i, 16);
- if (n > 8)
- q = gfc_getmem (n + 2);
- else
- q = buff;
-
- low = 0;
- high = 0;
- p = mpz_get_str (q, 16, i);
- if (p[0] == '-')
- {
- negate = 1;
- p++;
- }
- else
- negate = 0;
-
- while (*p)
- {
- n = *(p++);
- if (n >= '0' && n <= '9')
- n = n - '0';
- else if (n >= 'a' && n <= 'z')
- n = n + 10 - 'a';
- else if (n >= 'A' && n <= 'Z')
- n = n + 10 - 'A';
- else
- abort ();
-
- assert (n >= 0 && n < 16);
- high = (high << 4) + (low >> (BITS_PER_HOST_WIDE_INT - 4));
- low = (low << 4) + n;
- }
- res = build_int_2 (low, high);
- TREE_TYPE (res) = gfc_get_int_type (kind);
- if (negate)
- res = fold (build1 (NEGATE_EXPR, TREE_TYPE (res), res));
+ double_int val = mpz_get_double_int (gfc_get_int_type (kind), i, true);
+ return double_int_to_tree (gfc_get_int_type (kind), val);
+}
- if (q != buff)
- gfc_free (q);
+/* Converts a backend tree into a GMP integer. */
- return res;
+void
+gfc_conv_tree_to_mpz (mpz_t i, tree source)
+{
+ double_int val = tree_to_double_int (source);
+ mpz_set_double_int (i, val, TYPE_UNSIGNED (TREE_TYPE (source)));
}
-/* Converts a real constant into backend form. Uses an intermediate string
- representation. */
+/* Converts a real constant into backend form. */
+
tree
-gfc_conv_mpf_to_tree (mpf_t f, int kind)
+gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)
{
- tree res;
tree type;
- mp_exp_t exp;
- char *p;
- char *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);
-
- assert (gfc_real_kinds[n].radix == 2);
+ REAL_VALUE_TYPE real;
- n = MAX (abs (gfc_real_kinds[n].min_exponent),
- abs (gfc_real_kinds[n].min_exponent));
-#if 0
- edigits = 2 + (int) (log (n) / log (gfc_real_kinds[n].radix));
-#endif
- edigits = 1;
- while (n > 0)
- {
- n = n / 10;
- edigits += 3;
- }
-
-
- p = mpf_get_str (NULL, &exp, 10, 0, f);
-
- /* We also have one minus sign, "e", "." and a null terminator. */
- q = (char *) gfc_getmem (strlen (p) + edigits + 4);
-
- 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);
- }
- else
- {
- strcpy (q, "0");
- }
+ n = gfc_validate_kind (BT_REAL, kind, false);
+ gcc_assert (gfc_real_kinds[n].radix == 2);
type = gfc_get_real_type (kind);
- res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
- gfc_free (q);
- gfc_free (p);
+ if (mpfr_nan_p (f) && is_snan)
+ real_from_string (&real, "SNaN");
+ else
+ real_from_mpfr (&real, f, type, GFC_RND_MODE);
- return res;
+ return build_real (type, real);
}
+/* Converts a backend tree into a real constant. */
+
+void
+gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source)
+{
+ mpfr_from_real (f, TREE_REAL_CST_PTR (source), GFC_RND_MODE);
+}
/* Translate any literal constant to a tree. Constants never have
pre or post chains. Character literal constants are special
tree
gfc_conv_constant_to_tree (gfc_expr * expr)
{
- assert (expr->expr_type == EXPR_CONSTANT);
+ tree res;
+
+ gcc_assert (expr->expr_type == EXPR_CONSTANT);
+ /* If it is has a prescribed memory representation, we build a 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->representation.string)
+ return fold_build1 (VIEW_CONVERT_EXPR,
+ gfc_get_int_type (expr->ts.kind),
+ gfc_build_string_const (expr->representation.length,
+ expr->representation.string));
+ else
+ return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
case BT_REAL:
- return gfc_conv_mpf_to_tree (expr->value.real, expr->ts.kind);
+ if (expr->representation.string)
+ return fold_build1 (VIEW_CONVERT_EXPR,
+ gfc_get_real_type (expr->ts.kind),
+ gfc_build_string_const (expr->representation.length,
+ expr->representation.string));
+ else
+ return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
case BT_LOGICAL:
- return build_int_2 (expr->value.logical, 0);
+ if (expr->representation.string)
+ {
+ tree tmp = fold_build1 (VIEW_CONVERT_EXPR,
+ gfc_get_int_type (expr->ts.kind),
+ gfc_build_string_const (expr->representation.length,
+ expr->representation.string));
+ if (!integer_zerop (tmp) && !integer_onep (tmp))
+ gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
+ " has undefined result at %L", &expr->where);
+ return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
+ }
+ else
+ return build_int_cst (gfc_get_logical_type (expr->ts.kind),
+ expr->value.logical);
case BT_COMPLEX:
- {
- tree real = gfc_conv_mpf_to_tree (expr->value.complex.r,
- expr->ts.kind);
- tree imag = gfc_conv_mpf_to_tree (expr->value.complex.i,
- expr->ts.kind);
+ if (expr->representation.string)
+ return fold_build1 (VIEW_CONVERT_EXPR,
+ gfc_get_complex_type (expr->ts.kind),
+ gfc_build_string_const (expr->representation.length,
+ expr->representation.string));
+ else
+ {
+ tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
+ expr->ts.kind, expr->is_snan);
+ tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
+ expr->ts.kind, expr->is_snan);
- return build_complex (NULL_TREE, real, imag);
- }
+ return build_complex (gfc_typenode_for_spec (&expr->ts),
+ real, imag);
+ }
case BT_CHARACTER:
- return gfc_build_string_const (expr->value.character.length,
- expr->value.character.string);
+ res = gfc_build_wide_string_const (expr->ts.kind,
+ expr->value.character.length,
+ expr->value.character.string);
+ return res;
+
+ case BT_HOLLERITH:
+ return gfc_build_string_const (expr->representation.length,
+ expr->representation.string);
default:
fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
}
-/* Like gfc_conv_contrant_to_tree, but for a simplified expression.
+/* Like gfc_conv_constant_to_tree, but for a simplified expression.
We can handle character literal constants here as well. */
void
gfc_conv_constant (gfc_se * se, gfc_expr * expr)
{
- assert (expr->expr_type == EXPR_CONSTANT);
+ /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If
+ so, the expr_type will not yet be an EXPR_CONSTANT. We need to make
+ it so here. */
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
+ && expr->ts.u.derived->attr.is_iso_c)
+ {
+ if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+ || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
+ {
+ /* Create a new EXPR_CONSTANT expression for our local uses. */
+ expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ }
+ }
+
+ if (expr->expr_type != EXPR_CONSTANT)
+ {
+ gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ gfc_error ("non-constant initialization expression at %L", &expr->where);
+ se->expr = gfc_conv_constant_to_tree (e);
+ return;
+ }
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->data.scalar.string_length;
+ se->string_length = se->ss->string_length;
gfc_advance_se_ss_chain (se);
return;
}
/* Translate the constant and put it in the simplifier structure. */
se->expr = gfc_conv_constant_to_tree (expr);
- /* If this is a CHARACTER string, set it's length in the simplifier
+ /* If this is a CHARACTER string, set its length in the simplifier
structure, too. */
if (expr->ts.type == BT_CHARACTER)
se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
OSDN Git Service
