gcc/fortran/trans-const.c

   1 /* Translation of constants
   2    Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   3    Contributed by Paul Brook
   4
   5 This file is part of GCC.
   6
   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.
  11
  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.
  16
  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.  */
  21
  22 /* trans-const.c -- convert constant values */
  23
  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"
  35
  36 tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
  37
  38 /* Build a constant with given type from an int_cst.  */
  39
  40 tree
  41 gfc_build_const (tree type, tree intval)
  42 {
  43   tree val;
  44   tree zero;
  45
  46   switch (TREE_CODE (type))
  47     {
  48     case INTEGER_TYPE:
  49       val = convert (type, intval);
  50       break;
  51
  52     case REAL_TYPE:
  53       val = build_real_from_int_cst (type, intval);
  54       break;
  55
  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;
  61
  62     default:
  63       gcc_unreachable ();
  64     }
  65   return val;
  66 }
  67
  68 tree
  69 gfc_build_string_const (int length, const char *s)
  70 {
  71   tree str;
  72   tree len;
  73
  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;
  81 }
  82
  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)
  88 {
  89   return gfc_build_string_const (strlen (msgid) + 1, _(msgid));
  90 }
  91
  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.  */
  95
  96 tree
  97 gfc_conv_string_init (tree length, gfc_expr * expr)
  98 {
  99   char *s;
 100   HOST_WIDE_INT len;
 101   int slen;
 102   tree str;
 103
 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);
 108
 109   len = TREE_INT_CST_LOW (length);
 110   slen = expr->value.character.length;
 111
 112   if (len > slen)
 113     {
 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);
 119     }
 120   else
 121     str = gfc_build_string_const (len, expr->value.character.string);
 122
 123   return str;
 124 }
 125
 126
 127 /* Create a tree node for the string length if it is constant.  */
 128
 129 void
 130 gfc_conv_const_charlen (gfc_charlen * cl)
 131 {
 132   if (cl->backend_decl)
 133     return;
 134
 135   if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
 136     {
 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);
 141     }
 142 }
 143
 144 void
 145 gfc_init_constants (void)
 146 {
 147   int n;
 148
 149   for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
 150     gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
 151 }
 152
 153 /* Converts a GMP integer into a backend tree node.  */
 154 tree
 155 gfc_conv_mpz_to_tree (mpz_t i, int kind)
 156 {
 157   HOST_WIDE_INT high;
 158   unsigned HOST_WIDE_INT low;
 159
 160   if (mpz_fits_slong_p (i))
 161     {
 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;
 165     }
 166   else
 167     {
 168       unsigned HOST_WIDE_INT *words;
 169       size_t count, numb;
 170
 171       /* Determine the number of unsigned HOST_WIDE_INT that are required
 172          for represent the value.  The code to calculate count is
 173          extracted from the GMP manual, section "Integer Import and Export":
 174          http://gmplib.org/manual/Integer-Import-and-Export.html  */
 175       numb = 8*sizeof(HOST_WIDE_INT);
 176       count = (mpz_sizeinbase (i, 2) + numb-1) / numb;
 177       if (count < 2)
 178         count = 2;
 179       words = (unsigned HOST_WIDE_INT *) alloca (count * sizeof(HOST_WIDE_INT));
 180
 181       /* Since we know that the value is not zero (mpz_fits_slong_p),
 182          we know that at least one word will be written, but we don't know
 183          about the second.  It's quicker to zero the second word before
 184          than conditionally clear it later.  */
 185       words[1] = 0;
 186
 187       /* Extract the absolute value into words.  */
 188       mpz_export (words, &count, -1, sizeof(HOST_WIDE_INT), 0, 0, i);
 189
 190       /* We don't assume that all numbers are in range for its type.
 191          However, we never create a type larger than 2*HWI, which is the
 192          largest that the middle-end can handle. So, we only take the
 193          first two elements of words, which is equivalent to wrapping the
 194          value if it's larger than the type range.  */
 195       low = words[0];
 196       high = words[1];
 197
 198       /* Negate if necessary.  */
 199       if (mpz_sgn (i) < 0)
 200         {
 201           if (low == 0)
 202             high = -high;
 203           else
 204             low = -low, high = ~high;
 205         }
 206     }
 207
 208   return build_int_cst_wide (gfc_get_int_type (kind), low, high);
 209 }
 210
 211 /* Converts a real constant into backend form.  Uses an intermediate string
 212    representation.  */
 213
 214 tree
 215 gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
 216 {
 217   tree res;
 218   tree type;
 219   mp_exp_t exp;
 220   char *p, *q;
 221   int n;
 222   REAL_VALUE_TYPE real;
 223
 224   n = gfc_validate_kind (BT_REAL, kind, false);
 225
 226   gcc_assert (gfc_real_kinds[n].radix == 2);
 227
 228   type = gfc_get_real_type (kind);
 229
 230   /* Take care of Infinity and NaN.  */
 231   if (mpfr_inf_p (f))
 232     {
 233       real_inf (&real);
 234       if (mpfr_sgn (f) < 0)
 235         real = REAL_VALUE_NEGATE(real);
 236       res = build_real (type , real);
 237       return res;
 238     }
 239
 240   if (mpfr_nan_p (f))
 241     {
 242       real_nan (&real, "", 0, TYPE_MODE (type));
 243       res = build_real (type , real);
 244       return res;
 245     }
 246
 247   /* mpfr chooses too small a number of hexadecimal digits if the
 248      number of binary digits is not divisible by four, therefore we
 249      have to explicitly request a sufficient number of digits here.  */
 250   p = mpfr_get_str (NULL, &exp, 16, gfc_real_kinds[n].digits / 4 + 1,
 251                     f, GFC_RND_MODE);
 252
 253   /* REAL_VALUE_ATOF expects the exponent for mantissa * 2**exp,
 254      mpfr_get_str returns the exponent for mantissa * 16**exp, adjust
 255      for that.  */
 256   exp *= 4;
 257
 258   /* The additional 12 characters add space for the sprintf below.
 259      This leaves 6 digits for the exponent which is certainly enough.  */
 260   q = (char *) gfc_getmem (strlen (p) + 12);
 261
 262   if (p[0] == '-')
 263     sprintf (q, "-0x.%sp%d", &p[1], (int) exp);
 264   else
 265     sprintf (q, "0x.%sp%d", p, (int) exp);
 266
 267   res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
 268
 269   gfc_free (q);
 270   gfc_free (p);
 271
 272   return res;
 273 }
 274
 275
 276 /* Translate any literal constant to a tree.  Constants never have
 277    pre or post chains.  Character literal constants are special
 278    special because they have a value and a length, so they cannot be
 279    returned as a single tree.  It is up to the caller to set the
 280    length somewhere if necessary.
 281
 282    Returns the translated constant, or aborts if it gets a type it
 283    can't handle.  */
 284
 285 tree
 286 gfc_conv_constant_to_tree (gfc_expr * expr)
 287 {
 288   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 289
 290   /* If it is converted from Hollerith constant, we build string constant
 291      and VIEW_CONVERT to its type.  */
 292
 293   switch (expr->ts.type)
 294     {
 295     case BT_INTEGER:
 296       if (expr->from_H)
 297         return build1 (VIEW_CONVERT_EXPR,
 298                         gfc_get_int_type (expr->ts.kind),
 299                         gfc_build_string_const (expr->value.character.length,
 300                                 expr->value.character.string));
 301       else
 302         return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 303
 304     case BT_REAL:
 305       if (expr->from_H)
 306         return build1 (VIEW_CONVERT_EXPR,
 307                         gfc_get_real_type (expr->ts.kind),
 308                         gfc_build_string_const (expr->value.character.length,
 309                                 expr->value.character.string));
 310       else
 311         return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
 312
 313     case BT_LOGICAL:
 314       if (expr->from_H)
 315         return build1 (VIEW_CONVERT_EXPR,
 316                         gfc_get_logical_type (expr->ts.kind),
 317                         gfc_build_string_const (expr->value.character.length,
 318                                 expr->value.character.string));
 319       else
 320         return build_int_cst (gfc_get_logical_type (expr->ts.kind),
 321                             expr->value.logical);
 322
 323     case BT_COMPLEX:
 324       if (expr->from_H)
 325         return build1 (VIEW_CONVERT_EXPR,
 326                         gfc_get_complex_type (expr->ts.kind),
 327                         gfc_build_string_const (expr->value.character.length,
 328                                 expr->value.character.string));
 329       else
 330         {
 331           tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
 332                                           expr->ts.kind);
 333           tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
 334                                           expr->ts.kind);
 335
 336           return build_complex (gfc_typenode_for_spec (&expr->ts),
 337                                 real, imag);
 338         }
 339
 340     case BT_CHARACTER:
 341     case BT_HOLLERITH:
 342       return gfc_build_string_const (expr->value.character.length,
 343                                      expr->value.character.string);
 344
 345     default:
 346       fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
 347                    gfc_typename (&expr->ts));
 348     }
 349 }
 350
 351
 352 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
 353    We can handle character literal constants here as well.  */
 354
 355 void
 356 gfc_conv_constant (gfc_se * se, gfc_expr * expr)
 357 {
 358   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 359
 360   if (se->ss != NULL)
 361     {
 362       gcc_assert (se->ss != gfc_ss_terminator);
 363       gcc_assert (se->ss->type == GFC_SS_SCALAR);
 364       gcc_assert (se->ss->expr == expr);
 365
 366       se->expr = se->ss->data.scalar.expr;
 367       se->string_length = se->ss->string_length;
 368       gfc_advance_se_ss_chain (se);
 369       return;
 370     }
 371
 372   /* Translate the constant and put it in the simplifier structure.  */
 373   se->expr = gfc_conv_constant_to_tree (expr);
 374
 375   /* If this is a CHARACTER string, set its length in the simplifier
 376      structure, too.  */
 377   if (expr->ts.type == BT_CHARACTER)
 378     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
 379 }