gcc/fortran/trans-const.c

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