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

Generated by: LCOV version 1.0

LCOV profile is generated on x86_64 machine using following configure options: configure --disable-bootstrap --enable-coverage=opt --enable-languages=c,c++,fortran,go,jit,lto --enable-host-shared. GCC test suite is run with the built compiler.