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 to the full length.  */
  94 tree
  95 gfc_conv_string_init (tree length, gfc_expr * expr)
  96 {
  97   char *s;
  98   HOST_WIDE_INT len;
  99   int slen;
 100   tree str;
 101
 102   assert (expr->expr_type == EXPR_CONSTANT);
 103   assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
 104   assert (INTEGER_CST_P (length));
 105   assert (TREE_INT_CST_HIGH (length) == 0);
 106
 107   len = TREE_INT_CST_LOW (length);
 108   slen = expr->value.character.length;
 109   assert (len >= slen);
 110   if (len != slen)
 111     {
 112       s = gfc_getmem (len);
 113       memcpy (s, expr->value.character.string, slen);
 114       memset (&s[slen], ' ', len - slen);
 115       str = gfc_build_string_const (len, s);
 116       gfc_free (s);
 117     }
 118   else
 119     str = gfc_build_string_const (len, expr->value.character.string);
 120
 121   return str;
 122 }
 123
 124
 125 /* Create a tree node for the string length if it is constant.  */
 126
 127 void
 128 gfc_conv_const_charlen (gfc_charlen * cl)
 129 {
 130   if (cl->backend_decl)
 131     return;
 132
 133   if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
 134     {
 135       cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
 136                                                cl->length->ts.kind);
 137     }
 138 }
 139
 140 void
 141 gfc_init_constants (void)
 142 {
 143   int n;
 144
 145   for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
 146     {
 147       gfc_rank_cst[n] = build_int_2 (n, 0);
 148       TREE_TYPE (gfc_rank_cst[n]) = gfc_array_index_type;
 149     }
 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 #define BITS_PER_HOST_WIDE_INT (8 * sizeof (HOST_WIDE_INT))
 165 /* Converts a GMP integer into a backend tree node.  */
 166 tree
 167 gfc_conv_mpz_to_tree (mpz_t i, int kind)
 168 {
 169   int val;
 170   tree res;
 171   HOST_WIDE_INT high;
 172   unsigned HOST_WIDE_INT low;
 173   int negate;
 174   char buff[10];
 175   char *p;
 176   char *q;
 177   int n;
 178
 179   /* TODO: could be wrong if sizeof(HOST_WIDE_INT) |= SIZEOF (int).  */
 180   if (mpz_fits_slong_p (i))
 181     {
 182       val = mpz_get_si (i);
 183       res = build_int_2 (val, (val < 0) ? (HOST_WIDE_INT)-1 : 0);
 184       TREE_TYPE (res) = gfc_get_int_type (kind);
 185       return (res);
 186     }
 187
 188   n = mpz_sizeinbase (i, 16);
 189   if (n > 8)
 190     q = gfc_getmem (n + 2);
 191   else
 192     q = buff;
 193
 194   low = 0;
 195   high = 0;
 196   p = mpz_get_str (q, 16, i);
 197   if (p[0] == '-')
 198     {
 199       negate = 1;
 200       p++;
 201     }
 202   else
 203     negate = 0;
 204
 205   while (*p)
 206     {
 207       n = *(p++);
 208       if (n >= '0' && n <= '9')
 209         n = n - '0';
 210       else if (n >= 'a' && n <= 'z')
 211         n = n + 10 - 'a';
 212       else if (n >= 'A' && n <= 'Z')
 213         n = n + 10 - 'A';
 214       else
 215         abort ();
 216
 217       assert (n >= 0 && n < 16);
 218       high = (high << 4) + (low >> (BITS_PER_HOST_WIDE_INT - 4));
 219       low = (low << 4) + n;
 220     }
 221   res = build_int_2 (low, high);
 222   TREE_TYPE (res) = gfc_get_int_type (kind);
 223   if (negate)
 224     res = fold (build1 (NEGATE_EXPR, TREE_TYPE (res), res));
 225
 226   if (q != buff)
 227     gfc_free (q);
 228
 229   return res;
 230 }
 231
 232 /* Converts a real constant into backend form.  Uses an intermediate string
 233    representation.  */
 234 tree
 235 gfc_conv_mpf_to_tree (mpf_t f, int kind)
 236 {
 237   tree res;
 238   tree type;
 239   mp_exp_t exp;
 240   char *p;
 241   char *q;
 242   int n;
 243   int edigits;
 244
 245   for (n = 0; gfc_real_kinds[n].kind != 0; n++)
 246     {
 247       if (gfc_real_kinds[n].kind == kind)
 248         break;
 249     }
 250   assert (gfc_real_kinds[n].kind);
 251
 252   assert (gfc_real_kinds[n].radix == 2);
 253
 254   n = MAX (abs (gfc_real_kinds[n].min_exponent),
 255            abs (gfc_real_kinds[n].min_exponent));
 256 #if 0
 257   edigits = 2 + (int) (log (n) / log (gfc_real_kinds[n].radix));
 258 #endif
 259   edigits = 1;
 260   while (n > 0)
 261     {
 262       n = n / 10;
 263       edigits += 3;
 264     }
 265
 266
 267   p = mpf_get_str (NULL, &exp, 10, 0, f);
 268
 269   /* We also have one minus sign, "e", "." and a null terminator.  */
 270   q = (char *) gfc_getmem (strlen (p) + edigits + 4);
 271
 272   if (p[0])
 273     {
 274       if (p[0] == '-')
 275         {
 276           strcpy (&q[2], &p[1]);
 277           q[0] = '-';
 278           q[1] = '.';
 279         }
 280       else
 281         {
 282           strcpy (&q[1], p);
 283           q[0] = '.';
 284         }
 285       strcat (q, "e");
 286       sprintf (&q[strlen (q)], "%d", (int) exp);
 287     }
 288   else
 289     {
 290       strcpy (q, "0");
 291     }
 292
 293   type = gfc_get_real_type (kind);
 294   res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
 295   gfc_free (q);
 296   gfc_free (p);
 297
 298   return res;
 299 }
 300
 301
 302 /* Translate any literal constant to a tree.  Constants never have
 303    pre or post chains.  Character literal constants are special
 304    special because they have a value and a length, so they cannot be
 305    returned as a single tree.  It is up to the caller to set the
 306    length somewhere if necessary.
 307
 308    Returns the translated constant, or aborts if it gets a type it
 309    can't handle.  */
 310
 311 tree
 312 gfc_conv_constant_to_tree (gfc_expr * expr)
 313 {
 314   assert (expr->expr_type == EXPR_CONSTANT);
 315
 316   switch (expr->ts.type)
 317     {
 318     case BT_INTEGER:
 319       return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 320
 321     case BT_REAL:
 322       return gfc_conv_mpf_to_tree (expr->value.real, expr->ts.kind);
 323
 324     case BT_LOGICAL:
 325       return build_int_2 (expr->value.logical, 0);
 326
 327     case BT_COMPLEX:
 328       {
 329         tree real = gfc_conv_mpf_to_tree (expr->value.complex.r,
 330                                           expr->ts.kind);
 331         tree imag = gfc_conv_mpf_to_tree (expr->value.complex.i,
 332                                           expr->ts.kind);
 333
 334         return build_complex (NULL_TREE, real, imag);
 335       }
 336
 337     case BT_CHARACTER:
 338       return gfc_build_string_const (expr->value.character.length,
 339                                      expr->value.character.string);
 340
 341     default:
 342       fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
 343                    gfc_typename (&expr->ts));
 344     }
 345 }
 346
 347
 348 /* Like gfc_conv_contrant_to_tree, but for a simplified expression.
 349    We can handle character literal constants here as well.  */
 350
 351 void
 352 gfc_conv_constant (gfc_se * se, gfc_expr * expr)
 353 {
 354   assert (expr->expr_type == EXPR_CONSTANT);
 355
 356   if (se->ss != NULL)
 357     {
 358       assert (se->ss != gfc_ss_terminator);
 359       assert (se->ss->type == GFC_SS_SCALAR);
 360       assert (se->ss->expr == expr);
 361
 362       se->expr = se->ss->data.scalar.expr;
 363       se->string_length = se->ss->data.scalar.string_length;
 364       gfc_advance_se_ss_chain (se);
 365       return;
 366     }
 367
 368   /* Translate the constant and put it in the simplifier structure.  */
 369   se->expr = gfc_conv_constant_to_tree (expr);
 370
 371   /* If this is a CHARACTER string, set it's length in the simplifier
 372      structure, too.  */
 373   if (expr->ts.type == BT_CHARACTER)
 374     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
 375 }