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, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, 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     }
 145 }
 146
 147 void
 148 gfc_init_constants (void)
 149 {
 150   int n;
 151
 152   for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
 153     gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
 154
 155   gfc_strconst_bounds = gfc_build_cstring_const ("Array bound mismatch");
 156
 157   gfc_strconst_fault =
 158     gfc_build_cstring_const ("Array reference out of bounds");
 159
 160   gfc_strconst_wrong_return =
 161     gfc_build_cstring_const ("Incorrect function return value");
 162
 163   gfc_strconst_current_filename =
 164     gfc_build_cstring_const (gfc_option.source);
 165 }
 166
 167 /* Converts a GMP integer into a backend tree node.  */
 168 tree
 169 gfc_conv_mpz_to_tree (mpz_t i, int kind)
 170 {
 171   HOST_WIDE_INT high;
 172   unsigned HOST_WIDE_INT low;
 173
 174   if (mpz_fits_slong_p (i))
 175     {
 176       /* Note that HOST_WIDE_INT is never smaller than long.  */
 177       low = mpz_get_si (i);
 178       high = mpz_sgn (i) < 0 ? -1 : 0;
 179     }
 180   else
 181     {
 182       unsigned HOST_WIDE_INT words[2];
 183       size_t count;
 184
 185       /* Since we know that the value is not zero (mpz_fits_slong_p),
 186          we know that at least one word will be written, but we don't know
 187          about the second.  It's quicker to zero the second word before
 188          than conditionally clear it later.  */
 189       words[1] = 0;
 190
 191       /* Extract the absolute value into words.  */
 192       mpz_export (words, &count, -1, sizeof (HOST_WIDE_INT), 0, 0, i);
 193
 194       /* We assume that all numbers are in range for its type, and that
 195          we never create a type larger than 2*HWI, which is the largest
 196          that the middle-end can handle.  */
 197       gcc_assert (count == 1 || count == 2);
 198
 199       low = words[0];
 200       high = words[1];
 201
 202       /* Negate if necessary.  */
 203       if (mpz_sgn (i) < 0)
 204         {
 205           if (low == 0)
 206             high = -high;
 207           else
 208             low = -low, high = ~high;
 209         }
 210     }
 211
 212   return build_int_cst_wide (gfc_get_int_type (kind), low, high);
 213 }
 214
 215 /* Converts a real constant into backend form.  Uses an intermediate string
 216    representation.  */
 217
 218 tree
 219 gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
 220 {
 221   tree res;
 222   tree type;
 223   mp_exp_t exp;
 224   char *p, *q;
 225   int n;
 226
 227   n = gfc_validate_kind (BT_REAL, kind, false);
 228
 229   gcc_assert (gfc_real_kinds[n].radix == 2);
 230
 231   /* mpfr chooses too small a number of hexadecimal digits if the
 232      number of binary digits is not divisible by four, therefore we
 233      have to explicitly request a sufficient number of digits here.  */
 234   p = mpfr_get_str (NULL, &exp, 16, gfc_real_kinds[n].digits / 4 + 1,
 235                     f, GFC_RND_MODE);
 236
 237   /* REAL_VALUE_ATOF expects the exponent for mantissa * 2**exp,
 238      mpfr_get_str returns the exponent for mantissa * 16**exp, adjust
 239      for that.  */
 240   exp *= 4;
 241
 242   /* The additional 12 characters add space for the sprintf below.
 243      This leaves 6 digits for the exponent which is certainly enough.  */
 244   q = (char *) gfc_getmem (strlen (p) + 12);
 245
 246   if (p[0] == '-')
 247     sprintf (q, "-0x.%sp%d", &p[1], (int) exp);
 248   else
 249     sprintf (q, "0x.%sp%d", p, (int) exp);
 250
 251   type = gfc_get_real_type (kind);
 252   res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
 253
 254   gfc_free (q);
 255   gfc_free (p);
 256
 257   return res;
 258 }
 259
 260
 261 /* Translate any literal constant to a tree.  Constants never have
 262    pre or post chains.  Character literal constants are special
 263    special because they have a value and a length, so they cannot be
 264    returned as a single tree.  It is up to the caller to set the
 265    length somewhere if necessary.
 266
 267    Returns the translated constant, or aborts if it gets a type it
 268    can't handle.  */
 269
 270 tree
 271 gfc_conv_constant_to_tree (gfc_expr * expr)
 272 {
 273   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 274
 275   switch (expr->ts.type)
 276     {
 277     case BT_INTEGER:
 278       return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 279
 280     case BT_REAL:
 281       return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
 282
 283     case BT_LOGICAL:
 284       return build_int_cst (gfc_get_logical_type (expr->ts.kind),
 285                             expr->value.logical);
 286
 287     case BT_COMPLEX:
 288       {
 289         tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
 290                                           expr->ts.kind);
 291         tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
 292                                           expr->ts.kind);
 293
 294         return build_complex (gfc_typenode_for_spec (&expr->ts),
 295                               real, imag);
 296       }
 297
 298     case BT_CHARACTER:
 299       return gfc_build_string_const (expr->value.character.length,
 300                                      expr->value.character.string);
 301
 302     default:
 303       fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
 304                    gfc_typename (&expr->ts));
 305     }
 306 }
 307
 308
 309 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
 310    We can handle character literal constants here as well.  */
 311
 312 void
 313 gfc_conv_constant (gfc_se * se, gfc_expr * expr)
 314 {
 315   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 316
 317   if (se->ss != NULL)
 318     {
 319       gcc_assert (se->ss != gfc_ss_terminator);
 320       gcc_assert (se->ss->type == GFC_SS_SCALAR);
 321       gcc_assert (se->ss->expr == expr);
 322
 323       se->expr = se->ss->data.scalar.expr;
 324       se->string_length = se->ss->string_length;
 325       gfc_advance_se_ss_chain (se);
 326       return;
 327     }
 328
 329   /* Translate the constant and put it in the simplifier structure.  */
 330   se->expr = gfc_conv_constant_to_tree (expr);
 331
 332   /* If this is a CHARACTER string, set its length in the simplifier
 333      structure, too.  */
 334   if (expr->ts.type == BT_CHARACTER)
 335     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
 336 }