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