LCOV - code coverage report
Current view: top level - gcc/fortran - target-memory.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 378 390 96.9 %
Date: 2020-03-28 11:57:23 Functions: 24 26 92.3 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* Simulate storage of variables into target memory.
       2                 :            :    Copyright (C) 2007-2020 Free Software Foundation, Inc.
       3                 :            :    Contributed by Paul Thomas and Brooks Moses
       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                 :            : #include "config.h"
      22                 :            : #include "system.h"
      23                 :            : #include "coretypes.h"
      24                 :            : #include "tree.h"
      25                 :            : #include "gfortran.h"
      26                 :            : #include "trans.h"
      27                 :            : #include "fold-const.h"
      28                 :            : #include "stor-layout.h"
      29                 :            : #include "arith.h"
      30                 :            : #include "constructor.h"
      31                 :            : #include "trans-const.h"
      32                 :            : #include "trans-types.h"
      33                 :            : #include "target-memory.h"
      34                 :            : 
      35                 :            : /* --------------------------------------------------------------- */
      36                 :            : /* Calculate the size of an expression.  */
      37                 :            : 
      38                 :            : 
      39                 :            : static size_t
      40                 :       3500 : size_integer (int kind)
      41                 :            : {
      42                 :       3500 :   return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_int_type (kind)));
      43                 :            : }
      44                 :            : 
      45                 :            : 
      46                 :            : static size_t
      47                 :       3787 : size_float (int kind)
      48                 :            : {
      49                 :       3787 :   return GET_MODE_SIZE (SCALAR_FLOAT_TYPE_MODE (gfc_get_real_type (kind)));
      50                 :            : }
      51                 :            : 
      52                 :            : 
      53                 :            : static size_t
      54                 :        603 : size_complex (int kind)
      55                 :            : {
      56                 :          0 :   return 2 * size_float (kind);
      57                 :            : }
      58                 :            : 
      59                 :            : 
      60                 :            : static size_t
      61                 :        957 : size_logical (int kind)
      62                 :            : {
      63                 :        957 :   return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_logical_type (kind)));
      64                 :            : }
      65                 :            : 
      66                 :            : 
      67                 :            : static size_t
      68                 :     189400 : size_character (gfc_charlen_t length, int kind)
      69                 :            : {
      70                 :          0 :   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
      71                 :     189400 :   return length * gfc_character_kinds[i].bit_size / 8;
      72                 :            : }
      73                 :            : 
      74                 :            : 
      75                 :            : /* Return the size of a single element of the given expression.
      76                 :            :    Equivalent to gfc_target_expr_size for scalars.  */
      77                 :            : 
      78                 :            : bool
      79                 :       4710 : gfc_element_size (gfc_expr *e, size_t *siz)
      80                 :            : {
      81                 :       4710 :   tree type;
      82                 :            : 
      83                 :       4710 :   switch (e->ts.type)
      84                 :            :     {
      85                 :       1794 :     case BT_INTEGER:
      86                 :       1794 :       *siz = size_integer (e->ts.kind);
      87                 :       1794 :       return true;
      88                 :        998 :     case BT_REAL:
      89                 :        998 :       *siz = size_float (e->ts.kind);
      90                 :        998 :       return true;
      91                 :        603 :     case BT_COMPLEX:
      92                 :        603 :       *siz = size_complex (e->ts.kind);
      93                 :        603 :       return true;
      94                 :        516 :     case BT_LOGICAL:
      95                 :        516 :       *siz = size_logical (e->ts.kind);
      96                 :        516 :       return true;
      97                 :        678 :     case BT_CHARACTER:
      98                 :        678 :       if (e->expr_type == EXPR_CONSTANT)
      99                 :        443 :         *siz = size_character (e->value.character.length, e->ts.kind);
     100                 :        235 :       else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
     101                 :        215 :                && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
     102                 :        215 :                && e->ts.u.cl->length->ts.type == BT_INTEGER)
     103                 :            :         {
     104                 :        215 :           HOST_WIDE_INT length;
     105                 :            : 
     106                 :        215 :           gfc_extract_hwi (e->ts.u.cl->length, &length);
     107                 :        215 :           *siz = size_character (length, e->ts.kind);
     108                 :            :         }
     109                 :            :       else
     110                 :            :         {
     111                 :         20 :           *siz = 0;
     112                 :         20 :           return false;
     113                 :            :         }
     114                 :            :       return true;
     115                 :            : 
     116                 :          7 :     case BT_HOLLERITH:
     117                 :          7 :       *siz = e->representation.length;
     118                 :          7 :       return true;
     119                 :        114 :     case BT_DERIVED:
     120                 :        114 :     case BT_CLASS:
     121                 :        114 :     case BT_VOID:
     122                 :        114 :     case BT_ASSUMED:
     123                 :        114 :     case BT_PROCEDURE:
     124                 :        114 :       {
     125                 :            :         /* Determine type size without clobbering the typespec for ISO C
     126                 :            :            binding types.  */
     127                 :        114 :         gfc_typespec ts;
     128                 :        114 :         HOST_WIDE_INT size;
     129                 :        114 :         ts = e->ts;
     130                 :        114 :         type = gfc_typenode_for_spec (&ts);
     131                 :        114 :         size = int_size_in_bytes (type);
     132                 :        114 :         gcc_assert (size >= 0);
     133                 :        114 :         *siz = size;
     134                 :            :       }
     135                 :        114 :       return true;
     136                 :          0 :     default:
     137                 :          0 :       gfc_internal_error ("Invalid expression in gfc_element_size.");
     138                 :            :       *siz = 0;
     139                 :            :       return false;
     140                 :            :     }
     141                 :            :   return true;
     142                 :            : }
     143                 :            : 
     144                 :            : 
     145                 :            : /* Return the size of an expression in its target representation.  */
     146                 :            : 
     147                 :            : bool
     148                 :       3431 : gfc_target_expr_size (gfc_expr *e, size_t *size)
     149                 :            : {
     150                 :       3431 :   mpz_t tmp;
     151                 :       3431 :   size_t asz, el_size;
     152                 :            : 
     153                 :       3431 :   gcc_assert (e != NULL);
     154                 :            : 
     155                 :       3431 :   *size = 0;
     156                 :       3431 :   if (e->rank)
     157                 :            :     {
     158                 :        344 :       if (gfc_array_size (e, &tmp))
     159                 :        344 :         asz = mpz_get_ui (tmp);
     160                 :            :       else
     161                 :            :         return false;
     162                 :            :     }
     163                 :            :   else
     164                 :            :     asz = 1;
     165                 :            : 
     166                 :       3431 :   if (!gfc_element_size (e, &el_size))
     167                 :            :     return false;
     168                 :       3430 :   *size = asz * el_size;
     169                 :       3430 :   return true;
     170                 :            : }
     171                 :            : 
     172                 :            : 
     173                 :            : /* The encode_* functions export a value into a buffer, and
     174                 :            :    return the number of bytes of the buffer that have been
     175                 :            :    used.  */
     176                 :            : 
     177                 :            : static unsigned HOST_WIDE_INT
     178                 :        208 : encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
     179                 :            : {
     180                 :        208 :   mpz_t array_size;
     181                 :        208 :   int i;
     182                 :        208 :   int ptr = 0;
     183                 :            : 
     184                 :        208 :   gfc_constructor_base ctor = expr->value.constructor;
     185                 :            : 
     186                 :        208 :   gfc_array_size (expr, &array_size);
     187                 :        779 :   for (i = 0; i < (int)mpz_get_ui (array_size); i++)
     188                 :            :     {
     189                 :        559 :       ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i),
     190                 :        559 :                                      &buffer[ptr], buffer_size - ptr);
     191                 :            :     }
     192                 :            : 
     193                 :        208 :   mpz_clear (array_size);
     194                 :        208 :   return ptr;
     195                 :            : }
     196                 :            : 
     197                 :            : 
     198                 :            : static int
     199                 :        656 : encode_integer (int kind, mpz_t integer, unsigned char *buffer,
     200                 :            :                 size_t buffer_size)
     201                 :            : {
     202                 :        656 :   return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
     203                 :        251 :                              buffer, buffer_size);
     204                 :            : }
     205                 :            : 
     206                 :            : 
     207                 :            : static int
     208                 :        156 : encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
     209                 :            : {
     210                 :        156 :   return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
     211                 :        156 :                              buffer_size);
     212                 :            : }
     213                 :            : 
     214                 :            : 
     215                 :            : static int
     216                 :         18 : encode_complex (int kind, mpc_t cmplx,
     217                 :            :                 unsigned char *buffer, size_t buffer_size)
     218                 :            : {
     219                 :         18 :   int size;
     220                 :         18 :   size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);
     221                 :         36 :   size += encode_float (kind, mpc_imagref (cmplx),
     222                 :         18 :                         &buffer[size], buffer_size - size);
     223                 :         18 :   return size;
     224                 :            : }
     225                 :            : 
     226                 :            : 
     227                 :            : static int
     228                 :         63 : encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
     229                 :            : {
     230                 :         63 :   return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
     231                 :            :                                             logical),
     232                 :         63 :                              buffer, buffer_size);
     233                 :            : }
     234                 :            : 
     235                 :            : 
     236                 :            : size_t
     237                 :      94197 : gfc_encode_character (int kind, size_t length, const gfc_char_t *string,
     238                 :            :                       unsigned char *buffer, size_t buffer_size)
     239                 :            : {
     240                 :      94197 :   size_t elsize = size_character (1, kind);
     241                 :      94197 :   tree type = gfc_get_char_type (kind);
     242                 :            : 
     243                 :      94197 :   gcc_assert (buffer_size >= size_character (length, kind));
     244                 :            : 
     245                 :    1721080 :   for (size_t i = 0; i < length; i++)
     246                 :    1626880 :     native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
     247                 :            :                         elsize);
     248                 :            : 
     249                 :      94197 :   return length;
     250                 :            : }
     251                 :            : 
     252                 :            : 
     253                 :            : static unsigned HOST_WIDE_INT
     254                 :         14 : encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
     255                 :            : {
     256                 :         14 :   gfc_constructor *c;
     257                 :         14 :   gfc_component *cmp;
     258                 :         14 :   int ptr;
     259                 :         14 :   tree type;
     260                 :         14 :   HOST_WIDE_INT size;
     261                 :            : 
     262                 :         14 :   type = gfc_typenode_for_spec (&source->ts);
     263                 :            : 
     264                 :         14 :   for (c = gfc_constructor_first (source->value.constructor),
     265                 :         14 :        cmp = source->ts.u.derived->components;
     266                 :         34 :        c;
     267                 :         20 :        c = gfc_constructor_next (c), cmp = cmp->next)
     268                 :            :     {
     269                 :         20 :       gcc_assert (cmp);
     270                 :         20 :       if (!c->expr)
     271                 :          0 :         continue;
     272                 :         20 :       ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
     273                 :         20 :             + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
     274                 :            : 
     275                 :         20 :       if (c->expr->expr_type == EXPR_NULL)
     276                 :            :         {
     277                 :          1 :           size = int_size_in_bytes (TREE_TYPE (cmp->backend_decl));
     278                 :          1 :           gcc_assert (size >= 0);
     279                 :          1 :           memset (&buffer[ptr], 0, size);
     280                 :            :         }
     281                 :            :       else
     282                 :         19 :         gfc_target_encode_expr (c->expr, &buffer[ptr],
     283                 :         19 :                                 buffer_size - ptr);
     284                 :            :     }
     285                 :            : 
     286                 :         14 :   size = int_size_in_bytes (type);
     287                 :         14 :   gcc_assert (size >= 0);
     288                 :         14 :   return size;
     289                 :            : }
     290                 :            : 
     291                 :            : 
     292                 :            : /* Write a constant expression in binary form to a buffer.  */
     293                 :            : unsigned HOST_WIDE_INT
     294                 :       1453 : gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
     295                 :            :                         size_t buffer_size)
     296                 :            : {
     297                 :       1453 :   if (source == NULL)
     298                 :            :     return 0;
     299                 :            : 
     300                 :       1453 :   if (source->expr_type == EXPR_ARRAY)
     301                 :        208 :     return encode_array (source, buffer, buffer_size);
     302                 :            : 
     303                 :       1245 :   gcc_assert (source->expr_type == EXPR_CONSTANT
     304                 :            :               || source->expr_type == EXPR_STRUCTURE
     305                 :            :               || source->expr_type == EXPR_SUBSTRING);
     306                 :            : 
     307                 :            :   /* If we already have a target-memory representation, we use that rather
     308                 :            :      than recreating one.  */
     309                 :       1245 :   if (source->representation.string)
     310                 :            :     {
     311                 :        142 :       memcpy (buffer, source->representation.string,
     312                 :        142 :               source->representation.length);
     313                 :        142 :       return source->representation.length;
     314                 :            :     }
     315                 :            : 
     316                 :       1103 :   switch (source->ts.type)
     317                 :            :     {
     318                 :        402 :     case BT_INTEGER:
     319                 :        402 :       return encode_integer (source->ts.kind, source->value.integer, buffer,
     320                 :        402 :                              buffer_size);
     321                 :        120 :     case BT_REAL:
     322                 :        120 :       return encode_float (source->ts.kind, source->value.real, buffer,
     323                 :        120 :                            buffer_size);
     324                 :         18 :     case BT_COMPLEX:
     325                 :         18 :       return encode_complex (source->ts.kind, source->value.complex,
     326                 :         18 :                              buffer, buffer_size);
     327                 :         63 :     case BT_LOGICAL:
     328                 :         63 :       return encode_logical (source->ts.kind, source->value.logical, buffer,
     329                 :         63 :                              buffer_size);
     330                 :        483 :     case BT_CHARACTER:
     331                 :        483 :       if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
     332                 :        453 :         return gfc_encode_character (source->ts.kind,
     333                 :        453 :                                      source->value.character.length,
     334                 :        453 :                                      source->value.character.string,
     335                 :        453 :                                      buffer, buffer_size);
     336                 :            :       else
     337                 :            :         {
     338                 :         30 :           HOST_WIDE_INT start, end;
     339                 :            : 
     340                 :         30 :           gcc_assert (source->expr_type == EXPR_SUBSTRING);
     341                 :         30 :           gfc_extract_hwi (source->ref->u.ss.start, &start);
     342                 :         30 :           gfc_extract_hwi (source->ref->u.ss.end, &end);
     343                 :         30 :           return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
     344                 :         30 :                                        &source->value.character.string[start-1],
     345                 :            :                                        buffer, buffer_size);
     346                 :            :         }
     347                 :            : 
     348                 :         17 :     case BT_DERIVED:
     349                 :         17 :       if (source->ts.u.derived->ts.f90_type == BT_VOID)
     350                 :            :         {
     351                 :          3 :           gfc_constructor *c;
     352                 :          3 :           gcc_assert (source->expr_type == EXPR_STRUCTURE);
     353                 :          3 :           c = gfc_constructor_first (source->value.constructor);
     354                 :          3 :           gcc_assert (c->expr->expr_type == EXPR_CONSTANT
     355                 :            :                       && c->expr->ts.type == BT_INTEGER);
     356                 :          3 :           return encode_integer (gfc_index_integer_kind, c->expr->value.integer,
     357                 :          3 :                                  buffer, buffer_size);
     358                 :            :         }
     359                 :            : 
     360                 :         14 :       return encode_derived (source, buffer, buffer_size);
     361                 :          0 :     default:
     362                 :          0 :       gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
     363                 :            :       return 0;
     364                 :            :     }
     365                 :            : }
     366                 :            : 
     367                 :            : 
     368                 :            : static size_t
     369                 :        157 : interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
     370                 :            : {
     371                 :        157 :   gfc_constructor_base base = NULL;
     372                 :        157 :   size_t array_size = 1;
     373                 :        157 :   size_t ptr = 0;
     374                 :            : 
     375                 :            :   /* Calculate array size from its shape and rank.  */
     376                 :        157 :   gcc_assert (result->rank > 0 && result->shape);
     377                 :            : 
     378                 :        314 :   for (int i = 0; i < result->rank; i++)
     379                 :        176 :     array_size *= mpz_get_ui (result->shape[i]);
     380                 :            : 
     381                 :            :   /* Iterate over array elements, producing constructors.  */
     382                 :        828 :   for (size_t i = 0; i < array_size; i++)
     383                 :            :     {
     384                 :        671 :       gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind,
     385                 :            :                                            &result->where);
     386                 :        671 :       e->ts = result->ts;
     387                 :            : 
     388                 :        671 :       if (e->ts.type == BT_CHARACTER)
     389                 :        163 :         e->value.character.length = result->value.character.length;
     390                 :            : 
     391                 :        671 :       gfc_constructor_append_expr (&base, e, &result->where);
     392                 :            : 
     393                 :        671 :       ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e,
     394                 :            :                                         true);
     395                 :            :     }
     396                 :            : 
     397                 :        157 :   result->value.constructor = base;
     398                 :        157 :   return ptr;
     399                 :            : }
     400                 :            : 
     401                 :            : 
     402                 :            : int
     403                 :       1204 : gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
     404                 :            :                    mpz_t integer)
     405                 :            : {
     406                 :       1204 :   mpz_init (integer);
     407                 :       1204 :   gfc_conv_tree_to_mpz (integer,
     408                 :            :                         native_interpret_expr (gfc_get_int_type (kind),
     409                 :            :                                                buffer, buffer_size));
     410                 :       1204 :   return size_integer (kind);
     411                 :            : }
     412                 :            : 
     413                 :            : 
     414                 :            : int
     415                 :       1935 : gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
     416                 :            :                      mpfr_t real)
     417                 :            : {
     418                 :       1935 :   gfc_set_model_kind (kind);
     419                 :       1935 :   mpfr_init (real);
     420                 :       1935 :   gfc_conv_tree_to_mpfr (real,
     421                 :            :                          native_interpret_expr (gfc_get_real_type (kind),
     422                 :            :                                                 buffer, buffer_size));
     423                 :            : 
     424                 :       1935 :   return size_float (kind);
     425                 :            : }
     426                 :            : 
     427                 :            : 
     428                 :            : int
     429                 :        512 : gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
     430                 :            :                        mpc_t complex)
     431                 :            : {
     432                 :        512 :   int size;
     433                 :       1024 :   size = gfc_interpret_float (kind, &buffer[0], buffer_size,
     434                 :        512 :                               mpc_realref (complex));
     435                 :       1024 :   size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
     436                 :        512 :                                mpc_imagref (complex));
     437                 :        512 :   return size;
     438                 :            : }
     439                 :            : 
     440                 :            : 
     441                 :            : int
     442                 :        441 : gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
     443                 :            :                    int *logical)
     444                 :            : {
     445                 :        441 :   tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
     446                 :            :                                   buffer_size);
     447                 :        441 :   *logical = wi::to_wide (t) == 0 ? 0 : 1;
     448                 :        441 :   return size_logical (kind);
     449                 :            : }
     450                 :            : 
     451                 :            : 
     452                 :            : size_t
     453                 :        342 : gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
     454                 :            :                          gfc_expr *result)
     455                 :            : {
     456                 :        342 :   if (result->ts.u.cl && result->ts.u.cl->length)
     457                 :        254 :     result->value.character.length =
     458                 :        254 :       gfc_mpz_get_hwi (result->ts.u.cl->length->value.integer);
     459                 :            : 
     460                 :        342 :   gcc_assert (buffer_size >= size_character (result->value.character.length,
     461                 :            :                                              result->ts.kind));
     462                 :        684 :   result->value.character.string =
     463                 :        342 :     gfc_get_wide_string (result->value.character.length + 1);
     464                 :            : 
     465                 :        342 :   if (result->ts.kind == gfc_default_character_kind)
     466                 :       1156 :     for (size_t i = 0; i < (size_t) result->value.character.length; i++)
     467                 :        820 :       result->value.character.string[i] = (gfc_char_t) buffer[i];
     468                 :            :   else
     469                 :            :     {
     470                 :          6 :       mpz_t integer;
     471                 :          6 :       size_t bytes = size_character (1, result->ts.kind);
     472                 :          6 :       mpz_init (integer);
     473                 :          6 :       gcc_assert (bytes <= sizeof (unsigned long));
     474                 :            : 
     475                 :         30 :       for (size_t i = 0; i < (size_t) result->value.character.length; i++)
     476                 :            :         {
     477                 :         24 :           gfc_conv_tree_to_mpz (integer,
     478                 :            :             native_interpret_expr (gfc_get_char_type (result->ts.kind),
     479                 :         24 :                                    &buffer[bytes*i], buffer_size-bytes*i));
     480                 :         24 :           result->value.character.string[i]
     481                 :         24 :             = (gfc_char_t) mpz_get_ui (integer);
     482                 :            :         }
     483                 :            : 
     484                 :          6 :       mpz_clear (integer);
     485                 :            :     }
     486                 :            : 
     487                 :        342 :   result->value.character.string[result->value.character.length] = '\0';
     488                 :            : 
     489                 :        342 :   return result->value.character.length;
     490                 :            : }
     491                 :            : 
     492                 :            : 
     493                 :            : int
     494                 :         28 : gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
     495                 :            : {
     496                 :         28 :   gfc_component *cmp;
     497                 :         28 :   int ptr;
     498                 :         28 :   tree type;
     499                 :            : 
     500                 :            :   /* The attributes of the derived type need to be bolted to the floor.  */
     501                 :         28 :   result->expr_type = EXPR_STRUCTURE;
     502                 :            : 
     503                 :         28 :   cmp = result->ts.u.derived->components;
     504                 :            : 
     505                 :         28 :   if (result->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
     506                 :          8 :       && (result->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
     507                 :          1 :           || result->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
     508                 :            :     {
     509                 :          8 :       gfc_constructor *c;
     510                 :          8 :       gfc_expr *e;
     511                 :            :       /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec
     512                 :            :          sets this to BT_INTEGER.  */
     513                 :          8 :       result->ts.type = BT_DERIVED;
     514                 :          8 :       e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where);
     515                 :          8 :       c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
     516                 :          8 :       c->n.component = cmp;
     517                 :          8 :       gfc_target_interpret_expr (buffer, buffer_size, e, true);
     518                 :          8 :       e->ts.is_iso_c = 1;
     519                 :          8 :       return int_size_in_bytes (ptr_type_node);
     520                 :            :     }
     521                 :            : 
     522                 :         20 :   type = gfc_typenode_for_spec (&result->ts);
     523                 :            : 
     524                 :            :   /* Run through the derived type components.  */
     525                 :         67 :   for (;cmp; cmp = cmp->next)
     526                 :            :     {
     527                 :         47 :       gfc_constructor *c;
     528                 :         47 :       gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
     529                 :            :                                            &result->where);
     530                 :         47 :       e->ts = cmp->ts;
     531                 :            : 
     532                 :            :       /* Copy shape, if needed.  */
     533                 :         47 :       if (cmp->as && cmp->as->rank)
     534                 :            :         {
     535                 :         12 :           int n;
     536                 :            : 
     537                 :         12 :           e->expr_type = EXPR_ARRAY;
     538                 :         12 :           e->rank = cmp->as->rank;
     539                 :            : 
     540                 :         12 :           e->shape = gfc_get_shape (e->rank);
     541                 :         24 :           for (n = 0; n < e->rank; n++)
     542                 :            :              {
     543                 :         12 :                mpz_init_set_ui (e->shape[n], 1);
     544                 :         12 :                mpz_add (e->shape[n], e->shape[n],
     545                 :         12 :                         cmp->as->upper[n]->value.integer);
     546                 :         12 :                mpz_sub (e->shape[n], e->shape[n],
     547                 :         12 :                         cmp->as->lower[n]->value.integer);
     548                 :            :              }
     549                 :            :         }
     550                 :            : 
     551                 :         47 :       c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
     552                 :            : 
     553                 :            :       /* The constructor points to the component.  */
     554                 :         47 :       c->n.component = cmp;
     555                 :            : 
     556                 :            :       /* Calculate the offset, which consists of the FIELD_OFFSET in
     557                 :            :          bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized,
     558                 :            :          and additional bits of FIELD_BIT_OFFSET. The code assumes that all
     559                 :            :          sizes of the components are multiples of BITS_PER_UNIT,
     560                 :            :          i.e. there are, e.g., no bit fields.  */
     561                 :            : 
     562                 :         47 :       gcc_assert (cmp->backend_decl);
     563                 :         47 :       ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl));
     564                 :         47 :       gcc_assert (ptr % 8 == 0);
     565                 :         47 :       ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
     566                 :            : 
     567                 :         47 :       gcc_assert (e->ts.type != BT_VOID || cmp->attr.caf_token);
     568                 :         47 :       gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, true);
     569                 :            :     }
     570                 :            : 
     571                 :         20 :   return int_size_in_bytes (type);
     572                 :            : }
     573                 :            : 
     574                 :            : 
     575                 :            : /* Read a binary buffer to a constant expression.  */
     576                 :            : size_t
     577                 :       1410 : gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
     578                 :            :                            gfc_expr *result, bool convert_widechar)
     579                 :            : {
     580                 :       1410 :   if (result->expr_type == EXPR_ARRAY)
     581                 :        157 :     return interpret_array (buffer, buffer_size, result);
     582                 :            : 
     583                 :       1253 :   switch (result->ts.type)
     584                 :            :     {
     585                 :        639 :     case BT_INTEGER:
     586                 :       1278 :       result->representation.length =
     587                 :       1278 :         gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
     588                 :        639 :                                result->value.integer);
     589                 :        639 :       break;
     590                 :            : 
     591                 :        146 :     case BT_REAL:
     592                 :        292 :       result->representation.length =
     593                 :        292 :         gfc_interpret_float (result->ts.kind, buffer, buffer_size,
     594                 :        146 :                              result->value.real);
     595                 :        146 :       break;
     596                 :            : 
     597                 :         37 :     case BT_COMPLEX:
     598                 :         74 :       result->representation.length =
     599                 :         74 :         gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
     600                 :         37 :                                result->value.complex);
     601                 :         37 :       break;
     602                 :            : 
     603                 :         60 :     case BT_LOGICAL:
     604                 :        120 :       result->representation.length =
     605                 :         60 :         gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
     606                 :            :                                &result->value.logical);
     607                 :         60 :       break;
     608                 :            : 
     609                 :        342 :     case BT_CHARACTER:
     610                 :        684 :       result->representation.length =
     611                 :        342 :         gfc_interpret_character (buffer, buffer_size, result);
     612                 :        342 :       break;
     613                 :            : 
     614                 :          0 :     case BT_CLASS:
     615                 :          0 :       result->ts = CLASS_DATA (result)->ts;
     616                 :            :       /* Fall through.  */
     617                 :         28 :     case BT_DERIVED:
     618                 :         56 :       result->representation.length =
     619                 :         28 :         gfc_interpret_derived (buffer, buffer_size, result);
     620                 :         28 :       gcc_assert (result->representation.length >= 0);
     621                 :            :       break;
     622                 :            : 
     623                 :          1 :     case BT_VOID:
     624                 :            :       /* This deals with caf_tokens.  */
     625                 :          2 :       result->representation.length =
     626                 :          2 :         gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
     627                 :          1 :                                result->value.integer);
     628                 :          1 :       break;
     629                 :            : 
     630                 :          0 :     default:
     631                 :          0 :       gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
     632                 :       1253 :       break;
     633                 :            :     }
     634                 :            : 
     635                 :       1253 :   if (result->ts.type == BT_CHARACTER && convert_widechar)
     636                 :        163 :     result->representation.string
     637                 :        163 :       = gfc_widechar_to_char (result->value.character.string,
     638                 :        163 :                               result->value.character.length);
     639                 :            :   else
     640                 :            :     {
     641                 :       2180 :       result->representation.string =
     642                 :       1090 :         XCNEWVEC (char, result->representation.length + 1);
     643                 :       1090 :       memcpy (result->representation.string, buffer,
     644                 :       1090 :               result->representation.length);
     645                 :       1090 :       result->representation.string[result->representation.length] = '\0';
     646                 :            :     }
     647                 :            : 
     648                 :       1253 :   return result->representation.length;
     649                 :            : }
     650                 :            : 
     651                 :            : 
     652                 :            : /* --------------------------------------------------------------- */
     653                 :            : /* Two functions used by trans-common.c to write overlapping
     654                 :            :    equivalence initializers to a buffer.  This is added to the union
     655                 :            :    and the original initializers freed.  */
     656                 :            : 
     657                 :            : 
     658                 :            : /* Writes the values of a constant expression to a char buffer. If another
     659                 :            :    unequal initializer has already been written to the buffer, this is an
     660                 :            :    error.  */
     661                 :            : 
     662                 :            : static size_t
     663                 :        206 : expr_to_char (gfc_expr *e, locus *loc,
     664                 :            :               unsigned char *data, unsigned char *chk, size_t len)
     665                 :            : {
     666                 :        206 :   int i;
     667                 :        206 :   int ptr;
     668                 :        206 :   gfc_constructor *c;
     669                 :        206 :   gfc_component *cmp;
     670                 :        206 :   unsigned char *buffer;
     671                 :            : 
     672                 :        206 :   if (e == NULL)
     673                 :            :     return 0;
     674                 :            : 
     675                 :            :   /* Take a derived type, one component at a time, using the offsets from the backend
     676                 :            :      declaration.  */
     677                 :        206 :   if (e->ts.type == BT_DERIVED)
     678                 :            :     {
     679                 :         15 :       for (c = gfc_constructor_first (e->value.constructor),
     680                 :         15 :            cmp = e->ts.u.derived->components;
     681                 :         54 :            c; c = gfc_constructor_next (c), cmp = cmp->next)
     682                 :            :         {
     683                 :         39 :           gcc_assert (cmp && cmp->backend_decl);
     684                 :         39 :           if (!c->expr)
     685                 :         12 :             continue;
     686                 :         27 :           ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
     687                 :         27 :             + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
     688                 :         27 :           expr_to_char (c->expr, loc, &data[ptr], &chk[ptr], len);
     689                 :            :         }
     690                 :         15 :       return len;
     691                 :            :     }
     692                 :            : 
     693                 :            :   /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
     694                 :            :      to the target, in a buffer and check off the initialized part of the buffer.  */
     695                 :        191 :   gfc_target_expr_size (e, &len);
     696                 :        191 :   buffer = (unsigned char*)alloca (len);
     697                 :        191 :   len = gfc_target_encode_expr (e, buffer, len);
     698                 :            : 
     699                 :       1009 :   for (i = 0; i < (int)len; i++)
     700                 :            :     {
     701                 :        821 :       if (chk[i] && (buffer[i] != data[i]))
     702                 :            :         {
     703                 :          3 :           if (loc)
     704                 :          3 :             gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
     705                 :            :                         "at %L", loc);
     706                 :            :           else
     707                 :          0 :             gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
     708                 :            :                         "at %C");
     709                 :          3 :           return 0;
     710                 :            :         }
     711                 :        818 :       chk[i] = 0xFF;
     712                 :            :     }
     713                 :            : 
     714                 :        188 :   memcpy (data, buffer, len);
     715                 :        188 :   return len;
     716                 :            : }
     717                 :            : 
     718                 :            : 
     719                 :            : /* Writes the values from the equivalence initializers to a char* array
     720                 :            :    that will be written to the constructor to make the initializer for
     721                 :            :    the union declaration.  */
     722                 :            : 
     723                 :            : size_t
     724                 :        239 : gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, locus *loc,
     725                 :            :                         unsigned char *data,
     726                 :            :                         unsigned char *chk, size_t length)
     727                 :            : {
     728                 :        239 :   size_t len = 0;
     729                 :        239 :   gfc_constructor * c;
     730                 :            : 
     731                 :        239 :   switch (e->expr_type)
     732                 :            :     {
     733                 :        179 :     case EXPR_CONSTANT:
     734                 :        179 :     case EXPR_STRUCTURE:
     735                 :        179 :       len = expr_to_char (e, loc, &data[0], &chk[0], length);
     736                 :        179 :       break;
     737                 :            : 
     738                 :         60 :     case EXPR_ARRAY:
     739                 :         60 :       for (c = gfc_constructor_first (e->value.constructor);
     740                 :        203 :            c; c = gfc_constructor_next (c))
     741                 :            :         {
     742                 :        143 :           size_t elt_size;
     743                 :            : 
     744                 :        143 :           gfc_target_expr_size (c->expr, &elt_size);
     745                 :            : 
     746                 :        143 :           if (mpz_cmp_si (c->offset, 0) != 0)
     747                 :         83 :             len = elt_size * (size_t)mpz_get_si (c->offset);
     748                 :            : 
     749                 :        143 :           len = len + gfc_merge_initializers (ts, c->expr, loc, &data[len],
     750                 :            :                                               &chk[len], length - len);
     751                 :            :         }
     752                 :            :       break;
     753                 :            : 
     754                 :            :     default:
     755                 :            :       return 0;
     756                 :            :     }
     757                 :            : 
     758                 :            :   return len;
     759                 :            : }
     760                 :            : 
     761                 :            : 
     762                 :            : /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
     763                 :            :    When successful, no BOZ or nothing to do, true is returned.  */
     764                 :            : 
     765                 :            : bool
     766                 :        251 : gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
     767                 :            : {
     768                 :        251 :   size_t buffer_size, boz_bit_size, ts_bit_size;
     769                 :        251 :   int index;
     770                 :        251 :   unsigned char *buffer;
     771                 :            : 
     772                 :        251 :   if (expr->ts.type != BT_INTEGER)
     773                 :            :     return true;
     774                 :            : 
     775                 :            :   /* Don't convert BOZ to logical, character, derived etc.  */
     776                 :        251 :   gcc_assert (ts->type == BT_REAL);
     777                 :            : 
     778                 :        251 :   buffer_size = size_float (ts->kind);
     779                 :        251 :   ts_bit_size = buffer_size * 8;
     780                 :            : 
     781                 :            :   /* Convert BOZ to the smallest possible integer kind.  */
     782                 :        251 :   boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
     783                 :            : 
     784                 :        251 :   gcc_assert (boz_bit_size <= ts_bit_size);
     785                 :            : 
     786                 :        871 :   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
     787                 :        871 :     if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
     788                 :            :       break;
     789                 :            : 
     790                 :        251 :   expr->ts.kind = gfc_integer_kinds[index].kind;
     791                 :        251 :   buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
     792                 :            : 
     793                 :        251 :   buffer = (unsigned char*)alloca (buffer_size);
     794                 :        251 :   encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
     795                 :        251 :   mpz_clear (expr->value.integer);
     796                 :            : 
     797                 :        251 :   mpfr_init (expr->value.real);
     798                 :        251 :   gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
     799                 :            : 
     800                 :        251 :   expr->ts.type = ts->type;
     801                 :        251 :   expr->ts.kind = ts->kind;
     802                 :            : 
     803                 :        251 :   return true;
     804                 :            : }

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.