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