LCOV - code coverage report
Current view: top level - gcc/fortran - array.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 92.3 % 1291 1191
Test Date: 2025-10-18 14:39:06 Functions: 98.0 % 51 50
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* Array things
       2                 :             :    Copyright (C) 2000-2025 Free Software Foundation, Inc.
       3                 :             :    Contributed by Andy Vaught
       4                 :             : 
       5                 :             : This file is part of GCC.
       6                 :             : 
       7                 :             : GCC is free software; you can redistribute it and/or modify it under
       8                 :             : the terms of the GNU General Public License as published by the Free
       9                 :             : Software Foundation; either version 3, or (at your option) any later
      10                 :             : version.
      11                 :             : 
      12                 :             : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      13                 :             : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      14                 :             : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      15                 :             : for more details.
      16                 :             : 
      17                 :             : You should have received a copy of the GNU General Public License
      18                 :             : along with GCC; see the file COPYING3.  If not see
      19                 :             : <http://www.gnu.org/licenses/>.  */
      20                 :             : 
      21                 :             : #include "config.h"
      22                 :             : #include "system.h"
      23                 :             : #include "coretypes.h"
      24                 :             : #include "options.h"
      25                 :             : #include "gfortran.h"
      26                 :             : #include "parse.h"
      27                 :             : #include "match.h"
      28                 :             : #include "constructor.h"
      29                 :             : 
      30                 :             : /**************** Array reference matching subroutines *****************/
      31                 :             : 
      32                 :             : /* Copy an array reference structure.  */
      33                 :             : 
      34                 :             : gfc_array_ref *
      35                 :      167217 : gfc_copy_array_ref (gfc_array_ref *src)
      36                 :             : {
      37                 :      167217 :   gfc_array_ref *dest;
      38                 :      167217 :   int i;
      39                 :             : 
      40                 :      167217 :   if (src == NULL)
      41                 :             :     return NULL;
      42                 :             : 
      43                 :      167217 :   dest = gfc_get_array_ref ();
      44                 :             : 
      45                 :      167217 :   *dest = *src;
      46                 :             : 
      47                 :     2675472 :   for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
      48                 :             :     {
      49                 :     2508255 :       dest->start[i] = gfc_copy_expr (src->start[i]);
      50                 :     2508255 :       dest->end[i] = gfc_copy_expr (src->end[i]);
      51                 :     2508255 :       dest->stride[i] = gfc_copy_expr (src->stride[i]);
      52                 :             :     }
      53                 :             : 
      54                 :      167217 :   dest->stat = gfc_copy_expr (src->stat);
      55                 :      167217 :   dest->team = gfc_copy_expr (src->team);
      56                 :             : 
      57                 :      167217 :   return dest;
      58                 :             : }
      59                 :             : 
      60                 :             : 
      61                 :             : /* Match a single dimension of an array reference.  This can be a
      62                 :             :    single element or an array section.  Any modifications we've made
      63                 :             :    to the ar structure are cleaned up by the caller.  If the init
      64                 :             :    is set, we require the subscript to be a valid initialization
      65                 :             :    expression.  */
      66                 :             : 
      67                 :             : static match
      68                 :      357843 : match_subscript (gfc_array_ref *ar, int init, bool match_star)
      69                 :             : {
      70                 :      357843 :   match m = MATCH_ERROR;
      71                 :      357843 :   bool star = false;
      72                 :      357843 :   int i;
      73                 :      357843 :   bool saw_boz = false;
      74                 :             : 
      75                 :      357843 :   i = ar->dimen + ar->codimen;
      76                 :             : 
      77                 :      357843 :   gfc_gobble_whitespace ();
      78                 :      357843 :   ar->c_where[i] = gfc_current_locus;
      79                 :      357843 :   ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
      80                 :             : 
      81                 :             :   /* We can't be sure of the difference between DIMEN_ELEMENT and
      82                 :             :      DIMEN_VECTOR until we know the type of the element itself at
      83                 :             :      resolution time.  */
      84                 :             : 
      85                 :      357843 :   ar->dimen_type[i] = DIMEN_UNKNOWN;
      86                 :             : 
      87                 :      357843 :   if (gfc_match_char (':') == MATCH_YES)
      88                 :       43491 :     goto end_element;
      89                 :             : 
      90                 :             :   /* Get start element.  */
      91                 :      314352 :   if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
      92                 :             :     star = true;
      93                 :             : 
      94                 :      314352 :   if (!star && init)
      95                 :        1636 :     m = gfc_match_init_expr (&ar->start[i]);
      96                 :      312716 :   else if (!star)
      97                 :      312055 :     m = gfc_match_expr (&ar->start[i]);
      98                 :             : 
      99                 :      314352 :   if (ar->start[i] && ar->start[i]->ts.type == BT_BOZ)
     100                 :             :     {
     101                 :           1 :       gfc_error ("Invalid BOZ literal constant used in subscript at %C");
     102                 :           1 :       saw_boz = true;
     103                 :             :     }
     104                 :             : 
     105                 :      314352 :   if (m == MATCH_NO)
     106                 :           4 :     gfc_error ("Expected array subscript at %C");
     107                 :      314352 :   if (m != MATCH_YES)
     108                 :             :     return MATCH_ERROR;
     109                 :             : 
     110                 :      314342 :   if (gfc_match_char (':') == MATCH_NO)
     111                 :      279680 :     goto matched;
     112                 :             : 
     113                 :       34662 :   if (star)
     114                 :             :     {
     115                 :           0 :       gfc_error ("Unexpected %<*%> in coarray subscript at %C");
     116                 :           0 :       return MATCH_ERROR;
     117                 :             :     }
     118                 :             : 
     119                 :             :   /* Get an optional end element.  Because we've seen the colon, we
     120                 :             :      definitely have a range along this dimension.  */
     121                 :       34662 : end_element:
     122                 :       78153 :   ar->dimen_type[i] = DIMEN_RANGE;
     123                 :             : 
     124                 :       78153 :   if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
     125                 :             :     star = true;
     126                 :       77997 :   else if (init)
     127                 :         371 :     m = gfc_match_init_expr (&ar->end[i]);
     128                 :             :   else
     129                 :       77626 :     m = gfc_match_expr (&ar->end[i]);
     130                 :             : 
     131                 :       78153 :   if (ar->end[i] && ar->end[i]->ts.type == BT_BOZ)
     132                 :             :     {
     133                 :           1 :       gfc_error ("Invalid BOZ literal constant used in subscript at %C");
     134                 :           1 :       saw_boz = true;
     135                 :             :     }
     136                 :             : 
     137                 :       78153 :   if (m == MATCH_ERROR)
     138                 :             :     return MATCH_ERROR;
     139                 :             : 
     140                 :       78153 :   if (star && ar->start[i] == NULL)
     141                 :             :     {
     142                 :           2 :       gfc_error ("Missing lower bound in assumed size "
     143                 :             :                  "coarray specification at %C");
     144                 :           2 :       return MATCH_ERROR;
     145                 :             :     }
     146                 :             : 
     147                 :             :   /* See if we have an optional stride.  */
     148                 :       78151 :   if (gfc_match_char (':') == MATCH_YES)
     149                 :             :     {
     150                 :       16646 :       if (star)
     151                 :             :         {
     152                 :           0 :           gfc_error ("Strides not allowed in coarray subscript at %C");
     153                 :           0 :           return MATCH_ERROR;
     154                 :             :         }
     155                 :             : 
     156                 :       16646 :       m = init ? gfc_match_init_expr (&ar->stride[i])
     157                 :       16645 :                : gfc_match_expr (&ar->stride[i]);
     158                 :             : 
     159                 :       16646 :       if (ar->stride[i] && ar->stride[i]->ts.type == BT_BOZ)
     160                 :             :         {
     161                 :           1 :           gfc_error ("Invalid BOZ literal constant used in subscript at %C");
     162                 :           1 :           saw_boz = true;
     163                 :             :         }
     164                 :             : 
     165                 :       16646 :       if (m == MATCH_NO)
     166                 :           0 :         gfc_error ("Expected array subscript stride at %C");
     167                 :       16646 :       if (m != MATCH_YES)
     168                 :             :         return MATCH_ERROR;
     169                 :             :     }
     170                 :             : 
     171                 :       61505 : matched:
     172                 :      357831 :   if (star)
     173                 :         815 :     ar->dimen_type[i] = DIMEN_STAR;
     174                 :             : 
     175                 :      357831 :   return (saw_boz ? MATCH_ERROR : MATCH_YES);
     176                 :             : }
     177                 :             : 
     178                 :             : /** Match one of TEAM=, TEAM_NUMBER= or STAT=.  */
     179                 :             : 
     180                 :             : match
     181                 :        4860 : match_team_or_stat (gfc_array_ref *ar)
     182                 :             : {
     183                 :        4860 :   gfc_expr *tmp;
     184                 :        4860 :   bool team_error = false;
     185                 :             : 
     186                 :        4860 :   if (gfc_match (" team = %e", &tmp) == MATCH_YES)
     187                 :             :     {
     188                 :          50 :       if (ar->team == NULL && ar->team_type == TEAM_UNSET)
     189                 :             :         {
     190                 :          46 :           ar->team = tmp;
     191                 :          46 :           ar->team_type = TEAM_TEAM;
     192                 :             :         }
     193                 :           4 :       else if (ar->team_type == TEAM_TEAM)
     194                 :             :         {
     195                 :           2 :           gfc_error ("Duplicate TEAM= attribute in %C");
     196                 :           2 :           return MATCH_ERROR;
     197                 :             :         }
     198                 :             :       else
     199                 :             :         team_error = true;
     200                 :             :     }
     201                 :        4810 :   else if (gfc_match (" team_number = %e", &tmp) == MATCH_YES)
     202                 :             :     {
     203                 :          68 :       if (!gfc_notify_std (GFC_STD_F2018, "TEAM_NUMBER= not supported at %C"))
     204                 :             :         return MATCH_ERROR;
     205                 :          66 :       if (ar->team == NULL && ar->team_type == TEAM_UNSET)
     206                 :             :         {
     207                 :          64 :           ar->team = tmp;
     208                 :          64 :           ar->team_type = TEAM_NUMBER;
     209                 :             :         }
     210                 :           2 :       else if (ar->team_type == TEAM_NUMBER)
     211                 :             :         {
     212                 :           2 :           gfc_error ("Duplicate TEAM_NUMBER= attribute in %C");
     213                 :           2 :           return MATCH_ERROR;
     214                 :             :         }
     215                 :             :       else
     216                 :             :         team_error = true;
     217                 :             :     }
     218                 :        4742 :   else if (gfc_match (" stat = %e", &tmp) == MATCH_YES)
     219                 :             :     {
     220                 :          79 :       if (ar->stat == NULL)
     221                 :             :         {
     222                 :          75 :           if (gfc_is_coindexed (tmp))
     223                 :             :             {
     224                 :           2 :               gfc_error ("Expression in STAT= at %C must not be coindexed");
     225                 :           2 :               gfc_free_expr (tmp);
     226                 :           2 :               return MATCH_ERROR;
     227                 :             :             }
     228                 :          73 :           ar->stat = tmp;
     229                 :             :         }
     230                 :             :       else
     231                 :             :         {
     232                 :           4 :           gfc_error ("Duplicate STAT= attribute in %C");
     233                 :           4 :           return MATCH_ERROR;
     234                 :             :         }
     235                 :             :     }
     236                 :             :   else
     237                 :             :     return MATCH_NO;
     238                 :             : 
     239                 :         185 :   if (ar->team && team_error)
     240                 :             :     {
     241                 :           2 :       gfc_error ("Only one of TEAM= or TEAM_NUMBER= may appear in a "
     242                 :             :                  "coarray reference at %C");
     243                 :           2 :       return MATCH_ERROR;
     244                 :             :     }
     245                 :             : 
     246                 :             :   return MATCH_YES;
     247                 :             : }
     248                 :             : 
     249                 :             : /* Match an array reference, whether it is the whole array or particular
     250                 :             :    elements or a section.  If init is set, the reference has to consist
     251                 :             :    of init expressions.  */
     252                 :             : 
     253                 :             : match
     254                 :      714991 : gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
     255                 :             :                      int corank, bool coarray_only)
     256                 :             : {
     257                 :      714991 :   match m;
     258                 :      714991 :   bool matched_bracket = false;
     259                 :             : 
     260                 :      714991 :   memset (ar, '\0', sizeof (*ar));
     261                 :             : 
     262                 :      714991 :   ar->where = gfc_current_locus;
     263                 :      714991 :   ar->as = as;
     264                 :      714991 :   ar->type = AR_UNKNOWN;
     265                 :             : 
     266                 :      714991 :   if (gfc_match_char ('[') == MATCH_YES)
     267                 :             :     {
     268                 :        3017 :        matched_bracket = true;
     269                 :        3017 :        goto coarray;
     270                 :             :     }
     271                 :      711974 :   else if (coarray_only && corank != 0)
     272                 :        1236 :     goto coarray;
     273                 :             : 
     274                 :      710738 :   if (gfc_match_char ('(') != MATCH_YES)
     275                 :             :     {
     276                 :      439243 :       ar->type = AR_FULL;
     277                 :      439243 :       ar->dimen = 0;
     278                 :      439243 :       if (corank != 0)
     279                 :             :         {
     280                 :      150704 :           for (int i = 0; i < GFC_MAX_DIMENSIONS; ++i)
     281                 :      141285 :             ar->dimen_type[i] = DIMEN_THIS_IMAGE;
     282                 :        9419 :           ar->codimen = corank;
     283                 :             :         }
     284                 :      439243 :       return MATCH_YES;
     285                 :             :     }
     286                 :             : 
     287                 :      353178 :   for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
     288                 :             :     {
     289                 :      353178 :       m = match_subscript (ar, init, false);
     290                 :      353178 :       if (m == MATCH_ERROR)
     291                 :             :         return MATCH_ERROR;
     292                 :             : 
     293                 :      353165 :       if (gfc_match_char (')') == MATCH_YES)
     294                 :             :         {
     295                 :      271474 :           ar->dimen++;
     296                 :      271474 :           goto coarray;
     297                 :             :         }
     298                 :             : 
     299                 :       81691 :       if (gfc_match_char (',') != MATCH_YES)
     300                 :             :         {
     301                 :           8 :           gfc_error ("Invalid form of array reference at %C");
     302                 :           8 :           return MATCH_ERROR;
     303                 :             :         }
     304                 :             :     }
     305                 :             : 
     306                 :           0 :   if (ar->dimen >= 7
     307                 :           0 :       && !gfc_notify_std (GFC_STD_F2008,
     308                 :             :                           "Array reference at %C has more than 7 dimensions"))
     309                 :             :     return MATCH_ERROR;
     310                 :             : 
     311                 :           0 :   gfc_error ("Array reference at %C cannot have more than %d dimensions",
     312                 :             :              GFC_MAX_DIMENSIONS);
     313                 :           0 :   return MATCH_ERROR;
     314                 :             : 
     315                 :      275727 : coarray:
     316                 :      275727 :   if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
     317                 :             :     {
     318                 :      271619 :       int dim = coarray_only ? 0 : ar->dimen;
     319                 :      271619 :       if (dim > 0 || coarray_only)
     320                 :             :         {
     321                 :      271619 :           if (corank != 0)
     322                 :             :             {
     323                 :       70334 :               for (int i = dim; i < GFC_MAX_DIMENSIONS; ++i)
     324                 :       65702 :                 ar->dimen_type[i] = DIMEN_THIS_IMAGE;
     325                 :        4632 :               ar->codimen = corank;
     326                 :             :             }
     327                 :      271619 :           return MATCH_YES;
     328                 :             :         }
     329                 :             :       else
     330                 :             :         return MATCH_ERROR;
     331                 :             :     }
     332                 :             : 
     333                 :        4108 :   if (flag_coarray == GFC_FCOARRAY_NONE)
     334                 :             :     {
     335                 :           0 :       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
     336                 :             :       return MATCH_ERROR;
     337                 :             :     }
     338                 :             : 
     339                 :        4108 :   if (corank == 0)
     340                 :             :     {
     341                 :           0 :         gfc_error ("Unexpected coarray designator at %C");
     342                 :           0 :         return MATCH_ERROR;
     343                 :             :     }
     344                 :             : 
     345                 :        4108 :   ar->team_type = TEAM_UNSET;
     346                 :             : 
     347                 :        4665 :   for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS;
     348                 :             :        ar->codimen++)
     349                 :             :     {
     350                 :        4665 :       m = match_subscript (ar, init, true);
     351                 :        4665 :       if (m == MATCH_ERROR)
     352                 :             :         return MATCH_ERROR;
     353                 :             : 
     354                 :        4663 :       if (gfc_match_char (',') != MATCH_YES)
     355                 :             :         {
     356                 :        3957 :           if (gfc_match_char ('*') == MATCH_YES)
     357                 :           0 :             gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
     358                 :           0 :                        ar->codimen + 1, corank);
     359                 :             :           else
     360                 :             :             {
     361                 :        3957 :               goto image_selector;
     362                 :             :             }
     363                 :           0 :           return MATCH_ERROR;
     364                 :             :         }
     365                 :         706 :       else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR)
     366                 :             :         {
     367                 :           2 :           gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
     368                 :             :                      ar->codimen + 1, corank);
     369                 :           2 :           return MATCH_ERROR;
     370                 :             :         }
     371                 :             : 
     372                 :         704 :       m = match_team_or_stat (ar);
     373                 :         704 :       if (m == MATCH_ERROR)
     374                 :             :         return MATCH_ERROR;
     375                 :         700 :       else if (m == MATCH_YES)
     376                 :         139 :         goto image_selector;
     377                 :             : 
     378                 :         561 :       if (gfc_match_char (']') == MATCH_YES)
     379                 :           0 :         goto rank_check;
     380                 :             : 
     381                 :         561 :       if (ar->codimen >= corank)
     382                 :             :         {
     383                 :           4 :           gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
     384                 :             :                      ar->codimen + 1, corank);
     385                 :           4 :           return MATCH_ERROR;
     386                 :             :         }
     387                 :             :     }
     388                 :             : 
     389                 :           0 :   gfc_error ("Array reference at %C cannot have more than %d dimensions",
     390                 :             :              GFC_MAX_DIMENSIONS);
     391                 :           0 :   return MATCH_ERROR;
     392                 :             : 
     393                 :        4156 : image_selector:
     394                 :        4156 :   for (;;)
     395                 :             :     {
     396                 :        4156 :       m = match_team_or_stat (ar);
     397                 :        4156 :       if (m == MATCH_ERROR)
     398                 :             :         return MATCH_ERROR;
     399                 :             : 
     400                 :        4146 :       if (gfc_match_char (']') == MATCH_YES)
     401                 :        4074 :         goto rank_check;
     402                 :             : 
     403                 :          72 :       if (gfc_match_char (',') != MATCH_YES)
     404                 :             :         {
     405                 :          12 :           gfc_error ("Invalid form of coarray reference at %C");
     406                 :          12 :           return MATCH_ERROR;
     407                 :             :         }
     408                 :             :     }
     409                 :             : 
     410                 :             :   return MATCH_ERROR;
     411                 :             : 
     412                 :        4074 : rank_check:
     413                 :        4074 :   ar->codimen++;
     414                 :        4074 :   if (ar->codimen < corank)
     415                 :             :     {
     416                 :          18 :       gfc_error ("Too few codimensions at %C, expected %d not %d", corank,
     417                 :             :                  ar->codimen);
     418                 :          18 :       return MATCH_ERROR;
     419                 :             :     }
     420                 :        4056 :   if (ar->codimen > corank)
     421                 :             :     {
     422                 :           2 :       gfc_error ("Too many codimensions at %C, expected %d not %d", corank,
     423                 :             :                  ar->codimen);
     424                 :           2 :       return MATCH_ERROR;
     425                 :             :     }
     426                 :             :   return MATCH_YES;
     427                 :             : }
     428                 :             : 
     429                 :             : 
     430                 :             : /************** Array specification matching subroutines ***************/
     431                 :             : 
     432                 :             : /* Free all of the expressions associated with array bounds
     433                 :             :    specifications.  */
     434                 :             : 
     435                 :             : void
     436                 :     6996904 : gfc_free_array_spec (gfc_array_spec *as)
     437                 :             : {
     438                 :     6996904 :   int i;
     439                 :             : 
     440                 :     6996904 :   if (as == NULL)
     441                 :             :     return;
     442                 :             : 
     443                 :      421185 :   if (as->corank == 0)
     444                 :             :     {
     445                 :      633512 :       for (i = 0; i < as->rank; i++)
     446                 :             :         {
     447                 :      215184 :           gfc_free_expr (as->lower[i]);
     448                 :      215184 :           gfc_free_expr (as->upper[i]);
     449                 :             :         }
     450                 :             :     }
     451                 :             :   else
     452                 :             :     {
     453                 :        2857 :       int n = as->rank + as->corank - (as->cotype == AS_EXPLICIT ? 1 : 0);
     454                 :        6472 :       for (i = 0; i < n; i++)
     455                 :             :         {
     456                 :        3615 :           gfc_free_expr (as->lower[i]);
     457                 :        3615 :           gfc_free_expr (as->upper[i]);
     458                 :             :         }
     459                 :             :     }
     460                 :             : 
     461                 :      421185 :   free (as);
     462                 :             : }
     463                 :             : 
     464                 :             : 
     465                 :             : /* Take an array bound, resolves the expression, that make up the
     466                 :             :    shape and check associated constraints.  */
     467                 :             : 
     468                 :             : static bool
     469                 :      336613 : resolve_array_bound (gfc_expr *e, int check_constant)
     470                 :             : {
     471                 :      336613 :   if (e == NULL)
     472                 :             :     return true;
     473                 :             : 
     474                 :      193737 :   if (!gfc_resolve_expr (e)
     475                 :      193737 :       || !gfc_specification_expr (e))
     476                 :          36 :     return false;
     477                 :             : 
     478                 :      193701 :   if (check_constant && !gfc_is_constant_expr (e))
     479                 :             :     {
     480                 :           0 :       if (e->expr_type == EXPR_VARIABLE)
     481                 :           0 :         gfc_error ("Variable %qs at %L in this context must be constant",
     482                 :           0 :                    e->symtree->n.sym->name, &e->where);
     483                 :             :       else
     484                 :           0 :         gfc_error ("Expression at %L in this context must be constant",
     485                 :             :                    &e->where);
     486                 :           0 :       return false;
     487                 :             :     }
     488                 :             : 
     489                 :             :   return true;
     490                 :             : }
     491                 :             : 
     492                 :             : 
     493                 :             : /* Takes an array specification, resolves the expressions that make up
     494                 :             :    the shape and make sure everything is integral.  */
     495                 :             : 
     496                 :             : bool
     497                 :     2781292 : gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
     498                 :             : {
     499                 :     2781292 :   gfc_expr *e;
     500                 :     2781292 :   int i;
     501                 :             : 
     502                 :     2781292 :   if (as == NULL)
     503                 :             :     return true;
     504                 :             : 
     505                 :      333570 :   if (as->resolved)
     506                 :             :     return true;
     507                 :             : 
     508                 :      329315 :   for (i = 0; i < as->rank + as->corank; i++)
     509                 :             :     {
     510                 :      168312 :       if (i == GFC_MAX_DIMENSIONS)
     511                 :             :         return false;
     512                 :             : 
     513                 :      168309 :       e = as->lower[i];
     514                 :      168309 :       if (!resolve_array_bound (e, check_constant))
     515                 :             :         return false;
     516                 :             : 
     517                 :      168304 :       e = as->upper[i];
     518                 :      168304 :       if (!resolve_array_bound (e, check_constant))
     519                 :             :         return false;
     520                 :             : 
     521                 :      168273 :       if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
     522                 :       97073 :         continue;
     523                 :             : 
     524                 :             :       /* If the size is negative in this dimension, set it to zero.  */
     525                 :       71200 :       if (as->lower[i]->expr_type == EXPR_CONSTANT
     526                 :       70502 :             && as->upper[i]->expr_type == EXPR_CONSTANT
     527                 :       61781 :             && mpz_cmp (as->upper[i]->value.integer,
     528                 :       61781 :                         as->lower[i]->value.integer) < 0)
     529                 :             :         {
     530                 :        1233 :           gfc_free_expr (as->upper[i]);
     531                 :        1233 :           as->upper[i] = gfc_copy_expr (as->lower[i]);
     532                 :        1233 :           mpz_sub_ui (as->upper[i]->value.integer,
     533                 :        1233 :                       as->upper[i]->value.integer, 1);
     534                 :             :         }
     535                 :             :     }
     536                 :             : 
     537                 :      161003 :   as->resolved = true;
     538                 :             : 
     539                 :      161003 :   return true;
     540                 :             : }
     541                 :             : 
     542                 :             : 
     543                 :             : /* Match a single array element specification.  The return values as
     544                 :             :    well as the upper and lower bounds of the array spec are filled
     545                 :             :    in according to what we see on the input.  The caller makes sure
     546                 :             :    individual specifications make sense as a whole.
     547                 :             : 
     548                 :             : 
     549                 :             :         Parsed       Lower   Upper  Returned
     550                 :             :         ------------------------------------
     551                 :             :           :           NULL    NULL   AS_DEFERRED (*)
     552                 :             :           x            1       x     AS_EXPLICIT
     553                 :             :           x:           x      NULL   AS_ASSUMED_SHAPE
     554                 :             :           x:y          x       y     AS_EXPLICIT
     555                 :             :           x:*          x      NULL   AS_ASSUMED_SIZE
     556                 :             :           *            1      NULL   AS_ASSUMED_SIZE
     557                 :             : 
     558                 :             :   (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE.  This
     559                 :             :   is fixed during the resolution of formal interfaces.
     560                 :             : 
     561                 :             :    Anything else AS_UNKNOWN.  */
     562                 :             : 
     563                 :             : static array_type
     564                 :      106594 : match_array_element_spec (gfc_array_spec *as)
     565                 :             : {
     566                 :      106594 :   gfc_expr **upper, **lower;
     567                 :      106594 :   match m;
     568                 :      106594 :   int rank;
     569                 :      106594 :   bool is_pdt_template;
     570                 :             : 
     571                 :      106594 :   rank = as->rank == -1 ? 0 : as->rank;
     572                 :      106594 :   lower = &as->lower[rank + as->corank - 1];
     573                 :      106594 :   upper = &as->upper[rank + as->corank - 1];
     574                 :             : 
     575                 :      106594 :   if (gfc_match_char ('*') == MATCH_YES)
     576                 :             :     {
     577                 :        7881 :       *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
     578                 :        7881 :       return AS_ASSUMED_SIZE;
     579                 :             :     }
     580                 :             : 
     581                 :       98713 :   if (gfc_match_char (':') == MATCH_YES)
     582                 :             :     {
     583                 :       37905 :       locus old_loc = gfc_current_locus;
     584                 :       37905 :       if (gfc_match_char ('*') == MATCH_YES)
     585                 :             :         {
     586                 :             :           /* F2018:R821: "assumed-implied-spec  is  [ lower-bound : ] *".  */
     587                 :           3 :           gfc_error ("A lower bound must precede colon in "
     588                 :             :                      "assumed-size array specification at %L", &old_loc);
     589                 :           3 :           return AS_UNKNOWN;
     590                 :             :         }
     591                 :             :       else
     592                 :             :         {
     593                 :             :           return AS_DEFERRED;
     594                 :             :         }
     595                 :             :     }
     596                 :             : 
     597                 :       60808 :   m = gfc_match_expr (upper);
     598                 :       60808 :   if (m == MATCH_NO)
     599                 :           1 :     gfc_error ("Expected expression in array specification at %C");
     600                 :       60808 :   if (m != MATCH_YES)
     601                 :             :     return AS_UNKNOWN;
     602                 :       60806 :   if (!gfc_expr_check_typed (*upper, gfc_current_ns, false))
     603                 :             :     return AS_UNKNOWN;
     604                 :             : 
     605                 :       60799 :   if (((*upper)->expr_type == EXPR_CONSTANT
     606                 :       60799 :         && (*upper)->ts.type != BT_INTEGER) ||
     607                 :             :       ((*upper)->expr_type == EXPR_FUNCTION
     608                 :         667 :         && (*upper)->ts.type == BT_UNKNOWN
     609                 :         666 :         && (*upper)->symtree
     610                 :         666 :         && strcmp ((*upper)->symtree->name, "null") == 0))
     611                 :             :     {
     612                 :           5 :       gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
     613                 :             :                  gfc_basic_typename ((*upper)->ts.type));
     614                 :           5 :       return AS_UNKNOWN;
     615                 :             :     }
     616                 :             : 
     617                 :      121588 :   is_pdt_template = gfc_current_block ()
     618                 :       54603 :                     && gfc_current_block ()->attr.pdt_template
     619                 :       61015 :                     && gfc_current_block ()->f2k_derived;
     620                 :             : 
     621                 :       60794 :   if ((*upper)->expr_type != EXPR_CONSTANT && is_pdt_template)
     622                 :         204 :     gfc_correct_parm_expr (gfc_current_block (), upper);
     623                 :             : 
     624                 :       60794 :   if (gfc_match_char (':') == MATCH_NO)
     625                 :             :     {
     626                 :       53725 :       *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
     627                 :       53725 :       return AS_EXPLICIT;
     628                 :             :     }
     629                 :             : 
     630                 :        7069 :   *lower = *upper;
     631                 :        7069 :   *upper = NULL;
     632                 :             : 
     633                 :        7069 :   if (gfc_match_char ('*') == MATCH_YES)
     634                 :             :     return AS_ASSUMED_SIZE;
     635                 :             : 
     636                 :        6589 :   m = gfc_match_expr (upper);
     637                 :        6589 :   if (m == MATCH_ERROR)
     638                 :             :     return AS_UNKNOWN;
     639                 :        6589 :   if (m == MATCH_NO)
     640                 :             :     return AS_ASSUMED_SHAPE;
     641                 :        5740 :   if (!gfc_expr_check_typed (*upper, gfc_current_ns, false))
     642                 :             :     return AS_UNKNOWN;
     643                 :             : 
     644                 :        5740 :   if (((*upper)->expr_type == EXPR_CONSTANT
     645                 :        5740 :         && (*upper)->ts.type != BT_INTEGER) ||
     646                 :             :       ((*upper)->expr_type == EXPR_FUNCTION
     647                 :          76 :         && (*upper)->ts.type == BT_UNKNOWN
     648                 :          76 :         && (*upper)->symtree
     649                 :          76 :         && strcmp ((*upper)->symtree->name, "null") == 0))
     650                 :             :     {
     651                 :           1 :       gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
     652                 :             :                  gfc_basic_typename ((*upper)->ts.type));
     653                 :           1 :       return AS_UNKNOWN;
     654                 :             :     }
     655                 :             : 
     656                 :        5739 :   if ((*upper)->expr_type != EXPR_CONSTANT && is_pdt_template)
     657                 :           6 :     gfc_correct_parm_expr (gfc_current_block (), upper);
     658                 :             : 
     659                 :             :   return AS_EXPLICIT;
     660                 :             : }
     661                 :             : 
     662                 :             : 
     663                 :             : /* Matches an array specification, incidentally figuring out what sort
     664                 :             :    it is.  Match either a normal array specification, or a coarray spec
     665                 :             :    or both.  Optionally allow [:] for coarrays.  */
     666                 :             : 
     667                 :             : match
     668                 :      298927 : gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
     669                 :             : {
     670                 :      298927 :   array_type current_type;
     671                 :      298927 :   gfc_array_spec *as;
     672                 :      298927 :   int i;
     673                 :             : 
     674                 :      298927 :   as = gfc_get_array_spec ();
     675                 :             : 
     676                 :      298927 :   if (!match_dim)
     677                 :          73 :     goto coarray;
     678                 :             : 
     679                 :      298854 :   if (gfc_match_char ('(') != MATCH_YES)
     680                 :             :     {
     681                 :      217354 :       if (!match_codim)
     682                 :        1160 :         goto done;
     683                 :      216194 :       goto coarray;
     684                 :             :     }
     685                 :             : 
     686                 :       81500 :   if (gfc_match (" .. )") == MATCH_YES)
     687                 :             :     {
     688                 :        4898 :       as->type = AS_ASSUMED_RANK;
     689                 :        4898 :       as->rank = -1;
     690                 :             : 
     691                 :        4898 :       if (!gfc_notify_std (GFC_STD_F2018, "Assumed-rank array at %C"))
     692                 :          29 :         goto cleanup;
     693                 :             : 
     694                 :        4869 :       if (!match_codim)
     695                 :        2092 :         goto done;
     696                 :        2777 :       goto coarray;
     697                 :             :     }
     698                 :             : 
     699                 :      104596 :   for (;;)
     700                 :             :     {
     701                 :      104596 :       as->rank++;
     702                 :      104596 :       current_type = match_array_element_spec (as);
     703                 :      104596 :       if (current_type == AS_UNKNOWN)
     704                 :          17 :         goto cleanup;
     705                 :             : 
     706                 :             :       /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
     707                 :             :          and implied-shape specifications.  If the rank is at least 2, we can
     708                 :             :          distinguish between them.  But for rank 1, we currently return
     709                 :             :          ASSUMED_SIZE; this gets adjusted later when we know for sure
     710                 :             :          whether the symbol parsed is a PARAMETER or not.  */
     711                 :             : 
     712                 :      104579 :       if (as->rank == 1)
     713                 :             :         {
     714                 :       76586 :           as->type = current_type;
     715                 :             :         }
     716                 :             :       else
     717                 :       27993 :         switch (as->type)
     718                 :             :           {             /* See how current spec meshes with the existing.  */
     719                 :           0 :           case AS_UNKNOWN:
     720                 :           0 :             goto cleanup;
     721                 :             : 
     722                 :          41 :           case AS_IMPLIED_SHAPE:
     723                 :          41 :             if (current_type != AS_ASSUMED_SIZE)
     724                 :             :               {
     725                 :           3 :                 gfc_error ("Bad array specification for implied-shape"
     726                 :             :                            " array at %C");
     727                 :           3 :                 goto cleanup;
     728                 :             :               }
     729                 :             :             break;
     730                 :             : 
     731                 :       17475 :           case AS_EXPLICIT:
     732                 :       17475 :             if (current_type == AS_ASSUMED_SIZE)
     733                 :             :               {
     734                 :         623 :                 as->type = AS_ASSUMED_SIZE;
     735                 :         623 :                 break;
     736                 :             :               }
     737                 :             : 
     738                 :       16852 :             if (current_type == AS_EXPLICIT)
     739                 :             :               break;
     740                 :             : 
     741                 :           0 :             gfc_error ("Bad array specification for an explicitly shaped "
     742                 :             :                        "array at %C");
     743                 :             : 
     744                 :           0 :             goto cleanup;
     745                 :             : 
     746                 :         236 :           case AS_ASSUMED_SHAPE:
     747                 :         236 :             if ((current_type == AS_ASSUMED_SHAPE)
     748                 :         236 :                 || (current_type == AS_DEFERRED))
     749                 :             :               break;
     750                 :             : 
     751                 :           0 :             gfc_error ("Bad array specification for assumed shape "
     752                 :             :                        "array at %C");
     753                 :           0 :             goto cleanup;
     754                 :             : 
     755                 :       10164 :           case AS_DEFERRED:
     756                 :       10164 :             if (current_type == AS_DEFERRED)
     757                 :             :               break;
     758                 :             : 
     759                 :           1 :             if (current_type == AS_ASSUMED_SHAPE)
     760                 :             :               {
     761                 :           0 :                 as->type = AS_ASSUMED_SHAPE;
     762                 :           0 :                 break;
     763                 :             :               }
     764                 :             : 
     765                 :           1 :             gfc_error ("Bad specification for deferred shape array at %C");
     766                 :           1 :             goto cleanup;
     767                 :             : 
     768                 :          77 :           case AS_ASSUMED_SIZE:
     769                 :          77 :             if (as->rank == 2 && current_type == AS_ASSUMED_SIZE)
     770                 :             :               {
     771                 :          75 :                 as->type = AS_IMPLIED_SHAPE;
     772                 :          75 :                 break;
     773                 :             :               }
     774                 :             : 
     775                 :           2 :             gfc_error ("Bad specification for assumed size array at %C");
     776                 :           2 :             goto cleanup;
     777                 :             : 
     778                 :           0 :           case AS_ASSUMED_RANK:
     779                 :           0 :             gcc_unreachable ();
     780                 :             :           }
     781                 :             : 
     782                 :      104573 :       if (gfc_match_char (')') == MATCH_YES)
     783                 :             :         break;
     784                 :             : 
     785                 :       28000 :       if (gfc_match_char (',') != MATCH_YES)
     786                 :             :         {
     787                 :           2 :           gfc_error ("Expected another dimension in array declaration at %C");
     788                 :           2 :           goto cleanup;
     789                 :             :         }
     790                 :             : 
     791                 :       27998 :       if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
     792                 :             :         {
     793                 :           2 :           gfc_error ("Array specification at %C has more than %d dimensions",
     794                 :             :                      GFC_MAX_DIMENSIONS);
     795                 :           2 :           goto cleanup;
     796                 :             :         }
     797                 :             : 
     798                 :       27996 :       if (as->corank + as->rank >= 7
     799                 :       27996 :           && !gfc_notify_std (GFC_STD_F2008, "Array specification at %C "
     800                 :             :                               "with more than 7 dimensions"))
     801                 :           2 :         goto cleanup;
     802                 :             :     }
     803                 :             : 
     804                 :       76573 :   if (!match_codim)
     805                 :       19044 :     goto done;
     806                 :             : 
     807                 :       57529 : coarray:
     808                 :      276573 :   if (gfc_match_char ('[')  != MATCH_YES)
     809                 :      275121 :     goto done;
     810                 :             : 
     811                 :        1452 :   if (!gfc_notify_std (GFC_STD_F2008, "Coarray declaration at %C"))
     812                 :           3 :     goto cleanup;
     813                 :             : 
     814                 :        1449 :   if (flag_coarray == GFC_FCOARRAY_NONE)
     815                 :             :     {
     816                 :           1 :       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
     817                 :             :       goto cleanup;
     818                 :             :     }
     819                 :             : 
     820                 :        1448 :   if (as->rank >= GFC_MAX_DIMENSIONS)
     821                 :             :     {
     822                 :           0 :       gfc_error ("Array specification at %C has more than %d "
     823                 :             :                  "dimensions", GFC_MAX_DIMENSIONS);
     824                 :           0 :       goto cleanup;
     825                 :             :     }
     826                 :             : 
     827                 :        1998 :   for (;;)
     828                 :             :     {
     829                 :        1998 :       as->corank++;
     830                 :        1998 :       current_type = match_array_element_spec (as);
     831                 :             : 
     832                 :        1998 :       if (current_type == AS_UNKNOWN)
     833                 :           1 :         goto cleanup;
     834                 :             : 
     835                 :        1997 :       if (as->corank == 1)
     836                 :        1447 :         as->cotype = current_type;
     837                 :             :       else
     838                 :         550 :         switch (as->cotype)
     839                 :             :           { /* See how current spec meshes with the existing.  */
     840                 :           0 :             case AS_IMPLIED_SHAPE:
     841                 :           0 :             case AS_UNKNOWN:
     842                 :           0 :               goto cleanup;
     843                 :             : 
     844                 :         361 :             case AS_EXPLICIT:
     845                 :         361 :               if (current_type == AS_ASSUMED_SIZE)
     846                 :             :                 {
     847                 :         186 :                   as->cotype = AS_ASSUMED_SIZE;
     848                 :         186 :                   break;
     849                 :             :                 }
     850                 :             : 
     851                 :         175 :               if (current_type == AS_EXPLICIT)
     852                 :             :                 break;
     853                 :             : 
     854                 :           0 :               gfc_error ("Bad array specification for an explicitly "
     855                 :             :                          "shaped array at %C");
     856                 :             : 
     857                 :           0 :               goto cleanup;
     858                 :             : 
     859                 :           0 :             case AS_ASSUMED_SHAPE:
     860                 :           0 :               if ((current_type == AS_ASSUMED_SHAPE)
     861                 :           0 :                   || (current_type == AS_DEFERRED))
     862                 :             :                 break;
     863                 :             : 
     864                 :           0 :               gfc_error ("Bad array specification for assumed shape "
     865                 :             :                          "array at %C");
     866                 :           0 :               goto cleanup;
     867                 :             : 
     868                 :         189 :             case AS_DEFERRED:
     869                 :         189 :               if (current_type == AS_DEFERRED)
     870                 :             :                 break;
     871                 :             : 
     872                 :           0 :               if (current_type == AS_ASSUMED_SHAPE)
     873                 :             :                 {
     874                 :           0 :                   as->cotype = AS_ASSUMED_SHAPE;
     875                 :           0 :                   break;
     876                 :             :                 }
     877                 :             : 
     878                 :           0 :               gfc_error ("Bad specification for deferred shape array at %C");
     879                 :           0 :               goto cleanup;
     880                 :             : 
     881                 :           0 :             case AS_ASSUMED_SIZE:
     882                 :           0 :               gfc_error ("Bad specification for assumed size array at %C");
     883                 :           0 :               goto cleanup;
     884                 :             : 
     885                 :           0 :             case AS_ASSUMED_RANK:
     886                 :           0 :               gcc_unreachable ();
     887                 :             :           }
     888                 :             : 
     889                 :        1997 :       if (gfc_match_char (']') == MATCH_YES)
     890                 :             :         break;
     891                 :             : 
     892                 :         552 :       if (gfc_match_char (',') != MATCH_YES)
     893                 :             :         {
     894                 :           0 :           gfc_error ("Expected another dimension in array declaration at %C");
     895                 :           0 :           goto cleanup;
     896                 :             :         }
     897                 :             : 
     898                 :         552 :       if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
     899                 :             :         {
     900                 :           2 :           gfc_error ("Array specification at %C has more than %d "
     901                 :             :                      "dimensions", GFC_MAX_DIMENSIONS);
     902                 :           2 :           goto cleanup;
     903                 :             :         }
     904                 :             :     }
     905                 :             : 
     906                 :        1445 :   if (current_type == AS_EXPLICIT)
     907                 :             :     {
     908                 :           1 :       gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
     909                 :           1 :       goto cleanup;
     910                 :             :     }
     911                 :             : 
     912                 :        1444 :   if (as->cotype == AS_ASSUMED_SIZE)
     913                 :         837 :     as->cotype = AS_EXPLICIT;
     914                 :             : 
     915                 :        1444 :   if (as->rank == 0)
     916                 :         824 :     as->type = as->cotype;
     917                 :             : 
     918                 :         620 : done:
     919                 :      298861 :   if (as->rank == 0 && as->corank == 0)
     920                 :             :     {
     921                 :      216596 :       *asp = NULL;
     922                 :      216596 :       gfc_free_array_spec (as);
     923                 :      216596 :       return MATCH_NO;
     924                 :             :     }
     925                 :             : 
     926                 :             :   /* If a lower bounds of an assumed shape array is blank, put in one.  */
     927                 :       82265 :   if (as->type == AS_ASSUMED_SHAPE)
     928                 :             :     {
     929                 :        1466 :       for (i = 0; i < as->rank + as->corank; i++)
     930                 :             :         {
     931                 :         853 :           if (as->lower[i] == NULL)
     932                 :           1 :             as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
     933                 :             :         }
     934                 :             :     }
     935                 :             : 
     936                 :       82265 :   *asp = as;
     937                 :             : 
     938                 :       82265 :   return MATCH_YES;
     939                 :             : 
     940                 :          65 : cleanup:
     941                 :             :   /* Something went wrong.  */
     942                 :          65 :   gfc_free_array_spec (as);
     943                 :          65 :   return MATCH_ERROR;
     944                 :             : }
     945                 :             : 
     946                 :             : /* Given a symbol and an array specification, modify the symbol to
     947                 :             :    have that array specification.  The error locus is needed in case
     948                 :             :    something goes wrong.  On failure, the caller must free the spec.  */
     949                 :             : 
     950                 :             : bool
     951                 :      264280 : gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
     952                 :             : {
     953                 :      264280 :   int i;
     954                 :      264280 :   symbol_attribute *attr;
     955                 :             : 
     956                 :      264280 :   if (as == NULL)
     957                 :             :     return true;
     958                 :             : 
     959                 :             :   /* If the symbol corresponds to a submodule module procedure the array spec is
     960                 :             :      already set, so do not attempt to set it again here. */
     961                 :       78790 :   attr = &sym->attr;
     962                 :       78790 :   if (gfc_submodule_procedure(attr))
     963                 :             :     return true;
     964                 :             : 
     965                 :       78789 :   if (as->rank
     966                 :       78789 :       && !gfc_add_dimension (&sym->attr, sym->name, error_loc))
     967                 :             :     return false;
     968                 :             : 
     969                 :       78783 :   if (as->corank
     970                 :       78783 :       && !gfc_add_codimension (&sym->attr, sym->name, error_loc))
     971                 :             :     return false;
     972                 :             : 
     973                 :       78778 :   if (sym->as == NULL)
     974                 :             :     {
     975                 :       78755 :       sym->as = as;
     976                 :       78755 :       return true;
     977                 :             :     }
     978                 :             : 
     979                 :          23 :   if ((sym->as->type == AS_ASSUMED_RANK && as->corank)
     980                 :          21 :       || (as->type == AS_ASSUMED_RANK && sym->as->corank))
     981                 :             :     {
     982                 :           4 :       gfc_error ("The assumed-rank array %qs at %L shall not have a "
     983                 :             :                  "codimension", sym->name, error_loc);
     984                 :           4 :       return false;
     985                 :             :     }
     986                 :             : 
     987                 :             :   /* Check F2018:C822.  */
     988                 :          19 :   if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS)
     989                 :           2 :     goto too_many;
     990                 :             : 
     991                 :          17 :   if (as->corank)
     992                 :             :     {
     993                 :           7 :       sym->as->cotype = as->cotype;
     994                 :           7 :       sym->as->corank = as->corank;
     995                 :             :       /* Check F2018:C822.  */
     996                 :           7 :       if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS)
     997                 :           2 :         goto too_many;
     998                 :             : 
     999                 :          10 :       for (i = 0; i < as->corank; i++)
    1000                 :             :         {
    1001                 :           5 :           sym->as->lower[sym->as->rank + i] = as->lower[i];
    1002                 :           5 :           sym->as->upper[sym->as->rank + i] = as->upper[i];
    1003                 :             :         }
    1004                 :             :     }
    1005                 :             :   else
    1006                 :             :     {
    1007                 :             :       /* The "sym" has no rank (checked via gfc_add_dimension). Thus
    1008                 :             :          the dimension is added - but first the codimensions (if existing
    1009                 :             :          need to be shifted to make space for the dimension.  */
    1010                 :          10 :       gcc_assert (as->corank == 0 && sym->as->rank == 0);
    1011                 :             : 
    1012                 :          10 :       sym->as->rank = as->rank;
    1013                 :          10 :       sym->as->type = as->type;
    1014                 :          10 :       sym->as->cray_pointee = as->cray_pointee;
    1015                 :          10 :       sym->as->cp_was_assumed = as->cp_was_assumed;
    1016                 :             : 
    1017                 :             :       /* Check F2018:C822.  */
    1018                 :          10 :       if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS)
    1019                 :           1 :         goto too_many;
    1020                 :             : 
    1021                 :          42 :       for (i = sym->as->corank - 1; i >= 0; i--)
    1022                 :             :         {
    1023                 :          33 :           sym->as->lower[as->rank + i] = sym->as->lower[i];
    1024                 :          33 :           sym->as->upper[as->rank + i] = sym->as->upper[i];
    1025                 :             :         }
    1026                 :          31 :       for (i = 0; i < as->rank; i++)
    1027                 :             :         {
    1028                 :          22 :           sym->as->lower[i] = as->lower[i];
    1029                 :          22 :           sym->as->upper[i] = as->upper[i];
    1030                 :             :         }
    1031                 :             :     }
    1032                 :             : 
    1033                 :          14 :   free (as);
    1034                 :          14 :   return true;
    1035                 :             : 
    1036                 :           5 : too_many:
    1037                 :             : 
    1038                 :           5 :   gfc_error ("rank + corank of %qs exceeds %d at %C", sym->name,
    1039                 :             :              GFC_MAX_DIMENSIONS);
    1040                 :           5 :   return false;
    1041                 :             : }
    1042                 :             : 
    1043                 :             : 
    1044                 :             : /* Copy an array specification.  */
    1045                 :             : 
    1046                 :             : gfc_array_spec *
    1047                 :      287738 : gfc_copy_array_spec (gfc_array_spec *src)
    1048                 :             : {
    1049                 :      287738 :   gfc_array_spec *dest;
    1050                 :      287738 :   int i;
    1051                 :             : 
    1052                 :      287738 :   if (src == NULL)
    1053                 :             :     return NULL;
    1054                 :             : 
    1055                 :       45168 :   dest = gfc_get_array_spec ();
    1056                 :             : 
    1057                 :       45168 :   *dest = *src;
    1058                 :             : 
    1059                 :       89683 :   for (i = 0; i < dest->rank + dest->corank; i++)
    1060                 :             :     {
    1061                 :       44515 :       dest->lower[i] = gfc_copy_expr (dest->lower[i]);
    1062                 :       44515 :       dest->upper[i] = gfc_copy_expr (dest->upper[i]);
    1063                 :             :     }
    1064                 :             : 
    1065                 :             :   return dest;
    1066                 :             : }
    1067                 :             : 
    1068                 :             : 
    1069                 :             : /* Returns nonzero if the two expressions are equal.
    1070                 :             :    We should not need to support more than constant values, as that's what is
    1071                 :             :    allowed in derived type component array spec.  However, we may create types
    1072                 :             :    with non-constant array spec for dummy variable class container types, for
    1073                 :             :    which the _data component holds the array spec of the variable declaration.
    1074                 :             :    So we have to support non-constant bounds as well.  */
    1075                 :             : 
    1076                 :             : static bool
    1077                 :         390 : compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
    1078                 :             : {
    1079                 :         390 :   if (bound1 == NULL || bound2 == NULL
    1080                 :         376 :       || bound1->ts.type != BT_INTEGER
    1081                 :         376 :       || bound2->ts.type != BT_INTEGER)
    1082                 :             :     return false;
    1083                 :             : 
    1084                 :             :   /* What qualifies as identical bounds?  We could probably just check that the
    1085                 :             :      expressions are exact clones.  We avoid rewriting a specific comparison
    1086                 :             :      function and re-use instead the rather involved gfc_dep_compare_expr which
    1087                 :             :      is just a bit more permissive, as it can also detect identical values for
    1088                 :             :      some mismatching expressions (extra parenthesis, swapped operands, unary
    1089                 :             :      plus, etc).  It probably only makes a difference in corner cases.  */
    1090                 :         375 :   return gfc_dep_compare_expr (bound1, bound2) == 0;
    1091                 :             : }
    1092                 :             : 
    1093                 :             : 
    1094                 :             : /* Compares two array specifications.  They must be constant or deferred
    1095                 :             :    shape.  */
    1096                 :             : 
    1097                 :             : bool
    1098                 :         698 : gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
    1099                 :             : {
    1100                 :         698 :   int i;
    1101                 :             : 
    1102                 :         698 :   if (as1 == NULL && as2 == NULL)
    1103                 :             :     return 1;
    1104                 :             : 
    1105                 :         698 :   if (as1 == NULL || as2 == NULL)
    1106                 :             :     return 0;
    1107                 :             : 
    1108                 :         698 :   if (as1->rank != as2->rank)
    1109                 :             :     return 0;
    1110                 :             : 
    1111                 :         696 :   if (as1->corank != as2->corank)
    1112                 :             :     return 0;
    1113                 :             : 
    1114                 :         696 :   if (as1->rank == 0)
    1115                 :             :     return 1;
    1116                 :             : 
    1117                 :         683 :   if (as1->type != as2->type)
    1118                 :             :     return 0;
    1119                 :             : 
    1120                 :         321 :   if (as1->cotype != as2->cotype)
    1121                 :             :     return 0;
    1122                 :             : 
    1123                 :         321 :   if (as1->type == AS_EXPLICIT)
    1124                 :         274 :     for (i = 0; i < as1->rank + as1->corank; i++)
    1125                 :             :       {
    1126                 :         195 :         if (!compare_bounds (as1->lower[i], as2->lower[i]))
    1127                 :             :           return 0;
    1128                 :             : 
    1129                 :         195 :         if (!compare_bounds (as1->upper[i], as2->upper[i]))
    1130                 :             :           return 0;
    1131                 :             :       }
    1132                 :             : 
    1133                 :             :   return 1;
    1134                 :             : }
    1135                 :             : 
    1136                 :             : 
    1137                 :             : /****************** Array constructor functions ******************/
    1138                 :             : 
    1139                 :             : 
    1140                 :             : /* Given an expression node that might be an array constructor and a
    1141                 :             :    symbol, make sure that no iterators in this or child constructors
    1142                 :             :    use the symbol as an implied-DO iterator.  Returns nonzero if a
    1143                 :             :    duplicate was found.  */
    1144                 :             : 
    1145                 :             : static bool
    1146                 :        8408 : check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
    1147                 :             : {
    1148                 :        8408 :   gfc_constructor *c;
    1149                 :        8408 :   gfc_expr *e;
    1150                 :             : 
    1151                 :       17123 :   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
    1152                 :             :     {
    1153                 :        8715 :       e = c->expr;
    1154                 :             : 
    1155                 :        8715 :       if (e->expr_type == EXPR_ARRAY
    1156                 :        8715 :           && check_duplicate_iterator (e->value.constructor, master))
    1157                 :             :         return 1;
    1158                 :             : 
    1159                 :        8715 :       if (c->iterator == NULL)
    1160                 :        8079 :         continue;
    1161                 :             : 
    1162                 :         636 :       if (c->iterator->var->symtree->n.sym == master)
    1163                 :             :         {
    1164                 :           0 :           gfc_error ("DO-iterator %qs at %L is inside iterator of the "
    1165                 :             :                      "same name", master->name, &c->where);
    1166                 :             : 
    1167                 :           0 :           return 1;
    1168                 :             :         }
    1169                 :             :     }
    1170                 :             : 
    1171                 :             :   return 0;
    1172                 :             : }
    1173                 :             : 
    1174                 :             : 
    1175                 :             : /* Forward declaration because these functions are mutually recursive.  */
    1176                 :             : static match match_array_cons_element (gfc_constructor_base *);
    1177                 :             : 
    1178                 :             : /* Match a list of array elements.  */
    1179                 :             : 
    1180                 :             : static match
    1181                 :      438767 : match_array_list (gfc_constructor_base *result)
    1182                 :             : {
    1183                 :      438767 :   gfc_constructor_base head;
    1184                 :      438767 :   gfc_constructor *p;
    1185                 :      438767 :   gfc_iterator iter;
    1186                 :      438767 :   locus old_loc;
    1187                 :      438767 :   gfc_expr *e;
    1188                 :      438767 :   match m;
    1189                 :      438767 :   int n;
    1190                 :             : 
    1191                 :      438767 :   old_loc = gfc_current_locus;
    1192                 :             : 
    1193                 :      438767 :   if (gfc_match_char ('(') == MATCH_NO)
    1194                 :             :     return MATCH_NO;
    1195                 :             : 
    1196                 :        9667 :   memset (&iter, '\0', sizeof (gfc_iterator));
    1197                 :        9667 :   head = NULL;
    1198                 :             : 
    1199                 :        9667 :   m = match_array_cons_element (&head);
    1200                 :        9667 :   if (m != MATCH_YES)
    1201                 :         147 :     goto cleanup;
    1202                 :             : 
    1203                 :        9520 :   if (gfc_match_char (',') != MATCH_YES)
    1204                 :             :     {
    1205                 :         329 :       m = MATCH_NO;
    1206                 :         329 :       goto cleanup;
    1207                 :             :     }
    1208                 :             : 
    1209                 :          58 :   for (n = 1;; n++)
    1210                 :             :     {
    1211                 :        9249 :       m = gfc_match_iterator (&iter, 0);
    1212                 :        9249 :       if (m == MATCH_YES)
    1213                 :             :         break;
    1214                 :        1584 :       if (m == MATCH_ERROR)
    1215                 :           1 :         goto cleanup;
    1216                 :             : 
    1217                 :        1583 :       m = match_array_cons_element (&head);
    1218                 :        1583 :       if (m == MATCH_ERROR)
    1219                 :           0 :         goto cleanup;
    1220                 :        1583 :       if (m == MATCH_NO)
    1221                 :             :         {
    1222                 :           0 :           if (n > 2)
    1223                 :           0 :             goto syntax;
    1224                 :           0 :           m = MATCH_NO;
    1225                 :           0 :           goto cleanup;         /* Could be a complex constant */
    1226                 :             :         }
    1227                 :             : 
    1228                 :        1583 :       if (gfc_match_char (',') != MATCH_YES)
    1229                 :             :         {
    1230                 :        1525 :           if (n > 2)
    1231                 :           0 :             goto syntax;
    1232                 :        1525 :           m = MATCH_NO;
    1233                 :        1525 :           goto cleanup;
    1234                 :             :         }
    1235                 :             :     }
    1236                 :             : 
    1237                 :        7665 :   if (gfc_match_char (')') != MATCH_YES)
    1238                 :           0 :     goto syntax;
    1239                 :             : 
    1240                 :        7665 :   if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
    1241                 :             :     {
    1242                 :           0 :       m = MATCH_ERROR;
    1243                 :           0 :       goto cleanup;
    1244                 :             :     }
    1245                 :             : 
    1246                 :        7665 :   e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
    1247                 :        7665 :   e->value.constructor = head;
    1248                 :             : 
    1249                 :        7665 :   p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
    1250                 :        7665 :   p->iterator = gfc_get_iterator ();
    1251                 :        7665 :   *p->iterator = iter;
    1252                 :             : 
    1253                 :        7665 :   return MATCH_YES;
    1254                 :             : 
    1255                 :           0 : syntax:
    1256                 :           0 :   gfc_error ("Syntax error in array constructor at %C");
    1257                 :           0 :   m = MATCH_ERROR;
    1258                 :             : 
    1259                 :        2002 : cleanup:
    1260                 :        2002 :   gfc_constructor_free (head);
    1261                 :        2002 :   gfc_free_iterator (&iter, 0);
    1262                 :        2002 :   gfc_current_locus = old_loc;
    1263                 :        2002 :   return m;
    1264                 :             : }
    1265                 :             : 
    1266                 :             : 
    1267                 :             : /* Match a single element of an array constructor, which can be a
    1268                 :             :    single expression or a list of elements.  */
    1269                 :             : 
    1270                 :             : static match
    1271                 :      438767 : match_array_cons_element (gfc_constructor_base *result)
    1272                 :             : {
    1273                 :      438767 :   gfc_expr *expr;
    1274                 :      438767 :   match m;
    1275                 :             : 
    1276                 :      438767 :   m = match_array_list (result);
    1277                 :      438767 :   if (m != MATCH_NO)
    1278                 :             :     return m;
    1279                 :             : 
    1280                 :      431100 :   m = gfc_match_expr (&expr);
    1281                 :      431100 :   if (m != MATCH_YES)
    1282                 :             :     return m;
    1283                 :             : 
    1284                 :      430945 :   if (expr->ts.type == BT_BOZ)
    1285                 :             :     {
    1286                 :           4 :       gfc_error ("BOZ literal constant at %L cannot appear in an "
    1287                 :             :                  "array constructor", &expr->where);
    1288                 :           4 :       goto done;
    1289                 :             :     }
    1290                 :             : 
    1291                 :      430941 :   if (expr->expr_type == EXPR_FUNCTION
    1292                 :       13401 :       && expr->ts.type == BT_UNKNOWN
    1293                 :       13401 :       && strcmp(expr->symtree->name, "null") == 0)
    1294                 :             :     {
    1295                 :           3 :       gfc_error ("NULL() at %C cannot appear in an array constructor");
    1296                 :           3 :       goto done;
    1297                 :             :     }
    1298                 :             : 
    1299                 :      430938 :   gfc_constructor_append_expr (result, expr, &gfc_current_locus);
    1300                 :      430938 :   return MATCH_YES;
    1301                 :             : 
    1302                 :           7 : done:
    1303                 :           7 :   gfc_free_expr (expr);
    1304                 :           7 :   return MATCH_ERROR;
    1305                 :             : }
    1306                 :             : 
    1307                 :             : 
    1308                 :             : /* Convert components of an array constructor to the type in ts.  */
    1309                 :             : 
    1310                 :             : static match
    1311                 :        3486 : walk_array_constructor (gfc_typespec *ts, gfc_constructor_base head)
    1312                 :             : {
    1313                 :        3486 :   gfc_constructor *c;
    1314                 :        3486 :   gfc_expr *e;
    1315                 :        3486 :   match m;
    1316                 :             : 
    1317                 :        7576 :   for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
    1318                 :             :     {
    1319                 :        4098 :       e = c->expr;
    1320                 :        4098 :       if (e->expr_type == EXPR_ARRAY && e->ts.type == BT_UNKNOWN
    1321                 :          48 :           && !e->ref && e->value.constructor)
    1322                 :             :         {
    1323                 :          48 :           m = walk_array_constructor (ts, e->value.constructor);
    1324                 :          48 :           if (m == MATCH_ERROR)
    1325                 :             :             return m;
    1326                 :             :         }
    1327                 :        4050 :       else if (!gfc_convert_type_warn (e, ts, 1, 1, true)
    1328                 :        4050 :                && e->ts.type != BT_UNKNOWN)
    1329                 :             :         return MATCH_ERROR;
    1330                 :             :     }
    1331                 :             :   return MATCH_YES;
    1332                 :             : }
    1333                 :             : 
    1334                 :             : /* Match an array constructor.  */
    1335                 :             : 
    1336                 :             : match
    1337                 :     4269959 : gfc_match_array_constructor (gfc_expr **result)
    1338                 :             : {
    1339                 :     4269959 :   gfc_constructor *c;
    1340                 :     4269959 :   gfc_constructor_base head;
    1341                 :     4269959 :   gfc_expr *expr;
    1342                 :     4269959 :   gfc_typespec ts;
    1343                 :     4269959 :   locus where;
    1344                 :     4269959 :   match m;
    1345                 :     4269959 :   const char *end_delim;
    1346                 :     4269959 :   bool seen_ts;
    1347                 :             : 
    1348                 :     4269959 :   head = NULL;
    1349                 :     4269959 :   seen_ts = false;
    1350                 :             : 
    1351                 :     4269959 :   if (gfc_match (" (/") == MATCH_NO)
    1352                 :             :     {
    1353                 :     4207804 :       if (gfc_match (" [") == MATCH_NO)
    1354                 :             :         return MATCH_NO;
    1355                 :             :       else
    1356                 :             :         {
    1357                 :       63925 :           if (!gfc_notify_std (GFC_STD_F2003, "[...] "
    1358                 :             :                                "style array constructors at %C"))
    1359                 :             :             return MATCH_ERROR;
    1360                 :             :           end_delim = " ]";
    1361                 :             :         }
    1362                 :             :     }
    1363                 :             :   else
    1364                 :             :     end_delim = " /)";
    1365                 :             : 
    1366                 :      126080 :   where = gfc_current_locus;
    1367                 :             : 
    1368                 :             :   /* Try to match an optional "type-spec ::"  */
    1369                 :      126080 :   gfc_clear_ts (&ts);
    1370                 :      126080 :   m = gfc_match_type_spec (&ts);
    1371                 :      126080 :   if (m == MATCH_YES)
    1372                 :             :     {
    1373                 :        5874 :       seen_ts = (gfc_match (" ::") == MATCH_YES);
    1374                 :             : 
    1375                 :        5874 :       if (seen_ts)
    1376                 :             :         {
    1377                 :        4669 :           if (!gfc_notify_std (GFC_STD_F2003, "Array constructor "
    1378                 :             :                                "including type specification at %C"))
    1379                 :           1 :             goto cleanup;
    1380                 :             : 
    1381                 :        4668 :           if (ts.deferred)
    1382                 :             :             {
    1383                 :           1 :               gfc_error ("Type-spec at %L cannot contain a deferred "
    1384                 :             :                          "type parameter", &where);
    1385                 :           1 :               goto cleanup;
    1386                 :             :             }
    1387                 :             : 
    1388                 :        4667 :           if (ts.type == BT_CHARACTER
    1389                 :         650 :               && ts.u.cl && !ts.u.cl->length && !ts.u.cl->length_from_typespec)
    1390                 :             :             {
    1391                 :           1 :               gfc_error ("Type-spec at %L cannot contain an asterisk for a "
    1392                 :             :                          "type parameter", &where);
    1393                 :           1 :               goto cleanup;
    1394                 :             :             }
    1395                 :             :         }
    1396                 :             :     }
    1397                 :      120206 :   else if (m == MATCH_ERROR)
    1398                 :          21 :     goto cleanup;
    1399                 :             : 
    1400                 :        5871 :   if (!seen_ts)
    1401                 :      121390 :     gfc_current_locus = where;
    1402                 :             : 
    1403                 :      126056 :   if (gfc_match (end_delim) == MATCH_YES)
    1404                 :             :     {
    1405                 :        1629 :       if (seen_ts)
    1406                 :        1628 :         goto done;
    1407                 :             :       else
    1408                 :             :         {
    1409                 :           1 :           gfc_error ("Empty array constructor at %C is not allowed");
    1410                 :           1 :           goto cleanup;
    1411                 :             :         }
    1412                 :             :     }
    1413                 :             : 
    1414                 :      427517 :   for (;;)
    1415                 :             :     {
    1416                 :      427517 :       m = match_array_cons_element (&head);
    1417                 :      427517 :       if (m == MATCH_ERROR)
    1418                 :          17 :         goto cleanup;
    1419                 :      427500 :       if (m == MATCH_NO)
    1420                 :           0 :         goto syntax;
    1421                 :             : 
    1422                 :      427500 :       if (gfc_match_char (',') == MATCH_NO)
    1423                 :             :         break;
    1424                 :             :     }
    1425                 :             : 
    1426                 :      124410 :   if (gfc_match (end_delim) == MATCH_NO)
    1427                 :           6 :     goto syntax;
    1428                 :             : 
    1429                 :      126032 : done:
    1430                 :             :   /* Size must be calculated at resolution time.  */
    1431                 :      126032 :   if (seen_ts)
    1432                 :             :     {
    1433                 :        4661 :       expr = gfc_get_array_expr (ts.type, ts.kind, &where);
    1434                 :        4661 :       expr->ts = ts;
    1435                 :             : 
    1436                 :             :       /* If the typespec is CHARACTER, check that array elements can
    1437                 :             :          be converted.  See PR fortran/67803.  */
    1438                 :        4661 :       if (ts.type == BT_CHARACTER)
    1439                 :             :         {
    1440                 :         649 :           c = gfc_constructor_first (head);
    1441                 :        2412 :           for (; c; c = gfc_constructor_next (c))
    1442                 :             :             {
    1443                 :        1119 :               if (gfc_numeric_ts (&c->expr->ts)
    1444                 :        1119 :                   || c->expr->ts.type == BT_LOGICAL)
    1445                 :             :                 {
    1446                 :           5 :                   gfc_error ("Incompatible typespec for array element at %L",
    1447                 :           5 :                              &c->expr->where);
    1448                 :           5 :                   return MATCH_ERROR;
    1449                 :             :                 }
    1450                 :             : 
    1451                 :             :               /* Special case null().  */
    1452                 :        1114 :               if (c->expr->expr_type == EXPR_FUNCTION
    1453                 :          54 :                   && c->expr->ts.type == BT_UNKNOWN
    1454                 :          54 :                   && strcmp (c->expr->symtree->name, "null") == 0)
    1455                 :             :                 {
    1456                 :           0 :                   gfc_error ("Incompatible typespec for array element at %L",
    1457                 :             :                              &c->expr->where);
    1458                 :           0 :                   return MATCH_ERROR;
    1459                 :             :                 }
    1460                 :             :             }
    1461                 :             :         }
    1462                 :             : 
    1463                 :             :       /* Walk the constructor, and if possible, do type conversion for
    1464                 :             :          numeric types.  */
    1465                 :        4656 :       if (gfc_numeric_ts (&ts))
    1466                 :             :         {
    1467                 :        3438 :           m = walk_array_constructor (&ts, head);
    1468                 :        3438 :           if (m == MATCH_ERROR)
    1469                 :             :             return m;
    1470                 :             :         }
    1471                 :             :     }
    1472                 :             :   else
    1473                 :      121371 :     expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
    1474                 :             : 
    1475                 :      126020 :   expr->value.constructor = head;
    1476                 :      126020 :   if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
    1477                 :         644 :     expr->ts.u.cl->length_from_typespec = seen_ts;
    1478                 :             : 
    1479                 :      126020 :   *result = expr;
    1480                 :             : 
    1481                 :      126020 :   return MATCH_YES;
    1482                 :             : 
    1483                 :           6 : syntax:
    1484                 :           6 :   gfc_error ("Syntax error in array constructor at %C");
    1485                 :             : 
    1486                 :          48 : cleanup:
    1487                 :          48 :   gfc_constructor_free (head);
    1488                 :          48 :   return MATCH_ERROR;
    1489                 :             : }
    1490                 :             : 
    1491                 :             : 
    1492                 :             : 
    1493                 :             : /************** Check array constructors for correctness **************/
    1494                 :             : 
    1495                 :             : /* Given an expression, compare it's type with the type of the current
    1496                 :             :    constructor.  Returns nonzero if an error was issued.  The
    1497                 :             :    cons_state variable keeps track of whether the type of the
    1498                 :             :    constructor being read or resolved is known to be good, bad or just
    1499                 :             :    starting out.  */
    1500                 :             : 
    1501                 :             : static gfc_typespec constructor_ts;
    1502                 :             : static enum
    1503                 :             : { CONS_START, CONS_GOOD, CONS_BAD }
    1504                 :             : cons_state;
    1505                 :             : 
    1506                 :             : static int
    1507                 :      985396 : check_element_type (gfc_expr *expr, bool convert)
    1508                 :             : {
    1509                 :      985396 :   if (cons_state == CONS_BAD)
    1510                 :             :     return 0;                   /* Suppress further errors */
    1511                 :             : 
    1512                 :      985396 :   if (cons_state == CONS_START)
    1513                 :             :     {
    1514                 :       53818 :       if (expr->ts.type == BT_UNKNOWN)
    1515                 :           0 :         cons_state = CONS_BAD;
    1516                 :             :       else
    1517                 :             :         {
    1518                 :       53818 :           cons_state = CONS_GOOD;
    1519                 :       53818 :           constructor_ts = expr->ts;
    1520                 :             :         }
    1521                 :             : 
    1522                 :       53818 :       return 0;
    1523                 :             :     }
    1524                 :             : 
    1525                 :      931578 :   if (gfc_compare_types (&constructor_ts, &expr->ts))
    1526                 :             :     return 0;
    1527                 :             : 
    1528                 :          63 :   if (convert)
    1529                 :          63 :     return gfc_convert_type_warn (expr, &constructor_ts, 1, 1, true) ? 0 : 1;
    1530                 :             : 
    1531                 :           0 :   gfc_error ("Element in %s array constructor at %L is %s",
    1532                 :             :              gfc_typename (&constructor_ts), &expr->where,
    1533                 :             :              gfc_typename (expr));
    1534                 :             : 
    1535                 :           0 :   cons_state = CONS_BAD;
    1536                 :           0 :   return 1;
    1537                 :             : }
    1538                 :             : 
    1539                 :             : 
    1540                 :             : /* Recursive work function for gfc_check_constructor_type().  */
    1541                 :             : 
    1542                 :             : static bool
    1543                 :       83686 : check_constructor_type (gfc_constructor_base base, bool convert)
    1544                 :             : {
    1545                 :       83686 :   gfc_constructor *c;
    1546                 :       83686 :   gfc_expr *e;
    1547                 :             : 
    1548                 :     1074940 :   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
    1549                 :             :     {
    1550                 :      991309 :       e = c->expr;
    1551                 :             : 
    1552                 :      991309 :       if (e->expr_type == EXPR_ARRAY)
    1553                 :             :         {
    1554                 :        5913 :           if (!check_constructor_type (e->value.constructor, convert))
    1555                 :             :             return false;
    1556                 :             : 
    1557                 :        5887 :           continue;
    1558                 :             :         }
    1559                 :             : 
    1560                 :      985396 :       if (check_element_type (e, convert))
    1561                 :             :         return false;
    1562                 :             :     }
    1563                 :             : 
    1564                 :             :   return true;
    1565                 :             : }
    1566                 :             : 
    1567                 :             : 
    1568                 :             : /* Check that all elements of an array constructor are the same type.
    1569                 :             :    On false, an error has been generated.  */
    1570                 :             : 
    1571                 :             : bool
    1572                 :       77773 : gfc_check_constructor_type (gfc_expr *e)
    1573                 :             : {
    1574                 :       77773 :   bool t;
    1575                 :             : 
    1576                 :       77773 :   if (e->ts.type != BT_UNKNOWN)
    1577                 :             :     {
    1578                 :       23946 :       cons_state = CONS_GOOD;
    1579                 :       23946 :       constructor_ts = e->ts;
    1580                 :             :     }
    1581                 :             :   else
    1582                 :             :     {
    1583                 :       53827 :       cons_state = CONS_START;
    1584                 :       53827 :       gfc_clear_ts (&constructor_ts);
    1585                 :             :     }
    1586                 :             : 
    1587                 :             :   /* If e->ts.type != BT_UNKNOWN, the array constructor included a
    1588                 :             :      typespec, and we will now convert the values on the fly.  */
    1589                 :       77773 :   t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
    1590                 :       77773 :   if (t && e->ts.type == BT_UNKNOWN)
    1591                 :       53827 :     e->ts = constructor_ts;
    1592                 :             : 
    1593                 :       77773 :   return t;
    1594                 :             : }
    1595                 :             : 
    1596                 :             : 
    1597                 :             : 
    1598                 :             : typedef struct cons_stack
    1599                 :             : {
    1600                 :             :   gfc_iterator *iterator;
    1601                 :             :   struct cons_stack *previous;
    1602                 :             : }
    1603                 :             : cons_stack;
    1604                 :             : 
    1605                 :             : static cons_stack *base;
    1606                 :             : 
    1607                 :             : static bool check_constructor (gfc_constructor_base, bool (*) (gfc_expr *));
    1608                 :             : 
    1609                 :             : /* Check an EXPR_VARIABLE expression in a constructor to make sure
    1610                 :             :    that that variable is an iteration variable.  */
    1611                 :             : 
    1612                 :             : bool
    1613                 :        6350 : gfc_check_iter_variable (gfc_expr *expr)
    1614                 :             : {
    1615                 :        6350 :   gfc_symbol *sym;
    1616                 :        6350 :   cons_stack *c;
    1617                 :             : 
    1618                 :        6350 :   sym = expr->symtree->n.sym;
    1619                 :             : 
    1620                 :        6360 :   for (c = base; c && c->iterator; c = c->previous)
    1621                 :          26 :     if (sym == c->iterator->var->symtree->n.sym)
    1622                 :             :       return true;
    1623                 :             : 
    1624                 :             :   return false;
    1625                 :             : }
    1626                 :             : 
    1627                 :             : 
    1628                 :             : /* Recursive work function for gfc_check_constructor().  This amounts
    1629                 :             :    to calling the check function for each expression in the
    1630                 :             :    constructor, giving variables with the names of iterators a pass.  */
    1631                 :             : 
    1632                 :             : static bool
    1633                 :        7027 : check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr *))
    1634                 :             : {
    1635                 :        7027 :   cons_stack element;
    1636                 :        7027 :   gfc_expr *e;
    1637                 :        7027 :   bool t;
    1638                 :        7027 :   gfc_constructor *c;
    1639                 :             : 
    1640                 :      355722 :   for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
    1641                 :             :     {
    1642                 :      348721 :       e = c->expr;
    1643                 :             : 
    1644                 :      348721 :       if (!e)
    1645                 :           0 :         continue;
    1646                 :             : 
    1647                 :      348721 :       if (e->expr_type != EXPR_ARRAY)
    1648                 :             :         {
    1649                 :      348513 :           if (!(*check_function)(e))
    1650                 :             :             return false;
    1651                 :      348493 :           continue;
    1652                 :             :         }
    1653                 :             : 
    1654                 :         208 :       element.previous = base;
    1655                 :         208 :       element.iterator = c->iterator;
    1656                 :             : 
    1657                 :         208 :       base = &element;
    1658                 :         208 :       t = check_constructor (e->value.constructor, check_function);
    1659                 :         208 :       base = element.previous;
    1660                 :             : 
    1661                 :         208 :       if (!t)
    1662                 :             :         return false;
    1663                 :             :     }
    1664                 :             : 
    1665                 :             :   /* Nothing went wrong, so all OK.  */
    1666                 :             :   return true;
    1667                 :             : }
    1668                 :             : 
    1669                 :             : 
    1670                 :             : /* Checks a constructor to see if it is a particular kind of
    1671                 :             :    expression -- specification, restricted, or initialization as
    1672                 :             :    determined by the check_function.  */
    1673                 :             : 
    1674                 :             : bool
    1675                 :        6819 : gfc_check_constructor (gfc_expr *expr, bool (*check_function) (gfc_expr *))
    1676                 :             : {
    1677                 :        6819 :   cons_stack *base_save;
    1678                 :        6819 :   bool t;
    1679                 :             : 
    1680                 :        6819 :   base_save = base;
    1681                 :        6819 :   base = NULL;
    1682                 :             : 
    1683                 :        6819 :   t = check_constructor (expr->value.constructor, check_function);
    1684                 :        6819 :   base = base_save;
    1685                 :             : 
    1686                 :        6819 :   return t;
    1687                 :             : }
    1688                 :             : 
    1689                 :             : 
    1690                 :             : 
    1691                 :             : /**************** Simplification of array constructors ****************/
    1692                 :             : 
    1693                 :             : iterator_stack *iter_stack;
    1694                 :             : 
    1695                 :             : typedef struct
    1696                 :             : {
    1697                 :             :   gfc_constructor_base base;
    1698                 :             :   int extract_count, extract_n;
    1699                 :             :   gfc_expr *extracted;
    1700                 :             :   mpz_t *count;
    1701                 :             : 
    1702                 :             :   mpz_t *offset;
    1703                 :             :   gfc_component *component;
    1704                 :             :   mpz_t *repeat;
    1705                 :             : 
    1706                 :             :   bool (*expand_work_function) (gfc_expr *);
    1707                 :             : }
    1708                 :             : expand_info;
    1709                 :             : 
    1710                 :             : static expand_info current_expand;
    1711                 :             : 
    1712                 :             : static bool expand_constructor (gfc_constructor_base);
    1713                 :             : 
    1714                 :             : 
    1715                 :             : /* Work function that counts the number of elements present in a
    1716                 :             :    constructor.  */
    1717                 :             : 
    1718                 :             : static bool
    1719                 :     4329520 : count_elements (gfc_expr *e)
    1720                 :             : {
    1721                 :     4329520 :   mpz_t result;
    1722                 :             : 
    1723                 :     4329520 :   if (e->rank == 0)
    1724                 :     4326636 :     mpz_add_ui (*current_expand.count, *current_expand.count, 1);
    1725                 :             :   else
    1726                 :             :     {
    1727                 :        2884 :       if (!gfc_array_size (e, &result))
    1728                 :             :         {
    1729                 :         499 :           gfc_free_expr (e);
    1730                 :         499 :           return false;
    1731                 :             :         }
    1732                 :             : 
    1733                 :        2385 :       mpz_add (*current_expand.count, *current_expand.count, result);
    1734                 :        2385 :       mpz_clear (result);
    1735                 :             :     }
    1736                 :             : 
    1737                 :     4329021 :   gfc_free_expr (e);
    1738                 :     4329021 :   return true;
    1739                 :             : }
    1740                 :             : 
    1741                 :             : 
    1742                 :             : /* Work function that extracts a particular element from an array
    1743                 :             :    constructor, freeing the rest.  */
    1744                 :             : 
    1745                 :             : static bool
    1746                 :     4934148 : extract_element (gfc_expr *e)
    1747                 :             : {
    1748                 :     4934148 :   if (e->rank != 0)
    1749                 :             :     {                           /* Something unextractable */
    1750                 :        1183 :       gfc_free_expr (e);
    1751                 :        1183 :       return false;
    1752                 :             :     }
    1753                 :             : 
    1754                 :     4932965 :   if (current_expand.extract_count == current_expand.extract_n)
    1755                 :          37 :     current_expand.extracted = e;
    1756                 :             :   else
    1757                 :     4932928 :     gfc_free_expr (e);
    1758                 :             : 
    1759                 :     4932965 :   current_expand.extract_count++;
    1760                 :             : 
    1761                 :     4932965 :   return true;
    1762                 :             : }
    1763                 :             : 
    1764                 :             : 
    1765                 :             : /* Work function that constructs a new constructor out of the old one,
    1766                 :             :    stringing new elements together.  */
    1767                 :             : 
    1768                 :             : static bool
    1769                 :     1279371 : expand (gfc_expr *e)
    1770                 :             : {
    1771                 :     1279371 :   gfc_constructor *c = gfc_constructor_append_expr (&current_expand.base,
    1772                 :             :                                                     e, &e->where);
    1773                 :             : 
    1774                 :     1279371 :   c->n.component = current_expand.component;
    1775                 :     1279371 :   return true;
    1776                 :             : }
    1777                 :             : 
    1778                 :             : 
    1779                 :             : /* Given an initialization expression that is a variable reference,
    1780                 :             :    substitute the current value of the iteration variable.  */
    1781                 :             : 
    1782                 :             : void
    1783                 :    13968374 : gfc_simplify_iterator_var (gfc_expr *e)
    1784                 :             : {
    1785                 :    13968374 :   iterator_stack *p;
    1786                 :             : 
    1787                 :    19231013 :   for (p = iter_stack; p; p = p->prev)
    1788                 :    19113916 :     if (e->symtree == p->variable)
    1789                 :             :       break;
    1790                 :             : 
    1791                 :    13968374 :   if (p == NULL)
    1792                 :             :     return;             /* Variable not found */
    1793                 :             : 
    1794                 :    13851277 :   gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
    1795                 :             : 
    1796                 :    13851277 :   mpz_set (e->value.integer, p->value);
    1797                 :             : 
    1798                 :    13851277 :   return;
    1799                 :             : }
    1800                 :             : 
    1801                 :             : 
    1802                 :             : /* Expand an expression with that is inside of a constructor,
    1803                 :             :    recursing into other constructors if present.  */
    1804                 :             : 
    1805                 :             : static bool
    1806                 :    11258919 : expand_expr (gfc_expr *e)
    1807                 :             : {
    1808                 :    11258919 :   if (e->expr_type == EXPR_ARRAY)
    1809                 :    11258919 :     return expand_constructor (e->value.constructor);
    1810                 :             : 
    1811                 :           0 :   e = gfc_copy_expr (e);
    1812                 :             : 
    1813                 :           0 :   if (!gfc_simplify_expr (e, 1))
    1814                 :             :     {
    1815                 :           0 :       gfc_free_expr (e);
    1816                 :           0 :       return false;
    1817                 :             :     }
    1818                 :             : 
    1819                 :           0 :   return current_expand.expand_work_function (e);
    1820                 :             : }
    1821                 :             : 
    1822                 :             : 
    1823                 :             : static bool
    1824                 :       27796 : expand_iterator (gfc_constructor *c)
    1825                 :             : {
    1826                 :       27796 :   gfc_expr *start, *end, *step;
    1827                 :       27796 :   iterator_stack frame;
    1828                 :       27796 :   mpz_t trip;
    1829                 :       27796 :   bool t;
    1830                 :             : 
    1831                 :       27796 :   end = step = NULL;
    1832                 :             : 
    1833                 :       27796 :   t = false;
    1834                 :             : 
    1835                 :       27796 :   mpz_init (trip);
    1836                 :       27796 :   mpz_init (frame.value);
    1837                 :       27796 :   frame.prev = NULL;
    1838                 :             : 
    1839                 :       27796 :   start = gfc_copy_expr (c->iterator->start);
    1840                 :       27796 :   if (!gfc_simplify_expr (start, 1))
    1841                 :           0 :     goto cleanup;
    1842                 :             : 
    1843                 :       27796 :   if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
    1844                 :         936 :     goto cleanup;
    1845                 :             : 
    1846                 :       26860 :   end = gfc_copy_expr (c->iterator->end);
    1847                 :       26860 :   if (!gfc_simplify_expr (end, 1))
    1848                 :           0 :     goto cleanup;
    1849                 :             : 
    1850                 :       26860 :   if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
    1851                 :        2902 :     goto cleanup;
    1852                 :             : 
    1853                 :       23958 :   step = gfc_copy_expr (c->iterator->step);
    1854                 :       23958 :   if (!gfc_simplify_expr (step, 1))
    1855                 :           0 :     goto cleanup;
    1856                 :             : 
    1857                 :       23958 :   if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
    1858                 :           0 :     goto cleanup;
    1859                 :             : 
    1860                 :       23958 :   if (mpz_sgn (step->value.integer) == 0)
    1861                 :             :     {
    1862                 :           0 :       gfc_error ("Iterator step at %L cannot be zero", &step->where);
    1863                 :           0 :       goto cleanup;
    1864                 :             :     }
    1865                 :             : 
    1866                 :             :   /* Calculate the trip count of the loop.  */
    1867                 :       23958 :   mpz_sub (trip, end->value.integer, start->value.integer);
    1868                 :       23958 :   mpz_add (trip, trip, step->value.integer);
    1869                 :       23958 :   mpz_tdiv_q (trip, trip, step->value.integer);
    1870                 :             : 
    1871                 :       23958 :   mpz_set (frame.value, start->value.integer);
    1872                 :             : 
    1873                 :       23958 :   frame.prev = iter_stack;
    1874                 :       23958 :   frame.variable = c->iterator->var->symtree;
    1875                 :       23958 :   iter_stack = &frame;
    1876                 :             : 
    1877                 :    11281712 :   while (mpz_sgn (trip) > 0)
    1878                 :             :     {
    1879                 :    11258919 :       if (!expand_expr (c->expr))
    1880                 :        1165 :         goto cleanup;
    1881                 :             : 
    1882                 :    11257754 :       mpz_add (frame.value, frame.value, step->value.integer);
    1883                 :    11257754 :       mpz_sub_ui (trip, trip, 1);
    1884                 :             :     }
    1885                 :             : 
    1886                 :             :   t = true;
    1887                 :             : 
    1888                 :       27796 : cleanup:
    1889                 :       27796 :   gfc_free_expr (start);
    1890                 :       27796 :   gfc_free_expr (end);
    1891                 :       27796 :   gfc_free_expr (step);
    1892                 :             : 
    1893                 :       27796 :   mpz_clear (trip);
    1894                 :       27796 :   mpz_clear (frame.value);
    1895                 :             : 
    1896                 :       27796 :   iter_stack = frame.prev;
    1897                 :             : 
    1898                 :       27796 :   return t;
    1899                 :             : }
    1900                 :             : 
    1901                 :             : /* Variables for noticing if all constructors are empty, and
    1902                 :             :    if any of them had a type.  */
    1903                 :             : 
    1904                 :             : static bool empty_constructor;
    1905                 :             : static gfc_typespec empty_ts;
    1906                 :             : 
    1907                 :             : /* Expand a constructor into constant constructors without any
    1908                 :             :    iterators, calling the work function for each of the expanded
    1909                 :             :    expressions.  The work function needs to either save or free the
    1910                 :             :    passed expression.  */
    1911                 :             : 
    1912                 :             : static bool
    1913                 :    11541877 : expand_constructor (gfc_constructor_base base)
    1914                 :             : {
    1915                 :    11541877 :   gfc_constructor *c;
    1916                 :    11541877 :   gfc_expr *e;
    1917                 :             : 
    1918                 :    29191396 :   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
    1919                 :             :     {
    1920                 :    17657371 :       if (c->iterator != NULL)
    1921                 :             :         {
    1922                 :       27796 :           if (!expand_iterator (c))
    1923                 :             :             return false;
    1924                 :       22793 :           continue;
    1925                 :             :         }
    1926                 :             : 
    1927                 :    17629575 :       e = c->expr;
    1928                 :             : 
    1929                 :    17629575 :       if (e == NULL)
    1930                 :             :         return false;
    1931                 :             : 
    1932                 :    17629575 :       if (empty_constructor)
    1933                 :       90144 :         empty_ts = e->ts;
    1934                 :             : 
    1935                 :             :       /* Simplify constant array expression/section within constructor.  */
    1936                 :    17629575 :       if (e->expr_type == EXPR_VARIABLE && e->rank > 0 && e->ref
    1937                 :        4361 :           && e->symtree && e->symtree->n.sym
    1938                 :        4361 :           && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
    1939                 :         715 :         gfc_simplify_expr (e, 0);
    1940                 :             : 
    1941                 :    17629575 :       if (e->expr_type == EXPR_ARRAY)
    1942                 :             :         {
    1943                 :        6772 :           if (!expand_constructor (e->value.constructor))
    1944                 :             :             return false;
    1945                 :             : 
    1946                 :        6741 :           continue;
    1947                 :             :         }
    1948                 :             : 
    1949                 :    17622803 :       empty_constructor = false;
    1950                 :    17622803 :       e = gfc_copy_expr (e);
    1951                 :    17622803 :       if (!gfc_simplify_expr (e, 1))
    1952                 :             :         {
    1953                 :         200 :           gfc_free_expr (e);
    1954                 :         200 :           return false;
    1955                 :             :         }
    1956                 :    17622603 :       e->from_constructor = 1;
    1957                 :    17622603 :       current_expand.offset = &c->offset;
    1958                 :    17622603 :       current_expand.repeat = &c->repeat;
    1959                 :    17622603 :       current_expand.component = c->n.component;
    1960                 :    17622603 :       if (!current_expand.expand_work_function(e))
    1961                 :             :         return false;
    1962                 :             :     }
    1963                 :             :   return true;
    1964                 :             : }
    1965                 :             : 
    1966                 :             : 
    1967                 :             : /* Given an array expression and an element number (starting at zero),
    1968                 :             :    return a pointer to the array element.  NULL is returned if the
    1969                 :             :    size of the array has been exceeded.  The expression node returned
    1970                 :             :    remains a part of the array and should not be freed.  Access is not
    1971                 :             :    efficient at all, but this is another place where things do not
    1972                 :             :    have to be particularly fast.  */
    1973                 :             : 
    1974                 :             : static gfc_expr *
    1975                 :       89114 : gfc_get_array_element (gfc_expr *array, int element)
    1976                 :             : {
    1977                 :       89114 :   expand_info expand_save;
    1978                 :       89114 :   gfc_expr *e;
    1979                 :       89114 :   bool rc;
    1980                 :             : 
    1981                 :       89114 :   expand_save = current_expand;
    1982                 :       89114 :   current_expand.extract_n = element;
    1983                 :       89114 :   current_expand.expand_work_function = extract_element;
    1984                 :       89114 :   current_expand.extracted = NULL;
    1985                 :       89114 :   current_expand.extract_count = 0;
    1986                 :             : 
    1987                 :       89114 :   iter_stack = NULL;
    1988                 :             : 
    1989                 :       89114 :   rc = expand_constructor (array->value.constructor);
    1990                 :       89114 :   e = current_expand.extracted;
    1991                 :       89114 :   current_expand = expand_save;
    1992                 :             : 
    1993                 :       89114 :   if (!rc)
    1994                 :        1677 :     return NULL;
    1995                 :             : 
    1996                 :             :   return e;
    1997                 :             : }
    1998                 :             : 
    1999                 :             : 
    2000                 :             : /* Top level subroutine for expanding constructors.  We only expand
    2001                 :             :    constructor if they are small enough.  */
    2002                 :             : 
    2003                 :             : bool
    2004                 :       91244 : gfc_expand_constructor (gfc_expr *e, bool fatal)
    2005                 :             : {
    2006                 :       91244 :   expand_info expand_save;
    2007                 :       91244 :   gfc_expr *f;
    2008                 :       91244 :   bool rc;
    2009                 :             : 
    2010                 :       91244 :   if (gfc_is_size_zero_array (e))
    2011                 :             :     return true;
    2012                 :             : 
    2013                 :             :   /* If we can successfully get an array element at the max array size then
    2014                 :             :      the array is too big to expand, so we just return.  */
    2015                 :       89114 :   f = gfc_get_array_element (e, flag_max_array_constructor);
    2016                 :       89114 :   if (f != NULL)
    2017                 :             :     {
    2018                 :          37 :       gfc_free_expr (f);
    2019                 :          37 :       if (fatal)
    2020                 :             :         {
    2021                 :           8 :           gfc_error ("The number of elements in the array constructor "
    2022                 :             :                      "at %L requires an increase of the allowed %d "
    2023                 :             :                      "upper limit.   See %<-fmax-array-constructor%> "
    2024                 :             :                      "option", &e->where, flag_max_array_constructor);
    2025                 :           8 :           return false;
    2026                 :             :         }
    2027                 :             :       return true;
    2028                 :             :     }
    2029                 :             : 
    2030                 :             :   /* We now know the array is not too big so go ahead and try to expand it.  */
    2031                 :       89077 :   expand_save = current_expand;
    2032                 :       89077 :   current_expand.base = NULL;
    2033                 :             : 
    2034                 :       89077 :   iter_stack = NULL;
    2035                 :             : 
    2036                 :       89077 :   empty_constructor = true;
    2037                 :       89077 :   gfc_clear_ts (&empty_ts);
    2038                 :       89077 :   current_expand.expand_work_function = expand;
    2039                 :             : 
    2040                 :       89077 :   if (!expand_constructor (e->value.constructor))
    2041                 :             :     {
    2042                 :         494 :       gfc_constructor_free (current_expand.base);
    2043                 :         494 :       rc = false;
    2044                 :         494 :       goto done;
    2045                 :             :     }
    2046                 :             : 
    2047                 :             :   /* If we don't have an explicit constructor type, and there
    2048                 :             :      were only empty constructors, then take the type from
    2049                 :             :      them.  */
    2050                 :             : 
    2051                 :       88583 :   if (constructor_ts.type == BT_UNKNOWN && empty_constructor)
    2052                 :           8 :     e->ts = empty_ts;
    2053                 :             : 
    2054                 :       88583 :   gfc_constructor_free (e->value.constructor);
    2055                 :       88583 :   e->value.constructor = current_expand.base;
    2056                 :             : 
    2057                 :       88583 :   rc = true;
    2058                 :             : 
    2059                 :       89077 : done:
    2060                 :       89077 :   current_expand = expand_save;
    2061                 :             : 
    2062                 :       89077 :   return rc;
    2063                 :             : }
    2064                 :             : 
    2065                 :             : 
    2066                 :             : /* Work function for checking that an element of a constructor is a
    2067                 :             :    constant, after removal of any iteration variables.  We return
    2068                 :             :    false if not so.  */
    2069                 :             : 
    2070                 :             : static bool
    2071                 :     7079564 : is_constant_element (gfc_expr *e)
    2072                 :             : {
    2073                 :     7079564 :   int rv;
    2074                 :             : 
    2075                 :     7079564 :   rv = gfc_is_constant_expr (e);
    2076                 :     7079564 :   gfc_free_expr (e);
    2077                 :             : 
    2078                 :     7079564 :   return rv ? true : false;
    2079                 :             : }
    2080                 :             : 
    2081                 :             : 
    2082                 :             : /* Given an array constructor, determine if the constructor is
    2083                 :             :    constant or not by expanding it and making sure that all elements
    2084                 :             :    are constants.  This is a bit of a hack since something like (/ (i,
    2085                 :             :    i=1,100000000) /) will take a while as* opposed to a more clever
    2086                 :             :    function that traverses the expression tree. FIXME.  */
    2087                 :             : 
    2088                 :             : bool
    2089                 :        5513 : gfc_constant_ac (gfc_expr *e)
    2090                 :             : {
    2091                 :        5513 :   expand_info expand_save;
    2092                 :        5513 :   bool rc;
    2093                 :             : 
    2094                 :        5513 :   iter_stack = NULL;
    2095                 :        5513 :   expand_save = current_expand;
    2096                 :        5513 :   current_expand.expand_work_function = is_constant_element;
    2097                 :             : 
    2098                 :        5513 :   rc = expand_constructor (e->value.constructor);
    2099                 :             : 
    2100                 :        5513 :   current_expand = expand_save;
    2101                 :        5513 :   if (!rc)
    2102                 :             :     return 0;
    2103                 :             : 
    2104                 :             :   return 1;
    2105                 :             : }
    2106                 :             : 
    2107                 :             : 
    2108                 :             : /* Returns nonzero if an array constructor has been completely
    2109                 :             :    expanded (no iterators) and zero if iterators are present.  */
    2110                 :             : 
    2111                 :             : bool
    2112                 :       26961 : gfc_expanded_ac (gfc_expr *e)
    2113                 :             : {
    2114                 :       26961 :   gfc_constructor *c;
    2115                 :             : 
    2116                 :       26961 :   if (e->expr_type == EXPR_ARRAY)
    2117                 :        5670 :     for (c = gfc_constructor_first (e->value.constructor);
    2118                 :       27377 :          c; c = gfc_constructor_next (c))
    2119                 :       21707 :       if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
    2120                 :           0 :         return 0;
    2121                 :             : 
    2122                 :             :   return 1;
    2123                 :             : }
    2124                 :             : 
    2125                 :             : 
    2126                 :             : /*************** Type resolution of array constructors ***************/
    2127                 :             : 
    2128                 :             : 
    2129                 :             : /* The symbol expr_is_sought_symbol_ref will try to find.  */
    2130                 :             : static const gfc_symbol *sought_symbol = NULL;
    2131                 :             : 
    2132                 :             : 
    2133                 :             : /* Tells whether the expression E is a variable reference to the symbol
    2134                 :             :    in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
    2135                 :             :    accordingly.
    2136                 :             :    To be used with gfc_expr_walker: if a reference is found we don't need
    2137                 :             :    to look further so we return 1 to skip any further walk.  */
    2138                 :             : 
    2139                 :             : static int
    2140                 :       14934 : expr_is_sought_symbol_ref (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
    2141                 :             :                            void *where)
    2142                 :             : {
    2143                 :       14934 :   gfc_expr *expr = *e;
    2144                 :       14934 :   locus *sym_loc = (locus *)where;
    2145                 :             : 
    2146                 :       14934 :   if (expr->expr_type == EXPR_VARIABLE
    2147                 :        1305 :       && expr->symtree->n.sym == sought_symbol)
    2148                 :             :     {
    2149                 :           9 :       *sym_loc = expr->where;
    2150                 :           9 :       return 1;
    2151                 :             :     }
    2152                 :             : 
    2153                 :             :   return 0;
    2154                 :             : }
    2155                 :             : 
    2156                 :             : 
    2157                 :             : /* Tells whether the expression EXPR contains a reference to the symbol
    2158                 :             :    SYM and in that case sets the position SYM_LOC where the reference is.  */
    2159                 :             : 
    2160                 :             : static bool
    2161                 :       14352 : find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr, locus *sym_loc)
    2162                 :             : {
    2163                 :       14352 :   int ret;
    2164                 :             : 
    2165                 :       14352 :   sought_symbol = sym;
    2166                 :           0 :   ret = gfc_expr_walker (&expr, &expr_is_sought_symbol_ref, sym_loc);
    2167                 :       14352 :   sought_symbol = NULL;
    2168                 :       14352 :   return ret;
    2169                 :             : }
    2170                 :             : 
    2171                 :             : 
    2172                 :             : /* Recursive array list resolution function.  All of the elements must
    2173                 :             :    be of the same type.  */
    2174                 :             : 
    2175                 :             : static bool
    2176                 :       67860 : resolve_array_list (gfc_constructor_base base)
    2177                 :             : {
    2178                 :       67860 :   bool t;
    2179                 :       67860 :   gfc_constructor *c;
    2180                 :       67860 :   gfc_iterator *iter;
    2181                 :             : 
    2182                 :       67860 :   t = true;
    2183                 :             : 
    2184                 :      616994 :   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
    2185                 :             :     {
    2186                 :      549134 :       iter = c->iterator;
    2187                 :      549134 :       if (iter != NULL)
    2188                 :             :         {
    2189                 :        4784 :           gfc_symbol *iter_var;
    2190                 :        4784 :           locus iter_var_loc;
    2191                 :             : 
    2192                 :        4784 :           if (!gfc_resolve_iterator (iter, false, true))
    2193                 :           1 :             t = false;
    2194                 :             : 
    2195                 :             :           /* Check for bounds referencing the iterator variable.  */
    2196                 :        4784 :           gcc_assert (iter->var->expr_type == EXPR_VARIABLE);
    2197                 :        4784 :           iter_var = iter->var->symtree->n.sym;
    2198                 :        4784 :           if (find_symbol_in_expr (iter_var, iter->start, &iter_var_loc))
    2199                 :             :             {
    2200                 :           1 :               if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO initial "
    2201                 :             :                                    "expression references control variable "
    2202                 :             :                                    "at %L", &iter_var_loc))
    2203                 :        4784 :                t = false;
    2204                 :             :             }
    2205                 :        4784 :           if (find_symbol_in_expr (iter_var, iter->end, &iter_var_loc))
    2206                 :             :             {
    2207                 :           7 :               if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO final "
    2208                 :             :                                    "expression references control variable "
    2209                 :             :                                    "at %L", &iter_var_loc))
    2210                 :        4784 :                t = false;
    2211                 :             :             }
    2212                 :        4784 :           if (find_symbol_in_expr (iter_var, iter->step, &iter_var_loc))
    2213                 :             :             {
    2214                 :           1 :               if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO step "
    2215                 :             :                                    "expression references control variable "
    2216                 :             :                                    "at %L", &iter_var_loc))
    2217                 :        4784 :                t = false;
    2218                 :             :             }
    2219                 :             :         }
    2220                 :             : 
    2221                 :      549134 :       if (!gfc_resolve_expr (c->expr))
    2222                 :          59 :         t = false;
    2223                 :             : 
    2224                 :      549134 :       if (UNLIMITED_POLY (c->expr))
    2225                 :             :         {
    2226                 :           1 :           gfc_error ("Array constructor value at %L shall not be unlimited "
    2227                 :             :                      "polymorphic [F2008: C4106]", &c->expr->where);
    2228                 :           1 :           t = false;
    2229                 :             :         }
    2230                 :             : 
    2231                 :             :       /* F2018:C7114 The declared type of an ac-value shall not be abstract.  */
    2232                 :      549134 :       if (c->expr->ts.type == BT_CLASS
    2233                 :          83 :           && c->expr->ts.u.derived
    2234                 :          83 :           && c->expr->ts.u.derived->attr.abstract
    2235                 :           5 :           && CLASS_DATA (c->expr))
    2236                 :             :         {
    2237                 :           5 :           gfc_error ("Array constructor value %qs at %L is of the ABSTRACT "
    2238                 :           5 :                      "type %qs", c->expr->symtree->name, &c->expr->where,
    2239                 :           5 :                      CLASS_DATA (c->expr)->ts.u.derived->name);
    2240                 :           5 :           t = false;
    2241                 :             :         }
    2242                 :             : 
    2243                 :             :     }
    2244                 :             : 
    2245                 :       67860 :   return t;
    2246                 :             : }
    2247                 :             : 
    2248                 :             : /* Resolve character array constructor. If it has a specified constant character
    2249                 :             :    length, pad/truncate the elements here; if the length is not specified and
    2250                 :             :    all elements are of compile-time known length, emit an error as this is
    2251                 :             :    invalid.  */
    2252                 :             : 
    2253                 :             : bool
    2254                 :       10091 : gfc_resolve_character_array_constructor (gfc_expr *expr)
    2255                 :             : {
    2256                 :       10091 :   gfc_constructor *p;
    2257                 :       10091 :   HOST_WIDE_INT found_length;
    2258                 :             : 
    2259                 :       10091 :   gcc_assert (expr->expr_type == EXPR_ARRAY);
    2260                 :       10091 :   gcc_assert (expr->ts.type == BT_CHARACTER);
    2261                 :             : 
    2262                 :       10091 :   if (expr->ts.u.cl == NULL)
    2263                 :             :     {
    2264                 :         156 :       for (p = gfc_constructor_first (expr->value.constructor);
    2265                 :         251 :            p; p = gfc_constructor_next (p))
    2266                 :         183 :         if (p->expr->ts.u.cl != NULL)
    2267                 :             :           {
    2268                 :             :             /* Ensure that if there is a char_len around that it is
    2269                 :             :                used; otherwise the middle-end confuses them!  */
    2270                 :          88 :             expr->ts.u.cl = p->expr->ts.u.cl;
    2271                 :          88 :             goto got_charlen;
    2272                 :             :           }
    2273                 :             : 
    2274                 :          68 :       expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
    2275                 :             :     }
    2276                 :             : 
    2277                 :        9935 : got_charlen:
    2278                 :             : 
    2279                 :             :   /* Early exit for zero size arrays. */
    2280                 :       10091 :   if (expr->shape)
    2281                 :             :     {
    2282                 :        9934 :       mpz_t size;
    2283                 :        9934 :       HOST_WIDE_INT arraysize;
    2284                 :             : 
    2285                 :        9934 :       gfc_array_size (expr, &size);
    2286                 :        9934 :       arraysize = mpz_get_ui (size);
    2287                 :        9934 :       mpz_clear (size);
    2288                 :             : 
    2289                 :        9934 :       if (arraysize == 0)
    2290                 :         344 :         return true;
    2291                 :             :     }
    2292                 :             : 
    2293                 :        9747 :   found_length = -1;
    2294                 :             : 
    2295                 :        9747 :   if (expr->ts.u.cl->length == NULL)
    2296                 :             :     {
    2297                 :             :       /* Check that all constant string elements have the same length until
    2298                 :             :          we reach the end or find a variable-length one.  */
    2299                 :             : 
    2300                 :        6789 :       for (p = gfc_constructor_first (expr->value.constructor);
    2301                 :       31608 :            p; p = gfc_constructor_next (p))
    2302                 :             :         {
    2303                 :       25171 :           HOST_WIDE_INT current_length = -1;
    2304                 :       25171 :           gfc_ref *ref;
    2305                 :       25407 :           for (ref = p->expr->ref; ref; ref = ref->next)
    2306                 :         251 :             if (ref->type == REF_SUBSTRING
    2307                 :          77 :                 && ref->u.ss.start
    2308                 :          77 :                 && ref->u.ss.start->expr_type == EXPR_CONSTANT
    2309                 :          52 :                 && ref->u.ss.end
    2310                 :          39 :                 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
    2311                 :             :               break;
    2312                 :             : 
    2313                 :       25171 :           if (p->expr->expr_type == EXPR_CONSTANT)
    2314                 :       24759 :             current_length = p->expr->value.character.length;
    2315                 :         412 :           else if (ref)
    2316                 :          15 :             current_length = gfc_mpz_get_hwi (ref->u.ss.end->value.integer)
    2317                 :          15 :               - gfc_mpz_get_hwi (ref->u.ss.start->value.integer) + 1;
    2318                 :         397 :           else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
    2319                 :          51 :                    && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
    2320                 :          51 :             current_length = gfc_mpz_get_hwi (p->expr->ts.u.cl->length->value.integer);
    2321                 :             :           else
    2322                 :             :             return true;
    2323                 :             : 
    2324                 :       24825 :           if (current_length < 0)
    2325                 :             :             current_length = 0;
    2326                 :             : 
    2327                 :       24825 :           if (found_length == -1)
    2328                 :        6461 :             found_length = current_length;
    2329                 :       18364 :           else if (found_length != current_length)
    2330                 :             :             {
    2331                 :           6 :               gfc_error ("Different CHARACTER lengths (%wd/%wd) in array"
    2332                 :             :                          " constructor at %L", found_length,
    2333                 :           6 :                          current_length, &p->expr->where);
    2334                 :           6 :               return false;
    2335                 :             :             }
    2336                 :             : 
    2337                 :       24819 :           gcc_assert (found_length == current_length);
    2338                 :             :         }
    2339                 :             : 
    2340                 :        6437 :       gcc_assert (found_length != -1);
    2341                 :             : 
    2342                 :             :       /* Update the character length of the array constructor.  */
    2343                 :        6437 :       expr->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
    2344                 :             :                                                 NULL, found_length);
    2345                 :             :     }
    2346                 :             :   else
    2347                 :             :     {
    2348                 :             :       /* We've got a character length specified.  It should be an integer,
    2349                 :             :          otherwise an error is signalled elsewhere.  */
    2350                 :        2958 :       gcc_assert (expr->ts.u.cl->length);
    2351                 :             : 
    2352                 :             :       /* If we've got a constant character length, pad according to this.
    2353                 :             :          gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
    2354                 :             :          max_length only if they pass.  */
    2355                 :        2958 :       gfc_extract_hwi (expr->ts.u.cl->length, &found_length);
    2356                 :             : 
    2357                 :             :       /* Now pad/truncate the elements accordingly to the specified character
    2358                 :             :          length.  This is ok inside this conditional, as in the case above
    2359                 :             :          (without typespec) all elements are verified to have the same length
    2360                 :             :          anyway.  */
    2361                 :        2958 :       if (found_length != -1)
    2362                 :        2891 :         for (p = gfc_constructor_first (expr->value.constructor);
    2363                 :       13671 :              p; p = gfc_constructor_next (p))
    2364                 :       10780 :           if (p->expr->expr_type == EXPR_CONSTANT)
    2365                 :             :             {
    2366                 :        9244 :               gfc_expr *cl = NULL;
    2367                 :        9244 :               HOST_WIDE_INT current_length = -1;
    2368                 :        9244 :               bool has_ts;
    2369                 :             : 
    2370                 :        9244 :               if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
    2371                 :             :               {
    2372                 :        1859 :                 cl = p->expr->ts.u.cl->length;
    2373                 :        1859 :                 gfc_extract_hwi (cl, &current_length);
    2374                 :             :               }
    2375                 :             : 
    2376                 :             :               /* If gfc_extract_int above set current_length, we implicitly
    2377                 :             :                  know the type is BT_INTEGER and it's EXPR_CONSTANT.  */
    2378                 :             : 
    2379                 :        9244 :               has_ts = expr->ts.u.cl->length_from_typespec;
    2380                 :             : 
    2381                 :        9244 :               if (! cl
    2382                 :        1859 :                   || (current_length != -1 && current_length != found_length))
    2383                 :        7503 :                 gfc_set_constant_character_len (found_length, p->expr,
    2384                 :             :                                                 has_ts ? -1 : found_length);
    2385                 :             :             }
    2386                 :             :     }
    2387                 :             : 
    2388                 :             :   return true;
    2389                 :             : }
    2390                 :             : 
    2391                 :             : 
    2392                 :             : /* Resolve all of the expressions in an array list.  */
    2393                 :             : 
    2394                 :             : bool
    2395                 :       67860 : gfc_resolve_array_constructor (gfc_expr *expr)
    2396                 :             : {
    2397                 :       67860 :   bool t;
    2398                 :             : 
    2399                 :       67860 :   t = resolve_array_list (expr->value.constructor);
    2400                 :       67860 :   if (t)
    2401                 :       67793 :     t = gfc_check_constructor_type (expr);
    2402                 :             : 
    2403                 :             :   /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
    2404                 :             :      the call to this function, so we don't need to call it here; if it was
    2405                 :             :      called twice, an error message there would be duplicated.  */
    2406                 :             : 
    2407                 :       67860 :   return t;
    2408                 :             : }
    2409                 :             : 
    2410                 :             : 
    2411                 :             : /* Copy an iterator structure.  */
    2412                 :             : 
    2413                 :             : gfc_iterator *
    2414                 :      850182 : gfc_copy_iterator (gfc_iterator *src)
    2415                 :             : {
    2416                 :      850182 :   gfc_iterator *dest;
    2417                 :             : 
    2418                 :      850182 :   if (src == NULL)
    2419                 :             :     return NULL;
    2420                 :             : 
    2421                 :         499 :   dest = gfc_get_iterator ();
    2422                 :             : 
    2423                 :         499 :   dest->var = gfc_copy_expr (src->var);
    2424                 :         499 :   dest->start = gfc_copy_expr (src->start);
    2425                 :         499 :   dest->end = gfc_copy_expr (src->end);
    2426                 :         499 :   dest->step = gfc_copy_expr (src->step);
    2427                 :         499 :   dest->annot = src->annot;
    2428                 :             : 
    2429                 :         499 :   return dest;
    2430                 :             : }
    2431                 :             : 
    2432                 :             : 
    2433                 :             : /********* Subroutines for determining the size of an array *********/
    2434                 :             : 
    2435                 :             : /* These are needed just to accommodate RESHAPE().  There are no
    2436                 :             :    diagnostics here, we just return false if something goes wrong.  */
    2437                 :             : 
    2438                 :             : 
    2439                 :             : /* Get the size of single dimension of an array specification.  The
    2440                 :             :    array is guaranteed to be one dimensional.  */
    2441                 :             : 
    2442                 :             : bool
    2443                 :      547799 : spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
    2444                 :             : {
    2445                 :      547799 :   if (as == NULL)
    2446                 :             :     return false;
    2447                 :             : 
    2448                 :      534377 :   if (dimen < 0 || dimen > as->rank - 1)
    2449                 :           0 :     gfc_internal_error ("spec_dimen_size(): Bad dimension");
    2450                 :             : 
    2451                 :      534377 :   if (as->type != AS_EXPLICIT
    2452                 :      341383 :       || !as->lower[dimen]
    2453                 :      341383 :       || !as->upper[dimen])
    2454                 :             :     return false;
    2455                 :             : 
    2456                 :      341383 :   if (as->lower[dimen]->expr_type != EXPR_CONSTANT
    2457                 :      340604 :       || as->upper[dimen]->expr_type != EXPR_CONSTANT
    2458                 :      322533 :       || as->lower[dimen]->ts.type != BT_INTEGER
    2459                 :      322533 :       || as->upper[dimen]->ts.type != BT_INTEGER)
    2460                 :             :     return false;
    2461                 :             : 
    2462                 :      322527 :   mpz_init (*result);
    2463                 :             : 
    2464                 :      322527 :   mpz_sub (*result, as->upper[dimen]->value.integer,
    2465                 :      322527 :            as->lower[dimen]->value.integer);
    2466                 :             : 
    2467                 :      322527 :   mpz_add_ui (*result, *result, 1);
    2468                 :             : 
    2469                 :      322527 :   if (mpz_cmp_si (*result, 0) < 0)
    2470                 :           0 :     mpz_set_si (*result, 0);
    2471                 :             : 
    2472                 :             :   return true;
    2473                 :             : }
    2474                 :             : 
    2475                 :             : 
    2476                 :             : bool
    2477                 :       29989 : spec_size (gfc_array_spec *as, mpz_t *result)
    2478                 :             : {
    2479                 :       29989 :   mpz_t size;
    2480                 :       29989 :   int d;
    2481                 :             : 
    2482                 :       29989 :   if (!as || as->type == AS_ASSUMED_RANK)
    2483                 :             :     return false;
    2484                 :             : 
    2485                 :       28539 :   mpz_init_set_ui (*result, 1);
    2486                 :             : 
    2487                 :       77675 :   for (d = 0; d < as->rank; d++)
    2488                 :             :     {
    2489                 :       34469 :       if (!spec_dimen_size (as, d, &size))
    2490                 :             :         {
    2491                 :       13872 :           mpz_clear (*result);
    2492                 :       13872 :           return false;
    2493                 :             :         }
    2494                 :             : 
    2495                 :       20597 :       mpz_mul (*result, *result, size);
    2496                 :       20597 :       mpz_clear (size);
    2497                 :             :     }
    2498                 :             : 
    2499                 :             :   return true;
    2500                 :             : }
    2501                 :             : 
    2502                 :             : 
    2503                 :             : /* Get the number of elements in an array section. Optionally, also supply
    2504                 :             :    the end value.  */
    2505                 :             : 
    2506                 :             : bool
    2507                 :       74794 : gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
    2508                 :             : {
    2509                 :       74794 :   mpz_t upper, lower, stride;
    2510                 :       74794 :   mpz_t diff;
    2511                 :       74794 :   bool t;
    2512                 :       74794 :   gfc_expr *stride_expr = NULL;
    2513                 :             : 
    2514                 :       74794 :   if (dimen < 0 || ar == NULL)
    2515                 :           0 :     gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
    2516                 :             : 
    2517                 :       74794 :   if (dimen > ar->dimen - 1)
    2518                 :             :     {
    2519                 :           1 :       gfc_error ("Bad array dimension at %L", &ar->c_where[dimen]);
    2520                 :           1 :       return false;
    2521                 :             :     }
    2522                 :             : 
    2523                 :       74793 :   switch (ar->dimen_type[dimen])
    2524                 :             :     {
    2525                 :         164 :     case DIMEN_ELEMENT:
    2526                 :         164 :       mpz_init (*result);
    2527                 :         164 :       mpz_set_ui (*result, 1);
    2528                 :         164 :       t = true;
    2529                 :         164 :       break;
    2530                 :             : 
    2531                 :        1381 :     case DIMEN_VECTOR:
    2532                 :        1381 :       t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
    2533                 :        1381 :       break;
    2534                 :             : 
    2535                 :       73248 :     case DIMEN_RANGE:
    2536                 :             : 
    2537                 :       73248 :       mpz_init (stride);
    2538                 :             : 
    2539                 :       73248 :       if (ar->stride[dimen] == NULL)
    2540                 :       51260 :         mpz_set_ui (stride, 1);
    2541                 :             :       else
    2542                 :             :         {
    2543                 :       21988 :           stride_expr = gfc_copy_expr(ar->stride[dimen]);
    2544                 :             : 
    2545                 :       21988 :           if (!gfc_simplify_expr (stride_expr, 1)
    2546                 :       21986 :              || stride_expr->expr_type != EXPR_CONSTANT
    2547                 :       42265 :              || mpz_cmp_ui (stride_expr->value.integer, 0) == 0)
    2548                 :             :             {
    2549                 :        1713 :               gfc_free_expr (stride_expr);
    2550                 :        1713 :               mpz_clear (stride);
    2551                 :        1713 :               return false;
    2552                 :             :             }
    2553                 :       20275 :           mpz_set (stride, stride_expr->value.integer);
    2554                 :       20275 :           gfc_free_expr(stride_expr);
    2555                 :             :         }
    2556                 :             : 
    2557                 :             :       /* Calculate the number of elements via gfc_dep_difference, but only if
    2558                 :             :          start and end are both supplied in the reference or the array spec.
    2559                 :             :          This is to guard against strange but valid code like
    2560                 :             : 
    2561                 :             :          subroutine foo(a,n)
    2562                 :             :          real a(1:n)
    2563                 :             :          n = 3
    2564                 :             :          print *,size(a(n-1:))
    2565                 :             : 
    2566                 :             :          where the user changes the value of a variable.  If we have to
    2567                 :             :          determine end as well, we cannot do this using gfc_dep_difference.
    2568                 :             :          Fall back to the constants-only code then.  */
    2569                 :             : 
    2570                 :       71535 :       if (end == NULL)
    2571                 :             :         {
    2572                 :       63479 :           bool use_dep;
    2573                 :             : 
    2574                 :       63479 :           use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen],
    2575                 :             :                                         &diff);
    2576                 :       63479 :           if (!use_dep && ar->end[dimen] == NULL && ar->start[dimen] == NULL)
    2577                 :       28058 :             use_dep = gfc_dep_difference (ar->as->upper[dimen],
    2578                 :       28058 :                                             ar->as->lower[dimen], &diff);
    2579                 :             : 
    2580                 :       42360 :           if (use_dep)
    2581                 :             :             {
    2582                 :       32185 :               mpz_init (*result);
    2583                 :       32185 :               mpz_add (*result, diff, stride);
    2584                 :       32185 :               mpz_div (*result, *result, stride);
    2585                 :       32185 :               if (mpz_cmp_ui (*result, 0) < 0)
    2586                 :         112 :                 mpz_set_ui (*result, 0);
    2587                 :             : 
    2588                 :       32185 :               mpz_clear (stride);
    2589                 :       32185 :               mpz_clear (diff);
    2590                 :       32185 :               return true;
    2591                 :             :             }
    2592                 :             : 
    2593                 :             :         }
    2594                 :             : 
    2595                 :             :       /*  Constant-only code here, which covers more cases
    2596                 :             :           like a(:4) etc.  */
    2597                 :       39350 :       mpz_init (upper);
    2598                 :       39350 :       mpz_init (lower);
    2599                 :       39350 :       t = false;
    2600                 :             : 
    2601                 :       39350 :       if (ar->start[dimen] == NULL)
    2602                 :             :         {
    2603                 :       29316 :           if (ar->as->lower[dimen] == NULL
    2604                 :       12202 :               || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT
    2605                 :       12199 :               || ar->as->lower[dimen]->ts.type != BT_INTEGER)
    2606                 :       17117 :             goto cleanup;
    2607                 :       12199 :           mpz_set (lower, ar->as->lower[dimen]->value.integer);
    2608                 :             :         }
    2609                 :             :       else
    2610                 :             :         {
    2611                 :       10034 :           if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
    2612                 :        2376 :             goto cleanup;
    2613                 :        7658 :           mpz_set (lower, ar->start[dimen]->value.integer);
    2614                 :             :         }
    2615                 :             : 
    2616                 :       19857 :       if (ar->end[dimen] == NULL)
    2617                 :             :         {
    2618                 :        6367 :           if (ar->as->upper[dimen] == NULL
    2619                 :        4954 :               || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT
    2620                 :        4424 :               || ar->as->upper[dimen]->ts.type != BT_INTEGER)
    2621                 :        1944 :             goto cleanup;
    2622                 :        4423 :           mpz_set (upper, ar->as->upper[dimen]->value.integer);
    2623                 :             :         }
    2624                 :             :       else
    2625                 :             :         {
    2626                 :       13490 :           if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
    2627                 :        4388 :             goto cleanup;
    2628                 :        9102 :           mpz_set (upper, ar->end[dimen]->value.integer);
    2629                 :             :         }
    2630                 :             : 
    2631                 :       13525 :       mpz_init (*result);
    2632                 :       13525 :       mpz_sub (*result, upper, lower);
    2633                 :       13525 :       mpz_add (*result, *result, stride);
    2634                 :       13525 :       mpz_div (*result, *result, stride);
    2635                 :             : 
    2636                 :             :       /* Zero stride caught earlier.  */
    2637                 :       13525 :       if (mpz_cmp_ui (*result, 0) < 0)
    2638                 :           8 :         mpz_set_ui (*result, 0);
    2639                 :       13525 :       t = true;
    2640                 :             : 
    2641                 :       13525 :       if (end)
    2642                 :             :         {
    2643                 :        6360 :           mpz_init (*end);
    2644                 :             : 
    2645                 :        6360 :           mpz_sub_ui (*end, *result, 1UL);
    2646                 :        6360 :           mpz_mul (*end, *end, stride);
    2647                 :        6360 :           mpz_add (*end, *end, lower);
    2648                 :             :         }
    2649                 :             : 
    2650                 :        7165 :     cleanup:
    2651                 :       39350 :       mpz_clear (upper);
    2652                 :       39350 :       mpz_clear (lower);
    2653                 :       39350 :       mpz_clear (stride);
    2654                 :       39350 :       return t;
    2655                 :             : 
    2656                 :           0 :     default:
    2657                 :           0 :       gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
    2658                 :             :     }
    2659                 :             : 
    2660                 :             :   return t;
    2661                 :             : }
    2662                 :             : 
    2663                 :             : 
    2664                 :             : static bool
    2665                 :        3402 : ref_size (gfc_array_ref *ar, mpz_t *result)
    2666                 :             : {
    2667                 :        3402 :   mpz_t size;
    2668                 :        3402 :   int d;
    2669                 :             : 
    2670                 :        3402 :   mpz_init_set_ui (*result, 1);
    2671                 :             : 
    2672                 :       10366 :   for (d = 0; d < ar->dimen; d++)
    2673                 :             :     {
    2674                 :        3958 :       if (!gfc_ref_dimen_size (ar, d, &size, NULL))
    2675                 :             :         {
    2676                 :         396 :           mpz_clear (*result);
    2677                 :         396 :           return false;
    2678                 :             :         }
    2679                 :             : 
    2680                 :        3562 :       mpz_mul (*result, *result, size);
    2681                 :        3562 :       mpz_clear (size);
    2682                 :             :     }
    2683                 :             : 
    2684                 :             :   return true;
    2685                 :             : }
    2686                 :             : 
    2687                 :             : 
    2688                 :             : /* Given an array expression and a dimension, figure out how many
    2689                 :             :    elements it has along that dimension.  Returns true if we were
    2690                 :             :    able to return a result in the 'result' variable, false
    2691                 :             :    otherwise.  */
    2692                 :             : 
    2693                 :             : bool
    2694                 :      693922 : gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
    2695                 :             : {
    2696                 :      693922 :   gfc_ref *ref;
    2697                 :      693922 :   int i;
    2698                 :             : 
    2699                 :      693922 :   gcc_assert (array != NULL);
    2700                 :             : 
    2701                 :      693922 :   if (array->ts.type == BT_CLASS)
    2702                 :             :     return false;
    2703                 :             : 
    2704                 :      682359 :   if (array->rank == -1)
    2705                 :             :     return false;
    2706                 :             : 
    2707                 :      682359 :   if (dimen < 0 || dimen > array->rank - 1)
    2708                 :           0 :     gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
    2709                 :             : 
    2710                 :      682359 :   switch (array->expr_type)
    2711                 :             :     {
    2712                 :      571989 :     case EXPR_VARIABLE:
    2713                 :      571989 :     case EXPR_FUNCTION:
    2714                 :      617782 :       for (ref = array->ref; ref; ref = ref->next)
    2715                 :             :         {
    2716                 :             :           /* Ultimate component is a procedure pointer.  */
    2717                 :      574042 :           if (ref->type == REF_COMPONENT
    2718                 :       34173 :               && !ref->next
    2719                 :        1053 :               && ref->u.c.component->attr.function
    2720                 :          91 :               && IS_PROC_POINTER (ref->u.c.component))
    2721                 :             :             return false;
    2722                 :             : 
    2723                 :      573951 :           if (ref->type != REF_ARRAY)
    2724                 :       34082 :             continue;
    2725                 :             : 
    2726                 :      539869 :           if (ref->u.ar.type == AR_FULL)
    2727                 :      466671 :             return spec_dimen_size (ref->u.ar.as, dimen, result);
    2728                 :             : 
    2729                 :       73198 :           if (ref->u.ar.type == AR_SECTION)
    2730                 :             :             {
    2731                 :      144037 :               for (i = 0; dimen >= 0; i++)
    2732                 :       82550 :                 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
    2733                 :       77255 :                   dimen--;
    2734                 :             : 
    2735                 :       61487 :               return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL);
    2736                 :             :             }
    2737                 :             :         }
    2738                 :             : 
    2739                 :       43740 :       if (array->shape)
    2740                 :             :         {
    2741                 :       12698 :           mpz_init_set (*result, array->shape[dimen]);
    2742                 :       12698 :           return true;
    2743                 :             :         }
    2744                 :             : 
    2745                 :       31042 :       if (array->symtree->n.sym->attr.generic
    2746                 :          26 :           && array->value.function.esym != NULL)
    2747                 :             :         {
    2748                 :          25 :           if (!spec_dimen_size (array->value.function.esym->as, dimen, result))
    2749                 :             :             return false;
    2750                 :             :         }
    2751                 :       31017 :       else if (!spec_dimen_size (array->symtree->n.sym->as, dimen, result))
    2752                 :             :         return false;
    2753                 :             : 
    2754                 :             :       break;
    2755                 :             : 
    2756                 :       97038 :     case EXPR_ARRAY:
    2757                 :       97038 :       if (array->shape == NULL) {
    2758                 :             :         /* Expressions with rank > 1 should have "shape" properly set */
    2759                 :       58256 :         if ( array->rank != 1 )
    2760                 :           0 :           gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
    2761                 :       58256 :         return gfc_array_size(array, result);
    2762                 :             :       }
    2763                 :             : 
    2764                 :             :       /* Fall through */
    2765                 :       52114 :     default:
    2766                 :       52114 :       if (array->shape == NULL)
    2767                 :             :         return false;
    2768                 :             : 
    2769                 :       44915 :       mpz_init_set (*result, array->shape[dimen]);
    2770                 :             : 
    2771                 :       44915 :       break;
    2772                 :             :     }
    2773                 :             : 
    2774                 :             :   return true;
    2775                 :             : }
    2776                 :             : 
    2777                 :             : 
    2778                 :             : /* Given an array expression, figure out how many elements are in the
    2779                 :             :    array.  Returns true if this is possible, and sets the 'result'
    2780                 :             :    variable.  Otherwise returns false.  */
    2781                 :             : 
    2782                 :             : bool
    2783                 :      124063 : gfc_array_size (gfc_expr *array, mpz_t *result)
    2784                 :             : {
    2785                 :      124063 :   expand_info expand_save;
    2786                 :      124063 :   gfc_ref *ref;
    2787                 :      124063 :   int i;
    2788                 :      124063 :   bool t;
    2789                 :             : 
    2790                 :      124063 :   if (array->ts.type == BT_CLASS)
    2791                 :             :     return false;
    2792                 :             : 
    2793                 :      123054 :   switch (array->expr_type)
    2794                 :             :     {
    2795                 :       92482 :     case EXPR_ARRAY:
    2796                 :       92482 :       gfc_push_suppress_errors ();
    2797                 :             : 
    2798                 :       92482 :       expand_save = current_expand;
    2799                 :             : 
    2800                 :       92482 :       current_expand.count = result;
    2801                 :       92482 :       mpz_init_set_ui (*result, 0);
    2802                 :             : 
    2803                 :       92482 :       current_expand.expand_work_function = count_elements;
    2804                 :       92482 :       iter_stack = NULL;
    2805                 :             : 
    2806                 :       92482 :       t = expand_constructor (array->value.constructor);
    2807                 :             : 
    2808                 :       92482 :       gfc_pop_suppress_errors ();
    2809                 :             : 
    2810                 :       92482 :       if (!t)
    2811                 :        2036 :         mpz_clear (*result);
    2812                 :       92482 :       current_expand = expand_save;
    2813                 :       92482 :       return t;
    2814                 :             : 
    2815                 :       25739 :     case EXPR_VARIABLE:
    2816                 :       27963 :       for (ref = array->ref; ref; ref = ref->next)
    2817                 :             :         {
    2818                 :       27962 :           if (ref->type != REF_ARRAY)
    2819                 :        1768 :             continue;
    2820                 :             : 
    2821                 :       26194 :           if (ref->u.ar.type == AR_FULL)
    2822                 :       22336 :             return spec_size (ref->u.ar.as, result);
    2823                 :             : 
    2824                 :        3858 :           if (ref->u.ar.type == AR_SECTION)
    2825                 :        3402 :             return ref_size (&ref->u.ar, result);
    2826                 :             :         }
    2827                 :             : 
    2828                 :           1 :       return spec_size (array->symtree->n.sym->as, result);
    2829                 :             : 
    2830                 :             : 
    2831                 :        4833 :     default:
    2832                 :        4833 :       if (array->rank == 0 || array->shape == NULL)
    2833                 :             :         return false;
    2834                 :             : 
    2835                 :        3437 :       mpz_init_set_ui (*result, 1);
    2836                 :             : 
    2837                 :       10685 :       for (i = 0; i < array->rank; i++)
    2838                 :        3811 :         mpz_mul (*result, *result, array->shape[i]);
    2839                 :             : 
    2840                 :             :       break;
    2841                 :             :     }
    2842                 :             : 
    2843                 :             :   return true;
    2844                 :             : }
    2845                 :             : 
    2846                 :             : 
    2847                 :             : /* Given an array reference, return the shape of the reference in an
    2848                 :             :    array of mpz_t integers.  */
    2849                 :             : 
    2850                 :             : bool
    2851                 :       10933 : gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
    2852                 :             : {
    2853                 :       10933 :   int d;
    2854                 :       10933 :   int i;
    2855                 :             : 
    2856                 :       10933 :   d = 0;
    2857                 :             : 
    2858                 :       10933 :   switch (ar->type)
    2859                 :             :     {
    2860                 :             :     case AR_FULL:
    2861                 :       17292 :       for (; d < ar->as->rank; d++)
    2862                 :       15021 :         if (!spec_dimen_size (ar->as, d, &shape[d]))
    2863                 :        8583 :           goto cleanup;
    2864                 :             : 
    2865                 :             :       return true;
    2866                 :             : 
    2867                 :             :     case AR_SECTION:
    2868                 :         199 :       for (i = 0; i < ar->dimen; i++)
    2869                 :             :         {
    2870                 :         157 :           if (ar->dimen_type[i] != DIMEN_ELEMENT)
    2871                 :             :             {
    2872                 :         129 :               if (!gfc_ref_dimen_size (ar, i, &shape[d], NULL))
    2873                 :          37 :                 goto cleanup;
    2874                 :          92 :               d++;
    2875                 :             :             }
    2876                 :             :         }
    2877                 :             : 
    2878                 :             :       return true;
    2879                 :             : 
    2880                 :             :     default:
    2881                 :             :       break;
    2882                 :             :     }
    2883                 :             : 
    2884                 :        8620 : cleanup:
    2885                 :        8620 :   gfc_clear_shape (shape, d);
    2886                 :        8620 :   return false;
    2887                 :             : }
    2888                 :             : 
    2889                 :             : 
    2890                 :             : /* Given an array expression, find the array reference structure that
    2891                 :             :    characterizes the reference.  */
    2892                 :             : 
    2893                 :             : gfc_array_ref *
    2894                 :       95748 : gfc_find_array_ref (gfc_expr *e, bool allow_null)
    2895                 :             : {
    2896                 :       95748 :   gfc_ref *ref;
    2897                 :             : 
    2898                 :      106635 :   for (ref = e->ref; ref; ref = ref->next)
    2899                 :       99585 :     if (ref->type == REF_ARRAY
    2900                 :       93571 :         && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
    2901                 :             :       break;
    2902                 :             : 
    2903                 :       95748 :   if (ref == NULL)
    2904                 :             :     {
    2905                 :        7050 :       if (allow_null)
    2906                 :             :         return NULL;
    2907                 :             :       else
    2908                 :           0 :         gfc_internal_error ("gfc_find_array_ref(): No ref found");
    2909                 :             :     }
    2910                 :             : 
    2911                 :       88698 :   return &ref->u.ar;
    2912                 :             : }
    2913                 :             : 
    2914                 :             : 
    2915                 :             : /* Find out if an array shape is known at compile time.  */
    2916                 :             : 
    2917                 :             : bool
    2918                 :          71 : gfc_is_compile_time_shape (gfc_array_spec *as)
    2919                 :             : {
    2920                 :          71 :   if (as->type != AS_EXPLICIT)
    2921                 :             :     return false;
    2922                 :             : 
    2923                 :         148 :   for (int i = 0; i < as->rank; i++)
    2924                 :          88 :     if (!gfc_is_constant_expr (as->lower[i])
    2925                 :          88 :         || !gfc_is_constant_expr (as->upper[i]))
    2926                 :           9 :       return false;
    2927                 :             : 
    2928                 :             :   return true;
    2929                 :             : }
        

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.