gcc/fortran/trans-const.c

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