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 /* String constants.  */
  37 tree gfc_strconst_bounds;
  38 tree gfc_strconst_fault;
  39 tree gfc_strconst_wrong_return;
  40 tree gfc_strconst_current_filename;
  41
  42 tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
  43
  44 /* Build a constant with given type from an int_cst.  */
  45
  46 tree
  47 gfc_build_const (tree type, tree intval)
  48 {
  49   tree val;
  50   tree zero;
  51
  52   switch (TREE_CODE (type))
  53     {
  54     case INTEGER_TYPE:
  55       val = convert (type, intval);
  56       break;
  57
  58     case REAL_TYPE:
  59       val = build_real_from_int_cst (type, intval);
  60       break;
  61
  62     case COMPLEX_TYPE:
  63       val = build_real_from_int_cst (TREE_TYPE (type), intval);
  64       zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
  65       val = build_complex (type, val, zero);
  66       break;
  67
  68     default:
  69       gcc_unreachable ();
  70     }
  71   return val;
  72 }
  73
  74 tree
  75 gfc_build_string_const (int length, const char *s)
  76 {
  77   tree str;
  78   tree len;
  79
  80   str = build_string (length, s);
  81   len = build_int_cst (NULL_TREE, length);
  82   TREE_TYPE (str) =
  83     build_array_type (gfc_character1_type_node,
  84                       build_range_type (gfc_charlen_type_node,
  85                                         integer_one_node, len));
  86   return str;
  87 }
  88
  89 /* Build a Fortran character constant from a zero-terminated string.
  90    Since this is mainly used for error messages, the string will get
  91    translated.  */
  92 tree
  93 gfc_build_cstring_const (const char *msgid)
  94 {
  95   return gfc_build_string_const (strlen (msgid) + 1, _(msgid));
  96 }
  97
  98 /* Return a string constant with the given length.  Used for static
  99    initializers.  The constant will be padded or truncated to match
 100    length.  */
 101
 102 tree
 103 gfc_conv_string_init (tree length, gfc_expr * expr)
 104 {
 105   char *s;
 106   HOST_WIDE_INT len;
 107   int slen;
 108   tree str;
 109
 110   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 111   gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
 112   gcc_assert (INTEGER_CST_P (length));
 113   gcc_assert (TREE_INT_CST_HIGH (length) == 0);
 114
 115   len = TREE_INT_CST_LOW (length);
 116   slen = expr->value.character.length;
 117
 118   if (len > slen)
 119     {
 120       s = gfc_getmem (len);
 121       memcpy (s, expr->value.character.string, slen);
 122       memset (&s[slen], ' ', len - slen);
 123       str = gfc_build_string_const (len, s);
 124       gfc_free (s);
 125     }
 126   else
 127     str = gfc_build_string_const (len, expr->value.character.string);
 128
 129   return str;
 130 }
 131
 132
 133 /* Create a tree node for the string length if it is constant.  */
 134
 135 void
 136 gfc_conv_const_charlen (gfc_charlen * cl)
 137 {
 138   if (cl->backend_decl)
 139     return;
 140
 141   if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
 142     {
 143       cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
 144                                                cl->length->ts.kind);
 145       cl->backend_decl = fold_convert (gfc_charlen_type_node,
 146                                         cl->backend_decl);
 147     }
 148 }
 149
 150 void
 151 gfc_init_constants (void)
 152 {
 153   int n;
 154
 155   for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
 156     gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
 157
 158   gfc_strconst_bounds = gfc_build_cstring_const ("Array bound mismatch");
 159
 160   gfc_strconst_fault =
 161     gfc_build_cstring_const ("Array reference out of bounds");
 162
 163   gfc_strconst_wrong_return =
 164     gfc_build_cstring_const ("Incorrect function return value");
 165
 166   gfc_strconst_current_filename =
 167     gfc_build_cstring_const (gfc_source_file);
 168 }
 169
 170 /* Converts a GMP integer into a backend tree node.  */
 171 tree
 172 gfc_conv_mpz_to_tree (mpz_t i, int kind)
 173 {
 174   HOST_WIDE_INT high;
 175   unsigned HOST_WIDE_INT low;
 176
 177   if (mpz_fits_slong_p (i))
 178     {
 179       /* Note that HOST_WIDE_INT is never smaller than long.  */
 180       low = mpz_get_si (i);
 181       high = mpz_sgn (i) < 0 ? -1 : 0;
 182     }
 183   else
 184     {
 185       unsigned HOST_WIDE_INT words[2];
 186       size_t count;
 187
 188       /* Since we know that the value is not zero (mpz_fits_slong_p),
 189          we know that at least one word will be written, but we don't know
 190          about the second.  It's quicker to zero the second word before
 191          than conditionally clear it later.  */
 192       words[1] = 0;
 193
 194       /* Extract the absolute value into words.  */
 195       mpz_export (words, &count, -1, sizeof (HOST_WIDE_INT), 0, 0, i);
 196
 197       /* We assume that all numbers are in range for its type, and that
 198          we never create a type larger than 2*HWI, which is the largest
 199          that the middle-end can handle.  */
 200       gcc_assert (count == 1 || count == 2);
 201
 202       low = words[0];
 203       high = words[1];
 204
 205       /* Negate if necessary.  */
 206       if (mpz_sgn (i) < 0)
 207         {
 208           if (low == 0)
 209             high = -high;
 210           else
 211             low = -low, high = ~high;
 212         }
 213     }
 214
 215   return build_int_cst_wide (gfc_get_int_type (kind), low, high);
 216 }
 217
 218 /* Converts a real constant into backend form.  Uses an intermediate string
 219    representation.  */
 220
 221 tree
 222 gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
 223 {
 224   tree res;
 225   tree type;
 226   mp_exp_t exp;
 227   char *p, *q;
 228   int n;
 229
 230   n = gfc_validate_kind (BT_REAL, kind, false);
 231
 232   gcc_assert (gfc_real_kinds[n].radix == 2);
 233
 234   /* mpfr chooses too small a number of hexadecimal digits if the
 235      number of binary digits is not divisible by four, therefore we
 236      have to explicitly request a sufficient number of digits here.  */
 237   p = mpfr_get_str (NULL, &exp, 16, gfc_real_kinds[n].digits / 4 + 1,
 238                     f, GFC_RND_MODE);
 239
 240   /* REAL_VALUE_ATOF expects the exponent for mantissa * 2**exp,
 241      mpfr_get_str returns the exponent for mantissa * 16**exp, adjust
 242      for that.  */
 243   exp *= 4;
 244
 245   /* The additional 12 characters add space for the sprintf below.
 246      This leaves 6 digits for the exponent which is certainly enough.  */
 247   q = (char *) gfc_getmem (strlen (p) + 12);
 248
 249   if (p[0] == '-')
 250     sprintf (q, "-0x.%sp%d", &p[1], (int) exp);
 251   else
 252     sprintf (q, "0x.%sp%d", p, (int) exp);
 253
 254   type = gfc_get_real_type (kind);
 255   res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
 256
 257   gfc_free (q);
 258   gfc_free (p);
 259
 260   return res;
 261 }
 262
 263
 264 /* Translate any literal constant to a tree.  Constants never have
 265    pre or post chains.  Character literal constants are special
 266    special because they have a value and a length, so they cannot be
 267    returned as a single tree.  It is up to the caller to set the
 268    length somewhere if necessary.
 269
 270    Returns the translated constant, or aborts if it gets a type it
 271    can't handle.  */
 272
 273 tree
 274 gfc_conv_constant_to_tree (gfc_expr * expr)
 275 {
 276   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 277
 278   /* If it is converted from Hollerith constant, we build string constant
 279      and VIEW_CONVERT to its type.  */
 280
 281   switch (expr->ts.type)
 282     {
 283     case BT_INTEGER:
 284       if (expr->from_H)
 285         return build1 (VIEW_CONVERT_EXPR,
 286                         gfc_get_int_type (expr->ts.kind),
 287                         gfc_build_string_const (expr->value.character.length,
 288                                 expr->value.character.string));
 289       else
 290         return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 291
 292     case BT_REAL:
 293       if (expr->from_H)
 294         return build1 (VIEW_CONVERT_EXPR,
 295                         gfc_get_real_type (expr->ts.kind),
 296                         gfc_build_string_const (expr->value.character.length,
 297                                 expr->value.character.string));
 298       else
 299         return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
 300
 301     case BT_LOGICAL:
 302       if (expr->from_H)
 303         return build1 (VIEW_CONVERT_EXPR,
 304                         gfc_get_logical_type (expr->ts.kind),
 305                         gfc_build_string_const (expr->value.character.length,
 306                                 expr->value.character.string));
 307       else
 308         return build_int_cst (gfc_get_logical_type (expr->ts.kind),
 309                             expr->value.logical);
 310
 311     case BT_COMPLEX:
 312       if (expr->from_H)
 313         return build1 (VIEW_CONVERT_EXPR,
 314                         gfc_get_complex_type (expr->ts.kind),
 315                         gfc_build_string_const (expr->value.character.length,
 316                                 expr->value.character.string));
 317       else
 318         {
 319           tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
 320                                           expr->ts.kind);
 321           tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
 322                                           expr->ts.kind);
 323
 324           return build_complex (gfc_typenode_for_spec (&expr->ts),
 325                                 real, imag);
 326         }
 327
 328     case BT_CHARACTER:
 329     case BT_HOLLERITH:
 330       return gfc_build_string_const (expr->value.character.length,
 331                                      expr->value.character.string);
 332
 333     default:
 334       fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
 335                    gfc_typename (&expr->ts));
 336     }
 337 }
 338
 339
 340 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
 341    We can handle character literal constants here as well.  */
 342
 343 void
 344 gfc_conv_constant (gfc_se * se, gfc_expr * expr)
 345 {
 346   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 347
 348   if (se->ss != NULL)
 349     {
 350       gcc_assert (se->ss != gfc_ss_terminator);
 351       gcc_assert (se->ss->type == GFC_SS_SCALAR);
 352       gcc_assert (se->ss->expr == expr);
 353
 354       se->expr = se->ss->data.scalar.expr;
 355       se->string_length = se->ss->string_length;
 356       gfc_advance_se_ss_chain (se);
 357       return;
 358     }
 359
 360   /* Translate the constant and put it in the simplifier structure.  */
 361   se->expr = gfc_conv_constant_to_tree (expr);
 362
 363   /* If this is a CHARACTER string, set its length in the simplifier
 364      structure, too.  */
 365   if (expr->ts.type == BT_CHARACTER)
 366     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
 367 }