LCOV - code coverage report
Current view: top level - gcc/fortran - trans-const.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 160 185 86.5 %
Date: 2020-03-28 11:57:23 Functions: 17 17 100.0 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* Translation of constants
       2                 :            :    Copyright (C) 2002-2020 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.c -- 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                 :       2926 : gfc_build_const (tree type, tree intval)
      43                 :            : {
      44                 :       2926 :   tree val;
      45                 :       2926 :   tree zero;
      46                 :            : 
      47                 :       2926 :   switch (TREE_CODE (type))
      48                 :            :     {
      49                 :       1512 :     case INTEGER_TYPE:
      50                 :       1512 :       val = convert (type, intval);
      51                 :       1512 :       break;
      52                 :            : 
      53                 :       1212 :     case REAL_TYPE:
      54                 :       1212 :       val = build_real_from_int_cst (type, intval);
      55                 :       1212 :       break;
      56                 :            : 
      57                 :        202 :     case COMPLEX_TYPE:
      58                 :        202 :       val = build_real_from_int_cst (TREE_TYPE (type), intval);
      59                 :        202 :       zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
      60                 :        202 :       val = build_complex (type, val, zero);
      61                 :        202 :       break;
      62                 :            : 
      63                 :          0 :     default:
      64                 :          0 :       gcc_unreachable ();
      65                 :            :     }
      66                 :       2926 :   return val;
      67                 :            : }
      68                 :            : 
      69                 :            : /* Build a string constant with C char type.  */
      70                 :            : 
      71                 :            : tree
      72                 :     164880 : gfc_build_string_const (size_t length, const char *s)
      73                 :            : {
      74                 :     164880 :   tree str;
      75                 :     164880 :   tree len;
      76                 :            : 
      77                 :     164880 :   str = build_string (length, s);
      78                 :     164880 :   len = size_int (length);
      79                 :     494640 :   TREE_TYPE (str) =
      80                 :     164880 :     build_array_type (gfc_character1_type_node,
      81                 :            :                       build_range_type (gfc_charlen_type_node,
      82                 :            :                                         size_one_node, len));
      83                 :     164880 :   TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
      84                 :     164880 :   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                 :      93714 : gfc_build_wide_string_const (int kind, size_t length, const gfc_char_t *string)
      93                 :            : {
      94                 :      93714 :   int i;
      95                 :      93714 :   tree str, len;
      96                 :      93714 :   size_t size;
      97                 :      93714 :   char *s;
      98                 :            : 
      99                 :      93714 :   i = gfc_validate_kind (BT_CHARACTER, kind, false);
     100                 :      93714 :   size = length * gfc_character_kinds[i].bit_size / 8;
     101                 :            : 
     102                 :      93714 :   s = XCNEWVAR (char, size);
     103                 :      93714 :   gfc_encode_character (kind, length, string, (unsigned char *) s, size);
     104                 :            : 
     105                 :      93714 :   str = build_string (size, s);
     106                 :      93714 :   free (s);
     107                 :            : 
     108                 :      93714 :   len = size_int (length);
     109                 :     281142 :   TREE_TYPE (str) =
     110                 :      93714 :     build_array_type (gfc_get_char_type (kind),
     111                 :            :                       build_range_type (gfc_charlen_type_node,
     112                 :            :                                         size_one_node, len));
     113                 :      93714 :   TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
     114                 :      93714 :   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                 :      54535 : gfc_build_cstring_const (const char *string)
     123                 :            : {
     124                 :      54535 :   return gfc_build_string_const (strlen (string) + 1, string);
     125                 :            : }
     126                 :            : 
     127                 :            : tree
     128                 :     102975 : gfc_build_localized_cstring_const (const char *msgid)
     129                 :            : {
     130                 :     102975 :   const char *localized = _(msgid);
     131                 :     102975 :   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                 :       2056 : gfc_conv_string_init (tree length, gfc_expr * expr)
     141                 :            : {
     142                 :       2056 :   gfc_char_t *s;
     143                 :       2056 :   HOST_WIDE_INT len;
     144                 :       2056 :   gfc_charlen_t slen;
     145                 :       2056 :   tree str;
     146                 :       2056 :   bool free_s = false;
     147                 :            : 
     148                 :       2056 :   gcc_assert (expr->expr_type == EXPR_CONSTANT);
     149                 :       2056 :   gcc_assert (expr->ts.type == BT_CHARACTER);
     150                 :       2056 :   gcc_assert (tree_fits_uhwi_p (length));
     151                 :            : 
     152                 :       2056 :   len = TREE_INT_CST_LOW (length);
     153                 :       2056 :   slen = expr->value.character.length;
     154                 :            : 
     155                 :       2056 :   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                 :       2056 :     s = expr->value.character.string;
     164                 :            : 
     165                 :       2056 :   str = gfc_build_wide_string_const (expr->ts.kind, len, s);
     166                 :            : 
     167                 :       2056 :   if (free_s)
     168                 :          0 :     free (s);
     169                 :            : 
     170                 :       2056 :   return str;
     171                 :            : }
     172                 :            : 
     173                 :            : 
     174                 :            : /* Create a tree node for the string length if it is constant.  */
     175                 :            : 
     176                 :            : void
     177                 :      25099 : gfc_conv_const_charlen (gfc_charlen * cl)
     178                 :            : {
     179                 :      25099 :   if (!cl || cl->backend_decl)
     180                 :            :     return;
     181                 :            : 
     182                 :      21181 :   if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
     183                 :            :     {
     184                 :      13134 :       cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
     185                 :            :                                                cl->length->ts.kind);
     186                 :      13134 :       cl->backend_decl = fold_convert (gfc_charlen_type_node,
     187                 :            :                                         cl->backend_decl);
     188                 :            :     }
     189                 :            : }
     190                 :            : 
     191                 :            : void
     192                 :      25178 : gfc_init_constants (void)
     193                 :            : {
     194                 :      25178 :   int n;
     195                 :            : 
     196                 :     428026 :   for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
     197                 :     402848 :     gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
     198                 :      25178 : }
     199                 :            : 
     200                 :            : /* Converts a GMP integer into a backend tree node.  */
     201                 :            : 
     202                 :            : tree
     203                 :    1428610 : gfc_conv_mpz_to_tree (mpz_t i, int kind)
     204                 :            : {
     205                 :    1428610 :   wide_int val = wi::from_mpz (gfc_get_int_type (kind), i, true);
     206                 :    1428610 :   return wide_int_to_tree (gfc_get_int_type (kind), val);
     207                 :            : }
     208                 :            : 
     209                 :            : 
     210                 :            : /* Convert a GMP integer into a tree node of type given by the type
     211                 :            :    argument.  */
     212                 :            : 
     213                 :            : tree
     214                 :         12 : gfc_conv_mpz_to_tree_type (mpz_t i, const tree type)
     215                 :            : {
     216                 :         12 :   const wide_int val = wi::from_mpz (type, i, true);
     217                 :         12 :   return wide_int_to_tree (type, val);
     218                 :            : }
     219                 :            : 
     220                 :            : 
     221                 :            : /* Converts a backend tree into a GMP integer.  */
     222                 :            : 
     223                 :            : void
     224                 :       1228 : gfc_conv_tree_to_mpz (mpz_t i, tree source)
     225                 :            : {
     226                 :       1228 :   wi::to_mpz (wi::to_wide (source), i, TYPE_SIGN (TREE_TYPE (source)));
     227                 :       1228 : }
     228                 :            : 
     229                 :            : /* Converts a real constant into backend form.  */
     230                 :            : 
     231                 :            : tree
     232                 :     103471 : gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)
     233                 :            : {
     234                 :     103471 :   tree type;
     235                 :     103471 :   int n;
     236                 :     103471 :   REAL_VALUE_TYPE real;
     237                 :            : 
     238                 :     103471 :   n = gfc_validate_kind (BT_REAL, kind, false);
     239                 :     103471 :   gcc_assert (gfc_real_kinds[n].radix == 2);
     240                 :            : 
     241                 :     103471 :   type = gfc_get_real_type (kind);
     242                 :     103471 :   if (mpfr_nan_p (f) && is_snan)
     243                 :          0 :      real_from_string (&real, "SNaN");
     244                 :            :   else
     245                 :     103471 :     real_from_mpfr (&real, f, type, GFC_RND_MODE);
     246                 :            : 
     247                 :     103471 :   return build_real (type, real);
     248                 :            : }
     249                 :            : 
     250                 :            : /* Returns a real constant that is +Infinity if the target
     251                 :            :    supports infinities for this floating-point mode, and
     252                 :            :    +HUGE_VAL otherwise (the largest representable number).  */
     253                 :            : 
     254                 :            : tree
     255                 :       3116 : gfc_build_inf_or_huge (tree type, int kind)
     256                 :            : {
     257                 :       3116 :   if (HONOR_INFINITIES (TYPE_MODE (type)))
     258                 :            :     {
     259                 :       3116 :       REAL_VALUE_TYPE real;
     260                 :       3116 :       real_inf (&real);
     261                 :       3116 :       return build_real (type, real);
     262                 :            :     }
     263                 :            :   else
     264                 :            :     {
     265                 :          0 :       int k = gfc_validate_kind (BT_REAL, kind, false);
     266                 :          0 :       return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0);
     267                 :            :     }
     268                 :            : }
     269                 :            : 
     270                 :            : /* Returns a floating-point NaN of a given type.  */
     271                 :            : 
     272                 :            : tree
     273                 :       1522 : gfc_build_nan (tree type, const char *str)
     274                 :            : {
     275                 :       1522 :   REAL_VALUE_TYPE real;
     276                 :       1522 :   real_nan (&real, str, 1, TYPE_MODE (type));
     277                 :       1522 :   return build_real (type, real);
     278                 :            : }
     279                 :            : 
     280                 :            : /* Converts a backend tree into a real constant.  */
     281                 :            : 
     282                 :            : void
     283                 :       1935 : gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source)
     284                 :            : {
     285                 :       1935 :   mpfr_from_real (f, TREE_REAL_CST_PTR (source), GFC_RND_MODE);
     286                 :       1935 : }
     287                 :            : 
     288                 :            : /* Translate any literal constant to a tree.  Constants never have
     289                 :            :    pre or post chains.  Character literal constants are special
     290                 :            :    special because they have a value and a length, so they cannot be
     291                 :            :    returned as a single tree.  It is up to the caller to set the
     292                 :            :    length somewhere if necessary.
     293                 :            : 
     294                 :            :    Returns the translated constant, or aborts if it gets a type it
     295                 :            :    can't handle.  */
     296                 :            : 
     297                 :            : tree
     298                 :    1008760 : gfc_conv_constant_to_tree (gfc_expr * expr)
     299                 :            : {
     300                 :    1008760 :   tree res;
     301                 :            : 
     302                 :    1008760 :   gcc_assert (expr->expr_type == EXPR_CONSTANT);
     303                 :            : 
     304                 :            :   /* If it is has a prescribed memory representation, we build a string
     305                 :            :      constant and VIEW_CONVERT to its type.  */
     306                 :            : 
     307                 :    1008760 :   switch (expr->ts.type)
     308                 :            :     {
     309                 :     767802 :     case BT_INTEGER:
     310                 :     767802 :       if (expr->representation.string)
     311                 :       1215 :         return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
     312                 :            :                          gfc_get_int_type (expr->ts.kind),
     313                 :       1215 :                          gfc_build_string_const (expr->representation.length,
     314                 :       1215 :                                                  expr->representation.string));
     315                 :            :       else
     316                 :     766587 :         return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
     317                 :            : 
     318                 :      87879 :     case BT_REAL:
     319                 :      87879 :       if (expr->representation.string)
     320                 :        728 :         return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
     321                 :            :                          gfc_get_real_type (expr->ts.kind),
     322                 :        728 :                          gfc_build_string_const (expr->representation.length,
     323                 :        728 :                                                  expr->representation.string));
     324                 :            :       else
     325                 :      87151 :         return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
     326                 :            : 
     327                 :      53700 :     case BT_LOGICAL:
     328                 :      53700 :       if (expr->representation.string)
     329                 :            :         {
     330                 :        387 :           tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
     331                 :            :                         gfc_get_int_type (expr->ts.kind),
     332                 :        387 :                         gfc_build_string_const (expr->representation.length,
     333                 :            :                                                 expr->representation.string));
     334                 :        387 :           if (!integer_zerop (tmp) && !integer_onep (tmp))
     335                 :        378 :             gfc_warning (flag_dec_char_conversions ? OPT_Wsurprising : 0,
     336                 :            :                          "Assigning value other than 0 or 1 to LOGICAL has "
     337                 :            :                          "undefined result at %L", &expr->where);
     338                 :        387 :           return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
     339                 :            :         }
     340                 :            :       else
     341                 :      53313 :         return build_int_cst (gfc_get_logical_type (expr->ts.kind),
     342                 :      53313 :                               expr->value.logical);
     343                 :            : 
     344                 :       7972 :     case BT_COMPLEX:
     345                 :       7972 :       if (expr->representation.string)
     346                 :        527 :         return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
     347                 :            :                          gfc_get_complex_type (expr->ts.kind),
     348                 :        527 :                          gfc_build_string_const (expr->representation.length,
     349                 :        527 :                                                  expr->representation.string));
     350                 :            :       else
     351                 :            :         {
     352                 :      14890 :           tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
     353                 :       7445 :                                           expr->ts.kind, expr->is_snan);
     354                 :      14890 :           tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
     355                 :       7445 :                                           expr->ts.kind, expr->is_snan);
     356                 :            : 
     357                 :       7445 :           return build_complex (gfc_typenode_for_spec (&expr->ts),
     358                 :       7445 :                                 real, imag);
     359                 :            :         }
     360                 :            : 
     361                 :      91381 :     case BT_CHARACTER:
     362                 :      91381 :       res = gfc_build_wide_string_const (expr->ts.kind,
     363                 :      91381 :                                          expr->value.character.length,
     364                 :      91381 :                                          expr->value.character.string);
     365                 :      91381 :       return res;
     366                 :            : 
     367                 :         31 :     case BT_HOLLERITH:
     368                 :         31 :       return gfc_build_string_const (expr->representation.length,
     369                 :         31 :                                      expr->representation.string);
     370                 :            : 
     371                 :          0 :     default:
     372                 :          0 :       gcc_unreachable ();
     373                 :            :     }
     374                 :            : }
     375                 :            : 
     376                 :            : 
     377                 :            : /* Like gfc_conv_constant_to_tree, but for a simplified expression.
     378                 :            :    We can handle character literal constants here as well.  */
     379                 :            : 
     380                 :            : void
     381                 :    1008110 : gfc_conv_constant (gfc_se * se, gfc_expr * expr)
     382                 :            : {
     383                 :    1008110 :   gfc_ss *ss;
     384                 :            : 
     385                 :            :   /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR.  If
     386                 :            :      so, the expr_type will not yet be an EXPR_CONSTANT.  We need to make
     387                 :            :      it so here.  */
     388                 :    1008110 :   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
     389                 :          0 :       && expr->ts.u.derived->attr.is_iso_c)
     390                 :            :     {
     391                 :          0 :       if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
     392                 :          0 :           || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
     393                 :            :         {
     394                 :            :           /* Create a new EXPR_CONSTANT expression for our local uses.  */
     395                 :          0 :           expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
     396                 :            :         }
     397                 :            :     }
     398                 :            : 
     399                 :    1008110 :   if (expr->expr_type != EXPR_CONSTANT)
     400                 :            :     {
     401                 :          1 :       gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
     402                 :          1 :       gfc_error ("non-constant initialization expression at %L", &expr->where);
     403                 :          1 :       se->expr = gfc_conv_constant_to_tree (e);
     404                 :          1 :       return;
     405                 :            :     }
     406                 :            : 
     407                 :    1008110 :   ss = se->ss;
     408                 :    1008110 :   if (ss != NULL)
     409                 :            :     {
     410                 :          0 :       gfc_ss_info *ss_info;
     411                 :            : 
     412                 :          0 :       ss_info = ss->info;
     413                 :          0 :       gcc_assert (ss != gfc_ss_terminator);
     414                 :          0 :       gcc_assert (ss_info->type == GFC_SS_SCALAR);
     415                 :          0 :       gcc_assert (ss_info->expr == expr);
     416                 :            : 
     417                 :          0 :       se->expr = ss_info->data.scalar.value;
     418                 :          0 :       se->string_length = ss_info->string_length;
     419                 :          0 :       gfc_advance_se_ss_chain (se);
     420                 :          0 :       return;
     421                 :            :     }
     422                 :            : 
     423                 :            :   /* Translate the constant and put it in the simplifier structure.  */
     424                 :    1008110 :   se->expr = gfc_conv_constant_to_tree (expr);
     425                 :            : 
     426                 :            :   /* If this is a CHARACTER string, set its length in the simplifier
     427                 :            :      structure, too.  */
     428                 :    1008110 :   if (expr->ts.type == BT_CHARACTER)
     429                 :      91381 :     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
     430                 :            : }

Generated by: LCOV version 1.0

LCOV profile is generated on x86_64 machine using following configure options: configure --disable-bootstrap --enable-coverage=opt --enable-languages=c,c++,fortran,go,jit,lto --enable-host-shared. GCC test suite is run with the built compiler.