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

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.