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