Line data    Source code

       1              : /* Translation of constants
       2              :    Copyright (C) 2002-2026 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 3, 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 COPYING3.  If not see
      19              : <http://www.gnu.org/licenses/>.  */
      20              : 
      21              : /* trans-const.cc -- convert constant values */
      22              : 
      23              : #include "config.h"
      24              : #include "system.h"
      25              : #include "coretypes.h"
      26              : #include "tree.h"
      27              : #include "gfortran.h"
      28              : #include "options.h"
      29              : #include "trans.h"
      30              : #include "fold-const.h"
      31              : #include "stor-layout.h"
      32              : #include "realmpfr.h"
      33              : #include "trans-const.h"
      34              : #include "trans-types.h"
      35              : #include "target-memory.h"
      36              : 
      37              : tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
      38              : tree gfc_index_zero_node;
      39              : tree gfc_index_one_node;
      40              : 
      41              : /* Build a constant with given type from an int_cst.  */
      42              : 
      43              : tree
      44         3374 : gfc_build_const (tree type, tree intval)
      45              : {
      46         3374 :   tree val;
      47         3374 :   tree zero;
      48              : 
      49         3374 :   switch (TREE_CODE (type))
      50              :     {
      51         1807 :     case INTEGER_TYPE:
      52         1807 :       val = convert (type, intval);
      53         1807 :       break;
      54              : 
      55         1335 :     case REAL_TYPE:
      56         1335 :       val = build_real_from_int_cst (type, intval);
      57         1335 :       break;
      58              : 
      59          232 :     case COMPLEX_TYPE:
      60          232 :       val = build_real_from_int_cst (TREE_TYPE (type), intval);
      61          232 :       zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
      62          232 :       val = build_complex (type, val, zero);
      63          232 :       break;
      64              : 
      65            0 :     default:
      66            0 :       gcc_unreachable ();
      67              :     }
      68         3374 :   return val;
      69              : }
      70              : 
      71              : /* Build a string constant with C char type.  */
      72              : 
      73              : tree
      74       259172 : gfc_build_string_const (size_t length, const char *s)
      75              : {
      76       259172 :   tree str;
      77       259172 :   tree len;
      78              : 
      79       259172 :   str = build_string (length, s);
      80       259172 :   len = size_int (length);
      81       259172 :   TREE_TYPE (str) =
      82       259172 :     build_array_type (gfc_character1_type_node,
      83              :                       build_range_type (gfc_charlen_type_node,
      84              :                                         size_one_node, len));
      85       259172 :   TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
      86       259172 :   return str;
      87              : }
      88              : 
      89              : 
      90              : /* Build a string constant with a type given by its kind; take care of
      91              :    non-default character kinds.  */
      92              : 
      93              : tree
      94       147899 : gfc_build_wide_string_const (int kind, size_t length, const gfc_char_t *string)
      95              : {
      96       147899 :   int i;
      97       147899 :   tree str, len;
      98       147899 :   size_t size;
      99       147899 :   char *s;
     100              : 
     101       147899 :   i = gfc_validate_kind (BT_CHARACTER, kind, false);
     102       147899 :   size = length * gfc_character_kinds[i].bit_size / 8;
     103              : 
     104       147899 :   s = XCNEWVAR (char, size);
     105       147899 :   gfc_encode_character (kind, length, string, (unsigned char *) s, size);
     106              : 
     107       147899 :   str = build_string (size, s);
     108       147899 :   free (s);
     109              : 
     110       147899 :   len = size_int (length);
     111       147899 :   TREE_TYPE (str) =
     112       147899 :     build_array_type (gfc_get_char_type (kind),
     113              :                       build_range_type (gfc_charlen_type_node,
     114              :                                         size_one_node, len));
     115       147899 :   TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
     116       147899 :   return str;
     117              : }
     118              : 
     119              : 
     120              : /* Build a Fortran character constant from a zero-terminated string.
     121              :    There a two version of this function, one that translates the string
     122              :    and one that doesn't.  */
     123              : tree
     124        72446 : gfc_build_cstring_const (const char *string)
     125              : {
     126        72446 :   return gfc_build_string_const (strlen (string) + 1, string);
     127              : }
     128              : 
     129              : tree
     130       177994 : gfc_build_localized_cstring_const (const char *msgid)
     131              : {
     132       177994 :   const char *localized = _(msgid);
     133       177994 :   return gfc_build_string_const (strlen (localized) + 1, localized);
     134              : }
     135              : 
     136              : 
     137              : /* Return a string constant with the given length.  Used for static
     138              :    initializers.  The constant will be padded or truncated to match
     139              :    length.  */
     140              : 
     141              : tree
     142         2704 : gfc_conv_string_init (tree length, gfc_expr * expr)
     143              : {
     144         2704 :   gfc_char_t *s;
     145         2704 :   HOST_WIDE_INT len;
     146         2704 :   gfc_charlen_t slen;
     147         2704 :   tree str;
     148         2704 :   bool free_s = false;
     149              : 
     150         2704 :   gcc_assert (expr->expr_type == EXPR_CONSTANT);
     151         2704 :   gcc_assert (expr->ts.type == BT_CHARACTER);
     152         2704 :   gcc_assert (tree_fits_uhwi_p (length));
     153              : 
     154         2704 :   len = TREE_INT_CST_LOW (length);
     155         2704 :   slen = expr->value.character.length;
     156              : 
     157         2704 :   if (len > slen)
     158              :     {
     159            0 :       s = gfc_get_wide_string (len);
     160            0 :       memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));
     161            0 :       gfc_wide_memset (&s[slen], ' ', len - slen);
     162            0 :       free_s = true;
     163              :     }
     164              :   else
     165         2704 :     s = expr->value.character.string;
     166              : 
     167         2704 :   str = gfc_build_wide_string_const (expr->ts.kind, len, s);
     168              : 
     169         2704 :   if (free_s)
     170            0 :     free (s);
     171              : 
     172         2704 :   return str;
     173              : }
     174              : 
     175              : 
     176              : /* Create a tree node for the string length if it is constant.  */
     177              : 
     178              : void
     179        35965 : gfc_conv_const_charlen (gfc_charlen * cl)
     180              : {
     181        35965 :   if (!cl || cl->backend_decl)
     182              :     return;
     183              : 
     184        34420 :   if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
     185              :     {
     186        19257 :       cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
     187              :                                                cl->length->ts.kind);
     188        19257 :       cl->backend_decl = fold_convert (gfc_charlen_type_node,
     189              :                                         cl->backend_decl);
     190              :     }
     191              : }
     192              : 
     193              : void
     194        31863 : gfc_init_constants (void)
     195              : {
     196        31863 :   int n;
     197              : 
     198       541671 :   for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
     199       509808 :     gfc_rank_cst[n] = build_int_cst (gfc_array_dim_rank_type, n);
     200              : 
     201        31863 :   gfc_index_zero_node = build_zero_cst (gfc_array_index_type);
     202        31863 :   gfc_index_one_node = build_one_cst (gfc_array_index_type);
     203        31863 : }
     204              : 
     205              : /* Converts a GMP integer into a backend tree node.  */
     206              : 
     207              : tree
     208      2235153 : gfc_conv_mpz_to_tree (mpz_t i, int kind)
     209              : {
     210      2235153 :   wide_int val = wi::from_mpz (gfc_get_int_type (kind), i, true);
     211      2235153 :   return wide_int_to_tree (gfc_get_int_type (kind), val);
     212      2235153 : }
     213              : 
     214              : /* Same, but for unsigned.  */
     215              : 
     216              : tree
     217        78824 : gfc_conv_mpz_unsigned_to_tree (mpz_t i, int kind)
     218              : {
     219        78824 :   wide_int val = wi:: from_mpz (gfc_get_unsigned_type (kind), i, true);
     220        78824 :   return wide_int_to_tree (gfc_get_unsigned_type (kind), val);
     221        78824 : }
     222              : 
     223              : /* Convert a GMP integer into a tree node of type given by the type
     224              :    argument.  */
     225              : 
     226              : tree
     227           31 : gfc_conv_mpz_to_tree_type (mpz_t i, const tree type)
     228              : {
     229           31 :   const wide_int val = wi::from_mpz (type, i, true);
     230           31 :   return wide_int_to_tree (type, val);
     231           31 : }
     232              : 
     233              : 
     234              : /* Converts a backend tree into a GMP integer.  */
     235              : 
     236              : void
     237         1963 : gfc_conv_tree_to_mpz (mpz_t i, tree source)
     238              : {
     239         1963 :   wi::to_mpz (wi::to_wide (source), i, TYPE_SIGN (TREE_TYPE (source)));
     240         1963 : }
     241              : 
     242              : /* Converts a real constant into backend form.  */
     243              : 
     244              : tree
     245       173314 : gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)
     246              : {
     247       173314 :   tree type;
     248       173314 :   int n;
     249       173314 :   REAL_VALUE_TYPE real;
     250              : 
     251       173314 :   n = gfc_validate_kind (BT_REAL, kind, false);
     252       173314 :   gcc_assert (gfc_real_kinds[n].radix == 2);
     253              : 
     254       173314 :   type = gfc_get_real_type (kind);
     255       173314 :   if (mpfr_nan_p (f) && is_snan)
     256            0 :      real_from_string (&real, "SNaN");
     257              :   else
     258       173314 :     real_from_mpfr (&real, f, type, GFC_RND_MODE);
     259              : 
     260       173314 :   return build_real (type, real);
     261              : }
     262              : 
     263              : /* Returns a real constant that is +Infinity if the target
     264              :    supports infinities for this floating-point mode, and
     265              :    +HUGE_VAL otherwise (the largest representable number).  */
     266              : 
     267              : tree
     268         5493 : gfc_build_inf_or_huge (tree type, int kind)
     269              : {
     270         5493 :   if (HONOR_INFINITIES (TYPE_MODE (type)))
     271              :     {
     272         5493 :       REAL_VALUE_TYPE real;
     273         5493 :       real_inf (&real);
     274         5493 :       return build_real (type, real);
     275              :     }
     276              :   else
     277              :     {
     278            0 :       int k = gfc_validate_kind (BT_REAL, kind, false);
     279            0 :       return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0);
     280              :     }
     281              : }
     282              : 
     283              : /* Returns a floating-point NaN of a given type.  */
     284              : 
     285              : tree
     286         1681 : gfc_build_nan (tree type, const char *str)
     287              : {
     288         1681 :   REAL_VALUE_TYPE real;
     289         1681 :   real_nan (&real, str, 1, TYPE_MODE (type));
     290         1681 :   return build_real (type, real);
     291              : }
     292              : 
     293              : /* Converts a backend tree into a real constant.  */
     294              : 
     295              : void
     296         1856 : gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source)
     297              : {
     298         1856 :   mpfr_from_real (f, TREE_REAL_CST_PTR (source), GFC_RND_MODE);
     299         1856 : }
     300              : 
     301              : /* Translate any literal constant to a tree.  Constants never have
     302              :    pre or post chains.  Character literal constants are special
     303              :    special because they have a value and a length, so they cannot be
     304              :    returned as a single tree.  It is up to the caller to set the
     305              :    length somewhere if necessary.
     306              : 
     307              :    Returns the translated constant, or aborts if it gets a type it
     308              :    can't handle.  */
     309              : 
     310              : tree
     311      1680534 : gfc_conv_constant_to_tree (gfc_expr * expr)
     312              : {
     313      1680534 :   tree res;
     314              : 
     315      1680534 :   gcc_assert (expr->expr_type == EXPR_CONSTANT);
     316              : 
     317              :   /* If it is has a prescribed memory representation, we build a string
     318              :      constant and VIEW_CONVERT to its type.  */
     319              : 
     320      1680534 :   switch (expr->ts.type)
     321              :     {
     322      1196045 :     case BT_INTEGER:
     323      1196045 :       if (expr->representation.string)
     324          886 :         return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
     325              :                          gfc_get_int_type (expr->ts.kind),
     326          886 :                          gfc_build_string_const (expr->representation.length,
     327          886 :                                                  expr->representation.string));
     328              :       else
     329      1195159 :         return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
     330              : 
     331        78758 :     case BT_UNSIGNED:
     332        78758 :       return gfc_conv_mpz_unsigned_to_tree (expr->value.integer, expr->ts.kind);
     333              : 
     334       148006 :     case BT_REAL:
     335       148006 :       if (expr->representation.string)
     336          649 :         return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
     337              :                          gfc_get_real_type (expr->ts.kind),
     338          649 :                          gfc_build_string_const (expr->representation.length,
     339          649 :                                                  expr->representation.string));
     340              :       else
     341       147357 :         return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
     342              : 
     343       100376 :     case BT_LOGICAL:
     344       100376 :       if (expr->representation.string)
     345              :         {
     346          387 :           tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
     347              :                         gfc_get_int_type (expr->ts.kind),
     348          387 :                         gfc_build_string_const (expr->representation.length,
     349              :                                                 expr->representation.string));
     350          387 :           if (!integer_zerop (tmp) && !integer_onep (tmp))
     351          378 :             gfc_warning (flag_dec_char_conversions ? OPT_Wsurprising : 0,
     352              :                          "Assigning value other than 0 or 1 to LOGICAL has "
     353              :                          "undefined result at %L", &expr->where);
     354          387 :           return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
     355              :         }
     356              :       else
     357        99989 :         return build_int_cst (gfc_get_logical_type (expr->ts.kind),
     358        99989 :                               expr->value.logical);
     359              : 
     360        12435 :     case BT_COMPLEX:
     361        12435 :       if (expr->representation.string)
     362          487 :         return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
     363              :                          gfc_get_complex_type (expr->ts.kind),
     364          487 :                          gfc_build_string_const (expr->representation.length,
     365          487 :                                                  expr->representation.string));
     366              :       else
     367              :         {
     368        23896 :           tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
     369        11948 :                                           expr->ts.kind, expr->is_snan);
     370        23896 :           tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
     371        11948 :                                           expr->ts.kind, expr->is_snan);
     372              : 
     373        11948 :           return build_complex (gfc_typenode_for_spec (&expr->ts),
     374        11948 :                                 real, imag);
     375              :         }
     376              : 
     377       144883 :     case BT_CHARACTER:
     378       144883 :       res = gfc_build_wide_string_const (expr->ts.kind,
     379       144883 :                                          expr->value.character.length,
     380       144883 :                                          expr->value.character.string);
     381       144883 :       return res;
     382              : 
     383           31 :     case BT_HOLLERITH:
     384           31 :       return gfc_build_string_const (expr->representation.length,
     385           31 :                                      expr->representation.string);
     386              : 
     387            0 :     default:
     388            0 :       gcc_unreachable ();
     389              :     }
     390              : }
     391              : 
     392              : 
     393              : /* Like gfc_conv_constant_to_tree, but for a simplified expression.
     394              :    We can handle character literal constants here as well.  */
     395              : 
     396              : void
     397      1679708 : gfc_conv_constant (gfc_se * se, gfc_expr * expr)
     398              : {
     399      1679708 :   gfc_ss *ss;
     400              : 
     401              :   /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR.  If
     402              :      so, the expr_type will not yet be an EXPR_CONSTANT.  We need to make
     403              :      it so here.  */
     404      1679708 :   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
     405            0 :       && expr->ts.u.derived->attr.is_iso_c)
     406              :     {
     407            0 :       if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
     408            0 :           || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
     409              :         {
     410              :           /* Create a new EXPR_CONSTANT expression for our local uses.  */
     411            0 :           expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
     412              :         }
     413              :     }
     414              : 
     415      1679708 :   if (expr->expr_type != EXPR_CONSTANT)
     416              :     {
     417            5 :       gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
     418            5 :       gfc_error ("non-constant initialization expression at %L", &expr->where);
     419            5 :       se->expr = gfc_conv_constant_to_tree (e);
     420            5 :       return;
     421              :     }
     422              : 
     423      1679703 :   ss = se->ss;
     424      1679703 :   if (ss != NULL)
     425              :     {
     426            0 :       gfc_ss_info *ss_info;
     427              : 
     428            0 :       ss_info = ss->info;
     429            0 :       gcc_assert (ss != gfc_ss_terminator);
     430            0 :       gcc_assert (ss_info->type == GFC_SS_SCALAR);
     431            0 :       gcc_assert (ss_info->expr == expr);
     432              : 
     433            0 :       se->expr = ss_info->data.scalar.value;
     434            0 :       se->string_length = ss_info->string_length;
     435            0 :       gfc_advance_se_ss_chain (se);
     436            0 :       return;
     437              :     }
     438              : 
     439              :   /* Translate the constant and put it in the simplifier structure.  */
     440      1679703 :   se->expr = gfc_conv_constant_to_tree (expr);
     441              : 
     442              :   /* If this is a CHARACTER string, set its length in the simplifier
     443              :      structure, too.  */
     444      1679703 :   if (expr->ts.type == BT_CHARACTER)
     445       144798 :     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
     446              : 
     447      1679703 :   if (se->want_pointer)
     448              :     {
     449           79 :       if (expr->ts.type == BT_CHARACTER)
     450            2 :         gfc_conv_string_parameter (se);
     451              :       else
     452           77 :         se->expr
     453           77 :           = gfc_build_addr_expr (NULL_TREE,
     454              :                                  gfc_trans_force_lval (&se->pre, se->expr));
     455              :     }
     456              : }