LCOV - code coverage report
Current view: top level - gcc/fortran - data.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 332 368 90.2 %
Date: 2020-03-28 11:57:23 Functions: 9 9 100.0 %
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-2020 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.c.
      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.c and
      33                 :            :    trans-array.c.  */
      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 void
      47                 :       1362 : get_array_index (gfc_array_ref *ar, mpz_t *offset)
      48                 :            : {
      49                 :       1362 :   gfc_expr *e;
      50                 :       1362 :   int i;
      51                 :       1362 :   mpz_t delta;
      52                 :       1362 :   mpz_t tmp;
      53                 :            : 
      54                 :       1362 :   mpz_init (tmp);
      55                 :       1362 :   mpz_set_si (*offset, 0);
      56                 :       1362 :   mpz_init_set_si (delta, 1);
      57                 :       3474 :   for (i = 0; i < ar->dimen; i++)
      58                 :            :     {
      59                 :       2112 :       e = gfc_copy_expr (ar->start[i]);
      60                 :       2112 :       gfc_simplify_expr (e, 1);
      61                 :            : 
      62                 :       2112 :       if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
      63                 :       2112 :           || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
      64                 :       4223 :           || (gfc_is_constant_expr (e) == 0))
      65                 :          1 :         gfc_error ("non-constant array in DATA statement %L", &ar->where);
      66                 :            : 
      67                 :       2112 :       mpz_set (tmp, e->value.integer);
      68                 :       2112 :       gfc_free_expr (e);
      69                 :       2112 :       mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
      70                 :       2112 :       mpz_mul (tmp, tmp, delta);
      71                 :       2112 :       mpz_add (*offset, tmp, *offset);
      72                 :            : 
      73                 :       2112 :       mpz_sub (tmp, ar->as->upper[i]->value.integer,
      74                 :       2112 :                ar->as->lower[i]->value.integer);
      75                 :       2112 :       mpz_add_ui (tmp, tmp, 1);
      76                 :       2112 :       mpz_mul (delta, tmp, delta);
      77                 :            :     }
      78                 :       1362 :   mpz_clear (delta);
      79                 :       1362 :   mpz_clear (tmp);
      80                 :       1362 : }
      81                 :            : 
      82                 :            : /* Find if there is a constructor which component is equal to COM.
      83                 :            :    TODO: remove this, use symbol.c(gfc_find_component) instead.  */
      84                 :            : 
      85                 :            : static gfc_constructor *
      86                 :        742 : find_con_by_component (gfc_component *com, gfc_constructor_base base)
      87                 :            : {
      88                 :        742 :   gfc_constructor *c;
      89                 :            : 
      90                 :       1186 :   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
      91                 :       1025 :     if (com == c->n.component)
      92                 :        581 :       return c;
      93                 :            : 
      94                 :            :   return NULL;
      95                 :            : }
      96                 :            : 
      97                 :            : 
      98                 :            : /* Create a character type initialization expression from RVALUE.
      99                 :            :    TS [and REF] describe [the substring of] the variable being initialized.
     100                 :            :    INIT is the existing initializer, not NULL.  Initialization is performed
     101                 :            :    according to normal assignment rules.  */
     102                 :            : 
     103                 :            : static gfc_expr *
     104                 :        656 : create_character_initializer (gfc_expr *init, gfc_typespec *ts,
     105                 :            :                               gfc_ref *ref, gfc_expr *rvalue)
     106                 :            : {
     107                 :        656 :   HOST_WIDE_INT len, start, end, tlen;
     108                 :        656 :   gfc_char_t *dest;
     109                 :        656 :   bool alloced_init = false;
     110                 :            : 
     111                 :        656 :   if (init && init->ts.type != BT_CHARACTER)
     112                 :            :     return NULL;
     113                 :            : 
     114                 :        655 :   gfc_extract_hwi (ts->u.cl->length, &len);
     115                 :            : 
     116                 :        655 :   if (init == NULL)
     117                 :            :     {
     118                 :            :       /* Create a new initializer.  */
     119                 :        609 :       init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
     120                 :        609 :       init->ts = *ts;
     121                 :        609 :       alloced_init = true;
     122                 :            :     }
     123                 :            : 
     124                 :        655 :   dest = init->value.character.string;
     125                 :            : 
     126                 :        655 :   if (ref)
     127                 :            :     {
     128                 :         96 :       gfc_expr *start_expr, *end_expr;
     129                 :            : 
     130                 :         96 :       gcc_assert (ref->type == REF_SUBSTRING);
     131                 :            : 
     132                 :            :       /* Only set a substring of the destination.  Fortran substring bounds
     133                 :            :          are one-based [start, end], we want zero based [start, end).  */
     134                 :         96 :       start_expr = gfc_copy_expr (ref->u.ss.start);
     135                 :         96 :       end_expr = gfc_copy_expr (ref->u.ss.end);
     136                 :            : 
     137                 :         96 :       if ((!gfc_simplify_expr(start_expr, 1))
     138                 :         96 :           || !(gfc_simplify_expr(end_expr, 1)))
     139                 :            :         {
     140                 :          0 :           gfc_error ("failure to simplify substring reference in DATA "
     141                 :          0 :                      "statement at %L", &ref->u.ss.start->where);
     142                 :          0 :           gfc_free_expr (start_expr);
     143                 :          0 :           gfc_free_expr (end_expr);
     144                 :          0 :           if (alloced_init)
     145                 :          0 :             gfc_free_expr (init);
     146                 :          0 :           return NULL;
     147                 :            :         }
     148                 :            : 
     149                 :         96 :       gfc_extract_hwi (start_expr, &start);
     150                 :         96 :       gfc_free_expr (start_expr);
     151                 :         96 :       start--;
     152                 :         96 :       gfc_extract_hwi (end_expr, &end);
     153                 :         96 :       gfc_free_expr (end_expr);
     154                 :            :     }
     155                 :            :   else
     156                 :            :     {
     157                 :            :       /* Set the whole string.  */
     158                 :        559 :       start = 0;
     159                 :        559 :       end = len;
     160                 :            :     }
     161                 :            : 
     162                 :            :   /* Copy the initial value.  */
     163                 :        655 :   if (rvalue->ts.type == BT_HOLLERITH)
     164                 :         42 :     len = rvalue->representation.length - rvalue->ts.u.pad;
     165                 :            :   else
     166                 :        613 :     len = rvalue->value.character.length;
     167                 :            : 
     168                 :        655 :   tlen = end - start;
     169                 :        655 :   if (len > tlen)
     170                 :            :     {
     171                 :         44 :       if (tlen < 0)
     172                 :            :         {
     173                 :          3 :           gfc_warning_now (0, "Unused initialization string at %L because "
     174                 :            :                            "variable has zero length", &rvalue->where);
     175                 :          3 :           len = 0;
     176                 :            :         }
     177                 :            :       else
     178                 :            :         {
     179                 :         41 :           gfc_warning_now (0, "Initialization string at %L was truncated to "
     180                 :            :                            "fit the variable (%ld/%ld)", &rvalue->where,
     181                 :            :                            (long) tlen, (long) len);
     182                 :         41 :           len = tlen;
     183                 :            :         }
     184                 :            :     }
     185                 :            : 
     186                 :        655 :   if (rvalue->ts.type == BT_HOLLERITH)
     187                 :            :     {
     188                 :        126 :       for (size_t i = 0; i < (size_t) len; i++)
     189                 :         84 :         dest[start+i] = rvalue->representation.string[i];
     190                 :            :     }
     191                 :            :   else
     192                 :        613 :     memcpy (&dest[start], rvalue->value.character.string,
     193                 :        613 :             len * sizeof (gfc_char_t));
     194                 :            : 
     195                 :            :   /* Pad with spaces.  Substrings will already be blanked.  */
     196                 :        655 :   if (len < tlen && ref == NULL)
     197                 :        204 :     gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
     198                 :            : 
     199                 :        655 :   if (rvalue->ts.type == BT_HOLLERITH)
     200                 :            :     {
     201                 :         42 :       init->representation.length = init->value.character.length;
     202                 :         42 :       init->representation.string
     203                 :         42 :         = gfc_widechar_to_char (init->value.character.string,
     204                 :            :                                 init->value.character.length);
     205                 :            :     }
     206                 :            : 
     207                 :            :   return init;
     208                 :            : }
     209                 :            : 
     210                 :            : 
     211                 :            : /* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
     212                 :            :    LVALUE already has an initialization, we extend this, otherwise we
     213                 :            :    create a new one.  If REPEAT is non-NULL, initialize *REPEAT
     214                 :            :    consecutive values in LVALUE the same value in RVALUE.  In that case,
     215                 :            :    LVALUE must refer to a full array, not an array section.  */
     216                 :            : 
     217                 :            : bool
     218                 :       8683 : gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
     219                 :            :                        mpz_t *repeat)
     220                 :            : {
     221                 :       8683 :   gfc_ref *ref;
     222                 :       8683 :   gfc_expr *init;
     223                 :       8683 :   gfc_expr *expr = NULL;
     224                 :       8683 :   gfc_constructor *con;
     225                 :       8683 :   gfc_constructor *last_con;
     226                 :       8683 :   gfc_symbol *symbol;
     227                 :       8683 :   gfc_typespec *last_ts;
     228                 :       8683 :   mpz_t offset;
     229                 :            : 
     230                 :       8683 :   symbol = lvalue->symtree->n.sym;
     231                 :       8683 :   init = symbol->value;
     232                 :       8683 :   last_ts = &symbol->ts;
     233                 :       8683 :   last_con = NULL;
     234                 :       8683 :   mpz_init_set_si (offset, 0);
     235                 :            : 
     236                 :            :   /* Find/create the parent expressions for subobject references.  */
     237                 :      16635 :   for (ref = lvalue->ref; ref; ref = ref->next)
     238                 :            :     {
     239                 :            :       /* Break out of the loop if we find a substring.  */
     240                 :       8067 :       if (ref->type == REF_SUBSTRING)
     241                 :            :         {
     242                 :            :           /* A substring should always be the last subobject reference.  */
     243                 :         96 :           gcc_assert (ref->next == NULL);
     244                 :            :           break;
     245                 :            :         }
     246                 :            : 
     247                 :            :       /* Use the existing initializer expression if it exists.  Otherwise
     248                 :            :          create a new one.  */
     249                 :       7971 :       if (init == NULL)
     250                 :       1121 :         expr = gfc_get_expr ();
     251                 :            :       else
     252                 :            :         expr = init;
     253                 :            : 
     254                 :            :       /* Find or create this element.  */
     255                 :       7971 :       switch (ref->type)
     256                 :            :         {
     257                 :       7495 :         case REF_ARRAY:
     258                 :       7495 :           if (ref->u.ar.as->rank == 0)
     259                 :            :             {
     260                 :          2 :               gcc_assert (ref->u.ar.as->corank > 0);
     261                 :          2 :               if (init == NULL)
     262                 :          2 :                 free (expr);
     263                 :          2 :               continue;
     264                 :            :             }
     265                 :            : 
     266                 :       7493 :           if (init && expr->expr_type != EXPR_ARRAY)
     267                 :            :             {
     268                 :          7 :               gfc_error ("%qs at %L already is initialized at %L",
     269                 :          7 :                          lvalue->symtree->n.sym->name, &lvalue->where,
     270                 :            :                          &init->where);
     271                 :          7 :               goto abort;
     272                 :            :             }
     273                 :            : 
     274                 :       7486 :           if (init == NULL)
     275                 :            :             {
     276                 :            :               /* The element typespec will be the same as the array
     277                 :            :                  typespec.  */
     278                 :        985 :               expr->ts = *last_ts;
     279                 :            :               /* Setup the expression to hold the constructor.  */
     280                 :        985 :               expr->expr_type = EXPR_ARRAY;
     281                 :        985 :               expr->rank = ref->u.ar.as->rank;
     282                 :            :             }
     283                 :            : 
     284                 :       7486 :           if (ref->u.ar.type == AR_ELEMENT)
     285                 :       1362 :             get_array_index (&ref->u.ar, &offset);
     286                 :            :           else
     287                 :       6124 :             mpz_set (offset, index);
     288                 :            : 
     289                 :            :           /* Check the bounds.  */
     290                 :       7486 :           if (mpz_cmp_si (offset, 0) < 0)
     291                 :            :             {
     292                 :          3 :               gfc_error ("Data element below array lower bound at %L",
     293                 :            :                          &lvalue->where);
     294                 :          3 :               goto abort;
     295                 :            :             }
     296                 :       7483 :           else if (repeat != NULL
     297                 :        195 :                    && ref->u.ar.type != AR_ELEMENT)
     298                 :            :             {
     299                 :        159 :               mpz_t size, end;
     300                 :        159 :               gcc_assert (ref->u.ar.type == AR_FULL
     301                 :            :                           && ref->next == NULL);
     302                 :        159 :               mpz_init_set (end, offset);
     303                 :        159 :               mpz_add (end, end, *repeat);
     304                 :        159 :               if (spec_size (ref->u.ar.as, &size))
     305                 :            :                 {
     306                 :        159 :                   if (mpz_cmp (end, size) > 0)
     307                 :            :                     {
     308                 :          0 :                       mpz_clear (size);
     309                 :          0 :                       gfc_error ("Data element above array upper bound at %L",
     310                 :            :                                  &lvalue->where);
     311                 :          0 :                       goto abort;
     312                 :            :                     }
     313                 :        159 :                   mpz_clear (size);
     314                 :            :                 }
     315                 :            : 
     316                 :        318 :               con = gfc_constructor_lookup (expr->value.constructor,
     317                 :        159 :                                             mpz_get_si (offset));
     318                 :        159 :               if (!con)
     319                 :            :                 {
     320                 :        310 :                   con = gfc_constructor_lookup_next (expr->value.constructor,
     321                 :        155 :                                                      mpz_get_si (offset));
     322                 :        155 :                   if (con != NULL && mpz_cmp (con->offset, end) >= 0)
     323                 :            :                     con = NULL;
     324                 :            :                 }
     325                 :            : 
     326                 :            :               /* Overwriting an existing initializer is non-standard but
     327                 :            :                  usually only provokes a warning from other compilers.  */
     328                 :        159 :               if (con != NULL && con->expr != NULL)
     329                 :            :                 {
     330                 :            :                   /* Order in which the expressions arrive here depends on
     331                 :            :                      whether they are from data statements or F95 style
     332                 :            :                      declarations.  Therefore, check which is the most
     333                 :            :                      recent.  */
     334                 :          8 :                   gfc_expr *exprd;
     335                 :          8 :                   exprd = (LOCATION_LINE (con->expr->where.lb->location)
     336                 :          8 :                            > LOCATION_LINE (rvalue->where.lb->location))
     337                 :          8 :                           ? con->expr : rvalue;
     338                 :          8 :                   if (gfc_notify_std (GFC_STD_GNU,
     339                 :            :                                       "re-initialization of %qs at %L",
     340                 :            :                                       symbol->name, &exprd->where) == false)
     341                 :          6 :                     return false;
     342                 :            :                 }
     343                 :            : 
     344                 :        163 :               while (con != NULL)
     345                 :            :                 {
     346                 :         10 :                   gfc_constructor *next_con = gfc_constructor_next (con);
     347                 :            : 
     348                 :         10 :                   if (mpz_cmp (con->offset, end) >= 0)
     349                 :            :                     break;
     350                 :         10 :                   if (mpz_cmp (con->offset, offset) < 0)
     351                 :            :                     {
     352                 :          0 :                       gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
     353                 :          0 :                       mpz_sub (con->repeat, offset, con->offset);
     354                 :            :                     }
     355                 :         10 :                   else if (mpz_cmp_si (con->repeat, 1) > 0
     356                 :          0 :                            && mpz_get_si (con->offset)
     357                 :          0 :                               + mpz_get_si (con->repeat) > mpz_get_si (end))
     358                 :            :                     {
     359                 :          0 :                       int endi;
     360                 :          0 :                       splay_tree_node node
     361                 :          0 :                         = splay_tree_lookup (con->base,
     362                 :            :                                              mpz_get_si (con->offset));
     363                 :          0 :                       gcc_assert (node
     364                 :            :                                   && con == (gfc_constructor *) node->value
     365                 :            :                                   && node->key == (splay_tree_key)
     366                 :            :                                                   mpz_get_si (con->offset));
     367                 :          0 :                       endi = mpz_get_si (con->offset)
     368                 :          0 :                              + mpz_get_si (con->repeat);
     369                 :          0 :                       if (endi > mpz_get_si (end) + 1)
     370                 :          0 :                         mpz_set_si (con->repeat, endi - mpz_get_si (end));
     371                 :            :                       else
     372                 :          0 :                         mpz_set_si (con->repeat, 1);
     373                 :          0 :                       mpz_set (con->offset, end);
     374                 :          0 :                       node->key = (splay_tree_key) mpz_get_si (end);
     375                 :          0 :                       break;
     376                 :            :                     }
     377                 :            :                   else
     378                 :         10 :                     gfc_constructor_remove (con);
     379                 :            :                   con = next_con;
     380                 :            :                 }
     381                 :            : 
     382                 :        306 :               con = gfc_constructor_insert_expr (&expr->value.constructor,
     383                 :            :                                                  NULL, &rvalue->where,
     384                 :        153 :                                                  mpz_get_si (offset));
     385                 :        153 :               mpz_set (con->repeat, *repeat);
     386                 :        153 :               repeat = NULL;
     387                 :        153 :               mpz_clear (end);
     388                 :        153 :               break;
     389                 :            :             }
     390                 :            :           else
     391                 :            :             {
     392                 :       7324 :               mpz_t size;
     393                 :       7324 :               if (spec_size (ref->u.ar.as, &size))
     394                 :            :                 {
     395                 :       7321 :                   if (mpz_cmp (offset, size) >= 0)
     396                 :            :                     {
     397                 :          3 :                       mpz_clear (size);
     398                 :          3 :                       gfc_error ("Data element above array upper bound at %L",
     399                 :            :                                  &lvalue->where);
     400                 :          3 :                       goto abort;
     401                 :            :                     }
     402                 :       7318 :                   mpz_clear (size);
     403                 :            :                 }
     404                 :            :             }
     405                 :            : 
     406                 :      14642 :           con = gfc_constructor_lookup (expr->value.constructor,
     407                 :       7321 :                                         mpz_get_si (offset));
     408                 :       7321 :           if (!con)
     409                 :            :             {
     410                 :       6933 :               con = gfc_constructor_insert_expr (&expr->value.constructor,
     411                 :            :                                                  NULL, &rvalue->where,
     412                 :       6933 :                                                  mpz_get_si (offset));
     413                 :            :             }
     414                 :        388 :           else if (mpz_cmp_si (con->repeat, 1) > 0)
     415                 :            :             {
     416                 :            :               /* Need to split a range.  */
     417                 :         14 :               if (mpz_cmp (con->offset, offset) < 0)
     418                 :            :                 {
     419                 :          9 :                   gfc_constructor *pred_con = con;
     420                 :         18 :                   con = gfc_constructor_insert_expr (&expr->value.constructor,
     421                 :            :                                                      NULL, &con->where,
     422                 :          9 :                                                      mpz_get_si (offset));
     423                 :          9 :                   con->expr = gfc_copy_expr (pred_con->expr);
     424                 :          9 :                   mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
     425                 :          9 :                   mpz_sub (con->repeat, con->repeat, offset);
     426                 :          9 :                   mpz_sub (pred_con->repeat, offset, pred_con->offset);
     427                 :            :                 }
     428                 :         14 :               if (mpz_cmp_si (con->repeat, 1) > 0)
     429                 :            :                 {
     430                 :         13 :                   gfc_constructor *succ_con;
     431                 :         13 :                   succ_con
     432                 :         26 :                     = gfc_constructor_insert_expr (&expr->value.constructor,
     433                 :            :                                                    NULL, &con->where,
     434                 :         13 :                                                    mpz_get_si (offset) + 1);
     435                 :         13 :                   succ_con->expr = gfc_copy_expr (con->expr);
     436                 :         13 :                   mpz_sub_ui (succ_con->repeat, con->repeat, 1);
     437                 :         13 :                   mpz_set_si (con->repeat, 1);
     438                 :            :                 }
     439                 :            :             }
     440                 :            :           break;
     441                 :            : 
     442                 :        476 :         case REF_COMPONENT:
     443                 :        476 :           if (init == NULL)
     444                 :            :             {
     445                 :            :               /* Setup the expression to hold the constructor.  */
     446                 :        134 :               expr->expr_type = EXPR_STRUCTURE;
     447                 :        134 :               expr->ts.type = BT_DERIVED;
     448                 :        134 :               expr->ts.u.derived = ref->u.c.sym;
     449                 :            :             }
     450                 :            :           else
     451                 :        342 :             gcc_assert (expr->expr_type == EXPR_STRUCTURE);
     452                 :        476 :           last_ts = &ref->u.c.component->ts;
     453                 :            : 
     454                 :            :           /* Find the same element in the existing constructor.  */
     455                 :        476 :           con = find_con_by_component (ref->u.c.component,
     456                 :            :                                        expr->value.constructor);
     457                 :            : 
     458                 :        476 :           if (con == NULL)
     459                 :            :             {
     460                 :            :               /* Create a new constructor.  */
     461                 :        152 :               con = gfc_constructor_append_expr (&expr->value.constructor,
     462                 :            :                                                  NULL, NULL);
     463                 :        152 :               con->n.component = ref->u.c.component;
     464                 :            :             }
     465                 :            :           break;
     466                 :            : 
     467                 :          0 :         default:
     468                 :          0 :           gcc_unreachable ();
     469                 :            :         }
     470                 :            : 
     471                 :       7950 :       if (init == NULL)
     472                 :            :         {
     473                 :            :           /* Point the container at the new expression.  */
     474                 :       1118 :           if (last_con == NULL)
     475                 :        917 :             symbol->value = expr;
     476                 :            :           else
     477                 :        201 :             last_con->expr = expr;
     478                 :            :         }
     479                 :       7950 :       init = con->expr;
     480                 :       7950 :       last_con = con;
     481                 :            :     }
     482                 :            : 
     483                 :       8664 :   mpz_clear (offset);
     484                 :       8664 :   gcc_assert (repeat == NULL);
     485                 :            : 
     486                 :            :   /* Overwriting an existing initializer is non-standard but usually only
     487                 :            :      provokes a warning from other compilers.  */
     488                 :       8664 :   if (init != NULL && init->where.lb && rvalue->where.lb)
     489                 :            :     {
     490                 :            :       /* Order in which the expressions arrive here depends on whether
     491                 :            :          they are from data statements or F95 style declarations.
     492                 :            :          Therefore, check which is the most recent.  */
     493                 :         73 :       expr = (LOCATION_LINE (init->where.lb->location)
     494                 :         73 :               > LOCATION_LINE (rvalue->where.lb->location))
     495                 :         73 :            ? init : rvalue;
     496                 :         73 :       if (gfc_notify_std (GFC_STD_GNU, "re-initialization of %qs at %L",
     497                 :            :                           symbol->name, &expr->where) == false)
     498                 :            :         return false;
     499                 :            :     }
     500                 :            : 
     501                 :       8649 :   if (ref || last_ts->type == BT_CHARACTER)
     502                 :            :     {
     503                 :            :       /* An initializer has to be constant.  */
     504                 :        658 :       if (rvalue->expr_type != EXPR_CONSTANT
     505                 :        657 :           || (lvalue->ts.u.cl->length == NULL
     506                 :         49 :               && !(ref && ref->u.ss.length != NULL)))
     507                 :            :         return false;
     508                 :        656 :       expr = create_character_initializer (init, last_ts, ref, rvalue);
     509                 :            :     }
     510                 :            :   else
     511                 :            :     {
     512                 :       7991 :       if (lvalue->ts.type == BT_DERIVED
     513                 :       7991 :           && gfc_has_default_initializer (lvalue->ts.u.derived))
     514                 :            :         {
     515                 :          1 :           gfc_error ("Nonpointer object %qs with default initialization "
     516                 :            :                      "shall not appear in a DATA statement at %L", 
     517                 :            :                      symbol->name, &lvalue->where);
     518                 :          1 :           return false;
     519                 :            :         }
     520                 :            : 
     521                 :       7990 :       expr = gfc_copy_expr (rvalue);
     522                 :       7990 :       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
     523                 :       1388 :         gfc_convert_type (expr, &lvalue->ts, 0);
     524                 :            :     }
     525                 :            : 
     526                 :       8646 :   if (last_con == NULL)
     527                 :       1572 :     symbol->value = expr;
     528                 :            :   else
     529                 :       7074 :     last_con->expr = expr;
     530                 :            : 
     531                 :            :   return true;
     532                 :            : 
     533                 :         13 : abort:
     534                 :         13 :   if (!init)
     535                 :          1 :     gfc_free_expr (expr);
     536                 :         13 :   mpz_clear (offset);
     537                 :         13 :   return false;
     538                 :            : }
     539                 :            : 
     540                 :            : 
     541                 :            : /* Modify the index of array section and re-calculate the array offset.  */
     542                 :            : 
     543                 :            : void 
     544                 :        267 : gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
     545                 :            :                      mpz_t *offset_ret)
     546                 :            : {
     547                 :        267 :   int i;
     548                 :        267 :   mpz_t delta;
     549                 :        267 :   mpz_t tmp; 
     550                 :        267 :   bool forwards;
     551                 :        267 :   int cmp;
     552                 :        267 :   gfc_expr *start, *end, *stride;
     553                 :            : 
     554                 :        447 :   for (i = 0; i < ar->dimen; i++)
     555                 :            :     {
     556                 :        347 :       if (ar->dimen_type[i] != DIMEN_RANGE)
     557                 :         63 :         continue;
     558                 :            : 
     559                 :        284 :       if (ar->stride[i])
     560                 :            :         {
     561                 :         96 :           stride = gfc_copy_expr(ar->stride[i]);
     562                 :         96 :           if(!gfc_simplify_expr(stride, 1))
     563                 :          0 :             gfc_internal_error("Simplification error");
     564                 :         96 :           mpz_add (section_index[i], section_index[i],
     565                 :         96 :                    stride->value.integer);
     566                 :         96 :           if (mpz_cmp_si (stride->value.integer, 0) >= 0)
     567                 :            :             forwards = true;
     568                 :            :           else
     569                 :         36 :             forwards = false;
     570                 :         96 :           gfc_free_expr(stride);        
     571                 :            :         }
     572                 :            :       else
     573                 :            :         {
     574                 :        188 :           mpz_add_ui (section_index[i], section_index[i], 1);
     575                 :        188 :           forwards = true;
     576                 :            :         }
     577                 :            :       
     578                 :        284 :       if (ar->end[i])
     579                 :            :         {
     580                 :        157 :           end = gfc_copy_expr(ar->end[i]);
     581                 :        157 :           if(!gfc_simplify_expr(end, 1))
     582                 :          0 :             gfc_internal_error("Simplification error");
     583                 :        157 :           cmp = mpz_cmp (section_index[i], end->value.integer);
     584                 :        157 :           gfc_free_expr(end);   
     585                 :            :         }
     586                 :            :       else
     587                 :        127 :         cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
     588                 :            : 
     589                 :        284 :       if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
     590                 :            :         {
     591                 :            :           /* Reset index to start, then loop to advance the next index.  */
     592                 :        117 :           if (ar->start[i])
     593                 :            :             {
     594                 :         70 :               start = gfc_copy_expr(ar->start[i]);
     595                 :         70 :               if(!gfc_simplify_expr(start, 1))
     596                 :          0 :                 gfc_internal_error("Simplification error");
     597                 :         70 :               mpz_set (section_index[i], start->value.integer);
     598                 :         70 :               gfc_free_expr(start); 
     599                 :            :             }
     600                 :            :           else
     601                 :         47 :             mpz_set (section_index[i], ar->as->lower[i]->value.integer);
     602                 :            :         }
     603                 :            :       else
     604                 :            :         break;
     605                 :            :     }
     606                 :            : 
     607                 :        267 :   mpz_set_si (*offset_ret, 0);
     608                 :        267 :   mpz_init_set_si (delta, 1);
     609                 :        267 :   mpz_init (tmp);
     610                 :        656 :   for (i = 0; i < ar->dimen; i++)
     611                 :            :     {
     612                 :        389 :       mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
     613                 :        389 :       mpz_mul (tmp, tmp, delta);
     614                 :        389 :       mpz_add (*offset_ret, tmp, *offset_ret);
     615                 :            : 
     616                 :        389 :       mpz_sub (tmp, ar->as->upper[i]->value.integer, 
     617                 :        389 :                ar->as->lower[i]->value.integer);
     618                 :        389 :       mpz_add_ui (tmp, tmp, 1);
     619                 :        389 :       mpz_mul (delta, tmp, delta);
     620                 :            :     }
     621                 :        267 :   mpz_clear (tmp);
     622                 :        267 :   mpz_clear (delta);
     623                 :        267 : }
     624                 :            : 
     625                 :            : 
     626                 :            : /* Rearrange a structure constructor so the elements are in the specified
     627                 :            :    order.  Also insert NULL entries if necessary.  */
     628                 :            : 
     629                 :            : static void
     630                 :      29722 : formalize_structure_cons (gfc_expr *expr)
     631                 :            : {
     632                 :      29722 :   gfc_constructor_base base = NULL;
     633                 :      29722 :   gfc_constructor *cur;
     634                 :      29722 :   gfc_component *order;
     635                 :            : 
     636                 :            :   /* Constructor is already formalized.  */
     637                 :      29722 :   cur = gfc_constructor_first (expr->value.constructor);
     638                 :      29722 :   if (!cur || cur->n.component == NULL)
     639                 :      29594 :     return;
     640                 :            : 
     641                 :        394 :   for (order = expr->ts.u.derived->components; order; order = order->next)
     642                 :            :     {
     643                 :        266 :       cur = find_con_by_component (order, expr->value.constructor);
     644                 :        266 :       if (cur)
     645                 :        257 :         gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
     646                 :            :       else
     647                 :          9 :         gfc_constructor_append_expr (&base, NULL, NULL);
     648                 :            :     }
     649                 :            : 
     650                 :            :   /* For all what it's worth, one would expect
     651                 :            :        gfc_constructor_free (expr->value.constructor);
     652                 :            :      here. However, if the constructor is actually free'd,
     653                 :            :      hell breaks loose in the testsuite?!  */
     654                 :            : 
     655                 :        128 :   expr->value.constructor = base;
     656                 :            : }
     657                 :            : 
     658                 :            : 
     659                 :            : /* Make sure an initialization expression is in normalized form, i.e., all
     660                 :            :    elements of the constructors are in the correct order.  */
     661                 :            : 
     662                 :            : static void
     663                 :    1020320 : formalize_init_expr (gfc_expr *expr)
     664                 :            : {
     665                 :    1020320 :   expr_t type;
     666                 :    1020320 :   gfc_constructor *c;
     667                 :            : 
     668                 :    1020320 :   if (expr == NULL)
     669                 :            :     return;
     670                 :            : 
     671                 :     340042 :   type = expr->expr_type;
     672                 :     340042 :   switch (type)
     673                 :            :     {
     674                 :       5807 :     case EXPR_ARRAY:
     675                 :       5807 :       for (c = gfc_constructor_first (expr->value.constructor);
     676                 :     432247 :            c; c = gfc_constructor_next (c))
     677                 :     213220 :         formalize_init_expr (c->expr);
     678                 :            : 
     679                 :            :     break;
     680                 :            : 
     681                 :      29722 :     case EXPR_STRUCTURE:
     682                 :      29722 :       formalize_structure_cons (expr);
     683                 :      29722 :       break;
     684                 :            : 
     685                 :            :     default:
     686                 :            :       break;
     687                 :            :     }
     688                 :            : }
     689                 :            : 
     690                 :            : 
     691                 :            : /* Resolve symbol's initial value after all data statement.  */
     692                 :            : 
     693                 :            : void
     694                 :     807097 : gfc_formalize_init_value (gfc_symbol *sym)
     695                 :            : {
     696                 :     807097 :   formalize_init_expr (sym->value);
     697                 :     807097 : }
     698                 :            : 
     699                 :            : 
     700                 :            : /* Get the integer value into RET_AS and SECTION from AS and AR, and return
     701                 :            :    offset.  */
     702                 :            :  
     703                 :            : void
     704                 :        107 : gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
     705                 :            : {
     706                 :        107 :   int i;
     707                 :        107 :   mpz_t delta;
     708                 :        107 :   mpz_t tmp;
     709                 :        107 :   gfc_expr *start;
     710                 :            : 
     711                 :        107 :   mpz_set_si (*offset, 0);
     712                 :        107 :   mpz_init (tmp);
     713                 :        107 :   mpz_init_set_si (delta, 1);
     714                 :        246 :   for (i = 0; i < ar->dimen; i++)
     715                 :            :     {
     716                 :        139 :       mpz_init (section_index[i]);
     717                 :        139 :       switch (ar->dimen_type[i])
     718                 :            :         {
     719                 :        139 :         case DIMEN_ELEMENT:
     720                 :        139 :         case DIMEN_RANGE:
     721                 :        139 :           if (ar->start[i])
     722                 :            :             {
     723                 :         94 :               start = gfc_copy_expr(ar->start[i]);
     724                 :         94 :               if(!gfc_simplify_expr(start, 1))
     725                 :          0 :                 gfc_internal_error("Simplification error");
     726                 :         94 :               mpz_sub (tmp, start->value.integer,
     727                 :         94 :                        ar->as->lower[i]->value.integer);
     728                 :         94 :               mpz_mul (tmp, tmp, delta);
     729                 :         94 :               mpz_add (*offset, tmp, *offset);
     730                 :         94 :               mpz_set (section_index[i], start->value.integer);
     731                 :         94 :               gfc_free_expr(start);
     732                 :            :             }
     733                 :            :           else
     734                 :         45 :               mpz_set (section_index[i], ar->as->lower[i]->value.integer);
     735                 :        139 :           break;
     736                 :            : 
     737                 :          0 :         case DIMEN_VECTOR:
     738                 :          0 :           gfc_internal_error ("TODO: Vector sections in data statements");
     739                 :            : 
     740                 :          0 :         default:
     741                 :          0 :           gcc_unreachable ();
     742                 :            :         }
     743                 :            : 
     744                 :        139 :       mpz_sub (tmp, ar->as->upper[i]->value.integer, 
     745                 :        139 :                ar->as->lower[i]->value.integer);
     746                 :        139 :       mpz_add_ui (tmp, tmp, 1);
     747                 :        139 :       mpz_mul (delta, tmp, delta);
     748                 :            :     }
     749                 :            : 
     750                 :        107 :   mpz_clear (tmp);
     751                 :        107 :   mpz_clear (delta);
     752                 :        107 : }
     753                 :            : 

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.