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 one word will be written, but we don't know
 187          about the second.  It's quicker to zero the second word before
 188          that 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;
 225   char *q;
 226   int n;
 227   int edigits;
 228
 229   for (n = 0; gfc_real_kinds[n].kind != 0; n++)
 230     {
 231       if (gfc_real_kinds[n].kind == kind)
 232         break;
 233     }
 234   gcc_assert (gfc_real_kinds[n].kind);
 235
 236   n = MAX (abs (gfc_real_kinds[n].min_exponent),
 237            abs (gfc_real_kinds[n].max_exponent));
 238
 239   edigits = 1;
 240   while (n > 0)
 241     {
 242       n = n / 10;
 243       edigits += 3;
 244     }
 245
 246   if (kind == gfc_default_double_kind)
 247     p = mpfr_get_str (NULL, &exp, 10, 17, f, GFC_RND_MODE);
 248   else
 249     p = mpfr_get_str (NULL, &exp, 10, 8, f, GFC_RND_MODE);
 250
 251
 252   /* We also have one minus sign, "e", "." and a null terminator.  */
 253   q = (char *) gfc_getmem (strlen (p) + edigits + 4);
 254
 255   if (p[0])
 256     {
 257       if (p[0] == '-')
 258         {
 259           strcpy (&q[2], &p[1]);
 260           q[0] = '-';
 261           q[1] = '.';
 262         }
 263       else
 264         {
 265           strcpy (&q[1], p);
 266           q[0] = '.';
 267         }
 268       strcat (q, "e");
 269       sprintf (&q[strlen (q)], "%d", (int) exp);
 270     }
 271   else
 272     {
 273       strcpy (q, "0");
 274     }
 275
 276   type = gfc_get_real_type (kind);
 277   res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
 278
 279   gfc_free (q);
 280   gfc_free (p);
 281
 282   return res;
 283 }
 284
 285
 286 /* Translate any literal constant to a tree.  Constants never have
 287    pre or post chains.  Character literal constants are special
 288    special because they have a value and a length, so they cannot be
 289    returned as a single tree.  It is up to the caller to set the
 290    length somewhere if necessary.
 291
 292    Returns the translated constant, or aborts if it gets a type it
 293    can't handle.  */
 294
 295 tree
 296 gfc_conv_constant_to_tree (gfc_expr * expr)
 297 {
 298   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 299
 300   switch (expr->ts.type)
 301     {
 302     case BT_INTEGER:
 303       return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 304
 305     case BT_REAL:
 306       return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
 307
 308     case BT_LOGICAL:
 309       return build_int_cst (gfc_get_logical_type (expr->ts.kind),
 310                             expr->value.logical);
 311
 312     case BT_COMPLEX:
 313       {
 314         tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
 315                                           expr->ts.kind);
 316         tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
 317                                           expr->ts.kind);
 318
 319         return build_complex (NULL_TREE, real, imag);
 320       }
 321
 322     case BT_CHARACTER:
 323       return gfc_build_string_const (expr->value.character.length,
 324                                      expr->value.character.string);
 325
 326     default:
 327       fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
 328                    gfc_typename (&expr->ts));
 329     }
 330 }
 331
 332
 333 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
 334    We can handle character literal constants here as well.  */
 335
 336 void
 337 gfc_conv_constant (gfc_se * se, gfc_expr * expr)
 338 {
 339   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 340
 341   if (se->ss != NULL)
 342     {
 343       gcc_assert (se->ss != gfc_ss_terminator);
 344       gcc_assert (se->ss->type == GFC_SS_SCALAR);
 345       gcc_assert (se->ss->expr == expr);
 346
 347       se->expr = se->ss->data.scalar.expr;
 348       se->string_length = se->ss->string_length;
 349       gfc_advance_se_ss_chain (se);
 350       return;
 351     }
 352
 353   /* Translate the constant and put it in the simplifier structure.  */
 354   se->expr = gfc_conv_constant_to_tree (expr);
 355
 356   /* If this is a CHARACTER string, set its length in the simplifier
 357      structure, too.  */
 358   if (expr->ts.type == BT_CHARACTER)
 359     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
 360 }