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, 0);
  86   TREE_TYPE (str) =
  87     build_array_type (gfc_character1_type_node,
  88                       build_range_type (gfc_strlen_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, 0);
 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       /* Note that mp_limb_t can be anywhere from short to long long,
 180          which gives us a nice variety of cases to choose from.  */
 181
 182       if (sizeof (mp_limb_t) == sizeof (HOST_WIDE_INT))
 183         {
 184           low = mpz_getlimbn (i, 0);
 185           high = mpz_getlimbn (i, 1);
 186         }
 187       else if (sizeof (mp_limb_t) == 2 * sizeof (HOST_WIDE_INT))
 188         {
 189           mp_limb_t limb0 = mpz_getlimbn (i, 0);
 190           int shift = (sizeof (mp_limb_t) - sizeof (HOST_WIDE_INT)) * CHAR_BIT;
 191           low = limb0;
 192           high = limb0 >> shift;
 193         }
 194       else if (sizeof (mp_limb_t) < sizeof (HOST_WIDE_INT))
 195         {
 196           int shift = sizeof (mp_limb_t) * CHAR_BIT;
 197           int n, count = sizeof (HOST_WIDE_INT) / sizeof (mp_limb_t);
 198           for (low = n = 0; n < count; ++n)
 199             {
 200               low <<= shift;
 201               low |= mpz_getlimbn (i, n);
 202             }
 203           for (high = 0, n = count; n < 2*count; ++n)
 204             {
 205               high <<= shift;
 206               high |= mpz_getlimbn (i, n);
 207             }
 208         }
 209
 210       /* By extracting limbs we constructed the absolute value of the
 211          desired number.  Negate if necessary.  */
 212       if (mpz_sgn (i) < 0)
 213         {
 214           if (low == 0)
 215             high = -high;
 216           else
 217             low = -low, high = ~high;
 218         }
 219     }
 220
 221   return build_int_cst (gfc_get_int_type (kind), low, high);
 222 }
 223
 224 /* Converts a real constant into backend form.  Uses an intermediate string
 225    representation.  */
 226
 227 tree
 228 gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
 229 {
 230   tree res;
 231   tree type;
 232   mp_exp_t exp;
 233   char *p;
 234   char *q;
 235   int n;
 236   int edigits;
 237
 238   for (n = 0; gfc_real_kinds[n].kind != 0; n++)
 239     {
 240       if (gfc_real_kinds[n].kind == kind)
 241         break;
 242     }
 243   assert (gfc_real_kinds[n].kind);
 244
 245   n = MAX (abs (gfc_real_kinds[n].min_exponent),
 246            abs (gfc_real_kinds[n].max_exponent));
 247
 248   edigits = 1;
 249   while (n > 0)
 250     {
 251       n = n / 10;
 252       edigits += 3;
 253     }
 254
 255   if (kind == gfc_default_double_kind())
 256     p = mpfr_get_str (NULL, &exp, 10, 17, f, GFC_RND_MODE);
 257   else
 258     p = mpfr_get_str (NULL, &exp, 10, 8, f, GFC_RND_MODE);
 259
 260
 261   /* We also have one minus sign, "e", "." and a null terminator.  */
 262   q = (char *) gfc_getmem (strlen (p) + edigits + 4);
 263
 264   if (p[0])
 265     {
 266       if (p[0] == '-')
 267         {
 268           strcpy (&q[2], &p[1]);
 269           q[0] = '-';
 270           q[1] = '.';
 271         }
 272       else
 273         {
 274           strcpy (&q[1], p);
 275           q[0] = '.';
 276         }
 277       strcat (q, "e");
 278       sprintf (&q[strlen (q)], "%d", (int) exp);
 279     }
 280   else
 281     {
 282       strcpy (q, "0");
 283     }
 284
 285   type = gfc_get_real_type (kind);
 286   res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
 287
 288   gfc_free (q);
 289   gfc_free (p);
 290
 291   return res;
 292 }
 293
 294
 295 /* Translate any literal constant to a tree.  Constants never have
 296    pre or post chains.  Character literal constants are special
 297    special because they have a value and a length, so they cannot be
 298    returned as a single tree.  It is up to the caller to set the
 299    length somewhere if necessary.
 300
 301    Returns the translated constant, or aborts if it gets a type it
 302    can't handle.  */
 303
 304 tree
 305 gfc_conv_constant_to_tree (gfc_expr * expr)
 306 {
 307   assert (expr->expr_type == EXPR_CONSTANT);
 308
 309   switch (expr->ts.type)
 310     {
 311     case BT_INTEGER:
 312       return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 313
 314     case BT_REAL:
 315       return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
 316
 317     case BT_LOGICAL:
 318       return build_int_cst (NULL_TREE, expr->value.logical, 0);
 319
 320     case BT_COMPLEX:
 321       {
 322         tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
 323                                           expr->ts.kind);
 324         tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
 325                                           expr->ts.kind);
 326
 327         return build_complex (NULL_TREE, real, imag);
 328       }
 329
 330     case BT_CHARACTER:
 331       return gfc_build_string_const (expr->value.character.length,
 332                                      expr->value.character.string);
 333
 334     default:
 335       fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
 336                    gfc_typename (&expr->ts));
 337     }
 338 }
 339
 340
 341 /* Like gfc_conv_constant_to_tree, but for a simplified expression.
 342    We can handle character literal constants here as well.  */
 343
 344 void
 345 gfc_conv_constant (gfc_se * se, gfc_expr * expr)
 346 {
 347   assert (expr->expr_type == EXPR_CONSTANT);
 348
 349   if (se->ss != NULL)
 350     {
 351       assert (se->ss != gfc_ss_terminator);
 352       assert (se->ss->type == GFC_SS_SCALAR);
 353       assert (se->ss->expr == expr);
 354
 355       se->expr = se->ss->data.scalar.expr;
 356       se->string_length = se->ss->data.scalar.string_length;
 357       gfc_advance_se_ss_chain (se);
 358       return;
 359     }
 360
 361   /* Translate the constant and put it in the simplifier structure.  */
 362   se->expr = gfc_conv_constant_to_tree (expr);
 363
 364   /* If this is a CHARACTER string, set its length in the simplifier
 365      structure, too.  */
 366   if (expr->ts.type == BT_CHARACTER)
 367     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
 368 }