LCOV - code coverage report
Current view: top level - gcc/fortran - data.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 90.5 % 441 399
Test Date: 2024-07-20 14:00:39 Functions: 100.0 % 9 9
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* Supporting functions for resolving DATA statement.
       2                 :             :    Copyright (C) 2002-2024 Free Software Foundation, Inc.
       3                 :             :    Contributed by Lifang Zeng <zlf605@hotmail.com>
       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                 :             : 
      22                 :             : /* Notes for DATA statement implementation:
      23                 :             : 
      24                 :             :    We first assign initial value to each symbol by gfc_assign_data_value
      25                 :             :    during resolving DATA statement. Refer to check_data_variable and
      26                 :             :    traverse_data_list in resolve.cc.
      27                 :             : 
      28                 :             :    The complexity exists in the handling of array section, implied do
      29                 :             :    and array of struct appeared in DATA statement.
      30                 :             : 
      31                 :             :    We call gfc_conv_structure, gfc_con_array_array_initializer,
      32                 :             :    etc., to convert the initial value. Refer to trans-expr.cc and
      33                 :             :    trans-array.cc.  */
      34                 :             : 
      35                 :             : #include "config.h"
      36                 :             : #include "system.h"
      37                 :             : #include "coretypes.h"
      38                 :             : #include "gfortran.h"
      39                 :             : #include "data.h"
      40                 :             : #include "constructor.h"
      41                 :             : 
      42                 :             : static void formalize_init_expr (gfc_expr *);
      43                 :             : 
      44                 :             : /* Calculate the array element offset.  */
      45                 :             : 
      46                 :             : static bool
      47                 :        1436 : get_array_index (gfc_array_ref *ar, mpz_t *offset)
      48                 :             : {
      49                 :        1436 :   gfc_expr *e;
      50                 :        1436 :   int i;
      51                 :        1436 :   mpz_t delta;
      52                 :        1436 :   mpz_t tmp;
      53                 :        1436 :   bool ok = true;
      54                 :             : 
      55                 :        1436 :   mpz_init (tmp);
      56                 :        1436 :   mpz_set_si (*offset, 0);
      57                 :        1436 :   mpz_init_set_si (delta, 1);
      58                 :        5055 :   for (i = 0; i < ar->dimen; i++)
      59                 :             :     {
      60                 :        2188 :       e = gfc_copy_expr (ar->start[i]);
      61                 :        2188 :       gfc_simplify_expr (e, 1);
      62                 :             : 
      63                 :        2188 :       if (!gfc_is_constant_expr (ar->as->lower[i])
      64                 :        2188 :           || !gfc_is_constant_expr (ar->as->upper[i])
      65                 :        4375 :           || !gfc_is_constant_expr (e))
      66                 :             :         {
      67                 :           1 :           gfc_error ("non-constant array in DATA statement %L", &ar->where);
      68                 :           1 :           ok = false;
      69                 :           1 :           break;
      70                 :             :         }
      71                 :             : 
      72                 :        2187 :       mpz_set (tmp, e->value.integer);
      73                 :        2187 :       gfc_free_expr (e);
      74                 :             : 
      75                 :             :       /* Overindexing is only allowed as a legacy extension.  */
      76                 :        2187 :       if (mpz_cmp (tmp, ar->as->lower[i]->value.integer) < 0
      77                 :        2187 :           && !gfc_notify_std (GFC_STD_LEGACY,
      78                 :             :                               "Subscript at %L below array lower bound "
      79                 :             :                               "(%ld < %ld) in dimension %d", &ar->c_where[i],
      80                 :             :                               mpz_get_si (tmp),
      81                 :             :                               mpz_get_si (ar->as->lower[i]->value.integer),
      82                 :             :                               i+1))
      83                 :             :         {
      84                 :             :           ok = false;
      85                 :             :           break;
      86                 :             :         }
      87                 :        2185 :       if (mpz_cmp (tmp, ar->as->upper[i]->value.integer) > 0
      88                 :        2185 :           && !gfc_notify_std (GFC_STD_LEGACY,
      89                 :             :                               "Subscript at %L above array upper bound "
      90                 :             :                               "(%ld > %ld) in dimension %d", &ar->c_where[i],
      91                 :             :                               mpz_get_si (tmp),
      92                 :             :                               mpz_get_si (ar->as->upper[i]->value.integer),
      93                 :             :                               i+1))
      94                 :             :         {
      95                 :             :           ok = false;
      96                 :             :           break;
      97                 :             :         }
      98                 :             : 
      99                 :        2183 :       mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
     100                 :        2183 :       mpz_mul (tmp, tmp, delta);
     101                 :        2183 :       mpz_add (*offset, tmp, *offset);
     102                 :             : 
     103                 :        2183 :       mpz_sub (tmp, ar->as->upper[i]->value.integer,
     104                 :        2183 :                ar->as->lower[i]->value.integer);
     105                 :        2183 :       mpz_add_ui (tmp, tmp, 1);
     106                 :        2183 :       mpz_mul (delta, tmp, delta);
     107                 :             :     }
     108                 :        1436 :   mpz_clear (delta);
     109                 :        1436 :   mpz_clear (tmp);
     110                 :             : 
     111                 :        1436 :   return ok;
     112                 :             : }
     113                 :             : 
     114                 :             : /* Find if there is a constructor which component is equal to COM.
     115                 :             :    TODO: remove this, use symbol.cc(gfc_find_component) instead.  */
     116                 :             : 
     117                 :             : static gfc_constructor *
     118                 :         844 : find_con_by_component (gfc_component *com, gfc_constructor_base base)
     119                 :             : {
     120                 :         844 :   gfc_constructor *c;
     121                 :             : 
     122                 :        1996 :   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
     123                 :        1814 :     if (com == c->n.component)
     124                 :         662 :       return c;
     125                 :             : 
     126                 :             :   return NULL;
     127                 :             : }
     128                 :             : 
     129                 :             : 
     130                 :             : /* Create a character type initialization expression from RVALUE.
     131                 :             :    TS [and REF] describe [the substring of] the variable being initialized.
     132                 :             :    INIT is the existing initializer, not NULL.  Initialization is performed
     133                 :             :    according to normal assignment rules.  */
     134                 :             : 
     135                 :             : static gfc_expr *
     136                 :         720 : create_character_initializer (gfc_expr *init, gfc_typespec *ts,
     137                 :             :                               gfc_ref *ref, gfc_expr *rvalue)
     138                 :             : {
     139                 :         720 :   HOST_WIDE_INT len, start, end, tlen;
     140                 :         720 :   gfc_char_t *dest;
     141                 :         720 :   bool alloced_init = false;
     142                 :             : 
     143                 :         720 :   if (init && init->ts.type != BT_CHARACTER)
     144                 :             :     return NULL;
     145                 :             : 
     146                 :         719 :   gfc_extract_hwi (ts->u.cl->length, &len);
     147                 :             : 
     148                 :         719 :   if (init == NULL)
     149                 :             :     {
     150                 :             :       /* Create a new initializer.  */
     151                 :         673 :       init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
     152                 :         673 :       init->ts = *ts;
     153                 :         673 :       alloced_init = true;
     154                 :             :     }
     155                 :             : 
     156                 :         719 :   dest = init->value.character.string;
     157                 :             : 
     158                 :         719 :   if (ref)
     159                 :             :     {
     160                 :          98 :       gfc_expr *start_expr, *end_expr;
     161                 :             : 
     162                 :          98 :       gcc_assert (ref->type == REF_SUBSTRING);
     163                 :             : 
     164                 :             :       /* Only set a substring of the destination.  Fortran substring bounds
     165                 :             :          are one-based [start, end], we want zero based [start, end).  */
     166                 :          98 :       start_expr = gfc_copy_expr (ref->u.ss.start);
     167                 :          98 :       end_expr = gfc_copy_expr (ref->u.ss.end);
     168                 :             : 
     169                 :          98 :       if ((!gfc_simplify_expr(start_expr, 1))
     170                 :          98 :           || !(gfc_simplify_expr(end_expr, 1)))
     171                 :             :         {
     172                 :           0 :           gfc_error ("failure to simplify substring reference in DATA "
     173                 :           0 :                      "statement at %L", &ref->u.ss.start->where);
     174                 :           0 :           gfc_free_expr (start_expr);
     175                 :           0 :           gfc_free_expr (end_expr);
     176                 :           0 :           if (alloced_init)
     177                 :           0 :             gfc_free_expr (init);
     178                 :           0 :           return NULL;
     179                 :             :         }
     180                 :             : 
     181                 :          98 :       gfc_extract_hwi (start_expr, &start);
     182                 :          98 :       gfc_free_expr (start_expr);
     183                 :          98 :       start--;
     184                 :          98 :       gfc_extract_hwi (end_expr, &end);
     185                 :          98 :       gfc_free_expr (end_expr);
     186                 :             :     }
     187                 :             :   else
     188                 :             :     {
     189                 :             :       /* Set the whole string.  */
     190                 :         621 :       start = 0;
     191                 :         621 :       end = len;
     192                 :             :     }
     193                 :             : 
     194                 :             :   /* Copy the initial value.  */
     195                 :         719 :   if (rvalue->ts.type == BT_HOLLERITH)
     196                 :          42 :     len = rvalue->representation.length - rvalue->ts.u.pad;
     197                 :             :   else
     198                 :         677 :     len = rvalue->value.character.length;
     199                 :             : 
     200                 :         719 :   tlen = end - start;
     201                 :         719 :   if (len > tlen)
     202                 :             :     {
     203                 :          44 :       if (tlen < 0)
     204                 :             :         {
     205                 :           3 :           gfc_warning_now (0, "Unused initialization string at %L because "
     206                 :             :                            "variable has zero length", &rvalue->where);
     207                 :           3 :           len = 0;
     208                 :             :         }
     209                 :             :       else
     210                 :             :         {
     211                 :          41 :           gfc_warning_now (0, "Initialization string at %L was truncated to "
     212                 :             :                            "fit the variable (%wd/%wd)", &rvalue->where,
     213                 :             :                            tlen, len);
     214                 :          41 :           len = tlen;
     215                 :             :         }
     216                 :             :     }
     217                 :             : 
     218                 :         719 :   if (start < 0)
     219                 :             :     {
     220                 :           1 :       gfc_error ("Substring start index at %L is less than one",
     221                 :           1 :                  &ref->u.ss.start->where);
     222                 :           1 :       return NULL;
     223                 :             :     }
     224                 :         718 :   if (end > init->value.character.length)
     225                 :             :     {
     226                 :           1 :       gfc_error ("Substring end index at %L exceeds the string length",
     227                 :           1 :                  &ref->u.ss.end->where);
     228                 :           1 :       return NULL;
     229                 :             :     }
     230                 :             : 
     231                 :         717 :   if (rvalue->ts.type == BT_HOLLERITH)
     232                 :             :     {
     233                 :         126 :       for (size_t i = 0; i < (size_t) len; i++)
     234                 :          84 :         dest[start+i] = rvalue->representation.string[i];
     235                 :             :     }
     236                 :             :   else
     237                 :         675 :     memcpy (&dest[start], rvalue->value.character.string,
     238                 :         675 :             len * sizeof (gfc_char_t));
     239                 :             : 
     240                 :             :   /* Pad with spaces.  Substrings will already be blanked.  */
     241                 :         717 :   if (len < tlen && ref == NULL)
     242                 :         206 :     gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
     243                 :             : 
     244                 :         717 :   if (rvalue->ts.type == BT_HOLLERITH)
     245                 :             :     {
     246                 :          42 :       init->representation.length = init->value.character.length;
     247                 :          42 :       init->representation.string
     248                 :          42 :         = gfc_widechar_to_char (init->value.character.string,
     249                 :             :                                 init->value.character.length);
     250                 :             :     }
     251                 :             : 
     252                 :             :   return init;
     253                 :             : }
     254                 :             : 
     255                 :             : 
     256                 :             : /* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
     257                 :             :    LVALUE already has an initialization, we extend this, otherwise we
     258                 :             :    create a new one.  If REPEAT is non-NULL, initialize *REPEAT
     259                 :             :    consecutive values in LVALUE the same value in RVALUE.  In that case,
     260                 :             :    LVALUE must refer to a full array, not an array section.  */
     261                 :             : 
     262                 :             : bool
     263                 :        9051 : gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
     264                 :             :                        mpz_t *repeat)
     265                 :             : {
     266                 :        9051 :   gfc_ref *ref;
     267                 :        9051 :   gfc_expr *init;
     268                 :        9051 :   gfc_expr *expr = NULL;
     269                 :        9051 :   gfc_expr *rexpr;
     270                 :        9051 :   gfc_constructor *con;
     271                 :        9051 :   gfc_constructor *last_con;
     272                 :        9051 :   gfc_symbol *symbol;
     273                 :        9051 :   gfc_typespec *last_ts;
     274                 :        9051 :   mpz_t offset;
     275                 :        9051 :   const char *msg = "F18(R841): data-implied-do object at %L is neither an "
     276                 :             :                     "array-element nor a scalar-structure-component";
     277                 :             : 
     278                 :        9051 :   symbol = lvalue->symtree->n.sym;
     279                 :        9051 :   init = symbol->value;
     280                 :        9051 :   last_ts = &symbol->ts;
     281                 :        9051 :   last_con = NULL;
     282                 :        9051 :   mpz_init_set_si (offset, 0);
     283                 :             : 
     284                 :             :   /* Find/create the parent expressions for subobject references.  */
     285                 :       17345 :   for (ref = lvalue->ref; ref; ref = ref->next)
     286                 :             :     {
     287                 :             :       /* Break out of the loop if we find a substring.  */
     288                 :        8426 :       if (ref->type == REF_SUBSTRING)
     289                 :             :         {
     290                 :             :           /* A substring should always be the last subobject reference.  */
     291                 :          98 :           gcc_assert (ref->next == NULL);
     292                 :             :           break;
     293                 :             :         }
     294                 :             : 
     295                 :             :       /* Use the existing initializer expression if it exists.  Otherwise
     296                 :             :          create a new one.  */
     297                 :        8328 :       if (init == NULL)
     298                 :        1221 :         expr = gfc_get_expr ();
     299                 :             :       else
     300                 :             :         expr = init;
     301                 :             : 
     302                 :             :       /* Find or create this element.  */
     303                 :        8328 :       switch (ref->type)
     304                 :             :         {
     305                 :        7817 :         case REF_ARRAY:
     306                 :        7817 :           if (ref->u.ar.as->rank == 0)
     307                 :             :             {
     308                 :           2 :               gcc_assert (ref->u.ar.as->corank > 0);
     309                 :           2 :               if (init == NULL)
     310                 :           2 :                 free (expr);
     311                 :           2 :               continue;
     312                 :             :             }
     313                 :             : 
     314                 :        7815 :           if (init && expr->expr_type != EXPR_ARRAY)
     315                 :             :             {
     316                 :           7 :               gfc_error ("%qs at %L already is initialized at %L",
     317                 :           7 :                          lvalue->symtree->n.sym->name, &lvalue->where,
     318                 :             :                          &init->where);
     319                 :           7 :               goto abort;
     320                 :             :             }
     321                 :             : 
     322                 :             :           if (init == NULL)
     323                 :             :             {
     324                 :             :               /* The element typespec will be the same as the array
     325                 :             :                  typespec.  */
     326                 :        1062 :               expr->ts = *last_ts;
     327                 :             :               /* Setup the expression to hold the constructor.  */
     328                 :        1062 :               expr->expr_type = EXPR_ARRAY;
     329                 :        1062 :               expr->rank = ref->u.ar.as->rank;
     330                 :             :             }
     331                 :             : 
     332                 :        7808 :           if (ref->u.ar.type == AR_ELEMENT)
     333                 :             :             {
     334                 :        1436 :               if (!get_array_index (&ref->u.ar, &offset))
     335                 :           5 :                 goto abort;
     336                 :             :             }
     337                 :             :           else
     338                 :        6372 :             mpz_set (offset, index);
     339                 :             : 
     340                 :             :           /* Check the bounds.  */
     341                 :        7803 :           if (mpz_cmp_si (offset, 0) < 0)
     342                 :             :             {
     343                 :           2 :               gfc_error ("Data element below array lower bound at %L",
     344                 :             :                          &lvalue->where);
     345                 :           2 :               goto abort;
     346                 :             :             }
     347                 :        7801 :           else if (repeat != NULL
     348                 :         196 :                    && ref->u.ar.type != AR_ELEMENT)
     349                 :             :             {
     350                 :         160 :               mpz_t size, end;
     351                 :         160 :               gcc_assert (ref->u.ar.type == AR_FULL
     352                 :             :                           && ref->next == NULL);
     353                 :         160 :               mpz_init_set (end, offset);
     354                 :         160 :               mpz_add (end, end, *repeat);
     355                 :         160 :               if (spec_size (ref->u.ar.as, &size))
     356                 :             :                 {
     357                 :         160 :                   if (mpz_cmp (end, size) > 0)
     358                 :             :                     {
     359                 :           0 :                       mpz_clear (size);
     360                 :           0 :                       gfc_error ("Data element above array upper bound at %L",
     361                 :             :                                  &lvalue->where);
     362                 :           0 :                       goto abort;
     363                 :             :                     }
     364                 :         160 :                   mpz_clear (size);
     365                 :             :                 }
     366                 :             : 
     367                 :         320 :               con = gfc_constructor_lookup (expr->value.constructor,
     368                 :         160 :                                             mpz_get_si (offset));
     369                 :         160 :               if (!con)
     370                 :             :                 {
     371                 :         312 :                   con = gfc_constructor_lookup_next (expr->value.constructor,
     372                 :         156 :                                                      mpz_get_si (offset));
     373                 :         156 :                   if (con != NULL && mpz_cmp (con->offset, end) >= 0)
     374                 :             :                     con = NULL;
     375                 :             :                 }
     376                 :             : 
     377                 :             :               /* Overwriting an existing initializer is non-standard but
     378                 :             :                  usually only provokes a warning from other compilers.  */
     379                 :           8 :               if (con != NULL && con->expr != NULL)
     380                 :             :                 {
     381                 :             :                   /* Order in which the expressions arrive here depends on
     382                 :             :                      whether they are from data statements or F95 style
     383                 :             :                      declarations.  Therefore, check which is the most
     384                 :             :                      recent.  */
     385                 :           8 :                   gfc_expr *exprd;
     386                 :           8 :                   exprd = (LOCATION_LINE (con->expr->where.lb->location)
     387                 :           8 :                            > LOCATION_LINE (rvalue->where.lb->location))
     388                 :           8 :                           ? con->expr : rvalue;
     389                 :           8 :                   if (gfc_notify_std (GFC_STD_GNU,
     390                 :             :                                       "re-initialization of %qs at %L",
     391                 :             :                                       symbol->name, &exprd->where) == false)
     392                 :           6 :                     return false;
     393                 :             :                 }
     394                 :             : 
     395                 :         164 :               while (con != NULL)
     396                 :             :                 {
     397                 :          10 :                   gfc_constructor *next_con = gfc_constructor_next (con);
     398                 :             : 
     399                 :          10 :                   if (mpz_cmp (con->offset, end) >= 0)
     400                 :             :                     break;
     401                 :          10 :                   if (mpz_cmp (con->offset, offset) < 0)
     402                 :             :                     {
     403                 :           0 :                       gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
     404                 :           0 :                       mpz_sub (con->repeat, offset, con->offset);
     405                 :             :                     }
     406                 :          10 :                   else if (mpz_cmp_si (con->repeat, 1) > 0
     407                 :           0 :                            && mpz_get_si (con->offset)
     408                 :           0 :                               + mpz_get_si (con->repeat) > mpz_get_si (end))
     409                 :             :                     {
     410                 :           0 :                       int endi;
     411                 :           0 :                       splay_tree_node node
     412                 :           0 :                         = splay_tree_lookup (con->base,
     413                 :             :                                              mpz_get_si (con->offset));
     414                 :           0 :                       gcc_assert (node
     415                 :             :                                   && con == (gfc_constructor *) node->value
     416                 :             :                                   && node->key == (splay_tree_key)
     417                 :             :                                                   mpz_get_si (con->offset));
     418                 :           0 :                       endi = mpz_get_si (con->offset)
     419                 :           0 :                              + mpz_get_si (con->repeat);
     420                 :           0 :                       if (endi > mpz_get_si (end) + 1)
     421                 :           0 :                         mpz_set_si (con->repeat, endi - mpz_get_si (end));
     422                 :             :                       else
     423                 :           0 :                         mpz_set_si (con->repeat, 1);
     424                 :           0 :                       mpz_set (con->offset, end);
     425                 :           0 :                       node->key = (splay_tree_key) mpz_get_si (end);
     426                 :           0 :                       break;
     427                 :             :                     }
     428                 :             :                   else
     429                 :          10 :                     gfc_constructor_remove (con);
     430                 :             :                   con = next_con;
     431                 :             :                 }
     432                 :             : 
     433                 :         308 :               con = gfc_constructor_insert_expr (&expr->value.constructor,
     434                 :             :                                                  NULL, &rvalue->where,
     435                 :         154 :                                                  mpz_get_si (offset));
     436                 :         154 :               mpz_set (con->repeat, *repeat);
     437                 :         154 :               repeat = NULL;
     438                 :         154 :               mpz_clear (end);
     439                 :         154 :               break;
     440                 :             :             }
     441                 :             :           else
     442                 :             :             {
     443                 :        7641 :               mpz_t size;
     444                 :        7641 :               if (spec_size (ref->u.ar.as, &size))
     445                 :             :                 {
     446                 :        7639 :                   if (mpz_cmp (offset, size) >= 0)
     447                 :             :                     {
     448                 :           2 :                       mpz_clear (size);
     449                 :           2 :                       gfc_error ("Data element above array upper bound at %L",
     450                 :             :                                  &lvalue->where);
     451                 :           2 :                       goto abort;
     452                 :             :                     }
     453                 :        7637 :                   mpz_clear (size);
     454                 :             :                 }
     455                 :             :             }
     456                 :             : 
     457                 :       15278 :           con = gfc_constructor_lookup (expr->value.constructor,
     458                 :        7639 :                                         mpz_get_si (offset));
     459                 :        7639 :           if (!con)
     460                 :             :             {
     461                 :        7245 :               con = gfc_constructor_insert_expr (&expr->value.constructor,
     462                 :             :                                                  NULL, &rvalue->where,
     463                 :        7245 :                                                  mpz_get_si (offset));
     464                 :             :             }
     465                 :         394 :           else if (mpz_cmp_si (con->repeat, 1) > 0)
     466                 :             :             {
     467                 :             :               /* Need to split a range.  */
     468                 :          14 :               if (mpz_cmp (con->offset, offset) < 0)
     469                 :             :                 {
     470                 :           9 :                   gfc_constructor *pred_con = con;
     471                 :          18 :                   con = gfc_constructor_insert_expr (&expr->value.constructor,
     472                 :             :                                                      NULL, &con->where,
     473                 :           9 :                                                      mpz_get_si (offset));
     474                 :           9 :                   con->expr = gfc_copy_expr (pred_con->expr);
     475                 :           9 :                   mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
     476                 :           9 :                   mpz_sub (con->repeat, con->repeat, offset);
     477                 :           9 :                   mpz_sub (pred_con->repeat, offset, pred_con->offset);
     478                 :             :                 }
     479                 :          14 :               if (mpz_cmp_si (con->repeat, 1) > 0)
     480                 :             :                 {
     481                 :          13 :                   gfc_constructor *succ_con;
     482                 :          13 :                   succ_con
     483                 :          26 :                     = gfc_constructor_insert_expr (&expr->value.constructor,
     484                 :             :                                                    NULL, &con->where,
     485                 :          13 :                                                    mpz_get_si (offset) + 1);
     486                 :          13 :                   succ_con->expr = gfc_copy_expr (con->expr);
     487                 :          13 :                   mpz_sub_ui (succ_con->repeat, con->repeat, 1);
     488                 :          13 :                   mpz_set_si (con->repeat, 1);
     489                 :             :                 }
     490                 :             :             }
     491                 :             :           break;
     492                 :             : 
     493                 :         499 :         case REF_COMPONENT:
     494                 :         499 :           if (init == NULL)
     495                 :             :             {
     496                 :             :               /* Setup the expression to hold the constructor.  */
     497                 :         151 :               expr->expr_type = EXPR_STRUCTURE;
     498                 :         151 :               expr->ts.type = BT_DERIVED;
     499                 :         151 :               expr->ts.u.derived = ref->u.c.sym;
     500                 :             :             }
     501                 :             :           else
     502                 :         348 :             gcc_assert (expr->expr_type == EXPR_STRUCTURE);
     503                 :         499 :           last_ts = &ref->u.c.component->ts;
     504                 :             : 
     505                 :             :           /* Find the same element in the existing constructor.  */
     506                 :         499 :           con = find_con_by_component (ref->u.c.component,
     507                 :             :                                        expr->value.constructor);
     508                 :             : 
     509                 :         499 :           if (con == NULL)
     510                 :             :             {
     511                 :             :               /* Create a new constructor.  */
     512                 :         172 :               con = gfc_constructor_append_expr (&expr->value.constructor,
     513                 :             :                                                  NULL, NULL);
     514                 :         172 :               con->n.component = ref->u.c.component;
     515                 :             :             }
     516                 :             :           break;
     517                 :             : 
     518                 :          12 :         case REF_INQUIRY:
     519                 :             : 
     520                 :             :           /* After some discussion on clf it was determined that the following
     521                 :             :              violates F18(R841). If the error is removed, the expected result
     522                 :             :              is obtained. Leaving the code in place ensures a clean error
     523                 :             :              recovery.  */
     524                 :          12 :           gfc_error (msg, &lvalue->where);
     525                 :             : 
     526                 :             :           /* This breaks with the other reference types in that the output
     527                 :             :              constructor has to be of type COMPLEX, whereas the lvalue is
     528                 :             :              of type REAL.  The rvalue is copied to the real or imaginary
     529                 :             :              part as appropriate.  In addition, for all except scalar
     530                 :             :              complex variables, a complex expression has to provided, where
     531                 :             :              the constructor does not have it, and the expression modified
     532                 :             :              with a new value for the real or imaginary part.  */
     533                 :          12 :           gcc_assert (ref->next == NULL && last_ts->type == BT_COMPLEX);
     534                 :          12 :           rexpr = gfc_copy_expr (rvalue);
     535                 :          12 :           if (!gfc_compare_types (&lvalue->ts, &rexpr->ts))
     536                 :           0 :             gfc_convert_type (rexpr, &lvalue->ts, 0);
     537                 :             : 
     538                 :             :           /* This is the scalar, complex case, where an initializer exists.  */
     539                 :          12 :           if (init && ref == lvalue->ref)
     540                 :           1 :             expr = symbol->value;
     541                 :             :           /* Then all cases, where a complex expression does not exist.  */
     542                 :          11 :           else if (!last_con || !last_con->expr)
     543                 :             :             {
     544                 :           6 :               expr = gfc_get_constant_expr (BT_COMPLEX, lvalue->ts.kind,
     545                 :             :                                             &lvalue->where);
     546                 :           6 :               if (last_con)
     547                 :           5 :                 last_con->expr = expr;
     548                 :             :             }
     549                 :             :           else
     550                 :             :             /* Finally, and existing constructor expression to be modified.  */
     551                 :             :             expr = last_con->expr;
     552                 :             : 
     553                 :             :           /* Rejection of LEN and KIND inquiry references is handled
     554                 :             :              elsewhere. The error here is added as backup. The assertion
     555                 :             :              of F2008 for RE and IM is also done elsewhere.  */
     556                 :          12 :           switch (ref->u.i)
     557                 :             :             {
     558                 :           0 :             case INQUIRY_LEN:
     559                 :           0 :             case INQUIRY_KIND:
     560                 :           0 :               gfc_error ("LEN or KIND inquiry ref in DATA statement at %L",
     561                 :             :                          &lvalue->where);
     562                 :           0 :               goto abort;
     563                 :           6 :             case INQUIRY_RE:
     564                 :           6 :               mpfr_set (mpc_realref (expr->value.complex),
     565                 :             :                         rexpr->value.real,
     566                 :             :                         GFC_RND_MODE);
     567                 :           6 :               break;
     568                 :           6 :             case INQUIRY_IM:
     569                 :           6 :               mpfr_set (mpc_imagref (expr->value.complex),
     570                 :             :                         rexpr->value.real,
     571                 :             :                         GFC_RND_MODE);
     572                 :           6 :               break;
     573                 :             :             }
     574                 :             : 
     575                 :             :           /* Only the scalar, complex expression needs to be saved as the
     576                 :             :              symbol value since the last constructor expression is already
     577                 :             :              provided as the initializer in the code after the reference
     578                 :             :              cases.  */
     579                 :          12 :           if (ref == lvalue->ref)
     580                 :           2 :             symbol->value = expr;
     581                 :             : 
     582                 :          12 :           gfc_free_expr (rexpr);
     583                 :          12 :           mpz_clear (offset);
     584                 :          12 :           return true;
     585                 :             : 
     586                 :           0 :         default:
     587                 :           0 :           gcc_unreachable ();
     588                 :             :         }
     589                 :             : 
     590                 :        8292 :       if (init == NULL)
     591                 :             :         {
     592                 :             :           /* Point the container at the new expression.  */
     593                 :        1210 :           if (last_con == NULL)
     594                 :        1007 :             symbol->value = expr;
     595                 :             :           else
     596                 :         203 :             last_con->expr = expr;
     597                 :             :         }
     598                 :        8292 :       init = con->expr;
     599                 :        8292 :       last_con = con;
     600                 :             :     }
     601                 :             : 
     602                 :        9017 :   mpz_clear (offset);
     603                 :        9017 :   gcc_assert (repeat == NULL);
     604                 :             : 
     605                 :             :   /* Overwriting an existing initializer is non-standard but usually only
     606                 :             :      provokes a warning from other compilers.  */
     607                 :        9017 :   if (init != NULL && init->where.lb && rvalue->where.lb)
     608                 :             :     {
     609                 :             :       /* Order in which the expressions arrive here depends on whether
     610                 :             :          they are from data statements or F95 style declarations.
     611                 :             :          Therefore, check which is the most recent.  */
     612                 :          73 :       expr = (LOCATION_LINE (init->where.lb->location)
     613                 :          73 :               > LOCATION_LINE (rvalue->where.lb->location))
     614                 :          73 :            ? init : rvalue;
     615                 :          73 :       if (gfc_notify_std (GFC_STD_GNU, "re-initialization of %qs at %L",
     616                 :             :                           symbol->name, &expr->where) == false)
     617                 :             :         return false;
     618                 :             :     }
     619                 :             : 
     620                 :        9002 :   if (ref || (last_ts->type == BT_CHARACTER
     621                 :         631 :               && rvalue->expr_type == EXPR_CONSTANT))
     622                 :             :     {
     623                 :             :       /* An initializer has to be constant.  */
     624                 :         721 :       if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
     625                 :             :         return false;
     626                 :         720 :       if (lvalue->ts.u.cl->length
     627                 :         670 :           && lvalue->ts.u.cl->length->expr_type != EXPR_CONSTANT)
     628                 :             :         return false;
     629                 :         720 :       expr = create_character_initializer (init, last_ts, ref, rvalue);
     630                 :         720 :       if (!expr)
     631                 :             :         return false;
     632                 :             :     }
     633                 :             :   else
     634                 :             :     {
     635                 :        8281 :       if (lvalue->ts.type == BT_DERIVED
     636                 :        8281 :           && gfc_has_default_initializer (lvalue->ts.u.derived))
     637                 :             :         {
     638                 :           1 :           gfc_error ("Nonpointer object %qs with default initialization "
     639                 :             :                      "shall not appear in a DATA statement at %L",
     640                 :             :                      symbol->name, &lvalue->where);
     641                 :           1 :           return false;
     642                 :             :         }
     643                 :             : 
     644                 :        8280 :       expr = gfc_copy_expr (rvalue);
     645                 :        8280 :       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
     646                 :        1421 :         gfc_convert_type (expr, &lvalue->ts, 0);
     647                 :             :     }
     648                 :             : 
     649                 :        8997 :   if (IS_POINTER (symbol)
     650                 :        8997 :       && !gfc_check_pointer_assign (lvalue, rvalue, false, true))
     651                 :             :     return false;
     652                 :             : 
     653                 :        8996 :   if (last_con == NULL)
     654                 :        1595 :     symbol->value = expr;
     655                 :             :   else
     656                 :        7401 :     last_con->expr = expr;
     657                 :             : 
     658                 :             :   return true;
     659                 :             : 
     660                 :          16 : abort:
     661                 :          16 :   if (!init)
     662                 :           3 :     gfc_free_expr (expr);
     663                 :          16 :   mpz_clear (offset);
     664                 :          16 :   return false;
     665                 :             : }
     666                 :             : 
     667                 :             : 
     668                 :             : /* Modify the index of array section and re-calculate the array offset.  */
     669                 :             : 
     670                 :             : void
     671                 :         363 : gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
     672                 :             :                      mpz_t *offset_ret, int *vector_offset)
     673                 :             : {
     674                 :         363 :   int i;
     675                 :         363 :   mpz_t delta;
     676                 :         363 :   mpz_t tmp;
     677                 :         363 :   bool forwards;
     678                 :         363 :   int cmp;
     679                 :         363 :   gfc_expr *start, *end, *stride, *elem;
     680                 :         363 :   gfc_constructor_base base;
     681                 :             : 
     682                 :         609 :   for (i = 0; i < ar->dimen; i++)
     683                 :             :     {
     684                 :         467 :       bool advance = false;
     685                 :             : 
     686                 :         467 :       switch (ar->dimen_type[i])
     687                 :             :         {
     688                 :             :         case DIMEN_ELEMENT:
     689                 :             :           /* Loop to advance the next index.  */
     690                 :             :           advance = true;
     691                 :             :           break;
     692                 :             : 
     693                 :         320 :         case DIMEN_RANGE:
     694                 :         320 :           if (ar->stride[i])
     695                 :             :             {
     696                 :         120 :               stride = gfc_copy_expr(ar->stride[i]);
     697                 :         120 :               if(!gfc_simplify_expr(stride, 1))
     698                 :           0 :                 gfc_internal_error("Simplification error");
     699                 :         120 :               mpz_add (section_index[i], section_index[i],
     700                 :         120 :                        stride->value.integer);
     701                 :         120 :               if (mpz_cmp_si (stride->value.integer, 0) >= 0)
     702                 :             :                 forwards = true;
     703                 :             :               else
     704                 :          36 :                 forwards = false;
     705                 :         120 :               gfc_free_expr(stride);
     706                 :             :             }
     707                 :             :           else
     708                 :             :             {
     709                 :         200 :               mpz_add_ui (section_index[i], section_index[i], 1);
     710                 :         200 :               forwards = true;
     711                 :             :             }
     712                 :             : 
     713                 :         320 :           if (ar->end[i])
     714                 :             :             {
     715                 :         193 :               end = gfc_copy_expr(ar->end[i]);
     716                 :         193 :               if(!gfc_simplify_expr(end, 1))
     717                 :           0 :                 gfc_internal_error("Simplification error");
     718                 :         193 :               cmp = mpz_cmp (section_index[i], end->value.integer);
     719                 :         193 :               gfc_free_expr(end);
     720                 :             :             }
     721                 :             :           else
     722                 :         127 :             cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
     723                 :             : 
     724                 :         320 :           if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
     725                 :             :             {
     726                 :             :               /* Reset index to start, then loop to advance the next index.  */
     727                 :         129 :               if (ar->start[i])
     728                 :             :                 {
     729                 :          76 :                   start = gfc_copy_expr(ar->start[i]);
     730                 :          76 :                   if(!gfc_simplify_expr(start, 1))
     731                 :           0 :                     gfc_internal_error("Simplification error");
     732                 :          76 :                   mpz_set (section_index[i], start->value.integer);
     733                 :          76 :                   gfc_free_expr(start);
     734                 :             :                 }
     735                 :             :               else
     736                 :          53 :                 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
     737                 :             :               advance = true;
     738                 :             :             }
     739                 :             :           break;
     740                 :             : 
     741                 :          72 :         case DIMEN_VECTOR:
     742                 :          72 :           vector_offset[i]++;
     743                 :          72 :           base = ar->start[i]->value.constructor;
     744                 :          72 :           elem = gfc_constructor_lookup_expr (base, vector_offset[i]);
     745                 :             : 
     746                 :          72 :           if (elem == NULL)
     747                 :             :             {
     748                 :             :               /* Reset to first vector element and advance the next index.  */
     749                 :          42 :               vector_offset[i] = 0;
     750                 :          42 :               elem = gfc_constructor_lookup_expr (base, 0);
     751                 :          42 :               advance = true;
     752                 :             :             }
     753                 :          42 :           if (elem)
     754                 :             :             {
     755                 :          72 :               start = gfc_copy_expr (elem);
     756                 :          72 :               if (!gfc_simplify_expr (start, 1))
     757                 :           0 :                 gfc_internal_error ("Simplification error");
     758                 :          72 :               mpz_set (section_index[i], start->value.integer);
     759                 :          72 :               gfc_free_expr (start);
     760                 :             :             }
     761                 :             :           break;
     762                 :             : 
     763                 :           0 :         default:
     764                 :           0 :           gcc_unreachable ();
     765                 :             :         }
     766                 :             : 
     767                 :          72 :       if (!advance)
     768                 :             :         break;
     769                 :             :     }
     770                 :             : 
     771                 :         363 :   mpz_set_si (*offset_ret, 0);
     772                 :         363 :   mpz_init_set_si (delta, 1);
     773                 :         363 :   mpz_init (tmp);
     774                 :        1247 :   for (i = 0; i < ar->dimen; i++)
     775                 :             :     {
     776                 :         521 :       mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
     777                 :         521 :       mpz_mul (tmp, tmp, delta);
     778                 :         521 :       mpz_add (*offset_ret, tmp, *offset_ret);
     779                 :             : 
     780                 :         521 :       mpz_sub (tmp, ar->as->upper[i]->value.integer,
     781                 :         521 :                ar->as->lower[i]->value.integer);
     782                 :         521 :       mpz_add_ui (tmp, tmp, 1);
     783                 :         521 :       mpz_mul (delta, tmp, delta);
     784                 :             :     }
     785                 :         363 :   mpz_clear (tmp);
     786                 :         363 :   mpz_clear (delta);
     787                 :         363 : }
     788                 :             : 
     789                 :             : 
     790                 :             : /* Rearrange a structure constructor so the elements are in the specified
     791                 :             :    order.  Also insert NULL entries if necessary.  */
     792                 :             : 
     793                 :             : static void
     794                 :       51429 : formalize_structure_cons (gfc_expr *expr)
     795                 :             : {
     796                 :       51429 :   gfc_constructor_base base = NULL;
     797                 :       51429 :   gfc_constructor *cur;
     798                 :       51429 :   gfc_component *order;
     799                 :             : 
     800                 :             :   /* Constructor is already formalized.  */
     801                 :       51429 :   cur = gfc_constructor_first (expr->value.constructor);
     802                 :       51429 :   if (!cur || cur->n.component == NULL)
     803                 :       51281 :     return;
     804                 :             : 
     805                 :         493 :   for (order = expr->ts.u.derived->components; order; order = order->next)
     806                 :             :     {
     807                 :         345 :       cur = find_con_by_component (order, expr->value.constructor);
     808                 :         345 :       if (cur)
     809                 :         335 :         gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
     810                 :             :       else
     811                 :          10 :         gfc_constructor_append_expr (&base, NULL, NULL);
     812                 :             :     }
     813                 :             : 
     814                 :             :   /* For all what it's worth, one would expect
     815                 :             :        gfc_constructor_free (expr->value.constructor);
     816                 :             :      here. However, if the constructor is actually free'd,
     817                 :             :      hell breaks loose in the testsuite?!  */
     818                 :             : 
     819                 :         148 :   expr->value.constructor = base;
     820                 :             : }
     821                 :             : 
     822                 :             : 
     823                 :             : /* Make sure an initialization expression is in normalized form, i.e., all
     824                 :             :    elements of the constructors are in the correct order.  */
     825                 :             : 
     826                 :             : static void
     827                 :     1740448 : formalize_init_expr (gfc_expr *expr)
     828                 :             : {
     829                 :     1740448 :   expr_t type;
     830                 :     1740448 :   gfc_constructor *c;
     831                 :             : 
     832                 :     1740448 :   if (expr == NULL)
     833                 :             :     return;
     834                 :             : 
     835                 :      534331 :   type = expr->expr_type;
     836                 :      534331 :   switch (type)
     837                 :             :     {
     838                 :        7625 :     case EXPR_ARRAY:
     839                 :        7625 :       for (c = gfc_constructor_first (expr->value.constructor);
     840                 :      228279 :            c; c = gfc_constructor_next (c))
     841                 :      220654 :         formalize_init_expr (c->expr);
     842                 :             : 
     843                 :             :     break;
     844                 :             : 
     845                 :       51429 :     case EXPR_STRUCTURE:
     846                 :       51429 :       formalize_structure_cons (expr);
     847                 :       51429 :       break;
     848                 :             : 
     849                 :             :     default:
     850                 :             :       break;
     851                 :             :     }
     852                 :             : }
     853                 :             : 
     854                 :             : 
     855                 :             : /* Resolve symbol's initial value after all data statement.  */
     856                 :             : 
     857                 :             : void
     858                 :     1519794 : gfc_formalize_init_value (gfc_symbol *sym)
     859                 :             : {
     860                 :     1519794 :   formalize_init_expr (sym->value);
     861                 :     1519794 : }
     862                 :             : 
     863                 :             : 
     864                 :             : /* Get the integer value into RET_AS and SECTION from AS and AR, and return
     865                 :             :    offset.  */
     866                 :             : 
     867                 :             : void
     868                 :         149 : gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset,
     869                 :             :                        int *vector_offset)
     870                 :             : {
     871                 :         149 :   int i;
     872                 :         149 :   mpz_t delta;
     873                 :         149 :   mpz_t tmp;
     874                 :         149 :   gfc_expr *start, *elem;
     875                 :         149 :   gfc_constructor_base base;
     876                 :             : 
     877                 :         149 :   mpz_set_si (*offset, 0);
     878                 :         149 :   mpz_init (tmp);
     879                 :         149 :   mpz_init_set_si (delta, 1);
     880                 :         491 :   for (i = 0; i < ar->dimen; i++)
     881                 :             :     {
     882                 :         193 :       mpz_init (section_index[i]);
     883                 :         193 :       switch (ar->dimen_type[i])
     884                 :             :         {
     885                 :         157 :         case DIMEN_ELEMENT:
     886                 :         157 :         case DIMEN_RANGE:
     887                 :         157 :           elem = ar->start[i];
     888                 :         157 :           break;
     889                 :             : 
     890                 :          36 :         case DIMEN_VECTOR:
     891                 :          36 :           vector_offset[i] = 0;
     892                 :          36 :           base = ar->start[i]->value.constructor;
     893                 :          36 :           elem = gfc_constructor_lookup_expr (base, vector_offset[i]);
     894                 :          36 :           break;
     895                 :             : 
     896                 :           0 :         default:
     897                 :           0 :           gcc_unreachable ();
     898                 :             :         }
     899                 :             : 
     900                 :         193 :       if (elem)
     901                 :             :         {
     902                 :         142 :           start = gfc_copy_expr (elem);
     903                 :         142 :           if (!gfc_simplify_expr (start, 1))
     904                 :           0 :             gfc_internal_error ("Simplification error");
     905                 :         142 :           mpz_sub (tmp, start->value.integer,
     906                 :         142 :                    ar->as->lower[i]->value.integer);
     907                 :         142 :           mpz_mul (tmp, tmp, delta);
     908                 :         142 :           mpz_add (*offset, tmp, *offset);
     909                 :         142 :           mpz_set (section_index[i], start->value.integer);
     910                 :         142 :           gfc_free_expr (start);
     911                 :             :         }
     912                 :             :       else
     913                 :             :         /* Fallback for empty section or constructor.  */
     914                 :          51 :         mpz_set (section_index[i], ar->as->lower[i]->value.integer);
     915                 :             : 
     916                 :         193 :       mpz_sub (tmp, ar->as->upper[i]->value.integer,
     917                 :         193 :                ar->as->lower[i]->value.integer);
     918                 :         193 :       mpz_add_ui (tmp, tmp, 1);
     919                 :         193 :       mpz_mul (delta, tmp, delta);
     920                 :             :     }
     921                 :             : 
     922                 :         149 :   mpz_clear (tmp);
     923                 :         149 :   mpz_clear (delta);
     924                 :         149 : }
     925                 :             : 
        

Generated by: LCOV version 2.1-beta

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,rust,m2 --enable-host-shared. GCC test suite is run with the built compiler.