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 */
{
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);
}
}
size_t count;
/* Since we know that the value is not zero (mpz_fits_slong_p),
- we know that at one word will be written, but we don't know
+ 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
- that conditionally clear it later. */
+ than conditionally clear it later. */
words[1] = 0;
/* Extract the absolute value into words. */
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;
- }
- gcc_assert (gfc_real_kinds[n].kind);
-
- n = MAX (abs (gfc_real_kinds[n].min_exponent),
- abs (gfc_real_kinds[n].max_exponent));
+ n = gfc_validate_kind (BT_REAL, kind, false);
- edigits = 1;
- while (n > 0)
- {
- n = n / 10;
- edigits += 3;
- }
+ gcc_assert (gfc_real_kinds[n].radix == 2);
- 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)));
{
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);
OSDN Git Service
