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       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   switch (expr->ts.type)
 278     {
 279     case BT_INTEGER:
 280       return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 281
 282     case BT_REAL:
 283       return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
 284
 285     case BT_LOGICAL:
 286       return build_int_cst (gfc_get_logical_type (expr->ts.kind),
 287                             expr->value.logical);
 288
 289     case BT_COMPLEX:
 290       {
 291         tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
 292                                           expr->ts.kind);
 293         tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
 294                                           expr->ts.kind);
 295
 296         return build_complex (gfc_typenode_for_spec (&expr->ts),
 297                               real, imag);
 298       }
 299
 300     case BT_CHARACTER:
 301       return gfc_build_string_const (expr->value.character.length,
 302                                      expr->value.character.string);
 303
 304     default:
 305       fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
 306                    gfc_typename (&expr->ts));
 307     }
 308 }
 309
 310
 311 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
 312    We can handle character literal constants here as well.  */
 313
 314 void
 315 gfc_conv_constant (gfc_se * se, gfc_expr * expr)
 316 {
 317   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 318
 319   if (se->ss != NULL)
 320     {
 321       gcc_assert (se->ss != gfc_ss_terminator);
 322       gcc_assert (se->ss->type == GFC_SS_SCALAR);
 323       gcc_assert (se->ss->expr == expr);
 324
 325       se->expr = se->ss->data.scalar.expr;
 326       se->string_length = se->ss->string_length;
 327       gfc_advance_se_ss_chain (se);
 328       return;
 329     }
 330
 331   /* Translate the constant and put it in the simplifier structure.  */
 332   se->expr = gfc_conv_constant_to_tree (expr);
 333
 334   /* If this is a CHARACTER string, set its length in the simplifier
 335      structure, too.  */
 336   if (expr->ts.type == BT_CHARACTER)
 337     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
 338 }