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