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 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       abort ();
  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_2 (length, 0);
  85   TREE_TYPE (str) =
  86     build_array_type (gfc_character1_type_node,
  87                       build_range_type (gfc_strlen_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   assert (expr->expr_type == EXPR_CONSTANT);
 105   assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
 106   assert (INTEGER_CST_P (length));
 107   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     {
 149       gfc_rank_cst[n] = build_int_2 (n, 0);
 150       TREE_TYPE (gfc_rank_cst[n]) = gfc_array_index_type;
 151     }
 152
 153   gfc_strconst_bounds = gfc_build_string_const (21, "Array bound mismatch");
 154
 155   gfc_strconst_fault =
 156     gfc_build_string_const (30, "Array reference out of bounds");
 157
 158   gfc_strconst_wrong_return =
 159     gfc_build_string_const (32, "Incorrect function return value");
 160
 161   gfc_strconst_current_filename =
 162     gfc_build_string_const (strlen (gfc_option.source) + 1,
 163                             gfc_option.source);
 164 }
 165
 166 #define BITS_PER_HOST_WIDE_INT (8 * sizeof (HOST_WIDE_INT))
 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   int val;
 172   tree res;
 173   HOST_WIDE_INT high;
 174   unsigned HOST_WIDE_INT low;
 175   int negate;
 176   char buff[10];
 177   char *p;
 178   char *q;
 179   int n;
 180
 181   /* TODO: could be wrong if sizeof(HOST_WIDE_INT) |= SIZEOF (int).  */
 182   if (mpz_fits_slong_p (i))
 183     {
 184       val = mpz_get_si (i);
 185       res = build_int_2 (val, (val < 0) ? (HOST_WIDE_INT)-1 : 0);
 186       TREE_TYPE (res) = gfc_get_int_type (kind);
 187       return (res);
 188     }
 189
 190   n = mpz_sizeinbase (i, 16);
 191   if (n > 8)
 192     q = gfc_getmem (n + 2);
 193   else
 194     q = buff;
 195
 196   low = 0;
 197   high = 0;
 198   p = mpz_get_str (q, 16, i);
 199   if (p[0] == '-')
 200     {
 201       negate = 1;
 202       p++;
 203     }
 204   else
 205     negate = 0;
 206
 207   while (*p)
 208     {
 209       n = *(p++);
 210       if (n >= '0' && n <= '9')
 211         n = n - '0';
 212       else if (n >= 'a' && n <= 'z')
 213         n = n + 10 - 'a';
 214       else if (n >= 'A' && n <= 'Z')
 215         n = n + 10 - 'A';
 216       else
 217         abort ();
 218
 219       assert (n >= 0 && n < 16);
 220       high = (high << 4) + (low >> (BITS_PER_HOST_WIDE_INT - 4));
 221       low = (low << 4) + n;
 222     }
 223   res = build_int_2 (low, high);
 224   TREE_TYPE (res) = gfc_get_int_type (kind);
 225   if (negate)
 226     res = fold (build1 (NEGATE_EXPR, TREE_TYPE (res), res));
 227
 228   if (q != buff)
 229     gfc_free (q);
 230
 231   return res;
 232 }
 233
 234 /* Converts a real constant into backend form.  Uses an intermediate string
 235    representation.  */
 236 tree
 237 gfc_conv_mpf_to_tree (mpf_t f, int kind)
 238 {
 239   tree res;
 240   tree type;
 241   mp_exp_t exp;
 242   char *p;
 243   char *q;
 244   int n;
 245   int edigits;
 246
 247   for (n = 0; gfc_real_kinds[n].kind != 0; n++)
 248     {
 249       if (gfc_real_kinds[n].kind == kind)
 250         break;
 251     }
 252   assert (gfc_real_kinds[n].kind);
 253
 254   assert (gfc_real_kinds[n].radix == 2);
 255
 256   n = MAX (abs (gfc_real_kinds[n].min_exponent),
 257            abs (gfc_real_kinds[n].max_exponent));
 258 #if 0
 259   edigits = 2 + (int) (log (n) / log (gfc_real_kinds[n].radix));
 260 #endif
 261   edigits = 1;
 262   while (n > 0)
 263     {
 264       n = n / 10;
 265       edigits += 3;
 266     }
 267
 268
 269   p = mpf_get_str (NULL, &exp, 10, 0, f);
 270
 271   /* We also have one minus sign, "e", "." and a null terminator.  */
 272   q = (char *) gfc_getmem (strlen (p) + edigits + 4);
 273
 274   if (p[0])
 275     {
 276       if (p[0] == '-')
 277         {
 278           strcpy (&q[2], &p[1]);
 279           q[0] = '-';
 280           q[1] = '.';
 281         }
 282       else
 283         {
 284           strcpy (&q[1], p);
 285           q[0] = '.';
 286         }
 287       strcat (q, "e");
 288       sprintf (&q[strlen (q)], "%d", (int) exp);
 289     }
 290   else
 291     {
 292       strcpy (q, "0");
 293     }
 294
 295   type = gfc_get_real_type (kind);
 296   res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
 297   gfc_free (q);
 298   gfc_free (p);
 299
 300   return res;
 301 }
 302
 303
 304 /* Translate any literal constant to a tree.  Constants never have
 305    pre or post chains.  Character literal constants are special
 306    special because they have a value and a length, so they cannot be
 307    returned as a single tree.  It is up to the caller to set the
 308    length somewhere if necessary.
 309
 310    Returns the translated constant, or aborts if it gets a type it
 311    can't handle.  */
 312
 313 tree
 314 gfc_conv_constant_to_tree (gfc_expr * expr)
 315 {
 316   assert (expr->expr_type == EXPR_CONSTANT);
 317
 318   switch (expr->ts.type)
 319     {
 320     case BT_INTEGER:
 321       return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 322
 323     case BT_REAL:
 324       return gfc_conv_mpf_to_tree (expr->value.real, expr->ts.kind);
 325
 326     case BT_LOGICAL:
 327       return build_int_2 (expr->value.logical, 0);
 328
 329     case BT_COMPLEX:
 330       {
 331         tree real = gfc_conv_mpf_to_tree (expr->value.complex.r,
 332                                           expr->ts.kind);
 333         tree imag = gfc_conv_mpf_to_tree (expr->value.complex.i,
 334                                           expr->ts.kind);
 335
 336         return build_complex (NULL_TREE, real, imag);
 337       }
 338
 339     case BT_CHARACTER:
 340       return gfc_build_string_const (expr->value.character.length,
 341                                      expr->value.character.string);
 342
 343     default:
 344       fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
 345                    gfc_typename (&expr->ts));
 346     }
 347 }
 348
 349
 350 /* Like gfc_conv_contrant_to_tree, but for a simplified expression.
 351    We can handle character literal constants here as well.  */
 352
 353 void
 354 gfc_conv_constant (gfc_se * se, gfc_expr * expr)
 355 {
 356   assert (expr->expr_type == EXPR_CONSTANT);
 357
 358   if (se->ss != NULL)
 359     {
 360       assert (se->ss != gfc_ss_terminator);
 361       assert (se->ss->type == GFC_SS_SCALAR);
 362       assert (se->ss->expr == expr);
 363
 364       se->expr = se->ss->data.scalar.expr;
 365       se->string_length = se->ss->data.scalar.string_length;
 366       gfc_advance_se_ss_chain (se);
 367       return;
 368     }
 369
 370   /* Translate the constant and put it in the simplifier structure.  */
 371   se->expr = gfc_conv_constant_to_tree (expr);
 372
 373   /* If this is a CHARACTER string, set it's length in the simplifier
 374      structure, too.  */
 375   if (expr->ts.type == BT_CHARACTER)
 376     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
 377 }