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[2];
 169       size_t count;
 170
 171       /* Since we know that the value is not zero (mpz_fits_slong_p),
 172          we know that at least one word will be written, but we don't know
 173          about the second.  It's quicker to zero the second word before
 174          than conditionally clear it later.  */
 175       words[1] = 0;
 176
 177       /* Extract the absolute value into words.  */
 178       mpz_export (words, &count, -1, sizeof (HOST_WIDE_INT), 0, 0, i);
 179
 180       /* We assume that all numbers are in range for its type, and that
 181          we never create a type larger than 2*HWI, which is the largest
 182          that the middle-end can handle.  */
 183       gcc_assert (count == 1 || count == 2);
 184
 185       low = words[0];
 186       high = words[1];
 187
 188       /* Negate if necessary.  */
 189       if (mpz_sgn (i) < 0)
 190         {
 191           if (low == 0)
 192             high = -high;
 193           else
 194             low = -low, high = ~high;
 195         }
 196     }
 197
 198   return build_int_cst_wide (gfc_get_int_type (kind), low, high);
 199 }
 200
 201 /* Converts a real constant into backend form.  Uses an intermediate string
 202    representation.  */
 203
 204 tree
 205 gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
 206 {
 207   tree res;
 208   tree type;
 209   mp_exp_t exp;
 210   char *p, *q;
 211   int n;
 212   REAL_VALUE_TYPE real;
 213
 214   n = gfc_validate_kind (BT_REAL, kind, false);
 215
 216   gcc_assert (gfc_real_kinds[n].radix == 2);
 217
 218   type = gfc_get_real_type (kind);
 219
 220   /* Take care of Infinity and NaN.  */
 221   if (mpfr_inf_p (f))
 222     {
 223       real_inf (&real);
 224       if (mpfr_sgn (f) < 0)
 225         real = REAL_VALUE_NEGATE(real);
 226       res = build_real (type , real);
 227       return res;
 228     }
 229
 230   if (mpfr_nan_p (f))
 231     {
 232       real_nan (&real, "", 0, TYPE_MODE (type));
 233       res = build_real (type , real);
 234       return res;
 235     }
 236
 237   /* mpfr chooses too small a number of hexadecimal digits if the
 238      number of binary digits is not divisible by four, therefore we
 239      have to explicitly request a sufficient number of digits here.  */
 240   p = mpfr_get_str (NULL, &exp, 16, gfc_real_kinds[n].digits / 4 + 1,
 241                     f, GFC_RND_MODE);
 242
 243   /* REAL_VALUE_ATOF expects the exponent for mantissa * 2**exp,
 244      mpfr_get_str returns the exponent for mantissa * 16**exp, adjust
 245      for that.  */
 246   exp *= 4;
 247
 248   /* The additional 12 characters add space for the sprintf below.
 249      This leaves 6 digits for the exponent which is certainly enough.  */
 250   q = (char *) gfc_getmem (strlen (p) + 12);
 251
 252   if (p[0] == '-')
 253     sprintf (q, "-0x.%sp%d", &p[1], (int) exp);
 254   else
 255     sprintf (q, "0x.%sp%d", p, (int) exp);
 256
 257   res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
 258
 259   gfc_free (q);
 260   gfc_free (p);
 261
 262   return res;
 263 }
 264
 265
 266 /* Translate any literal constant to a tree.  Constants never have
 267    pre or post chains.  Character literal constants are special
 268    special because they have a value and a length, so they cannot be
 269    returned as a single tree.  It is up to the caller to set the
 270    length somewhere if necessary.
 271
 272    Returns the translated constant, or aborts if it gets a type it
 273    can't handle.  */
 274
 275 tree
 276 gfc_conv_constant_to_tree (gfc_expr * expr)
 277 {
 278   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 279
 280   /* If it is converted from Hollerith constant, we build string constant
 281      and VIEW_CONVERT to its type.  */
 282
 283   switch (expr->ts.type)
 284     {
 285     case BT_INTEGER:
 286       if (expr->from_H)
 287         return build1 (VIEW_CONVERT_EXPR,
 288                         gfc_get_int_type (expr->ts.kind),
 289                         gfc_build_string_const (expr->value.character.length,
 290                                 expr->value.character.string));
 291       else
 292         return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 293
 294     case BT_REAL:
 295       if (expr->from_H)
 296         return build1 (VIEW_CONVERT_EXPR,
 297                         gfc_get_real_type (expr->ts.kind),
 298                         gfc_build_string_const (expr->value.character.length,
 299                                 expr->value.character.string));
 300       else
 301         return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
 302
 303     case BT_LOGICAL:
 304       if (expr->from_H)
 305         return build1 (VIEW_CONVERT_EXPR,
 306                         gfc_get_logical_type (expr->ts.kind),
 307                         gfc_build_string_const (expr->value.character.length,
 308                                 expr->value.character.string));
 309       else
 310         return build_int_cst (gfc_get_logical_type (expr->ts.kind),
 311                             expr->value.logical);
 312
 313     case BT_COMPLEX:
 314       if (expr->from_H)
 315         return build1 (VIEW_CONVERT_EXPR,
 316                         gfc_get_complex_type (expr->ts.kind),
 317                         gfc_build_string_const (expr->value.character.length,
 318                                 expr->value.character.string));
 319       else
 320         {
 321           tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
 322                                           expr->ts.kind);
 323           tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
 324                                           expr->ts.kind);
 325
 326           return build_complex (gfc_typenode_for_spec (&expr->ts),
 327                                 real, imag);
 328         }
 329
 330     case BT_CHARACTER:
 331     case BT_HOLLERITH:
 332       return gfc_build_string_const (expr->value.character.length,
 333                                      expr->value.character.string);
 334
 335     default:
 336       fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
 337                    gfc_typename (&expr->ts));
 338     }
 339 }
 340
 341
 342 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
 343    We can handle character literal constants here as well.  */
 344
 345 void
 346 gfc_conv_constant (gfc_se * se, gfc_expr * expr)
 347 {
 348   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 349
 350   if (se->ss != NULL)
 351     {
 352       gcc_assert (se->ss != gfc_ss_terminator);
 353       gcc_assert (se->ss->type == GFC_SS_SCALAR);
 354       gcc_assert (se->ss->expr == expr);
 355
 356       se->expr = se->ss->data.scalar.expr;
 357       se->string_length = se->ss->string_length;
 358       gfc_advance_se_ss_chain (se);
 359       return;
 360     }
 361
 362   /* Translate the constant and put it in the simplifier structure.  */
 363   se->expr = gfc_conv_constant_to_tree (expr);
 364
 365   /* If this is a CHARACTER string, set its length in the simplifier
 366      structure, too.  */
 367   if (expr->ts.type == BT_CHARACTER)
 368     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
 369 }