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