LCOV - code coverage report
Current view: top level - gcc/fortran - trans-array.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 95.6 % 5735 5484
Test Date: 2024-06-15 14:19:33 Functions: 95.1 % 184 175
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* Array translation routines
       2                 :             :    Copyright (C) 2002-2024 Free Software Foundation, Inc.
       3                 :             :    Contributed by Paul Brook <paul@nowt.org>
       4                 :             :    and Steven Bosscher <s.bosscher@student.tudelft.nl>
       5                 :             : 
       6                 :             : This file is part of GCC.
       7                 :             : 
       8                 :             : GCC is free software; you can redistribute it and/or modify it under
       9                 :             : the terms of the GNU General Public License as published by the Free
      10                 :             : Software Foundation; either version 3, or (at your option) any later
      11                 :             : version.
      12                 :             : 
      13                 :             : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      14                 :             : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      15                 :             : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      16                 :             : for more details.
      17                 :             : 
      18                 :             : You should have received a copy of the GNU General Public License
      19                 :             : along with GCC; see the file COPYING3.  If not see
      20                 :             : <http://www.gnu.org/licenses/>.  */
      21                 :             : 
      22                 :             : /* trans-array.cc-- Various array related code, including scalarization,
      23                 :             :                    allocation, initialization and other support routines.  */
      24                 :             : 
      25                 :             : /* How the scalarizer works.
      26                 :             :    In gfortran, array expressions use the same core routines as scalar
      27                 :             :    expressions.
      28                 :             :    First, a Scalarization State (SS) chain is built.  This is done by walking
      29                 :             :    the expression tree, and building a linear list of the terms in the
      30                 :             :    expression.  As the tree is walked, scalar subexpressions are translated.
      31                 :             : 
      32                 :             :    The scalarization parameters are stored in a gfc_loopinfo structure.
      33                 :             :    First the start and stride of each term is calculated by
      34                 :             :    gfc_conv_ss_startstride.  During this process the expressions for the array
      35                 :             :    descriptors and data pointers are also translated.
      36                 :             : 
      37                 :             :    If the expression is an assignment, we must then resolve any dependencies.
      38                 :             :    In Fortran all the rhs values of an assignment must be evaluated before
      39                 :             :    any assignments take place.  This can require a temporary array to store the
      40                 :             :    values.  We also require a temporary when we are passing array expressions
      41                 :             :    or vector subscripts as procedure parameters.
      42                 :             : 
      43                 :             :    Array sections are passed without copying to a temporary.  These use the
      44                 :             :    scalarizer to determine the shape of the section.  The flag
      45                 :             :    loop->array_parameter tells the scalarizer that the actual values and loop
      46                 :             :    variables will not be required.
      47                 :             : 
      48                 :             :    The function gfc_conv_loop_setup generates the scalarization setup code.
      49                 :             :    It determines the range of the scalarizing loop variables.  If a temporary
      50                 :             :    is required, this is created and initialized.  Code for scalar expressions
      51                 :             :    taken outside the loop is also generated at this time.  Next the offset and
      52                 :             :    scaling required to translate from loop variables to array indices for each
      53                 :             :    term is calculated.
      54                 :             : 
      55                 :             :    A call to gfc_start_scalarized_body marks the start of the scalarized
      56                 :             :    expression.  This creates a scope and declares the loop variables.  Before
      57                 :             :    calling this gfc_make_ss_chain_used must be used to indicate which terms
      58                 :             :    will be used inside this loop.
      59                 :             : 
      60                 :             :    The scalar gfc_conv_* functions are then used to build the main body of the
      61                 :             :    scalarization loop.  Scalarization loop variables and precalculated scalar
      62                 :             :    values are automatically substituted.  Note that gfc_advance_se_ss_chain
      63                 :             :    must be used, rather than changing the se->ss directly.
      64                 :             : 
      65                 :             :    For assignment expressions requiring a temporary two sub loops are
      66                 :             :    generated.  The first stores the result of the expression in the temporary,
      67                 :             :    the second copies it to the result.  A call to
      68                 :             :    gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
      69                 :             :    the start of the copying loop.  The temporary may be less than full rank.
      70                 :             : 
      71                 :             :    Finally gfc_trans_scalarizing_loops is called to generate the implicit do
      72                 :             :    loops.  The loops are added to the pre chain of the loopinfo.  The post
      73                 :             :    chain may still contain cleanup code.
      74                 :             : 
      75                 :             :    After the loop code has been added into its parent scope gfc_cleanup_loop
      76                 :             :    is called to free all the SS allocated by the scalarizer.  */
      77                 :             : 
      78                 :             : #include "config.h"
      79                 :             : #include "system.h"
      80                 :             : #include "coretypes.h"
      81                 :             : #include "options.h"
      82                 :             : #include "tree.h"
      83                 :             : #include "gfortran.h"
      84                 :             : #include "gimple-expr.h"
      85                 :             : #include "tree-iterator.h"
      86                 :             : #include "stringpool.h"  /* Required by "attribs.h".  */
      87                 :             : #include "attribs.h" /* For lookup_attribute.  */
      88                 :             : #include "trans.h"
      89                 :             : #include "fold-const.h"
      90                 :             : #include "constructor.h"
      91                 :             : #include "trans-types.h"
      92                 :             : #include "trans-array.h"
      93                 :             : #include "trans-const.h"
      94                 :             : #include "dependency.h"
      95                 :             : 
      96                 :             : static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
      97                 :             : 
      98                 :             : /* The contents of this structure aren't actually used, just the address.  */
      99                 :             : static gfc_ss gfc_ss_terminator_var;
     100                 :             : gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
     101                 :             : 
     102                 :             : 
     103                 :             : static tree
     104                 :       50313 : gfc_array_dataptr_type (tree desc)
     105                 :             : {
     106                 :       50313 :   return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
     107                 :             : }
     108                 :             : 
     109                 :             : /* Build expressions to access members of the CFI descriptor.  */
     110                 :             : #define CFI_FIELD_BASE_ADDR 0
     111                 :             : #define CFI_FIELD_ELEM_LEN 1
     112                 :             : #define CFI_FIELD_VERSION 2
     113                 :             : #define CFI_FIELD_RANK 3
     114                 :             : #define CFI_FIELD_ATTRIBUTE 4
     115                 :             : #define CFI_FIELD_TYPE 5
     116                 :             : #define CFI_FIELD_DIM 6
     117                 :             : 
     118                 :             : #define CFI_DIM_FIELD_LOWER_BOUND 0
     119                 :             : #define CFI_DIM_FIELD_EXTENT 1
     120                 :             : #define CFI_DIM_FIELD_SM 2
     121                 :             : 
     122                 :             : static tree
     123                 :       84903 : gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
     124                 :             : {
     125                 :       84903 :   tree type = TREE_TYPE (desc);
     126                 :       84903 :   gcc_assert (TREE_CODE (type) == RECORD_TYPE
     127                 :             :               && TYPE_FIELDS (type)
     128                 :             :               && (strcmp ("base_addr",
     129                 :             :                          IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type))))
     130                 :             :                   == 0));
     131                 :       84903 :   tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
     132                 :       84903 :   gcc_assert (field != NULL_TREE);
     133                 :             : 
     134                 :       84903 :   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
     135                 :       84903 :                           desc, field, NULL_TREE);
     136                 :             : }
     137                 :             : 
     138                 :             : tree
     139                 :       14190 : gfc_get_cfi_desc_base_addr (tree desc)
     140                 :             : {
     141                 :       14190 :   return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
     142                 :             : }
     143                 :             : 
     144                 :             : tree
     145                 :       10668 : gfc_get_cfi_desc_elem_len (tree desc)
     146                 :             : {
     147                 :       10668 :   return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN);
     148                 :             : }
     149                 :             : 
     150                 :             : tree
     151                 :        7190 : gfc_get_cfi_desc_version (tree desc)
     152                 :             : {
     153                 :        7190 :   return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION);
     154                 :             : }
     155                 :             : 
     156                 :             : tree
     157                 :        7815 : gfc_get_cfi_desc_rank (tree desc)
     158                 :             : {
     159                 :        7815 :   return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK);
     160                 :             : }
     161                 :             : 
     162                 :             : tree
     163                 :        7282 : gfc_get_cfi_desc_type (tree desc)
     164                 :             : {
     165                 :        7282 :   return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE);
     166                 :             : }
     167                 :             : 
     168                 :             : tree
     169                 :        7190 : gfc_get_cfi_desc_attribute (tree desc)
     170                 :             : {
     171                 :        7190 :   return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE);
     172                 :             : }
     173                 :             : 
     174                 :             : static tree
     175                 :       30568 : gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
     176                 :             : {
     177                 :       30568 :   tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
     178                 :       30568 :   tmp = gfc_build_array_ref (tmp, idx, NULL_TREE, true);
     179                 :       30568 :   tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
     180                 :       30568 :   gcc_assert (field != NULL_TREE);
     181                 :       30568 :   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
     182                 :       30568 :                           tmp, field, NULL_TREE);
     183                 :             : }
     184                 :             : 
     185                 :             : tree
     186                 :        6786 : gfc_get_cfi_dim_lbound (tree desc, tree idx)
     187                 :             : {
     188                 :        6786 :   return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND);
     189                 :             : }
     190                 :             : 
     191                 :             : tree
     192                 :       11922 : gfc_get_cfi_dim_extent (tree desc, tree idx)
     193                 :             : {
     194                 :       11922 :   return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
     195                 :             : }
     196                 :             : 
     197                 :             : tree
     198                 :       11860 : gfc_get_cfi_dim_sm (tree desc, tree idx)
     199                 :             : {
     200                 :       11860 :   return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM);
     201                 :             : }
     202                 :             : 
     203                 :             : #undef CFI_FIELD_BASE_ADDR
     204                 :             : #undef CFI_FIELD_ELEM_LEN
     205                 :             : #undef CFI_FIELD_VERSION
     206                 :             : #undef CFI_FIELD_RANK
     207                 :             : #undef CFI_FIELD_ATTRIBUTE
     208                 :             : #undef CFI_FIELD_TYPE
     209                 :             : #undef CFI_FIELD_DIM
     210                 :             : 
     211                 :             : #undef CFI_DIM_FIELD_LOWER_BOUND
     212                 :             : #undef CFI_DIM_FIELD_EXTENT
     213                 :             : #undef CFI_DIM_FIELD_SM
     214                 :             : 
     215                 :             : /* Build expressions to access the members of an array descriptor.
     216                 :             :    It's surprisingly easy to mess up here, so never access
     217                 :             :    an array descriptor by "brute force", always use these
     218                 :             :    functions.  This also avoids problems if we change the format
     219                 :             :    of an array descriptor.
     220                 :             : 
     221                 :             :    To understand these magic numbers, look at the comments
     222                 :             :    before gfc_build_array_type() in trans-types.cc.
     223                 :             : 
     224                 :             :    The code within these defines should be the only code which knows the format
     225                 :             :    of an array descriptor.
     226                 :             : 
     227                 :             :    Any code just needing to read obtain the bounds of an array should use
     228                 :             :    gfc_conv_array_* rather than the following functions as these will return
     229                 :             :    know constant values, and work with arrays which do not have descriptors.
     230                 :             : 
     231                 :             :    Don't forget to #undef these!  */
     232                 :             : 
     233                 :             : #define DATA_FIELD 0
     234                 :             : #define OFFSET_FIELD 1
     235                 :             : #define DTYPE_FIELD 2
     236                 :             : #define SPAN_FIELD 3
     237                 :             : #define DIMENSION_FIELD 4
     238                 :             : #define CAF_TOKEN_FIELD 5
     239                 :             : 
     240                 :             : #define STRIDE_SUBFIELD 0
     241                 :             : #define LBOUND_SUBFIELD 1
     242                 :             : #define UBOUND_SUBFIELD 2
     243                 :             : 
     244                 :             : static tree
     245                 :     1554705 : gfc_get_descriptor_field (tree desc, unsigned field_idx)
     246                 :             : {
     247                 :     1554705 :   tree type = TREE_TYPE (desc);
     248                 :     1554705 :   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
     249                 :             : 
     250                 :     1554705 :   tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
     251                 :     1554705 :   gcc_assert (field != NULL_TREE);
     252                 :             : 
     253                 :     1554705 :   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
     254                 :     1554705 :                           desc, field, NULL_TREE);
     255                 :             : }
     256                 :             : 
     257                 :             : /* This provides READ-ONLY access to the data field.  The field itself
     258                 :             :    doesn't have the proper type.  */
     259                 :             : 
     260                 :             : tree
     261                 :      224855 : gfc_conv_descriptor_data_get (tree desc)
     262                 :             : {
     263                 :      224855 :   tree type = TREE_TYPE (desc);
     264                 :      224855 :   if (TREE_CODE (type) == REFERENCE_TYPE)
     265                 :           0 :     gcc_unreachable ();
     266                 :             : 
     267                 :      224855 :   tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
     268                 :      224855 :   return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field);
     269                 :             : }
     270                 :             : 
     271                 :             : /* This provides WRITE access to the data field.
     272                 :             : 
     273                 :             :    TUPLES_P is true if we are generating tuples.
     274                 :             : 
     275                 :             :    This function gets called through the following macros:
     276                 :             :      gfc_conv_descriptor_data_set
     277                 :             :      gfc_conv_descriptor_data_set.  */
     278                 :             : 
     279                 :             : void
     280                 :      120906 : gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
     281                 :             : {
     282                 :      120906 :   tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
     283                 :      120906 :   gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
     284                 :      120906 : }
     285                 :             : 
     286                 :             : 
     287                 :             : /* This provides address access to the data field.  This should only be
     288                 :             :    used by array allocation, passing this on to the runtime.  */
     289                 :             : 
     290                 :             : tree
     291                 :        1003 : gfc_conv_descriptor_data_addr (tree desc)
     292                 :             : {
     293                 :        1003 :   tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
     294                 :        1003 :   return gfc_build_addr_expr (NULL_TREE, field);
     295                 :             : }
     296                 :             : 
     297                 :             : static tree
     298                 :      164214 : gfc_conv_descriptor_offset (tree desc)
     299                 :             : {
     300                 :      164214 :   tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
     301                 :      164214 :   gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
     302                 :      164214 :   return field;
     303                 :             : }
     304                 :             : 
     305                 :             : tree
     306                 :       60044 : gfc_conv_descriptor_offset_get (tree desc)
     307                 :             : {
     308                 :       60044 :   return gfc_conv_descriptor_offset (desc);
     309                 :             : }
     310                 :             : 
     311                 :             : void
     312                 :      101110 : gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
     313                 :             :                                 tree value)
     314                 :             : {
     315                 :      101110 :   tree t = gfc_conv_descriptor_offset (desc);
     316                 :      101110 :   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
     317                 :      101110 : }
     318                 :             : 
     319                 :             : 
     320                 :             : tree
     321                 :      143357 : gfc_conv_descriptor_dtype (tree desc)
     322                 :             : {
     323                 :      143357 :   tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
     324                 :      143357 :   gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
     325                 :      143357 :   return field;
     326                 :             : }
     327                 :             : 
     328                 :             : static tree
     329                 :      132891 : gfc_conv_descriptor_span (tree desc)
     330                 :             : {
     331                 :      132891 :   tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
     332                 :      132891 :   gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
     333                 :      132891 :   return field;
     334                 :             : }
     335                 :             : 
     336                 :             : tree
     337                 :       27936 : gfc_conv_descriptor_span_get (tree desc)
     338                 :             : {
     339                 :       27936 :   return gfc_conv_descriptor_span (desc);
     340                 :             : }
     341                 :             : 
     342                 :             : void
     343                 :      104955 : gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
     344                 :             :                                 tree value)
     345                 :             : {
     346                 :      104955 :   tree t = gfc_conv_descriptor_span (desc);
     347                 :      104955 :   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
     348                 :      104955 : }
     349                 :             : 
     350                 :             : 
     351                 :             : tree
     352                 :       17482 : gfc_conv_descriptor_rank (tree desc)
     353                 :             : {
     354                 :       17482 :   tree tmp;
     355                 :       17482 :   tree dtype;
     356                 :             : 
     357                 :       17482 :   dtype = gfc_conv_descriptor_dtype (desc);
     358                 :       17482 :   tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
     359                 :       17482 :   gcc_assert (tmp != NULL_TREE
     360                 :             :               && TREE_TYPE (tmp) == signed_char_type_node);
     361                 :       17482 :   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
     362                 :       17482 :                           dtype, tmp, NULL_TREE);
     363                 :             : }
     364                 :             : 
     365                 :             : 
     366                 :             : tree
     367                 :         118 : gfc_conv_descriptor_version (tree desc)
     368                 :             : {
     369                 :         118 :   tree tmp;
     370                 :         118 :   tree dtype;
     371                 :             : 
     372                 :         118 :   dtype = gfc_conv_descriptor_dtype (desc);
     373                 :         118 :   tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_VERSION);
     374                 :         118 :   gcc_assert (tmp != NULL_TREE
     375                 :             :               && TREE_TYPE (tmp) == integer_type_node);
     376                 :         118 :   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
     377                 :         118 :                           dtype, tmp, NULL_TREE);
     378                 :             : }
     379                 :             : 
     380                 :             : 
     381                 :             : /* Return the element length from the descriptor dtype field.  */
     382                 :             : 
     383                 :             : tree
     384                 :        7504 : gfc_conv_descriptor_elem_len (tree desc)
     385                 :             : {
     386                 :        7504 :   tree tmp;
     387                 :        7504 :   tree dtype;
     388                 :             : 
     389                 :        7504 :   dtype = gfc_conv_descriptor_dtype (desc);
     390                 :        7504 :   tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
     391                 :             :                            GFC_DTYPE_ELEM_LEN);
     392                 :        7504 :   gcc_assert (tmp != NULL_TREE
     393                 :             :               && TREE_TYPE (tmp) == size_type_node);
     394                 :        7504 :   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
     395                 :        7504 :                           dtype, tmp, NULL_TREE);
     396                 :             : }
     397                 :             : 
     398                 :             : 
     399                 :             : tree
     400                 :           0 : gfc_conv_descriptor_attribute (tree desc)
     401                 :             : {
     402                 :           0 :   tree tmp;
     403                 :           0 :   tree dtype;
     404                 :             : 
     405                 :           0 :   dtype = gfc_conv_descriptor_dtype (desc);
     406                 :           0 :   tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
     407                 :             :                            GFC_DTYPE_ATTRIBUTE);
     408                 :           0 :   gcc_assert (tmp!= NULL_TREE
     409                 :             :               && TREE_TYPE (tmp) == short_integer_type_node);
     410                 :           0 :   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
     411                 :           0 :                           dtype, tmp, NULL_TREE);
     412                 :             : }
     413                 :             : 
     414                 :             : tree
     415                 :          73 : gfc_conv_descriptor_type (tree desc)
     416                 :             : {
     417                 :          73 :   tree tmp;
     418                 :          73 :   tree dtype;
     419                 :             : 
     420                 :          73 :   dtype = gfc_conv_descriptor_dtype (desc);
     421                 :          73 :   tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
     422                 :          73 :   gcc_assert (tmp!= NULL_TREE
     423                 :             :               && TREE_TYPE (tmp) == signed_char_type_node);
     424                 :          73 :   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
     425                 :          73 :                           dtype, tmp, NULL_TREE);
     426                 :             : }
     427                 :             : 
     428                 :             : tree
     429                 :      765783 : gfc_get_descriptor_dimension (tree desc)
     430                 :             : {
     431                 :      765783 :   tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
     432                 :      765783 :   gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
     433                 :             :               && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
     434                 :      765783 :   return field;
     435                 :             : }
     436                 :             : 
     437                 :             : 
     438                 :             : static tree
     439                 :      763533 : gfc_conv_descriptor_dimension (tree desc, tree dim)
     440                 :             : {
     441                 :      763533 :   tree tmp;
     442                 :             : 
     443                 :      763533 :   tmp = gfc_get_descriptor_dimension (desc);
     444                 :             : 
     445                 :      763533 :   return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
     446                 :             : }
     447                 :             : 
     448                 :             : 
     449                 :             : tree
     450                 :        1696 : gfc_conv_descriptor_token (tree desc)
     451                 :             : {
     452                 :        1696 :   gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
     453                 :        1696 :   tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
     454                 :             :   /* Should be a restricted pointer - except in the finalization wrapper.  */
     455                 :        1696 :   gcc_assert (TREE_TYPE (field) == prvoid_type_node
     456                 :             :               || TREE_TYPE (field) == pvoid_type_node);
     457                 :        1696 :   return field;
     458                 :             : }
     459                 :             : 
     460                 :             : static tree
     461                 :      763533 : gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
     462                 :             : {
     463                 :      763533 :   tree tmp = gfc_conv_descriptor_dimension (desc, dim);
     464                 :      763533 :   tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
     465                 :      763533 :   gcc_assert (field != NULL_TREE);
     466                 :             : 
     467                 :      763533 :   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
     468                 :      763533 :                           tmp, field, NULL_TREE);
     469                 :             : }
     470                 :             : 
     471                 :             : static tree
     472                 :      208502 : gfc_conv_descriptor_stride (tree desc, tree dim)
     473                 :             : {
     474                 :      208502 :   tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
     475                 :      208502 :   gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
     476                 :      208502 :   return field;
     477                 :             : }
     478                 :             : 
     479                 :             : tree
     480                 :      124563 : gfc_conv_descriptor_stride_get (tree desc, tree dim)
     481                 :             : {
     482                 :      124563 :   tree type = TREE_TYPE (desc);
     483                 :      124563 :   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
     484                 :      124563 :   if (integer_zerop (dim)
     485                 :      124563 :       && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
     486                 :       38055 :           ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
     487                 :       36987 :           ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
     488                 :       36855 :           ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
     489                 :       51667 :     return gfc_index_one_node;
     490                 :             : 
     491                 :       72896 :   return gfc_conv_descriptor_stride (desc, dim);
     492                 :             : }
     493                 :             : 
     494                 :             : void
     495                 :      135606 : gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
     496                 :             :                                 tree dim, tree value)
     497                 :             : {
     498                 :      135606 :   tree t = gfc_conv_descriptor_stride (desc, dim);
     499                 :      135606 :   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
     500                 :      135606 : }
     501                 :             : 
     502                 :             : static tree
     503                 :      287549 : gfc_conv_descriptor_lbound (tree desc, tree dim)
     504                 :             : {
     505                 :      287549 :   tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
     506                 :      287549 :   gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
     507                 :      287549 :   return field;
     508                 :             : }
     509                 :             : 
     510                 :             : tree
     511                 :      148472 : gfc_conv_descriptor_lbound_get (tree desc, tree dim)
     512                 :             : {
     513                 :      148472 :   return gfc_conv_descriptor_lbound (desc, dim);
     514                 :             : }
     515                 :             : 
     516                 :             : void
     517                 :      139077 : gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
     518                 :             :                                 tree dim, tree value)
     519                 :             : {
     520                 :      139077 :   tree t = gfc_conv_descriptor_lbound (desc, dim);
     521                 :      139077 :   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
     522                 :      139077 : }
     523                 :             : 
     524                 :             : static tree
     525                 :      267482 : gfc_conv_descriptor_ubound (tree desc, tree dim)
     526                 :             : {
     527                 :      267482 :   tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
     528                 :      267482 :   gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
     529                 :      267482 :   return field;
     530                 :             : }
     531                 :             : 
     532                 :             : tree
     533                 :      127503 : gfc_conv_descriptor_ubound_get (tree desc, tree dim)
     534                 :             : {
     535                 :      127503 :   return gfc_conv_descriptor_ubound (desc, dim);
     536                 :             : }
     537                 :             : 
     538                 :             : void
     539                 :      139979 : gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
     540                 :             :                                 tree dim, tree value)
     541                 :             : {
     542                 :      139979 :   tree t = gfc_conv_descriptor_ubound (desc, dim);
     543                 :      139979 :   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
     544                 :      139979 : }
     545                 :             : 
     546                 :             : /* Build a null array descriptor constructor.  */
     547                 :             : 
     548                 :             : tree
     549                 :         786 : gfc_build_null_descriptor (tree type)
     550                 :             : {
     551                 :         786 :   tree field;
     552                 :         786 :   tree tmp;
     553                 :             : 
     554                 :         786 :   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
     555                 :         786 :   gcc_assert (DATA_FIELD == 0);
     556                 :         786 :   field = TYPE_FIELDS (type);
     557                 :             : 
     558                 :             :   /* Set a NULL data pointer.  */
     559                 :         786 :   tmp = build_constructor_single (type, field, null_pointer_node);
     560                 :         786 :   TREE_CONSTANT (tmp) = 1;
     561                 :             :   /* All other fields are ignored.  */
     562                 :             : 
     563                 :         786 :   return tmp;
     564                 :             : }
     565                 :             : 
     566                 :             : 
     567                 :             : /* Modify a descriptor such that the lbound of a given dimension is the value
     568                 :             :    specified.  This also updates ubound and offset accordingly.  */
     569                 :             : 
     570                 :             : void
     571                 :         839 : gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
     572                 :             :                                   int dim, tree new_lbound)
     573                 :             : {
     574                 :         839 :   tree offs, ubound, lbound, stride;
     575                 :         839 :   tree diff, offs_diff;
     576                 :             : 
     577                 :         839 :   new_lbound = fold_convert (gfc_array_index_type, new_lbound);
     578                 :             : 
     579                 :         839 :   offs = gfc_conv_descriptor_offset_get (desc);
     580                 :         839 :   lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
     581                 :         839 :   ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
     582                 :         839 :   stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
     583                 :             : 
     584                 :             :   /* Get difference (new - old) by which to shift stuff.  */
     585                 :         839 :   diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
     586                 :             :                           new_lbound, lbound);
     587                 :             : 
     588                 :             :   /* Shift ubound and offset accordingly.  This has to be done before
     589                 :             :      updating the lbound, as they depend on the lbound expression!  */
     590                 :         839 :   ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
     591                 :             :                             ubound, diff);
     592                 :         839 :   gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
     593                 :         839 :   offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
     594                 :             :                                diff, stride);
     595                 :         839 :   offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
     596                 :             :                           offs, offs_diff);
     597                 :         839 :   gfc_conv_descriptor_offset_set (block, desc, offs);
     598                 :             : 
     599                 :             :   /* Finally set lbound to value we want.  */
     600                 :         839 :   gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
     601                 :         839 : }
     602                 :             : 
     603                 :             : 
     604                 :             : /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info).  */
     605                 :             : 
     606                 :             : void
     607                 :      227903 : gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
     608                 :             :                                      tree *dtype_off, tree *span_off,
     609                 :             :                                      tree *dim_off, tree *dim_size,
     610                 :             :                                      tree *stride_suboff, tree *lower_suboff,
     611                 :             :                                      tree *upper_suboff)
     612                 :             : {
     613                 :      227903 :   tree field;
     614                 :      227903 :   tree type;
     615                 :             : 
     616                 :      227903 :   type = TYPE_MAIN_VARIANT (desc_type);
     617                 :      227903 :   field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
     618                 :      227903 :   *data_off = byte_position (field);
     619                 :      227903 :   field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
     620                 :      227903 :   *dtype_off = byte_position (field);
     621                 :      227903 :   field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
     622                 :      227903 :   *span_off = byte_position (field);
     623                 :      227903 :   field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
     624                 :      227903 :   *dim_off = byte_position (field);
     625                 :      227903 :   type = TREE_TYPE (TREE_TYPE (field));
     626                 :      227903 :   *dim_size = TYPE_SIZE_UNIT (type);
     627                 :      227903 :   field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
     628                 :      227903 :   *stride_suboff = byte_position (field);
     629                 :      227903 :   field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
     630                 :      227903 :   *lower_suboff = byte_position (field);
     631                 :      227903 :   field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
     632                 :      227903 :   *upper_suboff = byte_position (field);
     633                 :      227903 : }
     634                 :             : 
     635                 :             : 
     636                 :             : /* Cleanup those #defines.  */
     637                 :             : 
     638                 :             : #undef DATA_FIELD
     639                 :             : #undef OFFSET_FIELD
     640                 :             : #undef DTYPE_FIELD
     641                 :             : #undef SPAN_FIELD
     642                 :             : #undef DIMENSION_FIELD
     643                 :             : #undef CAF_TOKEN_FIELD
     644                 :             : #undef STRIDE_SUBFIELD
     645                 :             : #undef LBOUND_SUBFIELD
     646                 :             : #undef UBOUND_SUBFIELD
     647                 :             : 
     648                 :             : 
     649                 :             : /* Mark a SS chain as used.  Flags specifies in which loops the SS is used.
     650                 :             :    flags & 1 = Main loop body.
     651                 :             :    flags & 2 = temp copy loop.  */
     652                 :             : 
     653                 :             : void
     654                 :      139389 : gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
     655                 :             : {
     656                 :      323835 :   for (; ss != gfc_ss_terminator; ss = ss->next)
     657                 :      184446 :     ss->info->useflags = flags;
     658                 :      139389 : }
     659                 :             : 
     660                 :             : 
     661                 :             : /* Free a gfc_ss chain.  */
     662                 :             : 
     663                 :             : void
     664                 :      146291 : gfc_free_ss_chain (gfc_ss * ss)
     665                 :             : {
     666                 :      146291 :   gfc_ss *next;
     667                 :             : 
     668                 :      300680 :   while (ss != gfc_ss_terminator)
     669                 :             :     {
     670                 :      154389 :       gcc_assert (ss != NULL);
     671                 :      154389 :       next = ss->next;
     672                 :      154389 :       gfc_free_ss (ss);
     673                 :      154389 :       ss = next;
     674                 :             :     }
     675                 :      146291 : }
     676                 :             : 
     677                 :             : 
     678                 :             : static void
     679                 :      395770 : free_ss_info (gfc_ss_info *ss_info)
     680                 :             : {
     681                 :      395770 :   int n;
     682                 :             : 
     683                 :      395770 :   ss_info->refcount--;
     684                 :      395770 :   if (ss_info->refcount > 0)
     685                 :             :     return;
     686                 :             : 
     687                 :      395026 :   gcc_assert (ss_info->refcount == 0);
     688                 :             : 
     689                 :      395026 :   switch (ss_info->type)
     690                 :             :     {
     691                 :             :     case GFC_SS_SECTION:
     692                 :     4460064 :       for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
     693                 :     4181310 :         if (ss_info->data.array.subscript[n])
     694                 :        4856 :           gfc_free_ss_chain (ss_info->data.array.subscript[n]);
     695                 :             :       break;
     696                 :             : 
     697                 :             :     default:
     698                 :             :       break;
     699                 :             :     }
     700                 :             : 
     701                 :      395026 :   free (ss_info);
     702                 :             : }
     703                 :             : 
     704                 :             : 
     705                 :             : /* Free a SS.  */
     706                 :             : 
     707                 :             : void
     708                 :      395770 : gfc_free_ss (gfc_ss * ss)
     709                 :             : {
     710                 :      395770 :   free_ss_info (ss->info);
     711                 :      395770 :   free (ss);
     712                 :      395770 : }
     713                 :             : 
     714                 :             : 
     715                 :             : /* Creates and initializes an array type gfc_ss struct.  */
     716                 :             : 
     717                 :             : gfc_ss *
     718                 :      335523 : gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
     719                 :             : {
     720                 :      335523 :   gfc_ss *ss;
     721                 :      335523 :   gfc_ss_info *ss_info;
     722                 :      335523 :   int i;
     723                 :             : 
     724                 :      335523 :   ss_info = gfc_get_ss_info ();
     725                 :      335523 :   ss_info->refcount++;
     726                 :      335523 :   ss_info->type = type;
     727                 :      335523 :   ss_info->expr = expr;
     728                 :             : 
     729                 :      335523 :   ss = gfc_get_ss ();
     730                 :      335523 :   ss->info = ss_info;
     731                 :      335523 :   ss->next = next;
     732                 :      335523 :   ss->dimen = dimen;
     733                 :      689961 :   for (i = 0; i < ss->dimen; i++)
     734                 :      354438 :     ss->dim[i] = i;
     735                 :             : 
     736                 :      335523 :   return ss;
     737                 :             : }
     738                 :             : 
     739                 :             : 
     740                 :             : /* Creates and initializes a temporary type gfc_ss struct.  */
     741                 :             : 
     742                 :             : gfc_ss *
     743                 :        8581 : gfc_get_temp_ss (tree type, tree string_length, int dimen)
     744                 :             : {
     745                 :        8581 :   gfc_ss *ss;
     746                 :        8581 :   gfc_ss_info *ss_info;
     747                 :        8581 :   int i;
     748                 :             : 
     749                 :        8581 :   ss_info = gfc_get_ss_info ();
     750                 :        8581 :   ss_info->refcount++;
     751                 :        8581 :   ss_info->type = GFC_SS_TEMP;
     752                 :        8581 :   ss_info->string_length = string_length;
     753                 :        8581 :   ss_info->data.temp.type = type;
     754                 :             : 
     755                 :        8581 :   ss = gfc_get_ss ();
     756                 :        8581 :   ss->info = ss_info;
     757                 :        8581 :   ss->next = gfc_ss_terminator;
     758                 :        8581 :   ss->dimen = dimen;
     759                 :       19554 :   for (i = 0; i < ss->dimen; i++)
     760                 :       10973 :     ss->dim[i] = i;
     761                 :             : 
     762                 :        8581 :   return ss;
     763                 :             : }
     764                 :             : 
     765                 :             : 
     766                 :             : /* Creates and initializes a scalar type gfc_ss struct.  */
     767                 :             : 
     768                 :             : gfc_ss *
     769                 :       54669 : gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
     770                 :             : {
     771                 :       54669 :   gfc_ss *ss;
     772                 :       54669 :   gfc_ss_info *ss_info;
     773                 :             : 
     774                 :       54669 :   ss_info = gfc_get_ss_info ();
     775                 :       54669 :   ss_info->refcount++;
     776                 :       54669 :   ss_info->type = GFC_SS_SCALAR;
     777                 :       54669 :   ss_info->expr = expr;
     778                 :             : 
     779                 :       54669 :   ss = gfc_get_ss ();
     780                 :       54669 :   ss->info = ss_info;
     781                 :       54669 :   ss->next = next;
     782                 :             : 
     783                 :       54669 :   return ss;
     784                 :             : }
     785                 :             : 
     786                 :             : 
     787                 :             : /* Free all the SS associated with a loop.  */
     788                 :             : 
     789                 :             : void
     790                 :      148149 : gfc_cleanup_loop (gfc_loopinfo * loop)
     791                 :             : {
     792                 :      148149 :   gfc_loopinfo *loop_next, **ploop;
     793                 :      148149 :   gfc_ss *ss;
     794                 :      148149 :   gfc_ss *next;
     795                 :             : 
     796                 :      148149 :   ss = loop->ss;
     797                 :      389319 :   while (ss != gfc_ss_terminator)
     798                 :             :     {
     799                 :      241170 :       gcc_assert (ss != NULL);
     800                 :      241170 :       next = ss->loop_chain;
     801                 :      241170 :       gfc_free_ss (ss);
     802                 :      241170 :       ss = next;
     803                 :             :     }
     804                 :             : 
     805                 :             :   /* Remove reference to self in the parent loop.  */
     806                 :      148149 :   if (loop->parent)
     807                 :         553 :     for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
     808                 :         553 :       if (*ploop == loop)
     809                 :             :         {
     810                 :         553 :           *ploop = loop->next;
     811                 :         553 :           break;
     812                 :             :         }
     813                 :             : 
     814                 :             :   /* Free non-freed nested loops.  */
     815                 :      148702 :   for (loop = loop->nested; loop; loop = loop_next)
     816                 :             :     {
     817                 :         553 :       loop_next = loop->next;
     818                 :         553 :       gfc_cleanup_loop (loop);
     819                 :         553 :       free (loop);
     820                 :             :     }
     821                 :      148149 : }
     822                 :             : 
     823                 :             : 
     824                 :             : static void
     825                 :      201181 : set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
     826                 :             : {
     827                 :      201181 :   int n;
     828                 :             : 
     829                 :      448683 :   for (; ss != gfc_ss_terminator; ss = ss->next)
     830                 :             :     {
     831                 :      247502 :       ss->loop = loop;
     832                 :             : 
     833                 :      247502 :       if (ss->info->type == GFC_SS_SCALAR
     834                 :             :           || ss->info->type == GFC_SS_REFERENCE
     835                 :      209972 :           || ss->info->type == GFC_SS_TEMP)
     836                 :       46111 :         continue;
     837                 :             : 
     838                 :     3222256 :       for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
     839                 :     3020865 :         if (ss->info->data.array.subscript[n] != NULL)
     840                 :        4712 :           set_ss_loop (ss->info->data.array.subscript[n], loop);
     841                 :             :     }
     842                 :      201181 : }
     843                 :             : 
     844                 :             : 
     845                 :             : /* Associate a SS chain with a loop.  */
     846                 :             : 
     847                 :             : void
     848                 :      196469 : gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
     849                 :             : {
     850                 :      196469 :   gfc_ss *ss;
     851                 :      196469 :   gfc_loopinfo *nested_loop;
     852                 :             : 
     853                 :      196469 :   if (head == gfc_ss_terminator)
     854                 :             :     return;
     855                 :             : 
     856                 :      196469 :   set_ss_loop (head, loop);
     857                 :             : 
     858                 :      196469 :   ss = head;
     859                 :      635728 :   for (; ss && ss != gfc_ss_terminator; ss = ss->next)
     860                 :             :     {
     861                 :      242790 :       if (ss->nested_ss)
     862                 :             :         {
     863                 :         737 :           nested_loop = ss->nested_ss->loop;
     864                 :             : 
     865                 :             :           /* More than one ss can belong to the same loop.  Hence, we add the
     866                 :             :              loop to the chain only if it is different from the previously
     867                 :             :              added one, to avoid duplicate nested loops.  */
     868                 :         737 :           if (nested_loop != loop->nested)
     869                 :             :             {
     870                 :         553 :               gcc_assert (nested_loop->parent == NULL);
     871                 :         553 :               nested_loop->parent = loop;
     872                 :             : 
     873                 :         553 :               gcc_assert (nested_loop->next == NULL);
     874                 :         553 :               nested_loop->next = loop->nested;
     875                 :         553 :               loop->nested = nested_loop;
     876                 :             :             }
     877                 :             :           else
     878                 :         184 :             gcc_assert (nested_loop->parent == loop);
     879                 :             :         }
     880                 :             : 
     881                 :      242790 :       if (ss->next == gfc_ss_terminator)
     882                 :      196469 :         ss->loop_chain = loop->ss;
     883                 :             :       else
     884                 :       46321 :         ss->loop_chain = ss->next;
     885                 :             :     }
     886                 :      196469 :   gcc_assert (ss == gfc_ss_terminator);
     887                 :      196469 :   loop->ss = head;
     888                 :             : }
     889                 :             : 
     890                 :             : 
     891                 :             : /* Returns true if the expression is an array pointer.  */
     892                 :             : 
     893                 :             : static bool
     894                 :      306879 : is_pointer_array (tree expr)
     895                 :             : {
     896                 :      306879 :   if (expr == NULL_TREE
     897                 :      306879 :       || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
     898                 :      383243 :       || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
     899                 :             :     return false;
     900                 :             : 
     901                 :       76364 :   if (VAR_P (expr)
     902                 :       76364 :       && GFC_DECL_PTR_ARRAY_P (expr))
     903                 :             :     return true;
     904                 :             : 
     905                 :       70900 :   if (TREE_CODE (expr) == PARM_DECL
     906                 :       70900 :       && GFC_DECL_PTR_ARRAY_P (expr))
     907                 :             :     return true;
     908                 :             : 
     909                 :       70900 :   if (INDIRECT_REF_P (expr)
     910                 :       70900 :       && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
     911                 :             :     return true;
     912                 :             : 
     913                 :             :   /* The field declaration is marked as an pointer array.  */
     914                 :       68827 :   if (TREE_CODE (expr) == COMPONENT_REF
     915                 :       10285 :       && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
     916                 :       71061 :       && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
     917                 :        2234 :     return true;
     918                 :             : 
     919                 :             :   return false;
     920                 :             : }
     921                 :             : 
     922                 :             : 
     923                 :             : /* If the symbol or expression reference a CFI descriptor, return the
     924                 :             :    pointer to the converted gfc descriptor. If an array reference is
     925                 :             :    present as the last argument, check that it is the one applied to
     926                 :             :    the CFI descriptor in the expression. Note that the CFI object is
     927                 :             :    always the symbol in the expression!  */
     928                 :             : 
     929                 :             : static bool
     930                 :      308796 : get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
     931                 :             :               tree *desc, gfc_array_ref *ar)
     932                 :             : {
     933                 :      308796 :   tree tmp;
     934                 :             : 
     935                 :      308796 :   if (!is_CFI_desc (sym, expr))
     936                 :             :     return false;
     937                 :             : 
     938                 :        4727 :   if (expr && ar)
     939                 :             :     {
     940                 :        4061 :       if (!(expr->ref && expr->ref->type == REF_ARRAY)
     941                 :        4043 :           || (&expr->ref->u.ar != ar))
     942                 :             :         return false;
     943                 :             :     }
     944                 :             : 
     945                 :        4697 :   if (sym == NULL)
     946                 :        1108 :     tmp = expr->symtree->n.sym->backend_decl;
     947                 :             :   else
     948                 :        3589 :     tmp = sym->backend_decl;
     949                 :             : 
     950                 :        4697 :   if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
     951                 :           0 :     tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
     952                 :             : 
     953                 :        4697 :   *desc = tmp;
     954                 :        4697 :   return true;
     955                 :             : }
     956                 :             : 
     957                 :             : 
     958                 :             : /* Return the span of an array.  */
     959                 :             : 
     960                 :             : tree
     961                 :       51282 : gfc_get_array_span (tree desc, gfc_expr *expr)
     962                 :             : {
     963                 :       51282 :   tree tmp;
     964                 :             : 
     965                 :       51282 :   if (is_pointer_array (desc)
     966                 :       51282 :       || (get_CFI_desc (NULL, expr, &desc, NULL)
     967                 :        1332 :           && (POINTER_TYPE_P (TREE_TYPE (desc))
     968                 :         666 :               ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
     969                 :           0 :               : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
     970                 :             :     {
     971                 :         491 :       if (POINTER_TYPE_P (TREE_TYPE (desc)))
     972                 :           0 :         desc = build_fold_indirect_ref_loc (input_location, desc);
     973                 :             : 
     974                 :             :       /* This will have the span field set.  */
     975                 :         491 :       tmp = gfc_conv_descriptor_span_get (desc);
     976                 :             :     }
     977                 :       50791 :   else if (expr->ts.type == BT_ASSUMED)
     978                 :             :     {
     979                 :         127 :       if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
     980                 :         127 :         desc = GFC_DECL_SAVED_DESCRIPTOR (desc);
     981                 :         127 :       if (POINTER_TYPE_P (TREE_TYPE (desc)))
     982                 :         127 :         desc = build_fold_indirect_ref_loc (input_location, desc);
     983                 :         127 :       tmp = gfc_conv_descriptor_span_get (desc);
     984                 :             :     }
     985                 :       50664 :   else if (TREE_CODE (desc) == COMPONENT_REF
     986                 :         555 :            && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
     987                 :       50766 :            && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
     988                 :             :     {
     989                 :             :       /* The descriptor is a class _data field and so use the vtable
     990                 :             :          size for the receiving span field.  */
     991                 :          42 :       tmp = gfc_get_vptr_from_expr (desc);
     992                 :          42 :       tmp = gfc_vptr_size_get (tmp);
     993                 :             :     }
     994                 :       50622 :   else if (expr && expr->expr_type == EXPR_VARIABLE
     995                 :       45294 :            && expr->symtree->n.sym->ts.type == BT_CLASS
     996                 :         960 :            && expr->ref->type == REF_COMPONENT
     997                 :         960 :            && expr->ref->next->type == REF_ARRAY
     998                 :         960 :            && expr->ref->next->next == NULL
     999                 :         936 :            && CLASS_DATA (expr->symtree->n.sym)->attr.dimension)
    1000                 :             :     {
    1001                 :             :       /* Dummys come in sometimes with the descriptor detached from
    1002                 :             :          the class field or declaration.  */
    1003                 :         914 :       tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl);
    1004                 :         914 :       tmp = gfc_vptr_size_get (tmp);
    1005                 :             :     }
    1006                 :             :   else
    1007                 :             :     {
    1008                 :             :       /* If none of the fancy stuff works, the span is the element
    1009                 :             :          size of the array. Attempt to deal with unbounded character
    1010                 :             :          types if possible. Otherwise, return NULL_TREE.  */
    1011                 :       49708 :       tmp = gfc_get_element_type (TREE_TYPE (desc));
    1012                 :       49708 :       if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
    1013                 :             :         {
    1014                 :       10349 :           gcc_assert (expr->ts.type == BT_CHARACTER);
    1015                 :             : 
    1016                 :       10349 :           tmp = gfc_get_character_len_in_bytes (tmp);
    1017                 :             : 
    1018                 :       10349 :           if (tmp == NULL_TREE || integer_zerop (tmp))
    1019                 :             :             {
    1020                 :          96 :               tree bs;
    1021                 :             : 
    1022                 :          96 :               tmp = gfc_get_expr_charlen (expr);
    1023                 :          96 :               tmp = fold_convert (gfc_array_index_type, tmp);
    1024                 :          96 :               bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
    1025                 :          96 :               tmp = fold_build2_loc (input_location, MULT_EXPR,
    1026                 :             :                                      gfc_array_index_type, tmp, bs);
    1027                 :             :             }
    1028                 :             : 
    1029                 :       10349 :           tmp = (tmp && !integer_zerop (tmp))
    1030                 :       20618 :             ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
    1031                 :             :         }
    1032                 :             :       else
    1033                 :       39359 :         tmp = fold_convert (gfc_array_index_type,
    1034                 :             :                             size_in_bytes (tmp));
    1035                 :             :     }
    1036                 :       51282 :   return tmp;
    1037                 :             : }
    1038                 :             : 
    1039                 :             : 
    1040                 :             : /* Generate an initializer for a static pointer or allocatable array.  */
    1041                 :             : 
    1042                 :             : void
    1043                 :         173 : gfc_trans_static_array_pointer (gfc_symbol * sym)
    1044                 :             : {
    1045                 :         173 :   tree type;
    1046                 :             : 
    1047                 :         173 :   gcc_assert (TREE_STATIC (sym->backend_decl));
    1048                 :             :   /* Just zero the data member.  */
    1049                 :         173 :   type = TREE_TYPE (sym->backend_decl);
    1050                 :         173 :   DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
    1051                 :         173 : }
    1052                 :             : 
    1053                 :             : 
    1054                 :             : /* If the bounds of SE's loop have not yet been set, see if they can be
    1055                 :             :    determined from array spec AS, which is the array spec of a called
    1056                 :             :    function.  MAPPING maps the callee's dummy arguments to the values
    1057                 :             :    that the caller is passing.  Add any initialization and finalization
    1058                 :             :    code to SE.  */
    1059                 :             : 
    1060                 :             : void
    1061                 :        7605 : gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
    1062                 :             :                                      gfc_se * se, gfc_array_spec * as)
    1063                 :             : {
    1064                 :        7605 :   int n, dim, total_dim;
    1065                 :        7605 :   gfc_se tmpse;
    1066                 :        7605 :   gfc_ss *ss;
    1067                 :        7605 :   tree lower;
    1068                 :        7605 :   tree upper;
    1069                 :        7605 :   tree tmp;
    1070                 :             : 
    1071                 :        7605 :   total_dim = 0;
    1072                 :             : 
    1073                 :        7605 :   if (!as || as->type != AS_EXPLICIT)
    1074                 :        6543 :     return;
    1075                 :             : 
    1076                 :        2149 :   for (ss = se->ss; ss; ss = ss->parent)
    1077                 :             :     {
    1078                 :        1087 :       total_dim += ss->loop->dimen;
    1079                 :        2529 :       for (n = 0; n < ss->loop->dimen; n++)
    1080                 :             :         {
    1081                 :             :           /* The bound is known, nothing to do.  */
    1082                 :        1442 :           if (ss->loop->to[n] != NULL_TREE)
    1083                 :         491 :             continue;
    1084                 :             : 
    1085                 :         951 :           dim = ss->dim[n];
    1086                 :         951 :           gcc_assert (dim < as->rank);
    1087                 :         951 :           gcc_assert (ss->loop->dimen <= as->rank);
    1088                 :             : 
    1089                 :             :           /* Evaluate the lower bound.  */
    1090                 :         951 :           gfc_init_se (&tmpse, NULL);
    1091                 :         951 :           gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
    1092                 :         951 :           gfc_add_block_to_block (&se->pre, &tmpse.pre);
    1093                 :         951 :           gfc_add_block_to_block (&se->post, &tmpse.post);
    1094                 :         951 :           lower = fold_convert (gfc_array_index_type, tmpse.expr);
    1095                 :             : 
    1096                 :             :           /* ...and the upper bound.  */
    1097                 :         951 :           gfc_init_se (&tmpse, NULL);
    1098                 :         951 :           gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
    1099                 :         951 :           gfc_add_block_to_block (&se->pre, &tmpse.pre);
    1100                 :         951 :           gfc_add_block_to_block (&se->post, &tmpse.post);
    1101                 :         951 :           upper = fold_convert (gfc_array_index_type, tmpse.expr);
    1102                 :             : 
    1103                 :             :           /* Set the upper bound of the loop to UPPER - LOWER.  */
    1104                 :         951 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
    1105                 :             :                                  gfc_array_index_type, upper, lower);
    1106                 :         951 :           tmp = gfc_evaluate_now (tmp, &se->pre);
    1107                 :         951 :           ss->loop->to[n] = tmp;
    1108                 :             :         }
    1109                 :             :     }
    1110                 :             : 
    1111                 :        1062 :   gcc_assert (total_dim == as->rank);
    1112                 :             : }
    1113                 :             : 
    1114                 :             : 
    1115                 :             : /* Generate code to allocate an array temporary, or create a variable to
    1116                 :             :    hold the data.  If size is NULL, zero the descriptor so that the
    1117                 :             :    callee will allocate the array.  If DEALLOC is true, also generate code to
    1118                 :             :    free the array afterwards.
    1119                 :             : 
    1120                 :             :    If INITIAL is not NULL, it is packed using internal_pack and the result used
    1121                 :             :    as data instead of allocating a fresh, unitialized area of memory.
    1122                 :             : 
    1123                 :             :    Initialization code is added to PRE and finalization code to POST.
    1124                 :             :    DYNAMIC is true if the caller may want to extend the array later
    1125                 :             :    using realloc.  This prevents us from putting the array on the stack.  */
    1126                 :             : 
    1127                 :             : static void
    1128                 :       24147 : gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
    1129                 :             :                                   gfc_array_info * info, tree size, tree nelem,
    1130                 :             :                                   tree initial, bool dynamic, bool dealloc)
    1131                 :             : {
    1132                 :       24147 :   tree tmp;
    1133                 :       24147 :   tree desc;
    1134                 :       24147 :   bool onstack;
    1135                 :             : 
    1136                 :       24147 :   desc = info->descriptor;
    1137                 :       24147 :   info->offset = gfc_index_zero_node;
    1138                 :       24147 :   if (size == NULL_TREE || (dynamic && integer_zerop (size)))
    1139                 :             :     {
    1140                 :             :       /* A callee allocated array.  */
    1141                 :        2414 :       gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
    1142                 :        2414 :       onstack = false;
    1143                 :             :     }
    1144                 :             :   else
    1145                 :             :     {
    1146                 :             :       /* Allocate the temporary.  */
    1147                 :       43466 :       onstack = !dynamic && initial == NULL_TREE
    1148                 :       21733 :                          && (flag_stack_arrays
    1149                 :       21448 :                              || gfc_can_put_var_on_stack (size));
    1150                 :             : 
    1151                 :       21733 :       if (onstack)
    1152                 :             :         {
    1153                 :             :           /* Make a temporary variable to hold the data.  */
    1154                 :       17533 :           tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
    1155                 :             :                                  nelem, gfc_index_one_node);
    1156                 :       17533 :           tmp = gfc_evaluate_now (tmp, pre);
    1157                 :       17533 :           tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    1158                 :             :                                   tmp);
    1159                 :       17533 :           tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
    1160                 :             :                                   tmp);
    1161                 :       17533 :           tmp = gfc_create_var (tmp, "A");
    1162                 :             :           /* If we're here only because of -fstack-arrays we have to
    1163                 :             :              emit a DECL_EXPR to make the gimplifier emit alloca calls.  */
    1164                 :       17533 :           if (!gfc_can_put_var_on_stack (size))
    1165                 :          17 :             gfc_add_expr_to_block (pre,
    1166                 :             :                                    fold_build1_loc (input_location,
    1167                 :          17 :                                                     DECL_EXPR, TREE_TYPE (tmp),
    1168                 :             :                                                     tmp));
    1169                 :       17533 :           tmp = gfc_build_addr_expr (NULL_TREE, tmp);
    1170                 :       17533 :           gfc_conv_descriptor_data_set (pre, desc, tmp);
    1171                 :             :         }
    1172                 :             :       else
    1173                 :             :         {
    1174                 :             :           /* Allocate memory to hold the data or call internal_pack.  */
    1175                 :        4200 :           if (initial == NULL_TREE)
    1176                 :             :             {
    1177                 :        4099 :               tmp = gfc_call_malloc (pre, NULL, size);
    1178                 :        4099 :               tmp = gfc_evaluate_now (tmp, pre);
    1179                 :             :             }
    1180                 :             :           else
    1181                 :             :             {
    1182                 :         101 :               tree packed;
    1183                 :         101 :               tree source_data;
    1184                 :         101 :               tree was_packed;
    1185                 :         101 :               stmtblock_t do_copying;
    1186                 :             : 
    1187                 :         101 :               tmp = TREE_TYPE (initial); /* Pointer to descriptor.  */
    1188                 :         101 :               gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
    1189                 :         101 :               tmp = TREE_TYPE (tmp); /* The descriptor itself.  */
    1190                 :         101 :               tmp = gfc_get_element_type (tmp);
    1191                 :         101 :               packed = gfc_create_var (build_pointer_type (tmp), "data");
    1192                 :             : 
    1193                 :         101 :               tmp = build_call_expr_loc (input_location,
    1194                 :             :                                      gfor_fndecl_in_pack, 1, initial);
    1195                 :         101 :               tmp = fold_convert (TREE_TYPE (packed), tmp);
    1196                 :         101 :               gfc_add_modify (pre, packed, tmp);
    1197                 :             : 
    1198                 :         101 :               tmp = build_fold_indirect_ref_loc (input_location,
    1199                 :             :                                              initial);
    1200                 :         101 :               source_data = gfc_conv_descriptor_data_get (tmp);
    1201                 :             : 
    1202                 :             :               /* internal_pack may return source->data without any allocation
    1203                 :             :                  or copying if it is already packed.  If that's the case, we
    1204                 :             :                  need to allocate and copy manually.  */
    1205                 :             : 
    1206                 :         101 :               gfc_start_block (&do_copying);
    1207                 :         101 :               tmp = gfc_call_malloc (&do_copying, NULL, size);
    1208                 :         101 :               tmp = fold_convert (TREE_TYPE (packed), tmp);
    1209                 :         101 :               gfc_add_modify (&do_copying, packed, tmp);
    1210                 :         101 :               tmp = gfc_build_memcpy_call (packed, source_data, size);
    1211                 :         101 :               gfc_add_expr_to_block (&do_copying, tmp);
    1212                 :             : 
    1213                 :         101 :               was_packed = fold_build2_loc (input_location, EQ_EXPR,
    1214                 :             :                                             logical_type_node, packed,
    1215                 :             :                                             source_data);
    1216                 :         101 :               tmp = gfc_finish_block (&do_copying);
    1217                 :         101 :               tmp = build3_v (COND_EXPR, was_packed, tmp,
    1218                 :             :                               build_empty_stmt (input_location));
    1219                 :         101 :               gfc_add_expr_to_block (pre, tmp);
    1220                 :             : 
    1221                 :         101 :               tmp = fold_convert (pvoid_type_node, packed);
    1222                 :             :             }
    1223                 :             : 
    1224                 :        4200 :           gfc_conv_descriptor_data_set (pre, desc, tmp);
    1225                 :             :         }
    1226                 :             :     }
    1227                 :       24147 :   info->data = gfc_conv_descriptor_data_get (desc);
    1228                 :             : 
    1229                 :             :   /* The offset is zero because we create temporaries with a zero
    1230                 :             :      lower bound.  */
    1231                 :       24147 :   gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
    1232                 :             : 
    1233                 :       24147 :   if (dealloc && !onstack)
    1234                 :             :     {
    1235                 :             :       /* Free the temporary.  */
    1236                 :        6406 :       tmp = gfc_conv_descriptor_data_get (desc);
    1237                 :        6406 :       tmp = gfc_call_free (tmp);
    1238                 :        6406 :       gfc_add_expr_to_block (post, tmp);
    1239                 :             :     }
    1240                 :       24147 : }
    1241                 :             : 
    1242                 :             : 
    1243                 :             : /* Get the scalarizer array dimension corresponding to actual array dimension
    1244                 :             :    given by ARRAY_DIM.
    1245                 :             : 
    1246                 :             :    For example, if SS represents the array ref a(1,:,:,1), it is a
    1247                 :             :    bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
    1248                 :             :    and 1 for ARRAY_DIM=2.
    1249                 :             :    If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
    1250                 :             :    scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
    1251                 :             :    ARRAY_DIM=3.
    1252                 :             :    If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
    1253                 :             :    array.  If called on the inner ss, the result would be respectively 0,1,2 for
    1254                 :             :    ARRAY_DIM=0,1,2.  If called on the outer ss, the result would be 0,1
    1255                 :             :    for ARRAY_DIM=1,2.  */
    1256                 :             : 
    1257                 :             : static int
    1258                 :      209749 : get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
    1259                 :             : {
    1260                 :      209749 :   int array_ref_dim;
    1261                 :      209749 :   int n;
    1262                 :             : 
    1263                 :      209749 :   array_ref_dim = 0;
    1264                 :             : 
    1265                 :      420494 :   for (; ss; ss = ss->parent)
    1266                 :      533861 :     for (n = 0; n < ss->dimen; n++)
    1267                 :      323116 :       if (ss->dim[n] < array_dim)
    1268                 :       55044 :         array_ref_dim++;
    1269                 :             : 
    1270                 :      209749 :   return array_ref_dim;
    1271                 :             : }
    1272                 :             : 
    1273                 :             : 
    1274                 :             : static gfc_ss *
    1275                 :      175875 : innermost_ss (gfc_ss *ss)
    1276                 :             : {
    1277                 :      321163 :   while (ss->nested_ss != NULL)
    1278                 :             :     ss = ss->nested_ss;
    1279                 :             : 
    1280                 :      320156 :   return ss;
    1281                 :             : }
    1282                 :             : 
    1283                 :             : 
    1284                 :             : 
    1285                 :             : /* Get the array reference dimension corresponding to the given loop dimension.
    1286                 :             :    It is different from the true array dimension given by the dim array in
    1287                 :             :    the case of a partial array reference (i.e. a(:,:,1,:) for example)
    1288                 :             :    It is different from the loop dimension in the case of a transposed array.
    1289                 :             :    */
    1290                 :             : 
    1291                 :             : static int
    1292                 :      175875 : get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
    1293                 :             : {
    1294                 :      175875 :   return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
    1295                 :      175875 :                                            ss->dim[loop_dim]);
    1296                 :             : }
    1297                 :             : 
    1298                 :             : 
    1299                 :             : /* Use the information in the ss to obtain the required information about
    1300                 :             :    the type and size of an array temporary, when the lhs in an assignment
    1301                 :             :    is a class expression.  */
    1302                 :             : 
    1303                 :             : static tree
    1304                 :         188 : get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
    1305                 :             : {
    1306                 :         188 :   gfc_ss *lhs_ss;
    1307                 :         188 :   gfc_ss *rhs_ss;
    1308                 :         188 :   tree tmp;
    1309                 :         188 :   tree tmp2;
    1310                 :         188 :   tree vptr;
    1311                 :         188 :   tree rhs_class_expr = NULL_TREE;
    1312                 :         188 :   tree lhs_class_expr = NULL_TREE;
    1313                 :         188 :   bool unlimited_rhs = false;
    1314                 :         188 :   bool unlimited_lhs = false;
    1315                 :         188 :   bool rhs_function = false;
    1316                 :         188 :   gfc_symbol *vtab;
    1317                 :             : 
    1318                 :             :   /* The second element in the loop chain contains the source for the
    1319                 :             :      temporary; ie. the rhs of the assignment.  */
    1320                 :         188 :   rhs_ss = ss->loop->ss->loop_chain;
    1321                 :             : 
    1322                 :         188 :   if (rhs_ss != gfc_ss_terminator
    1323                 :         188 :       && rhs_ss->info
    1324                 :         188 :       && rhs_ss->info->expr
    1325                 :         188 :       && rhs_ss->info->expr->ts.type == BT_CLASS
    1326                 :         104 :       && rhs_ss->info->data.array.descriptor)
    1327                 :             :     {
    1328                 :          98 :       if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
    1329                 :          50 :         rhs_class_expr
    1330                 :          50 :           = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
    1331                 :             :       else
    1332                 :          48 :         rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
    1333                 :          98 :       unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
    1334                 :          98 :       if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
    1335                 :          31 :         rhs_function = true;
    1336                 :             :     }
    1337                 :             : 
    1338                 :             :   /* For an assignment the lhs is the next element in the loop chain.
    1339                 :             :      If we have a class rhs, this had better be a class variable
    1340                 :             :      expression!  */
    1341                 :         188 :   lhs_ss = rhs_ss->loop_chain;
    1342                 :         188 :   if (lhs_ss != gfc_ss_terminator
    1343                 :         176 :       && lhs_ss->info
    1344                 :         176 :       && lhs_ss->info->expr
    1345                 :         176 :       && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
    1346                 :         176 :       && lhs_ss->info->expr->ts.type == BT_CLASS)
    1347                 :             :     {
    1348                 :         176 :       tmp = lhs_ss->info->data.array.descriptor;
    1349                 :         176 :       unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
    1350                 :             :     }
    1351                 :             :   else
    1352                 :             :     tmp = NULL_TREE;
    1353                 :             : 
    1354                 :             :   /* Get the lhs class expression.  */
    1355                 :         176 :   if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
    1356                 :         164 :     lhs_class_expr = gfc_get_class_from_expr (tmp);
    1357                 :             :   else
    1358                 :             :     return rhs_class_expr;
    1359                 :             : 
    1360                 :         164 :   gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
    1361                 :             : 
    1362                 :             :   /* Set the lhs vptr and, if necessary, the _len field.  */
    1363                 :         164 :   if (rhs_class_expr)
    1364                 :             :     {
    1365                 :             :       /* Both lhs and rhs are class expressions.  */
    1366                 :          73 :       tmp = gfc_class_vptr_get (lhs_class_expr);
    1367                 :         146 :       gfc_add_modify (pre, tmp,
    1368                 :          73 :                       fold_convert (TREE_TYPE (tmp),
    1369                 :             :                                     gfc_class_vptr_get (rhs_class_expr)));
    1370                 :          73 :       if (unlimited_lhs)
    1371                 :             :         {
    1372                 :          31 :           tmp = gfc_class_len_get (lhs_class_expr);
    1373                 :          31 :           if (unlimited_rhs)
    1374                 :          31 :             tmp2 = gfc_class_len_get (rhs_class_expr);
    1375                 :             :           else
    1376                 :           0 :             tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
    1377                 :          31 :           gfc_add_modify (pre, tmp, tmp2);
    1378                 :             :         }
    1379                 :             : 
    1380                 :          73 :       if (rhs_function)
    1381                 :             :         {
    1382                 :          31 :           tmp = gfc_class_data_get (rhs_class_expr);
    1383                 :          31 :           gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
    1384                 :             :         }
    1385                 :             :     }
    1386                 :             :   else
    1387                 :             :    {
    1388                 :             :       /* lhs is class and rhs is intrinsic or derived type.  */
    1389                 :          91 :       *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
    1390                 :          91 :       *eltype = gfc_get_element_type (*eltype);
    1391                 :          91 :       vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
    1392                 :          91 :       vptr = vtab->backend_decl;
    1393                 :          91 :       if (vptr == NULL_TREE)
    1394                 :          12 :         vptr = gfc_get_symbol_decl (vtab);
    1395                 :          91 :       vptr = gfc_build_addr_expr (NULL_TREE, vptr);
    1396                 :          91 :       tmp = gfc_class_vptr_get (lhs_class_expr);
    1397                 :          91 :       gfc_add_modify (pre, tmp,
    1398                 :          91 :                       fold_convert (TREE_TYPE (tmp), vptr));
    1399                 :             : 
    1400                 :          91 :       if (unlimited_lhs)
    1401                 :             :         {
    1402                 :           0 :           tmp = gfc_class_len_get (lhs_class_expr);
    1403                 :           0 :           if (rhs_ss->info
    1404                 :           0 :               && rhs_ss->info->expr
    1405                 :           0 :               && rhs_ss->info->expr->ts.type == BT_CHARACTER)
    1406                 :           0 :             tmp2 = build_int_cst (TREE_TYPE (tmp),
    1407                 :           0 :                                   rhs_ss->info->expr->ts.kind);
    1408                 :             :           else
    1409                 :           0 :             tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
    1410                 :           0 :           gfc_add_modify (pre, tmp, tmp2);
    1411                 :             :         }
    1412                 :             :     }
    1413                 :             : 
    1414                 :             :   return rhs_class_expr;
    1415                 :             : }
    1416                 :             : 
    1417                 :             : 
    1418                 :             : 
    1419                 :             : /* Generate code to create and initialize the descriptor for a temporary
    1420                 :             :    array.  This is used for both temporaries needed by the scalarizer, and
    1421                 :             :    functions returning arrays.  Adjusts the loop variables to be
    1422                 :             :    zero-based, and calculates the loop bounds for callee allocated arrays.
    1423                 :             :    Allocate the array unless it's callee allocated (we have a callee
    1424                 :             :    allocated array if 'callee_alloc' is true, or if loop->to[n] is
    1425                 :             :    NULL_TREE for any n).  Also fills in the descriptor, data and offset
    1426                 :             :    fields of info if known.  Returns the size of the array, or NULL for a
    1427                 :             :    callee allocated array.
    1428                 :             : 
    1429                 :             :    'eltype' == NULL signals that the temporary should be a class object.
    1430                 :             :    The 'initial' expression is used to obtain the size of the dynamic
    1431                 :             :    type; otherwise the allocation and initialization proceeds as for any
    1432                 :             :    other expression
    1433                 :             : 
    1434                 :             :    PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
    1435                 :             :    gfc_trans_allocate_array_storage.  */
    1436                 :             : 
    1437                 :             : tree
    1438                 :       24147 : gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
    1439                 :             :                              tree eltype, tree initial, bool dynamic,
    1440                 :             :                              bool dealloc, bool callee_alloc, locus * where)
    1441                 :             : {
    1442                 :       24147 :   gfc_loopinfo *loop;
    1443                 :       24147 :   gfc_ss *s;
    1444                 :       24147 :   gfc_array_info *info;
    1445                 :       24147 :   tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
    1446                 :       24147 :   tree type;
    1447                 :       24147 :   tree desc;
    1448                 :       24147 :   tree tmp;
    1449                 :       24147 :   tree size;
    1450                 :       24147 :   tree nelem;
    1451                 :       24147 :   tree cond;
    1452                 :       24147 :   tree or_expr;
    1453                 :       24147 :   tree elemsize;
    1454                 :       24147 :   tree class_expr = NULL_TREE;
    1455                 :       24147 :   int n, dim, tmp_dim;
    1456                 :       24147 :   int total_dim = 0;
    1457                 :             : 
    1458                 :             :   /* This signals a class array for which we need the size of the
    1459                 :             :      dynamic type.  Generate an eltype and then the class expression.  */
    1460                 :       24147 :   if (eltype == NULL_TREE && initial)
    1461                 :             :     {
    1462                 :           6 :       gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
    1463                 :           6 :       class_expr = build_fold_indirect_ref_loc (input_location, initial);
    1464                 :             :       /* Obtain the structure (class) expression.  */
    1465                 :           6 :       class_expr = gfc_get_class_from_expr (class_expr);
    1466                 :           6 :       gcc_assert (class_expr);
    1467                 :             :     }
    1468                 :             : 
    1469                 :             :   /* Otherwise, some expressions, such as class functions, arising from
    1470                 :             :      dependency checking in assignments come here with class element type.
    1471                 :             :      The descriptor can be obtained from the ss->info and then converted
    1472                 :             :      to the class object.  */
    1473                 :       24141 :   if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
    1474                 :         188 :     class_expr = get_class_info_from_ss (pre, ss, &eltype);
    1475                 :             : 
    1476                 :             :   /* If the dynamic type is not available, use the declared type.  */
    1477                 :       24147 :   if (eltype && GFC_CLASS_TYPE_P (eltype))
    1478                 :          97 :     eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
    1479                 :             : 
    1480                 :       24147 :   if (class_expr == NULL_TREE)
    1481                 :       24062 :     elemsize = fold_convert (gfc_array_index_type,
    1482                 :             :                              TYPE_SIZE_UNIT (eltype));
    1483                 :             :   else
    1484                 :             :     {
    1485                 :             :       /* Unlimited polymorphic entities are initialised with NULL vptr. They
    1486                 :             :          can be tested for by checking if the len field is present. If so
    1487                 :             :          test the vptr before using the vtable size.  */
    1488                 :          85 :       tmp = gfc_class_vptr_get (class_expr);
    1489                 :          85 :       tmp = fold_build2_loc (input_location, NE_EXPR,
    1490                 :             :                              logical_type_node,
    1491                 :          85 :                              tmp, build_int_cst (TREE_TYPE (tmp), 0));
    1492                 :          85 :       elemsize = fold_build3_loc (input_location, COND_EXPR,
    1493                 :             :                                   gfc_array_index_type,
    1494                 :             :                                   tmp,
    1495                 :             :                                   gfc_class_vtab_size_get (class_expr),
    1496                 :             :                                   gfc_index_zero_node);
    1497                 :          85 :       elemsize = gfc_evaluate_now (elemsize, pre);
    1498                 :          85 :       elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
    1499                 :             :       /* Casting the data as a character of the dynamic length ensures that
    1500                 :             :          assignment of elements works when needed.  */
    1501                 :          85 :       eltype = gfc_get_character_type_len (1, elemsize);
    1502                 :             :     }
    1503                 :             : 
    1504                 :       24147 :   memset (from, 0, sizeof (from));
    1505                 :       24147 :   memset (to, 0, sizeof (to));
    1506                 :             : 
    1507                 :       24147 :   info = &ss->info->data.array;
    1508                 :             : 
    1509                 :       24147 :   gcc_assert (ss->dimen > 0);
    1510                 :       24147 :   gcc_assert (ss->loop->dimen == ss->dimen);
    1511                 :             : 
    1512                 :       24147 :   if (warn_array_temporaries && where)
    1513                 :         204 :     gfc_warning (OPT_Warray_temporaries,
    1514                 :             :                  "Creating array temporary at %L", where);
    1515                 :             : 
    1516                 :             :   /* Set the lower bound to zero.  */
    1517                 :       48329 :   for (s = ss; s; s = s->parent)
    1518                 :             :     {
    1519                 :       24182 :       loop = s->loop;
    1520                 :             : 
    1521                 :       24182 :       total_dim += loop->dimen;
    1522                 :       55339 :       for (n = 0; n < loop->dimen; n++)
    1523                 :             :         {
    1524                 :       31157 :           dim = s->dim[n];
    1525                 :             : 
    1526                 :             :           /* Callee allocated arrays may not have a known bound yet.  */
    1527                 :       31157 :           if (loop->to[n])
    1528                 :       28445 :             loop->to[n] = gfc_evaluate_now (
    1529                 :             :                         fold_build2_loc (input_location, MINUS_EXPR,
    1530                 :             :                                          gfc_array_index_type,
    1531                 :             :                                          loop->to[n], loop->from[n]),
    1532                 :             :                         pre);
    1533                 :       31157 :           loop->from[n] = gfc_index_zero_node;
    1534                 :             : 
    1535                 :             :           /* We have just changed the loop bounds, we must clear the
    1536                 :             :              corresponding specloop, so that delta calculation is not skipped
    1537                 :             :              later in gfc_set_delta.  */
    1538                 :       31157 :           loop->specloop[n] = NULL;
    1539                 :             : 
    1540                 :             :           /* We are constructing the temporary's descriptor based on the loop
    1541                 :             :              dimensions.  As the dimensions may be accessed in arbitrary order
    1542                 :             :              (think of transpose) the size taken from the n'th loop may not map
    1543                 :             :              to the n'th dimension of the array.  We need to reconstruct loop
    1544                 :             :              infos in the right order before using it to set the descriptor
    1545                 :             :              bounds.  */
    1546                 :       31157 :           tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
    1547                 :       31157 :           from[tmp_dim] = loop->from[n];
    1548                 :       31157 :           to[tmp_dim] = loop->to[n];
    1549                 :             : 
    1550                 :       31157 :           info->delta[dim] = gfc_index_zero_node;
    1551                 :       31157 :           info->start[dim] = gfc_index_zero_node;
    1552                 :       31157 :           info->end[dim] = gfc_index_zero_node;
    1553                 :       31157 :           info->stride[dim] = gfc_index_one_node;
    1554                 :             :         }
    1555                 :             :     }
    1556                 :             : 
    1557                 :             :   /* Initialize the descriptor.  */
    1558                 :       24147 :   type =
    1559                 :       24147 :     gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
    1560                 :             :                                GFC_ARRAY_UNKNOWN, true);
    1561                 :       24147 :   desc = gfc_create_var (type, "atmp");
    1562                 :       24147 :   GFC_DECL_PACKED_ARRAY (desc) = 1;
    1563                 :             : 
    1564                 :             :   /* Emit a DECL_EXPR for the variable sized array type in
    1565                 :             :      GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
    1566                 :             :      sizes works correctly.  */
    1567                 :       24147 :   tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
    1568                 :       24147 :   if (! TYPE_NAME (arraytype))
    1569                 :       24147 :     TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
    1570                 :             :                                         NULL_TREE, arraytype);
    1571                 :       24147 :   gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
    1572                 :       24147 :                                       arraytype, TYPE_NAME (arraytype)));
    1573                 :             : 
    1574                 :       24147 :   if (class_expr != NULL_TREE)
    1575                 :             :     {
    1576                 :          85 :       tree class_data;
    1577                 :          85 :       tree dtype;
    1578                 :             : 
    1579                 :             :       /* Create a class temporary.  */
    1580                 :          85 :       tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
    1581                 :          85 :       gfc_add_modify (pre, tmp, class_expr);
    1582                 :             : 
    1583                 :             :       /* Assign the new descriptor to the _data field. This allows the
    1584                 :             :          vptr _copy to be used for scalarized assignment since the class
    1585                 :             :          temporary can be found from the descriptor.  */
    1586                 :          85 :       class_data = gfc_class_data_get (tmp);
    1587                 :          85 :       tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
    1588                 :          85 :                              TREE_TYPE (desc), desc);
    1589                 :          85 :       gfc_add_modify (pre, class_data, tmp);
    1590                 :             : 
    1591                 :             :       /* Take the dtype from the class expression.  */
    1592                 :          85 :       dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
    1593                 :          85 :       tmp = gfc_conv_descriptor_dtype (class_data);
    1594                 :          85 :       gfc_add_modify (pre, tmp, dtype);
    1595                 :             : 
    1596                 :             :       /* Point desc to the class _data field.  */
    1597                 :          85 :       desc = class_data;
    1598                 :             :     }
    1599                 :             :   else
    1600                 :             :     {
    1601                 :             :       /* Fill in the array dtype.  */
    1602                 :       24062 :       tmp = gfc_conv_descriptor_dtype (desc);
    1603                 :       24062 :       gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
    1604                 :             :     }
    1605                 :             : 
    1606                 :       24147 :   info->descriptor = desc;
    1607                 :       24147 :   size = gfc_index_one_node;
    1608                 :             : 
    1609                 :             :   /*
    1610                 :             :      Fill in the bounds and stride.  This is a packed array, so:
    1611                 :             : 
    1612                 :             :      size = 1;
    1613                 :             :      for (n = 0; n < rank; n++)
    1614                 :             :        {
    1615                 :             :          stride[n] = size
    1616                 :             :          delta = ubound[n] + 1 - lbound[n];
    1617                 :             :          size = size * delta;
    1618                 :             :        }
    1619                 :             :      size = size * sizeof(element);
    1620                 :             :   */
    1621                 :             : 
    1622                 :       24147 :   or_expr = NULL_TREE;
    1623                 :             : 
    1624                 :             :   /* If there is at least one null loop->to[n], it is a callee allocated
    1625                 :             :      array.  */
    1626                 :       52592 :   for (n = 0; n < total_dim; n++)
    1627                 :       30101 :     if (to[n] == NULL_TREE)
    1628                 :             :       {
    1629                 :             :         size = NULL_TREE;
    1630                 :             :         break;
    1631                 :             :       }
    1632                 :             : 
    1633                 :       24147 :   if (size == NULL_TREE)
    1634                 :        3322 :     for (s = ss; s; s = s->parent)
    1635                 :        4383 :       for (n = 0; n < s->loop->dimen; n++)
    1636                 :             :         {
    1637                 :        2717 :           dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
    1638                 :             : 
    1639                 :             :           /* For a callee allocated array express the loop bounds in terms
    1640                 :             :              of the descriptor fields.  */
    1641                 :        2717 :           tmp = fold_build2_loc (input_location,
    1642                 :             :                 MINUS_EXPR, gfc_array_index_type,
    1643                 :             :                 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
    1644                 :             :                 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
    1645                 :        2717 :           s->loop->to[n] = tmp;
    1646                 :             :         }
    1647                 :             :   else
    1648                 :             :     {
    1649                 :       50931 :       for (n = 0; n < total_dim; n++)
    1650                 :             :         {
    1651                 :             :           /* Store the stride and bound components in the descriptor.  */
    1652                 :       28440 :           gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
    1653                 :             : 
    1654                 :       28440 :           gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
    1655                 :             :                                           gfc_index_zero_node);
    1656                 :             : 
    1657                 :       28440 :           gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
    1658                 :             : 
    1659                 :       28440 :           tmp = fold_build2_loc (input_location, PLUS_EXPR,
    1660                 :             :                                  gfc_array_index_type,
    1661                 :             :                                  to[n], gfc_index_one_node);
    1662                 :             : 
    1663                 :             :           /* Check whether the size for this dimension is negative.  */
    1664                 :       28440 :           cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
    1665                 :             :                                   tmp, gfc_index_zero_node);
    1666                 :       28440 :           cond = gfc_evaluate_now (cond, pre);
    1667                 :             : 
    1668                 :       28440 :           if (n == 0)
    1669                 :             :             or_expr = cond;
    1670                 :             :           else
    1671                 :        5949 :             or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
    1672                 :             :                                        logical_type_node, or_expr, cond);
    1673                 :             : 
    1674                 :       28440 :           size = fold_build2_loc (input_location, MULT_EXPR,
    1675                 :             :                                   gfc_array_index_type, size, tmp);
    1676                 :       28440 :           size = gfc_evaluate_now (size, pre);
    1677                 :             :         }
    1678                 :             :     }
    1679                 :             : 
    1680                 :             :   /* Get the size of the array.  */
    1681                 :       24147 :   if (size && !callee_alloc)
    1682                 :             :     {
    1683                 :             :       /* If or_expr is true, then the extent in at least one
    1684                 :             :          dimension is zero and the size is set to zero.  */
    1685                 :       22298 :       size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
    1686                 :             :                               or_expr, gfc_index_zero_node, size);
    1687                 :             : 
    1688                 :       22298 :       nelem = size;
    1689                 :       22298 :       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    1690                 :             :                               size, elemsize);
    1691                 :             :     }
    1692                 :             :   else
    1693                 :             :     {
    1694                 :             :       nelem = size;
    1695                 :             :       size = NULL_TREE;
    1696                 :             :     }
    1697                 :             : 
    1698                 :             :   /* Set the span.  */
    1699                 :       24147 :   tmp = fold_convert (gfc_array_index_type, elemsize);
    1700                 :       24147 :   gfc_conv_descriptor_span_set (pre, desc, tmp);
    1701                 :             : 
    1702                 :       24147 :   gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
    1703                 :             :                                     dynamic, dealloc);
    1704                 :             : 
    1705                 :       48329 :   while (ss->parent)
    1706                 :             :     ss = ss->parent;
    1707                 :             : 
    1708                 :       24147 :   if (ss->dimen > ss->loop->temp_dim)
    1709                 :       21047 :     ss->loop->temp_dim = ss->dimen;
    1710                 :             : 
    1711                 :       24147 :   return size;
    1712                 :             : }
    1713                 :             : 
    1714                 :             : 
    1715                 :             : /* Return the number of iterations in a loop that starts at START,
    1716                 :             :    ends at END, and has step STEP.  */
    1717                 :             : 
    1718                 :             : static tree
    1719                 :         940 : gfc_get_iteration_count (tree start, tree end, tree step)
    1720                 :             : {
    1721                 :         940 :   tree tmp;
    1722                 :         940 :   tree type;
    1723                 :             : 
    1724                 :         940 :   type = TREE_TYPE (step);
    1725                 :         940 :   tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
    1726                 :         940 :   tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
    1727                 :         940 :   tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
    1728                 :         940 :                          build_int_cst (type, 1));
    1729                 :         940 :   tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
    1730                 :         940 :                          build_int_cst (type, 0));
    1731                 :         940 :   return fold_convert (gfc_array_index_type, tmp);
    1732                 :             : }
    1733                 :             : 
    1734                 :             : 
    1735                 :             : /* Extend the data in array DESC by EXTRA elements.  */
    1736                 :             : 
    1737                 :             : static void
    1738                 :         928 : gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
    1739                 :             : {
    1740                 :         928 :   tree arg0, arg1;
    1741                 :         928 :   tree tmp;
    1742                 :         928 :   tree size;
    1743                 :         928 :   tree ubound;
    1744                 :             : 
    1745                 :         928 :   if (integer_zerop (extra))
    1746                 :             :     return;
    1747                 :             : 
    1748                 :         898 :   ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
    1749                 :             : 
    1750                 :             :   /* Add EXTRA to the upper bound.  */
    1751                 :         898 :   tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
    1752                 :             :                          ubound, extra);
    1753                 :         898 :   gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
    1754                 :             : 
    1755                 :             :   /* Get the value of the current data pointer.  */
    1756                 :         898 :   arg0 = gfc_conv_descriptor_data_get (desc);
    1757                 :             : 
    1758                 :             :   /* Calculate the new array size.  */
    1759                 :         898 :   size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
    1760                 :         898 :   tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
    1761                 :             :                          ubound, gfc_index_one_node);
    1762                 :         898 :   arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
    1763                 :             :                           fold_convert (size_type_node, tmp),
    1764                 :             :                           fold_convert (size_type_node, size));
    1765                 :             : 
    1766                 :             :   /* Call the realloc() function.  */
    1767                 :         898 :   tmp = gfc_call_realloc (pblock, arg0, arg1);
    1768                 :         898 :   gfc_conv_descriptor_data_set (pblock, desc, tmp);
    1769                 :             : }
    1770                 :             : 
    1771                 :             : 
    1772                 :             : /* Return true if the bounds of iterator I can only be determined
    1773                 :             :    at run time.  */
    1774                 :             : 
    1775                 :             : static inline bool
    1776                 :        1957 : gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
    1777                 :             : {
    1778                 :        1957 :   return (i->start->expr_type != EXPR_CONSTANT
    1779                 :        1560 :           || i->end->expr_type != EXPR_CONSTANT
    1780                 :        2115 :           || i->step->expr_type != EXPR_CONSTANT);
    1781                 :             : }
    1782                 :             : 
    1783                 :             : 
    1784                 :             : /* Split the size of constructor element EXPR into the sum of two terms,
    1785                 :             :    one of which can be determined at compile time and one of which must
    1786                 :             :    be calculated at run time.  Set *SIZE to the former and return true
    1787                 :             :    if the latter might be nonzero.  */
    1788                 :             : 
    1789                 :             : static bool
    1790                 :        2622 : gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
    1791                 :             : {
    1792                 :        2622 :   if (expr->expr_type == EXPR_ARRAY)
    1793                 :         603 :     return gfc_get_array_constructor_size (size, expr->value.constructor);
    1794                 :        2019 :   else if (expr->rank > 0)
    1795                 :             :     {
    1796                 :             :       /* Calculate everything at run time.  */
    1797                 :         893 :       mpz_set_ui (*size, 0);
    1798                 :         893 :       return true;
    1799                 :             :     }
    1800                 :             :   else
    1801                 :             :     {
    1802                 :             :       /* A single element.  */
    1803                 :        1126 :       mpz_set_ui (*size, 1);
    1804                 :        1126 :       return false;
    1805                 :             :     }
    1806                 :             : }
    1807                 :             : 
    1808                 :             : 
    1809                 :             : /* Like gfc_get_array_constructor_element_size, but applied to the whole
    1810                 :             :    of array constructor C.  */
    1811                 :             : 
    1812                 :             : static bool
    1813                 :        2469 : gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
    1814                 :             : {
    1815                 :        2469 :   gfc_constructor *c;
    1816                 :        2469 :   gfc_iterator *i;
    1817                 :        2469 :   mpz_t val;
    1818                 :        2469 :   mpz_t len;
    1819                 :        2469 :   bool dynamic;
    1820                 :             : 
    1821                 :        2469 :   mpz_set_ui (*size, 0);
    1822                 :        2469 :   mpz_init (len);
    1823                 :        2469 :   mpz_init (val);
    1824                 :             : 
    1825                 :        2469 :   dynamic = false;
    1826                 :        5928 :   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
    1827                 :             :     {
    1828                 :        3459 :       i = c->iterator;
    1829                 :        3459 :       if (i && gfc_iterator_has_dynamic_bounds (i))
    1830                 :             :         dynamic = true;
    1831                 :             :       else
    1832                 :             :         {
    1833                 :        2141 :           dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
    1834                 :        2141 :           if (i)
    1835                 :             :             {
    1836                 :             :               /* Multiply the static part of the element size by the
    1837                 :             :                  number of iterations.  */
    1838                 :         116 :               mpz_sub (val, i->end->value.integer, i->start->value.integer);
    1839                 :         116 :               mpz_fdiv_q (val, val, i->step->value.integer);
    1840                 :         116 :               mpz_add_ui (val, val, 1);
    1841                 :         116 :               if (mpz_sgn (val) > 0)
    1842                 :          80 :                 mpz_mul (len, len, val);
    1843                 :             :               else
    1844                 :          36 :                 mpz_set_ui (len, 0);
    1845                 :             :             }
    1846                 :        2141 :           mpz_add (*size, *size, len);
    1847                 :             :         }
    1848                 :             :     }
    1849                 :        2469 :   mpz_clear (len);
    1850                 :        2469 :   mpz_clear (val);
    1851                 :        2469 :   return dynamic;
    1852                 :             : }
    1853                 :             : 
    1854                 :             : 
    1855                 :             : /* Make sure offset is a variable.  */
    1856                 :             : 
    1857                 :             : static void
    1858                 :        2822 : gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
    1859                 :             :                          tree * offsetvar)
    1860                 :             : {
    1861                 :             :   /* We should have already created the offset variable.  We cannot
    1862                 :             :      create it here because we may be in an inner scope.  */
    1863                 :        2822 :   gcc_assert (*offsetvar != NULL_TREE);
    1864                 :        2822 :   gfc_add_modify (pblock, *offsetvar, *poffset);
    1865                 :        2822 :   *poffset = *offsetvar;
    1866                 :        2822 :   TREE_USED (*offsetvar) = 1;
    1867                 :        2822 : }
    1868                 :             : 
    1869                 :             : 
    1870                 :             : /* Variables needed for bounds-checking.  */
    1871                 :             : static bool first_len;
    1872                 :             : static tree first_len_val;
    1873                 :             : static bool typespec_chararray_ctor;
    1874                 :             : 
    1875                 :             : static void
    1876                 :       12353 : gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
    1877                 :             :                               tree offset, gfc_se * se, gfc_expr * expr)
    1878                 :             : {
    1879                 :       12353 :   tree tmp;
    1880                 :             : 
    1881                 :       12353 :   gfc_conv_expr (se, expr);
    1882                 :             : 
    1883                 :             :   /* Store the value.  */
    1884                 :       12353 :   tmp = build_fold_indirect_ref_loc (input_location,
    1885                 :             :                                  gfc_conv_descriptor_data_get (desc));
    1886                 :       12353 :   tmp = gfc_build_array_ref (tmp, offset, NULL);
    1887                 :             : 
    1888                 :       12353 :   if (expr->expr_type == EXPR_FUNCTION && expr->ts.type == BT_DERIVED
    1889                 :          26 :       && expr->ts.u.derived->attr.alloc_comp)
    1890                 :             :     {
    1891                 :           2 :       if (!VAR_P (se->expr))
    1892                 :           2 :         se->expr = gfc_evaluate_now (se->expr, &se->pre);
    1893                 :           2 :       gfc_add_expr_to_block (&se->finalblock,
    1894                 :             :                              gfc_deallocate_alloc_comp_no_caf (
    1895                 :             :                                expr->ts.u.derived, se->expr, expr->rank, true));
    1896                 :             :     }
    1897                 :             : 
    1898                 :       12353 :   if (expr->ts.type == BT_CHARACTER)
    1899                 :             :     {
    1900                 :        1775 :       int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
    1901                 :        1775 :       tree esize;
    1902                 :             : 
    1903                 :        1775 :       esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
    1904                 :        1775 :       esize = fold_convert (gfc_charlen_type_node, esize);
    1905                 :        3550 :       esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
    1906                 :        1775 :                                TREE_TYPE (esize), esize,
    1907                 :        1775 :                                build_int_cst (TREE_TYPE (esize),
    1908                 :        1775 :                                           gfc_character_kinds[i].bit_size / 8));
    1909                 :             : 
    1910                 :        1775 :       gfc_conv_string_parameter (se);
    1911                 :        1775 :       if (POINTER_TYPE_P (TREE_TYPE (tmp)))
    1912                 :             :         {
    1913                 :             :           /* The temporary is an array of pointers.  */
    1914                 :           6 :           se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
    1915                 :           6 :           gfc_add_modify (&se->pre, tmp, se->expr);
    1916                 :             :         }
    1917                 :             :       else
    1918                 :             :         {
    1919                 :             :           /* The temporary is an array of string values.  */
    1920                 :        1769 :           tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
    1921                 :             :           /* We know the temporary and the value will be the same length,
    1922                 :             :              so can use memcpy.  */
    1923                 :        1769 :           gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
    1924                 :             :                                  se->string_length, se->expr, expr->ts.kind);
    1925                 :             :         }
    1926                 :        1775 :       if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
    1927                 :             :         {
    1928                 :         295 :           if (first_len)
    1929                 :             :             {
    1930                 :         115 :               gfc_add_modify (&se->pre, first_len_val,
    1931                 :         115 :                               fold_convert (TREE_TYPE (first_len_val),
    1932                 :             :                                             se->string_length));
    1933                 :         115 :               first_len = false;
    1934                 :             :             }
    1935                 :             :           else
    1936                 :             :             {
    1937                 :             :               /* Verify that all constructor elements are of the same
    1938                 :             :                  length.  */
    1939                 :         180 :               tree rhs = fold_convert (TREE_TYPE (first_len_val),
    1940                 :             :                                        se->string_length);
    1941                 :         180 :               tree cond = fold_build2_loc (input_location, NE_EXPR,
    1942                 :             :                                            logical_type_node, first_len_val,
    1943                 :             :                                            rhs);
    1944                 :         180 :               gfc_trans_runtime_check
    1945                 :         180 :                 (true, false, cond, &se->pre, &expr->where,
    1946                 :             :                  "Different CHARACTER lengths (%ld/%ld) in array constructor",
    1947                 :             :                  fold_convert (long_integer_type_node, first_len_val),
    1948                 :             :                  fold_convert (long_integer_type_node, se->string_length));
    1949                 :             :             }
    1950                 :             :         }
    1951                 :             :     }
    1952                 :       10578 :   else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
    1953                 :       10578 :            && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc))))
    1954                 :             :     {
    1955                 :             :       /* Assignment of a CLASS array constructor to a derived type array.  */
    1956                 :          24 :       if (expr->expr_type == EXPR_FUNCTION)
    1957                 :          18 :         se->expr = gfc_evaluate_now (se->expr, pblock);
    1958                 :          24 :       se->expr = gfc_class_data_get (se->expr);
    1959                 :          24 :       se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
    1960                 :          24 :       se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
    1961                 :          24 :       gfc_add_modify (&se->pre, tmp, se->expr);
    1962                 :             :     }
    1963                 :             :   else
    1964                 :             :     {
    1965                 :             :       /* TODO: Should the frontend already have done this conversion?  */
    1966                 :       10554 :       se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
    1967                 :       10554 :       gfc_add_modify (&se->pre, tmp, se->expr);
    1968                 :             :     }
    1969                 :             : 
    1970                 :       12353 :   gfc_add_block_to_block (pblock, &se->pre);
    1971                 :       12353 :   gfc_add_block_to_block (pblock, &se->post);
    1972                 :       12353 : }
    1973                 :             : 
    1974                 :             : 
    1975                 :             : /* Add the contents of an array to the constructor.  DYNAMIC is as for
    1976                 :             :    gfc_trans_array_constructor_value.  */
    1977                 :             : 
    1978                 :             : static void
    1979                 :        1052 : gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
    1980                 :             :                                       tree type ATTRIBUTE_UNUSED,
    1981                 :             :                                       tree desc, gfc_expr * expr,
    1982                 :             :                                       tree * poffset, tree * offsetvar,
    1983                 :             :                                       bool dynamic)
    1984                 :             : {
    1985                 :        1052 :   gfc_se se;
    1986                 :        1052 :   gfc_ss *ss;
    1987                 :        1052 :   gfc_loopinfo loop;
    1988                 :        1052 :   stmtblock_t body;
    1989                 :        1052 :   tree tmp;
    1990                 :        1052 :   tree size;
    1991                 :        1052 :   int n;
    1992                 :             : 
    1993                 :             :   /* We need this to be a variable so we can increment it.  */
    1994                 :        1052 :   gfc_put_offset_into_var (pblock, poffset, offsetvar);
    1995                 :             : 
    1996                 :        1052 :   gfc_init_se (&se, NULL);
    1997                 :             : 
    1998                 :             :   /* Walk the array expression.  */
    1999                 :        1052 :   ss = gfc_walk_expr (expr);
    2000                 :        1052 :   gcc_assert (ss != gfc_ss_terminator);
    2001                 :             : 
    2002                 :             :   /* Initialize the scalarizer.  */
    2003                 :        1052 :   gfc_init_loopinfo (&loop);
    2004                 :        1052 :   gfc_add_ss_to_loop (&loop, ss);
    2005                 :             : 
    2006                 :             :   /* Initialize the loop.  */
    2007                 :        1052 :   gfc_conv_ss_startstride (&loop);
    2008                 :        1052 :   gfc_conv_loop_setup (&loop, &expr->where);
    2009                 :             : 
    2010                 :             :   /* Make sure the constructed array has room for the new data.  */
    2011                 :        1052 :   if (dynamic)
    2012                 :             :     {
    2013                 :             :       /* Set SIZE to the total number of elements in the subarray.  */
    2014                 :         447 :       size = gfc_index_one_node;
    2015                 :         906 :       for (n = 0; n < loop.dimen; n++)
    2016                 :             :         {
    2017                 :         459 :           tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
    2018                 :             :                                          gfc_index_one_node);
    2019                 :         459 :           size = fold_build2_loc (input_location, MULT_EXPR,
    2020                 :             :                                   gfc_array_index_type, size, tmp);
    2021                 :             :         }
    2022                 :             : 
    2023                 :             :       /* Grow the constructed array by SIZE elements.  */
    2024                 :         447 :       gfc_grow_array (&loop.pre, desc, size);
    2025                 :             :     }
    2026                 :             : 
    2027                 :             :   /* Make the loop body.  */
    2028                 :        1052 :   gfc_mark_ss_chain_used (ss, 1);
    2029                 :        1052 :   gfc_start_scalarized_body (&loop, &body);
    2030                 :        1052 :   gfc_copy_loopinfo_to_se (&se, &loop);
    2031                 :        1052 :   se.ss = ss;
    2032                 :             : 
    2033                 :        1052 :   gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
    2034                 :        1052 :   gcc_assert (se.ss == gfc_ss_terminator);
    2035                 :             : 
    2036                 :             :   /* Increment the offset.  */
    2037                 :        1052 :   tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
    2038                 :             :                          *poffset, gfc_index_one_node);
    2039                 :        1052 :   gfc_add_modify (&body, *poffset, tmp);
    2040                 :             : 
    2041                 :             :   /* Finish the loop.  */
    2042                 :        1052 :   gfc_trans_scalarizing_loops (&loop, &body);
    2043                 :        1052 :   gfc_add_block_to_block (&loop.pre, &loop.post);
    2044                 :        1052 :   tmp = gfc_finish_block (&loop.pre);
    2045                 :        1052 :   gfc_add_expr_to_block (pblock, tmp);
    2046                 :             : 
    2047                 :        1052 :   gfc_cleanup_loop (&loop);
    2048                 :        1052 : }
    2049                 :             : 
    2050                 :             : 
    2051                 :             : /* Assign the values to the elements of an array constructor.  DYNAMIC
    2052                 :             :    is true if descriptor DESC only contains enough data for the static
    2053                 :             :    size calculated by gfc_get_array_constructor_size.  When true, memory
    2054                 :             :    for the dynamic parts must be allocated using realloc.  */
    2055                 :             : 
    2056                 :             : static void
    2057                 :        8369 : gfc_trans_array_constructor_value (stmtblock_t * pblock,
    2058                 :             :                                    stmtblock_t * finalblock,
    2059                 :             :                                    tree type, tree desc,
    2060                 :             :                                    gfc_constructor_base base, tree * poffset,
    2061                 :             :                                    tree * offsetvar, bool dynamic)
    2062                 :             : {
    2063                 :        8369 :   tree tmp;
    2064                 :        8369 :   tree start = NULL_TREE;
    2065                 :        8369 :   tree end = NULL_TREE;
    2066                 :        8369 :   tree step = NULL_TREE;
    2067                 :        8369 :   stmtblock_t body;
    2068                 :        8369 :   gfc_se se;
    2069                 :        8369 :   mpz_t size;
    2070                 :        8369 :   gfc_constructor *c;
    2071                 :        8369 :   gfc_typespec ts;
    2072                 :        8369 :   int ctr = 0;
    2073                 :             : 
    2074                 :        8369 :   tree shadow_loopvar = NULL_TREE;
    2075                 :        8369 :   gfc_saved_var saved_loopvar;
    2076                 :             : 
    2077                 :        8369 :   ts.type = BT_UNKNOWN;
    2078                 :        8369 :   mpz_init (size);
    2079                 :       21959 :   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
    2080                 :             :     {
    2081                 :       13590 :       ctr++;
    2082                 :             :       /* If this is an iterator or an array, the offset must be a variable.  */
    2083                 :       13590 :       if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
    2084                 :        1770 :         gfc_put_offset_into_var (pblock, poffset, offsetvar);
    2085                 :             : 
    2086                 :             :       /* Shadowing the iterator avoids changing its value and saves us from
    2087                 :             :          keeping track of it. Further, it makes sure that there's always a
    2088                 :             :          backend-decl for the symbol, even if there wasn't one before,
    2089                 :             :          e.g. in the case of an iterator that appears in a specification
    2090                 :             :          expression in an interface mapping.  */
    2091                 :       13590 :       if (c->iterator)
    2092                 :             :         {
    2093                 :        1140 :           gfc_symbol *sym;
    2094                 :        1140 :           tree type;
    2095                 :             : 
    2096                 :             :           /* Evaluate loop bounds before substituting the loop variable
    2097                 :             :              in case they depend on it.  Such a case is invalid, but it is
    2098                 :             :              not more expensive to do the right thing here.
    2099                 :             :              See PR 44354.  */
    2100                 :        1140 :           gfc_init_se (&se, NULL);
    2101                 :        1140 :           gfc_conv_expr_val (&se, c->iterator->start);
    2102                 :        1140 :           gfc_add_block_to_block (pblock, &se.pre);
    2103                 :        1140 :           start = gfc_evaluate_now (se.expr, pblock);
    2104                 :             : 
    2105                 :        1140 :           gfc_init_se (&se, NULL);
    2106                 :        1140 :           gfc_conv_expr_val (&se, c->iterator->end);
    2107                 :        1140 :           gfc_add_block_to_block (pblock, &se.pre);
    2108                 :        1140 :           end = gfc_evaluate_now (se.expr, pblock);
    2109                 :             : 
    2110                 :        1140 :           gfc_init_se (&se, NULL);
    2111                 :        1140 :           gfc_conv_expr_val (&se, c->iterator->step);
    2112                 :        1140 :           gfc_add_block_to_block (pblock, &se.pre);
    2113                 :        1140 :           step = gfc_evaluate_now (se.expr, pblock);
    2114                 :             : 
    2115                 :        1140 :           sym = c->iterator->var->symtree->n.sym;
    2116                 :        1140 :           type = gfc_typenode_for_spec (&sym->ts);
    2117                 :             : 
    2118                 :        1140 :           shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
    2119                 :        1140 :           gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
    2120                 :             :         }
    2121                 :             : 
    2122                 :       13590 :       gfc_start_block (&body);
    2123                 :             : 
    2124                 :       13590 :       if (c->expr->expr_type == EXPR_ARRAY)
    2125                 :             :         {
    2126                 :             :           /* Array constructors can be nested.  */
    2127                 :        1150 :           gfc_trans_array_constructor_value (&body, finalblock, type,
    2128                 :             :                                              desc, c->expr->value.constructor,
    2129                 :             :                                              poffset, offsetvar, dynamic);
    2130                 :             :         }
    2131                 :       12440 :       else if (c->expr->rank > 0)
    2132                 :             :         {
    2133                 :        1052 :           gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
    2134                 :             :                                                 poffset, offsetvar, dynamic);
    2135                 :             :         }
    2136                 :             :       else
    2137                 :             :         {
    2138                 :             :           /* This code really upsets the gimplifier so don't bother for now.  */
    2139                 :             :           gfc_constructor *p;
    2140                 :             :           HOST_WIDE_INT n;
    2141                 :             :           HOST_WIDE_INT size;
    2142                 :             : 
    2143                 :             :           p = c;
    2144                 :             :           n = 0;
    2145                 :       12803 :           while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
    2146                 :             :             {
    2147                 :        1415 :               p = gfc_constructor_next (p);
    2148                 :        1415 :               n++;
    2149                 :             :             }
    2150                 :       11388 :           if (n < 4)
    2151                 :             :             {
    2152                 :             :               /* Scalar values.  */
    2153                 :       11301 :               gfc_init_se (&se, NULL);
    2154                 :       11301 :               gfc_trans_array_ctor_element (&body, desc, *poffset,
    2155                 :             :                                             &se, c->expr);
    2156                 :             : 
    2157                 :       11301 :               *poffset = fold_build2_loc (input_location, PLUS_EXPR,
    2158                 :             :                                           gfc_array_index_type,
    2159                 :             :                                           *poffset, gfc_index_one_node);
    2160                 :       11301 :               if (finalblock)
    2161                 :         882 :                 gfc_add_block_to_block (finalblock, &se.finalblock);
    2162                 :             :             }
    2163                 :             :           else
    2164                 :             :             {
    2165                 :             :               /* Collect multiple scalar constants into a constructor.  */
    2166                 :          87 :               vec<constructor_elt, va_gc> *v = NULL;
    2167                 :          87 :               tree init;
    2168                 :          87 :               tree bound;
    2169                 :          87 :               tree tmptype;
    2170                 :          87 :               HOST_WIDE_INT idx = 0;
    2171                 :             : 
    2172                 :          87 :               p = c;
    2173                 :             :               /* Count the number of consecutive scalar constants.  */
    2174                 :         747 :               while (p && !(p->iterator
    2175                 :         673 :                             || p->expr->expr_type != EXPR_CONSTANT))
    2176                 :             :                 {
    2177                 :         660 :                   gfc_init_se (&se, NULL);
    2178                 :         660 :                   gfc_conv_constant (&se, p->expr);
    2179                 :             : 
    2180                 :         660 :                   if (c->expr->ts.type != BT_CHARACTER)
    2181                 :         660 :                     se.expr = fold_convert (type, se.expr);
    2182                 :             :                   /* For constant character array constructors we build
    2183                 :             :                      an array of pointers.  */
    2184                 :           0 :                   else if (POINTER_TYPE_P (type))
    2185                 :           0 :                     se.expr = gfc_build_addr_expr
    2186                 :           0 :                                 (gfc_get_pchar_type (p->expr->ts.kind),
    2187                 :             :                                  se.expr);
    2188                 :             : 
    2189                 :         660 :                   CONSTRUCTOR_APPEND_ELT (v,
    2190                 :             :                                           build_int_cst (gfc_array_index_type,
    2191                 :             :                                                          idx++),
    2192                 :             :                                           se.expr);
    2193                 :         660 :                   c = p;
    2194                 :         660 :                   p = gfc_constructor_next (p);
    2195                 :             :                 }
    2196                 :             : 
    2197                 :          87 :               bound = size_int (n - 1);
    2198                 :             :               /* Create an array type to hold them.  */
    2199                 :          87 :               tmptype = build_range_type (gfc_array_index_type,
    2200                 :             :                                           gfc_index_zero_node, bound);
    2201                 :          87 :               tmptype = build_array_type (type, tmptype);
    2202                 :             : 
    2203                 :          87 :               init = build_constructor (tmptype, v);
    2204                 :          87 :               TREE_CONSTANT (init) = 1;
    2205                 :          87 :               TREE_STATIC (init) = 1;
    2206                 :             :               /* Create a static variable to hold the data.  */
    2207                 :          87 :               tmp = gfc_create_var (tmptype, "data");
    2208                 :          87 :               TREE_STATIC (tmp) = 1;
    2209                 :          87 :               TREE_CONSTANT (tmp) = 1;
    2210                 :          87 :               TREE_READONLY (tmp) = 1;
    2211                 :          87 :               DECL_INITIAL (tmp) = init;
    2212                 :          87 :               init = tmp;
    2213                 :             : 
    2214                 :             :               /* Use BUILTIN_MEMCPY to assign the values.  */
    2215                 :          87 :               tmp = gfc_conv_descriptor_data_get (desc);
    2216                 :          87 :               tmp = build_fold_indirect_ref_loc (input_location,
    2217                 :             :                                              tmp);
    2218                 :          87 :               tmp = gfc_build_array_ref (tmp, *poffset, NULL);
    2219                 :          87 :               tmp = gfc_build_addr_expr (NULL_TREE, tmp);
    2220                 :          87 :               init = gfc_build_addr_expr (NULL_TREE, init);
    2221                 :             : 
    2222                 :          87 :               size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
    2223                 :          87 :               bound = build_int_cst (size_type_node, n * size);
    2224                 :          87 :               tmp = build_call_expr_loc (input_location,
    2225                 :             :                                          builtin_decl_explicit (BUILT_IN_MEMCPY),
    2226                 :             :                                          3, tmp, init, bound);
    2227                 :          87 :               gfc_add_expr_to_block (&body, tmp);
    2228                 :             : 
    2229                 :          87 :               *poffset = fold_build2_loc (input_location, PLUS_EXPR,
    2230                 :             :                                       gfc_array_index_type, *poffset,
    2231                 :             :                                       build_int_cst (gfc_array_index_type, n));
    2232                 :             :             }
    2233                 :       11388 :           if (!INTEGER_CST_P (*poffset))
    2234                 :             :             {
    2235                 :        1331 :               gfc_add_modify (&body, *offsetvar, *poffset);
    2236                 :        1331 :               *poffset = *offsetvar;
    2237                 :             :             }
    2238                 :             : 
    2239                 :       11388 :           if (!c->iterator)
    2240                 :       11388 :             ts = c->expr->ts;
    2241                 :             :         }
    2242                 :             : 
    2243                 :             :       /* The frontend should already have done any expansions
    2244                 :             :          at compile-time.  */
    2245                 :       13590 :       if (!c->iterator)
    2246                 :             :         {
    2247                 :             :           /* Pass the code as is.  */
    2248                 :       12450 :           tmp = gfc_finish_block (&body);
    2249                 :       12450 :           gfc_add_expr_to_block (pblock, tmp);
    2250                 :             :         }
    2251                 :             :       else
    2252                 :             :         {
    2253                 :             :           /* Build the implied do-loop.  */
    2254                 :        1140 :           stmtblock_t implied_do_block;
    2255                 :        1140 :           tree cond;
    2256                 :        1140 :           tree exit_label;
    2257                 :        1140 :           tree loopbody;
    2258                 :        1140 :           tree tmp2;
    2259                 :             : 
    2260                 :        1140 :           loopbody = gfc_finish_block (&body);
    2261                 :             : 
    2262                 :             :           /* Create a new block that holds the implied-do loop. A temporary
    2263                 :             :              loop-variable is used.  */
    2264                 :        1140 :           gfc_start_block(&implied_do_block);
    2265                 :             : 
    2266                 :             :           /* Initialize the loop.  */
    2267                 :        1140 :           gfc_add_modify (&implied_do_block, shadow_loopvar, start);
    2268                 :             : 
    2269                 :             :           /* If this array expands dynamically, and the number of iterations
    2270                 :             :              is not constant, we won't have allocated space for the static
    2271                 :             :              part of C->EXPR's size.  Do that now.  */
    2272                 :        1140 :           if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
    2273                 :             :             {
    2274                 :             :               /* Get the number of iterations.  */
    2275                 :         481 :               tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
    2276                 :             : 
    2277                 :             :               /* Get the static part of C->EXPR's size.  */
    2278                 :         481 :               gfc_get_array_constructor_element_size (&size, c->expr);
    2279                 :         481 :               tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
    2280                 :             : 
    2281                 :             :               /* Grow the array by TMP * TMP2 elements.  */
    2282                 :         481 :               tmp = fold_build2_loc (input_location, MULT_EXPR,
    2283                 :             :                                      gfc_array_index_type, tmp, tmp2);
    2284                 :         481 :               gfc_grow_array (&implied_do_block, desc, tmp);
    2285                 :             :             }
    2286                 :             : 
    2287                 :             :           /* Generate the loop body.  */
    2288                 :        1140 :           exit_label = gfc_build_label_decl (NULL_TREE);
    2289                 :        1140 :           gfc_start_block (&body);
    2290                 :             : 
    2291                 :             :           /* Generate the exit condition.  Depending on the sign of
    2292                 :             :              the step variable we have to generate the correct
    2293                 :             :              comparison.  */
    2294                 :        1140 :           tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    2295                 :        1140 :                                  step, build_int_cst (TREE_TYPE (step), 0));
    2296                 :        1140 :           cond = fold_build3_loc (input_location, COND_EXPR,
    2297                 :             :                       logical_type_node, tmp,
    2298                 :             :                       fold_build2_loc (input_location, GT_EXPR,
    2299                 :             :                                        logical_type_node, shadow_loopvar, end),
    2300                 :             :                       fold_build2_loc (input_location, LT_EXPR,
    2301                 :             :                                        logical_type_node, shadow_loopvar, end));
    2302                 :        1140 :           tmp = build1_v (GOTO_EXPR, exit_label);
    2303                 :        1140 :           TREE_USED (exit_label) = 1;
    2304                 :        1140 :           tmp = build3_v (COND_EXPR, cond, tmp,
    2305                 :             :                           build_empty_stmt (input_location));
    2306                 :        1140 :           gfc_add_expr_to_block (&body, tmp);
    2307                 :             : 
    2308                 :             :           /* The main loop body.  */
    2309                 :        1140 :           gfc_add_expr_to_block (&body, loopbody);
    2310                 :             : 
    2311                 :             :           /* Increase loop variable by step.  */
    2312                 :        1140 :           tmp = fold_build2_loc (input_location, PLUS_EXPR,
    2313                 :        1140 :                                  TREE_TYPE (shadow_loopvar), shadow_loopvar,
    2314                 :             :                                  step);
    2315                 :        1140 :           gfc_add_modify (&body, shadow_loopvar, tmp);
    2316                 :             : 
    2317                 :             :           /* Finish the loop.  */
    2318                 :        1140 :           tmp = gfc_finish_block (&body);
    2319                 :        1140 :           tmp = build1_v (LOOP_EXPR, tmp);
    2320                 :        1140 :           gfc_add_expr_to_block (&implied_do_block, tmp);
    2321                 :             : 
    2322                 :             :           /* Add the exit label.  */
    2323                 :        1140 :           tmp = build1_v (LABEL_EXPR, exit_label);
    2324                 :        1140 :           gfc_add_expr_to_block (&implied_do_block, tmp);
    2325                 :             : 
    2326                 :             :           /* Finish the implied-do loop.  */
    2327                 :        1140 :           tmp = gfc_finish_block(&implied_do_block);
    2328                 :        1140 :           gfc_add_expr_to_block(pblock, tmp);
    2329                 :             : 
    2330                 :        1140 :           gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
    2331                 :             :         }
    2332                 :             :     }
    2333                 :             : 
    2334                 :             :   /* F2008 4.5.6.3 para 5: If an executable construct references a structure
    2335                 :             :      constructor or array constructor, the entity created by the constructor is
    2336                 :             :      finalized after execution of the innermost executable construct containing
    2337                 :             :      the reference. This, in fact, was later deleted by the Combined Techical
    2338                 :             :      Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
    2339                 :             : 
    2340                 :             :      Transmit finalization of this constructor through 'finalblock'. */
    2341                 :        8369 :   if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
    2342                 :        8369 :       && !(gfc_option.allow_std & GFC_STD_GNU)
    2343                 :          52 :       && finalblock != NULL
    2344                 :          24 :       && gfc_may_be_finalized (ts)
    2345                 :          18 :       && ctr > 0 && desc != NULL_TREE
    2346                 :        8387 :       && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
    2347                 :             :     {
    2348                 :          18 :       symbol_attribute attr;
    2349                 :          18 :       gfc_se fse;
    2350                 :          18 :       gfc_warning (0, "The structure constructor at %C has been"
    2351                 :             :                          " finalized. This feature was removed by f08/0011."
    2352                 :             :                          " Use -std=f2018 or -std=gnu to eliminate the"
    2353                 :             :                          " finalization.");
    2354                 :          18 :       attr.pointer = attr.allocatable = 0;
    2355                 :          18 :       gfc_init_se (&fse, NULL);
    2356                 :          18 :       fse.expr = desc;
    2357                 :          18 :       gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
    2358                 :          18 :       gfc_add_block_to_block (finalblock, &fse.pre);
    2359                 :          18 :       gfc_add_block_to_block (finalblock, &fse.finalblock);
    2360                 :          18 :       gfc_add_block_to_block (finalblock, &fse.post);
    2361                 :             :     }
    2362                 :             : 
    2363                 :        8369 :   mpz_clear (size);
    2364                 :        8369 : }
    2365                 :             : 
    2366                 :             : 
    2367                 :             : /* The array constructor code can create a string length with an operand
    2368                 :             :    in the form of a temporary variable.  This variable will retain its
    2369                 :             :    context (current_function_decl).  If we store this length tree in a
    2370                 :             :    gfc_charlen structure which is shared by a variable in another
    2371                 :             :    context, the resulting gfc_charlen structure with a variable in a
    2372                 :             :    different context, we could trip the assertion in expand_expr_real_1
    2373                 :             :    when it sees that a variable has been created in one context and
    2374                 :             :    referenced in another.
    2375                 :             : 
    2376                 :             :    If this might be the case, we create a new gfc_charlen structure and
    2377                 :             :    link it into the current namespace.  */
    2378                 :             : 
    2379                 :             : static void
    2380                 :        7751 : store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
    2381                 :             : {
    2382                 :        7751 :   if (force_new_cl)
    2383                 :             :     {
    2384                 :        7724 :       gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
    2385                 :        7724 :       *clp = new_cl;
    2386                 :             :     }
    2387                 :        7751 :   (*clp)->backend_decl = len;
    2388                 :        7751 : }
    2389                 :             : 
    2390                 :             : /* A catch-all to obtain the string length for anything that is not
    2391                 :             :    a substring of non-constant length, a constant, array or variable.  */
    2392                 :             : 
    2393                 :             : static void
    2394                 :         261 : get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
    2395                 :             : {
    2396                 :         261 :   gfc_se se;
    2397                 :             : 
    2398                 :             :   /* Don't bother if we already know the length is a constant.  */
    2399                 :         261 :   if (*len && INTEGER_CST_P (*len))
    2400                 :          32 :     return;
    2401                 :             : 
    2402                 :         229 :   if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
    2403                 :          29 :         && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
    2404                 :             :     {
    2405                 :             :       /* This is easy.  */
    2406                 :           1 :       gfc_conv_const_charlen (e->ts.u.cl);
    2407                 :           1 :       *len = e->ts.u.cl->backend_decl;
    2408                 :             :     }
    2409                 :             :   else
    2410                 :             :     {
    2411                 :             :       /* Otherwise, be brutal even if inefficient.  */
    2412                 :         228 :       gfc_init_se (&se, NULL);
    2413                 :             : 
    2414                 :             :       /* No function call, in case of side effects.  */
    2415                 :         228 :       se.no_function_call = 1;
    2416                 :         228 :       if (e->rank == 0)
    2417                 :         116 :         gfc_conv_expr (&se, e);
    2418                 :             :       else
    2419                 :         112 :         gfc_conv_expr_descriptor (&se, e);
    2420                 :             : 
    2421                 :             :       /* Fix the value.  */
    2422                 :         228 :       *len = gfc_evaluate_now (se.string_length, &se.pre);
    2423                 :             : 
    2424                 :         228 :       gfc_add_block_to_block (block, &se.pre);
    2425                 :         228 :       gfc_add_block_to_block (block, &se.post);
    2426                 :             : 
    2427                 :         228 :       store_backend_decl (&e->ts.u.cl, *len, true);
    2428                 :             :     }
    2429                 :             : }
    2430                 :             : 
    2431                 :             : 
    2432                 :             : /* Figure out the string length of a variable reference expression.
    2433                 :             :    Used by get_array_ctor_strlen.  */
    2434                 :             : 
    2435                 :             : static void
    2436                 :         846 : get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
    2437                 :             : {
    2438                 :         846 :   gfc_ref *ref;
    2439                 :         846 :   gfc_typespec *ts;
    2440                 :         846 :   mpz_t char_len;
    2441                 :         846 :   gfc_se se;
    2442                 :             : 
    2443                 :             :   /* Don't bother if we already know the length is a constant.  */
    2444                 :         846 :   if (*len && INTEGER_CST_P (*len))
    2445                 :         509 :     return;
    2446                 :             : 
    2447                 :         417 :   ts = &expr->symtree->n.sym->ts;
    2448                 :         655 :   for (ref = expr->ref; ref; ref = ref->next)
    2449                 :             :     {
    2450                 :         318 :       switch (ref->type)
    2451                 :             :         {
    2452                 :         195 :         case REF_ARRAY:
    2453                 :             :           /* Array references don't change the string length.  */
    2454                 :         195 :           if (ts->deferred)
    2455                 :          99 :             get_array_ctor_all_strlen (block, expr, len);
    2456                 :             :           break;
    2457                 :             : 
    2458                 :          43 :         case REF_COMPONENT:
    2459                 :             :           /* Use the length of the component.  */
    2460                 :          43 :           ts = &ref->u.c.component->ts;
    2461                 :          43 :           break;
    2462                 :             : 
    2463                 :          80 :         case REF_SUBSTRING:
    2464                 :          80 :           if (ref->u.ss.end == NULL
    2465                 :          68 :               || ref->u.ss.start->expr_type != EXPR_CONSTANT
    2466                 :          61 :               || ref->u.ss.end->expr_type != EXPR_CONSTANT)
    2467                 :             :             {
    2468                 :             :               /* Note that this might evaluate expr.  */
    2469                 :          52 :               get_array_ctor_all_strlen (block, expr, len);
    2470                 :          52 :               return;
    2471                 :             :             }
    2472                 :          28 :           mpz_init_set_ui (char_len, 1);
    2473                 :          28 :           mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
    2474                 :          28 :           mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
    2475                 :          28 :           *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
    2476                 :          28 :           mpz_clear (char_len);
    2477                 :          28 :           return;
    2478                 :             : 
    2479                 :             :         case REF_INQUIRY:
    2480                 :             :           break;
    2481                 :             : 
    2482                 :           0 :         default:
    2483                 :           0 :          gcc_unreachable ();
    2484                 :             :         }
    2485                 :             :     }
    2486                 :             : 
    2487                 :             :   /* A last ditch attempt that is sometimes needed for deferred characters.  */
    2488                 :         337 :   if (!ts->u.cl->backend_decl)
    2489                 :             :     {
    2490                 :          19 :       gfc_init_se (&se, NULL);
    2491                 :          19 :       if (expr->rank)
    2492                 :          12 :         gfc_conv_expr_descriptor (&se, expr);
    2493                 :             :       else
    2494                 :           7 :         gfc_conv_expr (&se, expr);
    2495                 :          19 :       gcc_assert (se.string_length != NULL_TREE);
    2496                 :          19 :       gfc_add_block_to_block (block, &se.pre);
    2497                 :          19 :       ts->u.cl->backend_decl = se.string_length;
    2498                 :             :     }
    2499                 :             : 
    2500                 :         337 :   *len = ts->u.cl->backend_decl;
    2501                 :             : }
    2502                 :             : 
    2503                 :             : 
    2504                 :             : /* Figure out the string length of a character array constructor.
    2505                 :             :    If len is NULL, don't calculate the length; this happens for recursive calls
    2506                 :             :    when a sub-array-constructor is an element but not at the first position,
    2507                 :             :    so when we're not interested in the length.
    2508                 :             :    Returns TRUE if all elements are character constants.  */
    2509                 :             : 
    2510                 :             : bool
    2511                 :        8196 : get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
    2512                 :             : {
    2513                 :        8196 :   gfc_constructor *c;
    2514                 :        8196 :   bool is_const;
    2515                 :             : 
    2516                 :        8196 :   is_const = true;
    2517                 :             : 
    2518                 :        8196 :   if (gfc_constructor_first (base) == NULL)
    2519                 :             :     {
    2520                 :         303 :       if (len)
    2521                 :         303 :         *len = build_int_cstu (gfc_charlen_type_node, 0);
    2522                 :         303 :       return is_const;
    2523                 :             :     }
    2524                 :             : 
    2525                 :             :   /* Loop over all constructor elements to find out is_const, but in len we
    2526                 :             :      want to store the length of the first, not the last, element.  We can
    2527                 :             :      of course exit the loop as soon as is_const is found to be false.  */
    2528                 :        7893 :   for (c = gfc_constructor_first (base);
    2529                 :       44067 :        c && is_const; c = gfc_constructor_next (c))
    2530                 :             :     {
    2531                 :       36174 :       switch (c->expr->expr_type)
    2532                 :             :         {
    2533                 :       35127 :         case EXPR_CONSTANT:
    2534                 :       35127 :           if (len && !(*len && INTEGER_CST_P (*len)))
    2535                 :         394 :             *len = build_int_cstu (gfc_charlen_type_node,
    2536                 :         394 :                                    c->expr->value.character.length);
    2537                 :             :           break;
    2538                 :             : 
    2539                 :          31 :         case EXPR_ARRAY:
    2540                 :          31 :           if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
    2541                 :        1035 :             is_const = false;
    2542                 :             :           break;
    2543                 :             : 
    2544                 :         906 :         case EXPR_VARIABLE:
    2545                 :         906 :           is_const = false;
    2546                 :         906 :           if (len)
    2547                 :         846 :             get_array_ctor_var_strlen (block, c->expr, len);
    2548                 :             :           break;
    2549                 :             : 
    2550                 :         110 :         default:
    2551                 :         110 :           is_const = false;
    2552                 :         110 :           if (len)
    2553                 :         110 :             get_array_ctor_all_strlen (block, c->expr, len);
    2554                 :             :           break;
    2555                 :             :         }
    2556                 :             : 
    2557                 :             :       /* After the first iteration, we don't want the length modified.  */
    2558                 :       36174 :       len = NULL;
    2559                 :             :     }
    2560                 :             : 
    2561                 :             :   return is_const;
    2562                 :             : }
    2563                 :             : 
    2564                 :             : /* Check whether the array constructor C consists entirely of constant
    2565                 :             :    elements, and if so returns the number of those elements, otherwise
    2566                 :             :    return zero.  Note, an empty or NULL array constructor returns zero.  */
    2567                 :             : 
    2568                 :             : unsigned HOST_WIDE_INT
    2569                 :       49245 : gfc_constant_array_constructor_p (gfc_constructor_base base)
    2570                 :             : {
    2571                 :       49245 :   unsigned HOST_WIDE_INT nelem = 0;
    2572                 :             : 
    2573                 :       49245 :   gfc_constructor *c = gfc_constructor_first (base);
    2574                 :      306042 :   while (c)
    2575                 :             :     {
    2576                 :      217117 :       if (c->iterator
    2577                 :      215914 :           || c->expr->rank > 0
    2578                 :      215153 :           || c->expr->expr_type != EXPR_CONSTANT)
    2579                 :             :         return 0;
    2580                 :      207552 :       c = gfc_constructor_next (c);
    2581                 :      207552 :       nelem++;
    2582                 :             :     }
    2583                 :             :   return nelem;
    2584                 :             : }
    2585                 :             : 
    2586                 :             : 
    2587                 :             : /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
    2588                 :             :    and the tree type of it's elements, TYPE, return a static constant
    2589                 :             :    variable that is compile-time initialized.  */
    2590                 :             : 
    2591                 :             : tree
    2592                 :       32408 : gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
    2593                 :             : {
    2594                 :       32408 :   tree tmptype, init, tmp;
    2595                 :       32408 :   HOST_WIDE_INT nelem;
    2596                 :       32408 :   gfc_constructor *c;
    2597                 :       32408 :   gfc_array_spec as;
    2598                 :       32408 :   gfc_se se;
    2599                 :       32408 :   int i;
    2600                 :       32408 :   vec<constructor_elt, va_gc> *v = NULL;
    2601                 :             : 
    2602                 :             :   /* First traverse the constructor list, converting the constants
    2603                 :             :      to tree to build an initializer.  */
    2604                 :       32408 :   nelem = 0;
    2605                 :       32408 :   c = gfc_constructor_first (expr->value.constructor);
    2606                 :      248480 :   while (c)
    2607                 :             :     {
    2608                 :      183664 :       gfc_init_se (&se, NULL);
    2609                 :      183664 :       gfc_conv_constant (&se, c->expr);
    2610                 :      183664 :       if (c->expr->ts.type != BT_CHARACTER)
    2611                 :      149407 :         se.expr = fold_convert (type, se.expr);
    2612                 :       34257 :       else if (POINTER_TYPE_P (type))
    2613                 :       34257 :         se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
    2614                 :             :                                        se.expr);
    2615                 :      183664 :       CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
    2616                 :             :                               se.expr);
    2617                 :      183664 :       c = gfc_constructor_next (c);
    2618                 :      183664 :       nelem++;
    2619                 :             :     }
    2620                 :             : 
    2621                 :             :   /* Next determine the tree type for the array.  We use the gfortran
    2622                 :             :      front-end's gfc_get_nodesc_array_type in order to create a suitable
    2623                 :             :      GFC_ARRAY_TYPE_P that may be used by the scalarizer.  */
    2624                 :             : 
    2625                 :       32408 :   memset (&as, 0, sizeof (gfc_array_spec));
    2626                 :             : 
    2627                 :       32408 :   as.rank = expr->rank;
    2628                 :       32408 :   as.type = AS_EXPLICIT;
    2629                 :       32408 :   if (!expr->shape)
    2630                 :             :     {
    2631                 :           3 :       as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
    2632                 :           3 :       as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
    2633                 :             :                                       NULL, nelem - 1);
    2634                 :             :     }
    2635                 :             :   else
    2636                 :       68338 :     for (i = 0; i < expr->rank; i++)
    2637                 :             :       {
    2638                 :       35933 :         int tmp = (int) mpz_get_si (expr->shape[i]);
    2639                 :       35933 :         as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
    2640                 :       35933 :         as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
    2641                 :       35933 :                                         NULL, tmp - 1);
    2642                 :             :       }
    2643                 :             : 
    2644                 :       32408 :   tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
    2645                 :             : 
    2646                 :             :   /* as is not needed anymore.  */
    2647                 :      100752 :   for (i = 0; i < as.rank + as.corank; i++)
    2648                 :             :     {
    2649                 :       35936 :       gfc_free_expr (as.lower[i]);
    2650                 :       35936 :       gfc_free_expr (as.upper[i]);
    2651                 :             :     }
    2652                 :             : 
    2653                 :       32408 :   init = build_constructor (tmptype, v);
    2654                 :             : 
    2655                 :       32408 :   TREE_CONSTANT (init) = 1;
    2656                 :       32408 :   TREE_STATIC (init) = 1;
    2657                 :             : 
    2658                 :       32408 :   tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
    2659                 :             :                     tmptype);
    2660                 :       32408 :   DECL_ARTIFICIAL (tmp) = 1;
    2661                 :       32408 :   DECL_IGNORED_P (tmp) = 1;
    2662                 :       32408 :   TREE_STATIC (tmp) = 1;
    2663                 :       32408 :   TREE_CONSTANT (tmp) = 1;
    2664                 :       32408 :   TREE_READONLY (tmp) = 1;
    2665                 :       32408 :   DECL_INITIAL (tmp) = init;
    2666                 :       32408 :   pushdecl (tmp);
    2667                 :             : 
    2668                 :       32408 :   return tmp;
    2669                 :             : }
    2670                 :             : 
    2671                 :             : 
    2672                 :             : /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
    2673                 :             :    This mostly initializes the scalarizer state info structure with the
    2674                 :             :    appropriate values to directly use the array created by the function
    2675                 :             :    gfc_build_constant_array_constructor.  */
    2676                 :             : 
    2677                 :             : static void
    2678                 :       27900 : trans_constant_array_constructor (gfc_ss * ss, tree type)
    2679                 :             : {
    2680                 :       27900 :   gfc_array_info *info;
    2681                 :       27900 :   tree tmp;
    2682                 :       27900 :   int i;
    2683                 :             : 
    2684                 :       27900 :   tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
    2685                 :             : 
    2686                 :       27900 :   info = &ss->info->data.array;
    2687                 :             : 
    2688                 :       27900 :   info->descriptor = tmp;
    2689                 :       27900 :   info->data = gfc_build_addr_expr (NULL_TREE, tmp);
    2690                 :       27900 :   info->offset = gfc_index_zero_node;
    2691                 :             : 
    2692                 :       58054 :   for (i = 0; i < ss->dimen; i++)
    2693                 :             :     {
    2694                 :       30154 :       info->delta[i] = gfc_index_zero_node;
    2695                 :       30154 :       info->start[i] = gfc_index_zero_node;
    2696                 :       30154 :       info->end[i] = gfc_index_zero_node;
    2697                 :       30154 :       info->stride[i] = gfc_index_one_node;
    2698                 :             :     }
    2699                 :       27900 : }
    2700                 :             : 
    2701                 :             : 
    2702                 :             : static int
    2703                 :       27906 : get_rank (gfc_loopinfo *loop)
    2704                 :             : {
    2705                 :       27906 :   int rank;
    2706                 :             : 
    2707                 :       27906 :   rank = 0;
    2708                 :      123820 :   for (; loop; loop = loop->parent)
    2709                 :       61916 :     rank += loop->dimen;
    2710                 :             : 
    2711                 :       33998 :   return rank;
    2712                 :             : }
    2713                 :             : 
    2714                 :             : 
    2715                 :             : /* Helper routine of gfc_trans_array_constructor to determine if the
    2716                 :             :    bounds of the loop specified by LOOP are constant and simple enough
    2717                 :             :    to use with trans_constant_array_constructor.  Returns the
    2718                 :             :    iteration count of the loop if suitable, and NULL_TREE otherwise.  */
    2719                 :             : 
    2720                 :             : static tree
    2721                 :       27906 : constant_array_constructor_loop_size (gfc_loopinfo * l)
    2722                 :             : {
    2723                 :       27906 :   gfc_loopinfo *loop;
    2724                 :       27906 :   tree size = gfc_index_one_node;
    2725                 :       27906 :   tree tmp;
    2726                 :       27906 :   int i, total_dim;
    2727                 :             : 
    2728                 :       27906 :   total_dim = get_rank (l);
    2729                 :             : 
    2730                 :       55812 :   for (loop = l; loop; loop = loop->parent)
    2731                 :             :     {
    2732                 :       58078 :       for (i = 0; i < loop->dimen; i++)
    2733                 :             :         {
    2734                 :             :           /* If the bounds aren't constant, return NULL_TREE.  */
    2735                 :       30172 :           if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
    2736                 :             :             return NULL_TREE;
    2737                 :       30166 :           if (!integer_zerop (loop->from[i]))
    2738                 :             :             {
    2739                 :             :               /* Only allow nonzero "from" in one-dimensional arrays.  */
    2740                 :           0 :               if (total_dim != 1)
    2741                 :             :                 return NULL_TREE;
    2742                 :           0 :               tmp = fold_build2_loc (input_location, MINUS_EXPR,
    2743                 :             :                                      gfc_array_index_type,
    2744                 :             :                                      loop->to[i], loop->from[i]);
    2745                 :             :             }
    2746                 :             :           else
    2747                 :       30166 :             tmp = loop->to[i];
    2748                 :       30166 :           tmp = fold_build2_loc (input_location, PLUS_EXPR,
    2749                 :             :                                  gfc_array_index_type, tmp, gfc_index_one_node);
    2750                 :       30166 :           size = fold_build2_loc (input_location, MULT_EXPR,
    2751                 :             :                                   gfc_array_index_type, size, tmp);
    2752                 :             :         }
    2753                 :             :     }
    2754                 :             : 
    2755                 :             :   return size;
    2756                 :             : }
    2757                 :             : 
    2758                 :             : 
    2759                 :             : static tree *
    2760                 :       35119 : get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
    2761                 :             : {
    2762                 :       35119 :   gfc_ss *ss;
    2763                 :       35119 :   int n;
    2764                 :             : 
    2765                 :       35119 :   gcc_assert (array->nested_ss == NULL);
    2766                 :             : 
    2767                 :       35119 :   for (ss = array; ss; ss = ss->parent)
    2768                 :       35119 :     for (n = 0; n < ss->loop->dimen; n++)
    2769                 :       35119 :       if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
    2770                 :       35119 :         return &(ss->loop->to[n]);
    2771                 :             : 
    2772                 :           0 :   gcc_unreachable ();
    2773                 :             : }
    2774                 :             : 
    2775                 :             : 
    2776                 :             : static gfc_loopinfo *
    2777                 :      572599 : outermost_loop (gfc_loopinfo * loop)
    2778                 :             : {
    2779                 :      728664 :   while (loop->parent != NULL)
    2780                 :             :     loop = loop->parent;
    2781                 :             : 
    2782                 :      725423 :   return loop;
    2783                 :             : }
    2784                 :             : 
    2785                 :             : 
    2786                 :             : /* Array constructors are handled by constructing a temporary, then using that
    2787                 :             :    within the scalarization loop.  This is not optimal, but seems by far the
    2788                 :             :    simplest method.  */
    2789                 :             : 
    2790                 :             : static void
    2791                 :       35119 : trans_array_constructor (gfc_ss * ss, locus * where)
    2792                 :             : {
    2793                 :       35119 :   gfc_constructor_base c;
    2794                 :       35119 :   tree offset;
    2795                 :       35119 :   tree offsetvar;
    2796                 :       35119 :   tree desc;
    2797                 :       35119 :   tree type;
    2798                 :       35119 :   tree tmp;
    2799                 :       35119 :   tree *loop_ubound0;
    2800                 :       35119 :   bool dynamic;
    2801                 :       35119 :   bool old_first_len, old_typespec_chararray_ctor;
    2802                 :       35119 :   tree old_first_len_val;
    2803                 :       35119 :   gfc_loopinfo *loop, *outer_loop;
    2804                 :       35119 :   gfc_ss_info *ss_info;
    2805                 :       35119 :   gfc_expr *expr;
    2806                 :       35119 :   gfc_ss *s;
    2807                 :       35119 :   tree neg_len;
    2808                 :       35119 :   char *msg;
    2809                 :       35119 :   stmtblock_t finalblock;
    2810                 :       35119 :   bool finalize_required;
    2811                 :             : 
    2812                 :             :   /* Save the old values for nested checking.  */
    2813                 :       35119 :   old_first_len = first_len;
    2814                 :       35119 :   old_first_len_val = first_len_val;
    2815                 :       35119 :   old_typespec_chararray_ctor = typespec_chararray_ctor;
    2816                 :             : 
    2817                 :       35119 :   loop = ss->loop;
    2818                 :       35119 :   outer_loop = outermost_loop (loop);
    2819                 :       35119 :   ss_info = ss->info;
    2820                 :       35119 :   expr = ss_info->expr;
    2821                 :             : 
    2822                 :             :   /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
    2823                 :             :      typespec was given for the array constructor.  */
    2824                 :       70238 :   typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
    2825                 :        7523 :                              && expr->ts.u.cl
    2826                 :       42642 :                              && expr->ts.u.cl->length_from_typespec);
    2827                 :             : 
    2828                 :       35119 :   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    2829                 :        2431 :       && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
    2830                 :             :     {
    2831                 :        1450 :       first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
    2832                 :        1450 :       first_len = true;
    2833                 :             :     }
    2834                 :             : 
    2835                 :       35119 :   gcc_assert (ss->dimen == ss->loop->dimen);
    2836                 :             : 
    2837                 :       35119 :   c = expr->value.constructor;
    2838                 :       35119 :   if (expr->ts.type == BT_CHARACTER)
    2839                 :             :     {
    2840                 :        7523 :       bool const_string;
    2841                 :        7523 :       bool force_new_cl = false;
    2842                 :             : 
    2843                 :             :       /* get_array_ctor_strlen walks the elements of the constructor, if a
    2844                 :             :          typespec was given, we already know the string length and want the one
    2845                 :             :          specified there.  */
    2846                 :        7523 :       if (typespec_chararray_ctor && expr->ts.u.cl->length
    2847                 :         324 :           && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
    2848                 :             :         {
    2849                 :          27 :           gfc_se length_se;
    2850                 :             : 
    2851                 :          27 :           const_string = false;
    2852                 :          27 :           gfc_init_se (&length_se, NULL);
    2853                 :          27 :           gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
    2854                 :             :                               gfc_charlen_type_node);
    2855                 :          27 :           ss_info->string_length = length_se.expr;
    2856                 :             : 
    2857                 :             :           /* Check if the character length is negative.  If it is, then
    2858                 :             :              set LEN = 0.  */
    2859                 :          27 :           neg_len = fold_build2_loc (input_location, LT_EXPR,
    2860                 :             :                                      logical_type_node, ss_info->string_length,
    2861                 :          27 :                                      build_zero_cst (TREE_TYPE
    2862                 :             :                                                      (ss_info->string_length)));
    2863                 :             :           /* Print a warning if bounds checking is enabled.  */
    2864                 :          27 :           if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    2865                 :             :             {
    2866                 :          18 :               msg = xasprintf ("Negative character length treated as LEN = 0");
    2867                 :          18 :               gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
    2868                 :             :                                        where, msg);
    2869                 :          18 :               free (msg);
    2870                 :             :             }
    2871                 :             : 
    2872                 :          27 :           ss_info->string_length
    2873                 :          27 :             = fold_build3_loc (input_location, COND_EXPR,
    2874                 :             :                                gfc_charlen_type_node, neg_len,
    2875                 :             :                                build_zero_cst
    2876                 :          27 :                                (TREE_TYPE (ss_info->string_length)),
    2877                 :             :                                ss_info->string_length);
    2878                 :          27 :           ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
    2879                 :             :                                                      &length_se.pre);
    2880                 :          27 :           gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
    2881                 :          27 :           gfc_add_block_to_block (&outer_loop->post, &length_se.post);
    2882                 :          27 :         }
    2883                 :             :       else
    2884                 :             :         {
    2885                 :        7496 :           const_string = get_array_ctor_strlen (&outer_loop->pre, c,
    2886                 :             :                                                 &ss_info->string_length);
    2887                 :        7496 :           force_new_cl = true;
    2888                 :             : 
    2889                 :             :           /* Initialize "len" with string length for bounds checking.  */
    2890                 :        7496 :           if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    2891                 :        1468 :               && !typespec_chararray_ctor
    2892                 :        1450 :               && ss_info->string_length)
    2893                 :             :             {
    2894                 :        1450 :               gfc_se length_se;
    2895                 :             : 
    2896                 :        1450 :               gfc_init_se (&length_se, NULL);
    2897                 :        1450 :               gfc_add_modify (&length_se.pre, first_len_val,
    2898                 :        1450 :                               fold_convert (TREE_TYPE (first_len_val),
    2899                 :             :                                             ss_info->string_length));
    2900                 :        1450 :               ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
    2901                 :             :                                                          &length_se.pre);
    2902                 :        1450 :               gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
    2903                 :        1450 :               gfc_add_block_to_block (&outer_loop->post, &length_se.post);
    2904                 :             :             }
    2905                 :             :         }
    2906                 :             : 
    2907                 :             :       /* Complex character array constructors should have been taken care of
    2908                 :             :          and not end up here.  */
    2909                 :        7523 :       gcc_assert (ss_info->string_length);
    2910                 :             : 
    2911                 :        7523 :       store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
    2912                 :             : 
    2913                 :        7523 :       type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
    2914                 :        7523 :       if (const_string)
    2915                 :        6673 :         type = build_pointer_type (type);
    2916                 :             :     }
    2917                 :             :   else
    2918                 :       27621 :     type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
    2919                 :          25 :                                   ? &CLASS_DATA (expr)->ts : &expr->ts);
    2920                 :             : 
    2921                 :             :   /* See if the constructor determines the loop bounds.  */
    2922                 :       35119 :   dynamic = false;
    2923                 :             : 
    2924                 :       35119 :   loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
    2925                 :             : 
    2926                 :       69117 :   if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
    2927                 :             :     {
    2928                 :             :       /* We have a multidimensional parameter.  */
    2929                 :           0 :       for (s = ss; s; s = s->parent)
    2930                 :             :         {
    2931                 :             :           int n;
    2932                 :           0 :           for (n = 0; n < s->loop->dimen; n++)
    2933                 :             :             {
    2934                 :           0 :               s->loop->from[n] = gfc_index_zero_node;
    2935                 :           0 :               s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
    2936                 :             :                                                      gfc_index_integer_kind);
    2937                 :           0 :               s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
    2938                 :             :                                                 gfc_array_index_type,
    2939                 :           0 :                                                 s->loop->to[n],
    2940                 :             :                                                 gfc_index_one_node);
    2941                 :             :             }
    2942                 :             :         }
    2943                 :             :     }
    2944                 :             : 
    2945                 :       35119 :   if (*loop_ubound0 == NULL_TREE)
    2946                 :             :     {
    2947                 :         745 :       mpz_t size;
    2948                 :             : 
    2949                 :             :       /* We should have a 1-dimensional, zero-based loop.  */
    2950                 :         745 :       gcc_assert (loop->parent == NULL && loop->nested == NULL);
    2951                 :         745 :       gcc_assert (loop->dimen == 1);
    2952                 :         745 :       gcc_assert (integer_zerop (loop->from[0]));
    2953                 :             : 
    2954                 :             :       /* Split the constructor size into a static part and a dynamic part.
    2955                 :             :          Allocate the static size up-front and record whether the dynamic
    2956                 :             :          size might be nonzero.  */
    2957                 :         745 :       mpz_init (size);
    2958                 :         745 :       dynamic = gfc_get_array_constructor_size (&size, c);
    2959                 :         745 :       mpz_sub_ui (size, size, 1);
    2960                 :         745 :       loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
    2961                 :         745 :       mpz_clear (size);
    2962                 :             :     }
    2963                 :             : 
    2964                 :             :   /* Special case constant array constructors.  */
    2965                 :         745 :   if (!dynamic)
    2966                 :             :     {
    2967                 :       34389 :       unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
    2968                 :       34389 :       if (nelem > 0)
    2969                 :             :         {
    2970                 :       27906 :           tree size = constant_array_constructor_loop_size (loop);
    2971                 :       27906 :           if (size && compare_tree_int (size, nelem) == 0)
    2972                 :             :             {
    2973                 :       27900 :               trans_constant_array_constructor (ss, type);
    2974                 :       27900 :               goto finish;
    2975                 :             :             }
    2976                 :             :         }
    2977                 :             :     }
    2978                 :             : 
    2979                 :        7219 :   gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
    2980                 :             :                                NULL_TREE, dynamic, true, false, where);
    2981                 :             : 
    2982                 :        7219 :   desc = ss_info->data.array.descriptor;
    2983                 :        7219 :   offset = gfc_index_zero_node;
    2984                 :        7219 :   offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
    2985                 :        7219 :   suppress_warning (offsetvar);
    2986                 :        7219 :   TREE_USED (offsetvar) = 0;
    2987                 :             : 
    2988                 :        7219 :   gfc_init_block (&finalblock);
    2989                 :        7219 :   finalize_required = expr->must_finalize;
    2990                 :        7219 :   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
    2991                 :             :     finalize_required = true;
    2992                 :        7243 :   gfc_trans_array_constructor_value (&outer_loop->pre,
    2993                 :             :                                      finalize_required ? &finalblock : NULL,
    2994                 :             :                                      type, desc, c, &offset, &offsetvar,
    2995                 :             :                                      dynamic);
    2996                 :             : 
    2997                 :             :   /* If the array grows dynamically, the upper bound of the loop variable
    2998                 :             :      is determined by the array's final upper bound.  */
    2999                 :        7219 :   if (dynamic)
    3000                 :             :     {
    3001                 :         730 :       tmp = fold_build2_loc (input_location, MINUS_EXPR,
    3002                 :             :                              gfc_array_index_type,
    3003                 :             :                              offsetvar, gfc_index_one_node);
    3004                 :         730 :       tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
    3005                 :         730 :       gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
    3006                 :         730 :       if (*loop_ubound0 && VAR_P (*loop_ubound0))
    3007                 :           0 :         gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
    3008                 :             :       else
    3009                 :         730 :         *loop_ubound0 = tmp;
    3010                 :             :     }
    3011                 :             : 
    3012                 :        7219 :   if (TREE_USED (offsetvar))
    3013                 :        1770 :     pushdecl (offsetvar);
    3014                 :             :   else
    3015                 :        5449 :     gcc_assert (INTEGER_CST_P (offset));
    3016                 :             : 
    3017                 :             : #if 0
    3018                 :             :   /* Disable bound checking for now because it's probably broken.  */
    3019                 :             :   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    3020                 :             :     {
    3021                 :             :       gcc_unreachable ();
    3022                 :             :     }
    3023                 :             : #endif
    3024                 :             : 
    3025                 :        5449 : finish:
    3026                 :             :   /* Restore old values of globals.  */
    3027                 :       35119 :   first_len = old_first_len;
    3028                 :       35119 :   first_len_val = old_first_len_val;
    3029                 :       35119 :   typespec_chararray_ctor = old_typespec_chararray_ctor;
    3030                 :             : 
    3031                 :             :   /* F2008 4.5.6.3 para 5: If an executable construct references a structure
    3032                 :             :      constructor or array constructor, the entity created by the constructor is
    3033                 :             :      finalized after execution of the innermost executable construct containing
    3034                 :             :      the reference.  */
    3035                 :       35119 :   if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
    3036                 :        1353 :        && finalblock.head != NULL_TREE)
    3037                 :          20 :     gfc_add_block_to_block (&loop->post, &finalblock);
    3038                 :             : 
    3039                 :       35119 : }
    3040                 :             : 
    3041                 :             : 
    3042                 :             : /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
    3043                 :             :    called after evaluating all of INFO's vector dimensions.  Go through
    3044                 :             :    each such vector dimension and see if we can now fill in any missing
    3045                 :             :    loop bounds.  */
    3046                 :             : 
    3047                 :             : static void
    3048                 :      150147 : set_vector_loop_bounds (gfc_ss * ss)
    3049                 :             : {
    3050                 :      150147 :   gfc_loopinfo *loop, *outer_loop;
    3051                 :      150147 :   gfc_array_info *info;
    3052                 :      150147 :   gfc_se se;
    3053                 :      150147 :   tree tmp;
    3054                 :      150147 :   tree desc;
    3055                 :      150147 :   tree zero;
    3056                 :      150147 :   int n;
    3057                 :      150147 :   int dim;
    3058                 :             : 
    3059                 :      150147 :   outer_loop = outermost_loop (ss->loop);
    3060                 :             : 
    3061                 :      150147 :   info = &ss->info->data.array;
    3062                 :             : 
    3063                 :      300931 :   for (; ss; ss = ss->parent)
    3064                 :             :     {
    3065                 :      150784 :       loop = ss->loop;
    3066                 :             : 
    3067                 :      350871 :       for (n = 0; n < loop->dimen; n++)
    3068                 :             :         {
    3069                 :      200087 :           dim = ss->dim[n];
    3070                 :      200087 :           if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
    3071                 :         744 :               || loop->to[n] != NULL)
    3072                 :      199928 :             continue;
    3073                 :             : 
    3074                 :             :           /* Loop variable N indexes vector dimension DIM, and we don't
    3075                 :             :              yet know the upper bound of loop variable N.  Set it to the
    3076                 :             :              difference between the vector's upper and lower bounds.  */
    3077                 :         159 :           gcc_assert (loop->from[n] == gfc_index_zero_node);
    3078                 :         159 :           gcc_assert (info->subscript[dim]
    3079                 :             :                       && info->subscript[dim]->info->type == GFC_SS_VECTOR);
    3080                 :             : 
    3081                 :         159 :           gfc_init_se (&se, NULL);
    3082                 :         159 :           desc = info->subscript[dim]->info->data.array.descriptor;
    3083                 :         159 :           zero = gfc_rank_cst[0];
    3084                 :         159 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
    3085                 :             :                              gfc_array_index_type,
    3086                 :             :                              gfc_conv_descriptor_ubound_get (desc, zero),
    3087                 :             :                              gfc_conv_descriptor_lbound_get (desc, zero));
    3088                 :         159 :           tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
    3089                 :         159 :           loop->to[n] = tmp;
    3090                 :             :         }
    3091                 :             :     }
    3092                 :      150147 : }
    3093                 :             : 
    3094                 :             : 
    3095                 :             : /* Tells whether a scalar argument to an elemental procedure is saved out
    3096                 :             :    of a scalarization loop as a value or as a reference.  */
    3097                 :             : 
    3098                 :             : bool
    3099                 :       33311 : gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
    3100                 :             : {
    3101                 :       33311 :   if (ss_info->type != GFC_SS_REFERENCE)
    3102                 :             :     return false;
    3103                 :             : 
    3104                 :        3050 :   if (ss_info->data.scalar.needs_temporary)
    3105                 :             :     return false;
    3106                 :             : 
    3107                 :             :   /* If the actual argument can be absent (in other words, it can
    3108                 :             :      be a NULL reference), don't try to evaluate it; pass instead
    3109                 :             :      the reference directly.  */
    3110                 :        2686 :   if (ss_info->can_be_null_ref)
    3111                 :             :     return true;
    3112                 :             : 
    3113                 :             :   /* If the expression is of polymorphic type, it's actual size is not known,
    3114                 :             :      so we avoid copying it anywhere.  */
    3115                 :        2050 :   if (ss_info->data.scalar.dummy_arg
    3116                 :        1232 :       && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
    3117                 :             :          == BT_CLASS
    3118                 :        2100 :       && ss_info->expr->ts.type == BT_CLASS)
    3119                 :             :     return true;
    3120                 :             : 
    3121                 :             :   /* If the expression is a data reference of aggregate type,
    3122                 :             :      and the data reference is not used on the left hand side,
    3123                 :             :      avoid a copy by saving a reference to the content.  */
    3124                 :        2026 :   if (!ss_info->data.scalar.needs_temporary
    3125                 :        2026 :       && (ss_info->expr->ts.type == BT_DERIVED
    3126                 :        1126 :           || ss_info->expr->ts.type == BT_CLASS)
    3127                 :        2974 :       && gfc_expr_is_variable (ss_info->expr))
    3128                 :             :     return true;
    3129                 :             : 
    3130                 :             :   /* Otherwise the expression is evaluated to a temporary variable before the
    3131                 :             :      scalarization loop.  */
    3132                 :             :   return false;
    3133                 :             : }
    3134                 :             : 
    3135                 :             : 
    3136                 :             : /* Add the pre and post chains for all the scalar expressions in a SS chain
    3137                 :             :    to loop.  This is called after the loop parameters have been calculated,
    3138                 :             :    but before the actual scalarizing loops.  */
    3139                 :             : 
    3140                 :             : static void
    3141                 :      152976 : gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
    3142                 :             :                       locus * where)
    3143                 :             : {
    3144                 :      152976 :   gfc_loopinfo *nested_loop, *outer_loop;
    3145                 :      152976 :   gfc_se se;
    3146                 :      152976 :   gfc_ss_info *ss_info;
    3147                 :      152976 :   gfc_array_info *info;
    3148                 :      152976 :   gfc_expr *expr;
    3149                 :      152976 :   int n;
    3150                 :             : 
    3151                 :             :   /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
    3152                 :             :      arguments could get evaluated multiple times.  */
    3153                 :      152976 :   if (ss->is_alloc_lhs)
    3154                 :         152 :     return;
    3155                 :             : 
    3156                 :      152824 :   outer_loop = outermost_loop (loop);
    3157                 :             : 
    3158                 :             :   /* TODO: This can generate bad code if there are ordering dependencies,
    3159                 :             :      e.g., a callee allocated function and an unknown size constructor.  */
    3160                 :      152824 :   gcc_assert (ss != NULL);
    3161                 :             : 
    3162                 :      399964 :   for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
    3163                 :             :     {
    3164                 :      247140 :       gcc_assert (ss);
    3165                 :             : 
    3166                 :             :       /* Cross loop arrays are handled from within the most nested loop.  */
    3167                 :      247140 :       if (ss->nested_ss != NULL)
    3168                 :         737 :         continue;
    3169                 :             : 
    3170                 :      246403 :       ss_info = ss->info;
    3171                 :      246403 :       expr = ss_info->expr;
    3172                 :      246403 :       info = &ss_info->data.array;
    3173                 :             : 
    3174                 :      246403 :       switch (ss_info->type)
    3175                 :             :         {
    3176                 :       35946 :         case GFC_SS_SCALAR:
    3177                 :             :           /* Scalar expression.  Evaluate this now.  This includes elemental
    3178                 :             :              dimension indices, but not array section bounds.  */
    3179                 :       35946 :           gfc_init_se (&se, NULL);
    3180                 :       35946 :           gfc_conv_expr (&se, expr);
    3181                 :       35946 :           gfc_add_block_to_block (&outer_loop->pre, &se.pre);
    3182                 :             : 
    3183                 :       35946 :           if (expr->ts.type != BT_CHARACTER
    3184                 :       35946 :               && !gfc_is_alloc_class_scalar_function (expr))
    3185                 :             :             {
    3186                 :             :               /* Move the evaluation of scalar expressions outside the
    3187                 :             :                  scalarization loop, except for WHERE assignments.  */
    3188                 :       32369 :               if (subscript)
    3189                 :        3930 :                 se.expr = convert(gfc_array_index_type, se.expr);
    3190                 :       32369 :               if (!ss_info->where)
    3191                 :       31955 :                 se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
    3192                 :       32369 :               gfc_add_block_to_block (&outer_loop->pre, &se.post);
    3193                 :             :             }
    3194                 :             :           else
    3195                 :        3577 :             gfc_add_block_to_block (&outer_loop->post, &se.post);
    3196                 :             : 
    3197                 :       35946 :           ss_info->data.scalar.value = se.expr;
    3198                 :       35946 :           ss_info->string_length = se.string_length;
    3199                 :       35946 :           break;
    3200                 :             : 
    3201                 :        1525 :         case GFC_SS_REFERENCE:
    3202                 :             :           /* Scalar argument to elemental procedure.  */
    3203                 :        1525 :           gfc_init_se (&se, NULL);
    3204                 :        1525 :           if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
    3205                 :         780 :             gfc_conv_expr_reference (&se, expr);
    3206                 :             :           else
    3207                 :             :             {
    3208                 :             :               /* Evaluate the argument outside the loop and pass
    3209                 :             :                  a reference to the value.  */
    3210                 :         745 :               gfc_conv_expr (&se, expr);
    3211                 :             :             }
    3212                 :             : 
    3213                 :             :           /* Ensure that a pointer to the string is stored.  */
    3214                 :        1525 :           if (expr->ts.type == BT_CHARACTER)
    3215                 :         174 :             gfc_conv_string_parameter (&se);
    3216                 :             : 
    3217                 :        1525 :           gfc_add_block_to_block (&outer_loop->pre, &se.pre);
    3218                 :        1525 :           gfc_add_block_to_block (&outer_loop->post, &se.post);
    3219                 :        1525 :           if (gfc_is_class_scalar_expr (expr))
    3220                 :             :             /* This is necessary because the dynamic type will always be
    3221                 :             :                large than the declared type.  In consequence, assigning
    3222                 :             :                the value to a temporary could segfault.
    3223                 :             :                OOP-TODO: see if this is generally correct or is the value
    3224                 :             :                has to be written to an allocated temporary, whose address
    3225                 :             :                is passed via ss_info.  */
    3226                 :          48 :             ss_info->data.scalar.value = se.expr;
    3227                 :             :           else
    3228                 :        1477 :             ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
    3229                 :             :                                                            &outer_loop->pre);
    3230                 :             : 
    3231                 :        1525 :           ss_info->string_length = se.string_length;
    3232                 :        1525 :           break;
    3233                 :             : 
    3234                 :             :         case GFC_SS_SECTION:
    3235                 :             :           /* Add the expressions for scalar and vector subscripts.  */
    3236                 :     2402352 :           for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
    3237                 :     2252205 :             if (info->subscript[n])
    3238                 :        4674 :               gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
    3239                 :             : 
    3240                 :      150147 :           set_vector_loop_bounds (ss);
    3241                 :      150147 :           break;
    3242                 :             : 
    3243                 :         744 :         case GFC_SS_VECTOR:
    3244                 :             :           /* Get the vector's descriptor and store it in SS.  */
    3245                 :         744 :           gfc_init_se (&se, NULL);
    3246                 :         744 :           gfc_conv_expr_descriptor (&se, expr);
    3247                 :         744 :           gfc_add_block_to_block (&outer_loop->pre, &se.pre);
    3248                 :         744 :           gfc_add_block_to_block (&outer_loop->post, &se.post);
    3249                 :         744 :           info->descriptor = se.expr;
    3250                 :         744 :           break;
    3251                 :             : 
    3252                 :        5054 :         case GFC_SS_INTRINSIC:
    3253                 :        5054 :           gfc_add_intrinsic_ss_code (loop, ss);
    3254                 :        5054 :           break;
    3255                 :             : 
    3256                 :        8353 :         case GFC_SS_FUNCTION:
    3257                 :             :           /* Array function return value.  We call the function and save its
    3258                 :             :              result in a temporary for use inside the loop.  */
    3259                 :        8353 :           gfc_init_se (&se, NULL);
    3260                 :        8353 :           se.loop = loop;
    3261                 :        8353 :           se.ss = ss;
    3262                 :        8353 :           if (gfc_is_class_array_function (expr))
    3263                 :         165 :             expr->must_finalize = 1;
    3264                 :        8353 :           gfc_conv_expr (&se, expr);
    3265                 :        8353 :           gfc_add_block_to_block (&outer_loop->pre, &se.pre);
    3266                 :        8353 :           gfc_add_block_to_block (&outer_loop->post, &se.post);
    3267                 :        8353 :           gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
    3268                 :        8353 :           ss_info->string_length = se.string_length;
    3269                 :        8353 :           break;
    3270                 :             : 
    3271                 :       35119 :         case GFC_SS_CONSTRUCTOR:
    3272                 :       35119 :           if (expr->ts.type == BT_CHARACTER
    3273                 :        7523 :               && ss_info->string_length == NULL
    3274                 :        7523 :               && expr->ts.u.cl
    3275                 :        7523 :               && expr->ts.u.cl->length
    3276                 :        7217 :               && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
    3277                 :             :             {
    3278                 :        7166 :               gfc_init_se (&se, NULL);
    3279                 :        7166 :               gfc_conv_expr_type (&se, expr->ts.u.cl->length,
    3280                 :             :                                   gfc_charlen_type_node);
    3281                 :        7166 :               ss_info->string_length = se.expr;
    3282                 :        7166 :               gfc_add_block_to_block (&outer_loop->pre, &se.pre);
    3283                 :        7166 :               gfc_add_block_to_block (&outer_loop->post, &se.post);
    3284                 :             :             }
    3285                 :       35119 :           trans_array_constructor (ss, where);
    3286                 :       35119 :           break;
    3287                 :             : 
    3288                 :             :         case GFC_SS_TEMP:
    3289                 :             :         case GFC_SS_COMPONENT:
    3290                 :             :           /* Do nothing.  These are handled elsewhere.  */
    3291                 :             :           break;
    3292                 :             : 
    3293                 :           0 :         default:
    3294                 :           0 :           gcc_unreachable ();
    3295                 :             :         }
    3296                 :             :     }
    3297                 :             : 
    3298                 :      152824 :   if (!subscript)
    3299                 :      148703 :     for (nested_loop = loop->nested; nested_loop;
    3300                 :         553 :          nested_loop = nested_loop->next)
    3301                 :         553 :       gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
    3302                 :             : }
    3303                 :             : 
    3304                 :             : 
    3305                 :             : /* Translate expressions for the descriptor and data pointer of a SS.  */
    3306                 :             : /*GCC ARRAYS*/
    3307                 :             : 
    3308                 :             : static void
    3309                 :      269704 : gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
    3310                 :             : {
    3311                 :      269704 :   gfc_se se;
    3312                 :      269704 :   gfc_ss_info *ss_info;
    3313                 :      269704 :   gfc_array_info *info;
    3314                 :      269704 :   tree tmp;
    3315                 :             : 
    3316                 :      269704 :   ss_info = ss->info;
    3317                 :      269704 :   info = &ss_info->data.array;
    3318                 :             : 
    3319                 :             :   /* Get the descriptor for the array to be scalarized.  */
    3320                 :      269704 :   gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
    3321                 :      269704 :   gfc_init_se (&se, NULL);
    3322                 :      269704 :   se.descriptor_only = 1;
    3323                 :      269704 :   gfc_conv_expr_lhs (&se, ss_info->expr);
    3324                 :      269704 :   gfc_add_block_to_block (block, &se.pre);
    3325                 :      269704 :   info->descriptor = se.expr;
    3326                 :      269704 :   ss_info->string_length = se.string_length;
    3327                 :      269704 :   ss_info->class_container = se.class_container;
    3328                 :             : 
    3329                 :      269704 :   if (base)
    3330                 :             :     {
    3331                 :       98784 :       if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
    3332                 :       21639 :           && ss_info->expr->ts.u.cl->length == NULL)
    3333                 :             :         {
    3334                 :             :           /* Emit a DECL_EXPR for the variable sized array type in
    3335                 :             :              GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
    3336                 :             :              sizes works correctly.  */
    3337                 :        1025 :           tree arraytype = TREE_TYPE (
    3338                 :             :                 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
    3339                 :        1025 :           if (! TYPE_NAME (arraytype))
    3340                 :         873 :             TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
    3341                 :             :                                                 NULL_TREE, arraytype);
    3342                 :        1025 :           gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
    3343                 :        1025 :                                                 TYPE_NAME (arraytype)));
    3344                 :             :         }
    3345                 :             :       /* Also the data pointer.  */
    3346                 :       98784 :       tmp = gfc_conv_array_data (se.expr);
    3347                 :             :       /* If this is a variable or address or a class array, use it directly.
    3348                 :             :          Otherwise we must evaluate it now to avoid breaking dependency
    3349                 :             :          analysis by pulling the expressions for elemental array indices
    3350                 :             :          inside the loop.  */
    3351                 :       98784 :       if (!(DECL_P (tmp)
    3352                 :       89406 :             || (TREE_CODE (tmp) == ADDR_EXPR
    3353                 :       59516 :                 && DECL_P (TREE_OPERAND (tmp, 0)))
    3354                 :       32400 :             || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
    3355                 :       29601 :                 && TREE_CODE (se.expr) == COMPONENT_REF
    3356                 :        6899 :                 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))))))
    3357                 :       29824 :         tmp = gfc_evaluate_now (tmp, block);
    3358                 :       98784 :       info->data = tmp;
    3359                 :             : 
    3360                 :       98784 :       tmp = gfc_conv_array_offset (se.expr);
    3361                 :       98784 :       info->offset = gfc_evaluate_now (tmp, block);
    3362                 :             : 
    3363                 :             :       /* Make absolutely sure that the saved_offset is indeed saved
    3364                 :             :          so that the variable is still accessible after the loops
    3365                 :             :          are translated.  */
    3366                 :       98784 :       info->saved_offset = info->offset;
    3367                 :             :     }
    3368                 :      269704 : }
    3369                 :             : 
    3370                 :             : 
    3371                 :             : /* Initialize a gfc_loopinfo structure.  */
    3372                 :             : 
    3373                 :             : void
    3374                 :      152756 : gfc_init_loopinfo (gfc_loopinfo * loop)
    3375                 :             : {
    3376                 :      152756 :   int n;
    3377                 :             : 
    3378                 :      152756 :   memset (loop, 0, sizeof (gfc_loopinfo));
    3379                 :      152756 :   gfc_init_block (&loop->pre);
    3380                 :      152756 :   gfc_init_block (&loop->post);
    3381                 :             : 
    3382                 :             :   /* Initially scalarize in order and default to no loop reversal.  */
    3383                 :     2596852 :   for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
    3384                 :             :     {
    3385                 :     2291340 :       loop->order[n] = n;
    3386                 :     2291340 :       loop->reverse[n] = GFC_INHIBIT_REVERSE;
    3387                 :             :     }
    3388                 :             : 
    3389                 :      152756 :   loop->ss = gfc_ss_terminator;
    3390                 :      152756 : }
    3391                 :             : 
    3392                 :             : 
    3393                 :             : /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
    3394                 :             :    chain.  */
    3395                 :             : 
    3396                 :             : void
    3397                 :      146470 : gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
    3398                 :             : {
    3399                 :      146470 :   se->loop = loop;
    3400                 :      146470 : }
    3401                 :             : 
    3402                 :             : 
    3403                 :             : /* Return an expression for the data pointer of an array.  */
    3404                 :             : 
    3405                 :             : tree
    3406                 :      278483 : gfc_conv_array_data (tree descriptor)
    3407                 :             : {
    3408                 :      278483 :   tree type;
    3409                 :             : 
    3410                 :      278483 :   type = TREE_TYPE (descriptor);
    3411                 :      278483 :   if (GFC_ARRAY_TYPE_P (type))
    3412                 :             :     {
    3413                 :      202053 :       if (TREE_CODE (type) == POINTER_TYPE)
    3414                 :             :         return descriptor;
    3415                 :             :       else
    3416                 :             :         {
    3417                 :             :           /* Descriptorless arrays.  */
    3418                 :      152196 :           return gfc_build_addr_expr (NULL_TREE, descriptor);
    3419                 :             :         }
    3420                 :             :     }
    3421                 :             :   else
    3422                 :       76430 :     return gfc_conv_descriptor_data_get (descriptor);
    3423                 :             : }
    3424                 :             : 
    3425                 :             : 
    3426                 :             : /* Return an expression for the base offset of an array.  */
    3427                 :             : 
    3428                 :             : tree
    3429                 :      210154 : gfc_conv_array_offset (tree descriptor)
    3430                 :             : {
    3431                 :      210154 :   tree type;
    3432                 :             : 
    3433                 :      210154 :   type = TREE_TYPE (descriptor);
    3434                 :      210154 :   if (GFC_ARRAY_TYPE_P (type))
    3435                 :      155496 :     return GFC_TYPE_ARRAY_OFFSET (type);
    3436                 :             :   else
    3437                 :       54658 :     return gfc_conv_descriptor_offset_get (descriptor);
    3438                 :             : }
    3439                 :             : 
    3440                 :             : 
    3441                 :             : /* Get an expression for the array stride.  */
    3442                 :             : 
    3443                 :             : tree
    3444                 :      403538 : gfc_conv_array_stride (tree descriptor, int dim)
    3445                 :             : {
    3446                 :      403538 :   tree tmp;
    3447                 :      403538 :   tree type;
    3448                 :             : 
    3449                 :      403538 :   type = TREE_TYPE (descriptor);
    3450                 :             : 
    3451                 :             :   /* For descriptorless arrays use the array size.  */
    3452                 :      403538 :   tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
    3453                 :      403538 :   if (tmp != NULL_TREE)
    3454                 :             :     return tmp;
    3455                 :             : 
    3456                 :       77474 :   tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
    3457                 :       77474 :   return tmp;
    3458                 :             : }
    3459                 :             : 
    3460                 :             : 
    3461                 :             : /* Like gfc_conv_array_stride, but for the lower bound.  */
    3462                 :             : 
    3463                 :             : tree
    3464                 :      269918 : gfc_conv_array_lbound (tree descriptor, int dim)
    3465                 :             : {
    3466                 :      269918 :   tree tmp;
    3467                 :      269918 :   tree type;
    3468                 :             : 
    3469                 :      269918 :   type = TREE_TYPE (descriptor);
    3470                 :             : 
    3471                 :      269918 :   tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
    3472                 :      269918 :   if (tmp != NULL_TREE)
    3473                 :             :     return tmp;
    3474                 :             : 
    3475                 :       11584 :   tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
    3476                 :       11584 :   return tmp;
    3477                 :             : }
    3478                 :             : 
    3479                 :             : 
    3480                 :             : /* Like gfc_conv_array_stride, but for the upper bound.  */
    3481                 :             : 
    3482                 :             : tree
    3483                 :      175673 : gfc_conv_array_ubound (tree descriptor, int dim)
    3484                 :             : {
    3485                 :      175673 :   tree tmp;
    3486                 :      175673 :   tree type;
    3487                 :             : 
    3488                 :      175673 :   type = TREE_TYPE (descriptor);
    3489                 :             : 
    3490                 :      175673 :   tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
    3491                 :      175673 :   if (tmp != NULL_TREE)
    3492                 :             :     return tmp;
    3493                 :             : 
    3494                 :             :   /* This should only ever happen when passing an assumed shape array
    3495                 :             :      as an actual parameter.  The value will never be used.  */
    3496                 :        7394 :   if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
    3497                 :         541 :     return gfc_index_zero_node;
    3498                 :             : 
    3499                 :        6853 :   tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
    3500                 :        6853 :   return tmp;
    3501                 :             : }
    3502                 :             : 
    3503                 :             : 
    3504                 :             : /* Generate abridged name of a part-ref for use in bounds-check message.
    3505                 :             :    Cases:
    3506                 :             :    (1) for an ordinary array variable x return "x"
    3507                 :             :    (2) for z a DT scalar and array component x (at level 1) return "z%%x"
    3508                 :             :    (3) for z a DT scalar and array component x (at level > 1) or
    3509                 :             :        for z a DT array and array x (at any number of levels): "z...%%x"
    3510                 :             :  */
    3511                 :             : 
    3512                 :             : static char *
    3513                 :       35647 : abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
    3514                 :             : {
    3515                 :       35647 :   gfc_ref *ref;
    3516                 :       35647 :   gfc_symbol *sym;
    3517                 :       35647 :   char *ref_name = NULL;
    3518                 :       35647 :   const char *comp_name = NULL;
    3519                 :       35647 :   int len_sym, last_len = 0, level = 0;
    3520                 :       35647 :   bool sym_is_array;
    3521                 :             : 
    3522                 :       35647 :   gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
    3523                 :             : 
    3524                 :       35647 :   sym = expr->symtree->n.sym;
    3525                 :       71294 :   sym_is_array = (sym->ts.type != BT_CLASS
    3526                 :       35647 :                   ? sym->as != NULL
    3527                 :         159 :                   : IS_CLASS_ARRAY (sym));
    3528                 :       35647 :   len_sym = strlen (sym->name);
    3529                 :             : 
    3530                 :             :   /* Scan ref chain to get name of the array component (when ar != NULL) or
    3531                 :             :      array section, determine depth and remember its component name.  */
    3532                 :       50266 :   for (ref = expr->ref; ref; ref = ref->next)
    3533                 :             :     {
    3534                 :       36586 :       if (ref->type == REF_COMPONENT
    3535                 :         630 :           && strcmp (ref->u.c.component->name, "_data") != 0)
    3536                 :             :         {
    3537                 :         500 :           level++;
    3538                 :         500 :           comp_name = ref->u.c.component->name;
    3539                 :         500 :           continue;
    3540                 :             :         }
    3541                 :             : 
    3542                 :       36086 :       if (ref->type != REF_ARRAY)
    3543                 :         142 :         continue;
    3544                 :             : 
    3545                 :       35944 :       if (ar)
    3546                 :             :         {
    3547                 :       15507 :           if (&ref->u.ar == ar)
    3548                 :             :             break;
    3549                 :             :         }
    3550                 :       20437 :       else if (ref->u.ar.type == AR_SECTION)
    3551                 :             :         break;
    3552                 :             :     }
    3553                 :             : 
    3554                 :       35647 :   if (level > 0)
    3555                 :         474 :     last_len = strlen (comp_name);
    3556                 :             : 
    3557                 :             :   /* Provide a buffer sufficiently large to hold "x...%%z".  */
    3558                 :       35647 :   ref_name = XNEWVEC (char, len_sym + last_len + 6);
    3559                 :       35647 :   strcpy (ref_name, sym->name);
    3560                 :             : 
    3561                 :       35647 :   if (level == 1 && !sym_is_array)
    3562                 :             :     {
    3563                 :         190 :       strcat (ref_name, "%%");
    3564                 :         190 :       strcat (ref_name, comp_name);
    3565                 :             :     }
    3566                 :       35457 :   else if (level > 0)
    3567                 :             :     {
    3568                 :         284 :       strcat (ref_name, "...%%");
    3569                 :         284 :       strcat (ref_name, comp_name);
    3570                 :             :     }
    3571                 :             : 
    3572                 :       35647 :   return ref_name;
    3573                 :             : }
    3574                 :             : 
    3575                 :             : 
    3576                 :             : /* Generate code to perform an array index bound check.  */
    3577                 :             : 
    3578                 :             : static tree
    3579                 :        3616 : trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
    3580                 :             :                          locus * where, bool check_upper,
    3581                 :             :                          const char *compname = NULL)
    3582                 :             : {
    3583                 :        3616 :   tree fault;
    3584                 :        3616 :   tree tmp_lo, tmp_up;
    3585                 :        3616 :   tree descriptor;
    3586                 :        3616 :   char *msg;
    3587                 :        3616 :   char *ref_name = NULL;
    3588                 :        3616 :   const char * name = NULL;
    3589                 :        3616 :   gfc_expr *expr;
    3590                 :             : 
    3591                 :        3616 :   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
    3592                 :             :     return index;
    3593                 :             : 
    3594                 :         216 :   descriptor = ss->info->data.array.descriptor;
    3595                 :             : 
    3596                 :         216 :   index = gfc_evaluate_now (index, &se->pre);
    3597                 :             : 
    3598                 :             :   /* We find a name for the error message.  */
    3599                 :         216 :   name = ss->info->expr->symtree->n.sym->name;
    3600                 :         216 :   gcc_assert (name != NULL);
    3601                 :             : 
    3602                 :             :   /* When we have a component ref, get name of the array section.
    3603                 :             :      Note that there can only be one part ref.  */
    3604                 :         216 :   expr = ss->info->expr;
    3605                 :         216 :   if (expr->ref && !compname)
    3606                 :         142 :     name = ref_name = abridged_ref_name (expr, NULL);
    3607                 :             : 
    3608                 :         216 :   if (VAR_P (descriptor))
    3609                 :         138 :     name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
    3610                 :             : 
    3611                 :             :   /* Use given (array component) name.  */
    3612                 :         216 :   if (compname)
    3613                 :          74 :     name = compname;
    3614                 :             : 
    3615                 :             :   /* If upper bound is present, include both bounds in the error message.  */
    3616                 :         216 :   if (check_upper)
    3617                 :             :     {
    3618                 :         189 :       tmp_lo = gfc_conv_array_lbound (descriptor, n);
    3619                 :         189 :       tmp_up = gfc_conv_array_ubound (descriptor, n);
    3620                 :             : 
    3621                 :         189 :       if (name)
    3622                 :         189 :         msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
    3623                 :             :                          "outside of expected range (%%ld:%%ld)", n+1, name);
    3624                 :             :       else
    3625                 :           0 :         msg = xasprintf ("Index '%%ld' of dimension %d "
    3626                 :             :                          "outside of expected range (%%ld:%%ld)", n+1);
    3627                 :             : 
    3628                 :         189 :       fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    3629                 :             :                                index, tmp_lo);
    3630                 :         189 :       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
    3631                 :             :                                fold_convert (long_integer_type_node, index),
    3632                 :             :                                fold_convert (long_integer_type_node, tmp_lo),
    3633                 :             :                                fold_convert (long_integer_type_node, tmp_up));
    3634                 :         189 :       fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    3635                 :             :                                index, tmp_up);
    3636                 :         189 :       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
    3637                 :             :                                fold_convert (long_integer_type_node, index),
    3638                 :             :                                fold_convert (long_integer_type_node, tmp_lo),
    3639                 :             :                                fold_convert (long_integer_type_node, tmp_up));
    3640                 :         189 :       free (msg);
    3641                 :             :     }
    3642                 :             :   else
    3643                 :             :     {
    3644                 :          27 :       tmp_lo = gfc_conv_array_lbound (descriptor, n);
    3645                 :             : 
    3646                 :          27 :       if (name)
    3647                 :          27 :         msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
    3648                 :             :                          "below lower bound of %%ld", n+1, name);
    3649                 :             :       else
    3650                 :           0 :         msg = xasprintf ("Index '%%ld' of dimension %d "
    3651                 :             :                          "below lower bound of %%ld", n+1);
    3652                 :             : 
    3653                 :          27 :       fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    3654                 :             :                                index, tmp_lo);
    3655                 :          27 :       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
    3656                 :             :                                fold_convert (long_integer_type_node, index),
    3657                 :             :                                fold_convert (long_integer_type_node, tmp_lo));
    3658                 :          27 :       free (msg);
    3659                 :             :     }
    3660                 :             : 
    3661                 :         216 :   free (ref_name);
    3662                 :         216 :   return index;
    3663                 :             : }
    3664                 :             : 
    3665                 :             : 
    3666                 :             : /* Generate code for bounds checking for elemental dimensions.  */
    3667                 :             : 
    3668                 :             : static void
    3669                 :        6641 : array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
    3670                 :             : {
    3671                 :        6641 :   gfc_array_ref *ar;
    3672                 :        6641 :   gfc_ref *ref;
    3673                 :        6641 :   char *var_name = NULL;
    3674                 :        6641 :   int dim;
    3675                 :             : 
    3676                 :        6641 :   if (expr->expr_type == EXPR_VARIABLE)
    3677                 :             :     {
    3678                 :       12515 :       for (ref = expr->ref; ref; ref = ref->next)
    3679                 :             :         {
    3680                 :        6281 :           if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
    3681                 :             :             {
    3682                 :        3971 :               ar = &ref->u.ar;
    3683                 :        3971 :               var_name = abridged_ref_name (expr, ar);
    3684                 :        8231 :               for (dim = 0; dim < ar->dimen; dim++)
    3685                 :             :                 {
    3686                 :        4260 :                   if (ar->dimen_type[dim] == DIMEN_ELEMENT)
    3687                 :             :                     {
    3688                 :          74 :                       gfc_se indexse;
    3689                 :          74 :                       gfc_init_se (&indexse, NULL);
    3690                 :          74 :                       gfc_conv_expr_type (&indexse, ar->start[dim],
    3691                 :             :                                           gfc_array_index_type);
    3692                 :          74 :                       trans_array_bound_check (se, ss, indexse.expr, dim,
    3693                 :             :                                                &ar->where,
    3694                 :          74 :                                                ar->as->type != AS_ASSUMED_SIZE
    3695                 :          74 :                                                || dim < ar->dimen - 1,
    3696                 :             :                                                var_name);
    3697                 :             :                     }
    3698                 :             :                 }
    3699                 :        3971 :               free (var_name);
    3700                 :             :             }
    3701                 :             :         }
    3702                 :             :     }
    3703                 :        6641 : }
    3704                 :             : 
    3705                 :             : 
    3706                 :             : /* Return the offset for an index.  Performs bound checking for elemental
    3707                 :             :    dimensions.  Single element references are processed separately.
    3708                 :             :    DIM is the array dimension, I is the loop dimension.  */
    3709                 :             : 
    3710                 :             : static tree
    3711                 :      184650 : conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
    3712                 :             :                          gfc_array_ref * ar, tree stride)
    3713                 :             : {
    3714                 :      184650 :   gfc_array_info *info;
    3715                 :      184650 :   tree index;
    3716                 :      184650 :   tree desc;
    3717                 :      184650 :   tree data;
    3718                 :             : 
    3719                 :      184650 :   info = &ss->info->data.array;
    3720                 :             : 
    3721                 :             :   /* Get the index into the array for this dimension.  */
    3722                 :      184650 :   if (ar)
    3723                 :             :     {
    3724                 :      128760 :       gcc_assert (ar->type != AR_ELEMENT);
    3725                 :      128760 :       switch (ar->dimen_type[dim])
    3726                 :             :         {
    3727                 :           0 :         case DIMEN_THIS_IMAGE:
    3728                 :           0 :           gcc_unreachable ();
    3729                 :        2805 :           break;
    3730                 :        2805 :         case DIMEN_ELEMENT:
    3731                 :             :           /* Elemental dimension.  */
    3732                 :        2805 :           gcc_assert (info->subscript[dim]
    3733                 :             :                       && info->subscript[dim]->info->type == GFC_SS_SCALAR);
    3734                 :             :           /* We've already translated this value outside the loop.  */
    3735                 :        2805 :           index = info->subscript[dim]->info->data.scalar.value;
    3736                 :             : 
    3737                 :        5610 :           index = trans_array_bound_check (se, ss, index, dim, &ar->where,
    3738                 :        2805 :                                            ar->as->type != AS_ASSUMED_SIZE
    3739                 :        2805 :                                            || dim < ar->dimen - 1);
    3740                 :        2805 :           break;
    3741                 :             : 
    3742                 :         737 :         case DIMEN_VECTOR:
    3743                 :         737 :           gcc_assert (info && se->loop);
    3744                 :         737 :           gcc_assert (info->subscript[dim]
    3745                 :             :                       && info->subscript[dim]->info->type == GFC_SS_VECTOR);
    3746                 :         737 :           desc = info->subscript[dim]->info->data.array.descriptor;
    3747                 :             : 
    3748                 :             :           /* Get a zero-based index into the vector.  */
    3749                 :         737 :           index = fold_build2_loc (input_location, MINUS_EXPR,
    3750                 :             :                                    gfc_array_index_type,
    3751                 :             :                                    se->loop->loopvar[i], se->loop->from[i]);
    3752                 :             : 
    3753                 :             :           /* Multiply the index by the stride.  */
    3754                 :         737 :           index = fold_build2_loc (input_location, MULT_EXPR,
    3755                 :             :                                    gfc_array_index_type,
    3756                 :             :                                    index, gfc_conv_array_stride (desc, 0));
    3757                 :             : 
    3758                 :             :           /* Read the vector to get an index into info->descriptor.  */
    3759                 :         737 :           data = build_fold_indirect_ref_loc (input_location,
    3760                 :             :                                           gfc_conv_array_data (desc));
    3761                 :         737 :           index = gfc_build_array_ref (data, index, NULL);
    3762                 :         737 :           index = gfc_evaluate_now (index, &se->pre);
    3763                 :         737 :           index = fold_convert (gfc_array_index_type, index);
    3764                 :             : 
    3765                 :             :           /* Do any bounds checking on the final info->descriptor index.  */
    3766                 :        1474 :           index = trans_array_bound_check (se, ss, index, dim, &ar->where,
    3767                 :         737 :                                            ar->as->type != AS_ASSUMED_SIZE
    3768                 :         737 :                                            || dim < ar->dimen - 1);
    3769                 :         737 :           break;
    3770                 :             : 
    3771                 :      125218 :         case DIMEN_RANGE:
    3772                 :             :           /* Scalarized dimension.  */
    3773                 :      125218 :           gcc_assert (info && se->loop);
    3774                 :             : 
    3775                 :             :           /* Multiply the loop variable by the stride and delta.  */
    3776                 :      125218 :           index = se->loop->loopvar[i];
    3777                 :      125218 :           if (!integer_onep (info->stride[dim]))
    3778                 :        5330 :             index = fold_build2_loc (input_location, MULT_EXPR,
    3779                 :             :                                      gfc_array_index_type, index,
    3780                 :             :                                      info->stride[dim]);
    3781                 :      125218 :           if (!integer_zerop (info->delta[dim]))
    3782                 :       47537 :             index = fold_build2_loc (input_location, PLUS_EXPR,
    3783                 :             :                                      gfc_array_index_type, index,
    3784                 :             :                                      info->delta[dim]);
    3785                 :             :           break;
    3786                 :             : 
    3787                 :           0 :         default:
    3788                 :           0 :           gcc_unreachable ();
    3789                 :             :         }
    3790                 :             :     }
    3791                 :             :   else
    3792                 :             :     {
    3793                 :             :       /* Temporary array or derived type component.  */
    3794                 :       55890 :       gcc_assert (se->loop);
    3795                 :       55890 :       index = se->loop->loopvar[se->loop->order[i]];
    3796                 :             : 
    3797                 :             :       /* Pointer functions can have stride[0] different from unity.
    3798                 :             :          Use the stride returned by the function call and stored in
    3799                 :             :          the descriptor for the temporary.  */
    3800                 :       55890 :       if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
    3801                 :        6964 :           && se->ss->info->expr
    3802                 :        6964 :           && se->ss->info->expr->symtree
    3803                 :        6964 :           && se->ss->info->expr->symtree->n.sym->result
    3804                 :        6631 :           && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
    3805                 :         138 :         stride = gfc_conv_descriptor_stride_get (info->descriptor,
    3806                 :             :                                                  gfc_rank_cst[dim]);
    3807                 :             : 
    3808                 :       55890 :       if (info->delta[dim] && !integer_zerop (info->delta[dim]))
    3809                 :         708 :         index = fold_build2_loc (input_location, PLUS_EXPR,
    3810                 :             :                                  gfc_array_index_type, index, info->delta[dim]);
    3811                 :             :     }
    3812                 :             : 
    3813                 :             :   /* Multiply by the stride.  */
    3814                 :      184650 :   if (stride != NULL && !integer_onep (stride))
    3815                 :       47546 :     index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    3816                 :             :                              index, stride);
    3817                 :             : 
    3818                 :      184650 :   return index;
    3819                 :             : }
    3820                 :             : 
    3821                 :             : 
    3822                 :             : /* Build a scalarized array reference using the vptr 'size'.  */
    3823                 :             : 
    3824                 :             : static bool
    3825                 :      150742 : build_class_array_ref (gfc_se *se, tree base, tree index)
    3826                 :             : {
    3827                 :      150742 :   tree size;
    3828                 :      150742 :   tree decl = NULL_TREE;
    3829                 :      150742 :   tree tmp;
    3830                 :      150742 :   gfc_expr *expr = se->ss->info->expr;
    3831                 :      150742 :   gfc_expr *class_expr;
    3832                 :      150742 :   gfc_typespec *ts;
    3833                 :      150742 :   gfc_symbol *sym;
    3834                 :             : 
    3835                 :      150742 :   tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
    3836                 :             : 
    3837                 :       67620 :   if (tmp != NULL_TREE)
    3838                 :             :     decl = tmp;
    3839                 :             :   else
    3840                 :             :     {
    3841                 :             :       /* The base expression does not contain a class component, either
    3842                 :             :          because it is a temporary array or array descriptor.  Class
    3843                 :             :          array functions are correctly resolved above.  */
    3844                 :      147894 :       if (!expr
    3845                 :      147894 :           || (expr->ts.type != BT_CLASS
    3846                 :      137374 :               && !gfc_is_class_array_ref (expr, NULL)))
    3847                 :      147568 :         return false;
    3848                 :             : 
    3849                 :             :       /* Obtain the expression for the class entity or component that is
    3850                 :             :          followed by an array reference, which is not an element, so that
    3851                 :             :          the span of the array can be obtained.  */
    3852                 :         326 :       class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
    3853                 :             : 
    3854                 :         326 :       if (!ts)
    3855                 :             :         return false;
    3856                 :             : 
    3857                 :         301 :       sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
    3858                 :           0 :       if (sym && sym->attr.function
    3859                 :           0 :           && sym == sym->result
    3860                 :           0 :           && sym->backend_decl == current_function_decl)
    3861                 :             :         /* The temporary is the data field of the class data component
    3862                 :             :            of the current function.  */
    3863                 :           0 :         decl = gfc_get_fake_result_decl (sym, 0);
    3864                 :         301 :       else if (sym)
    3865                 :             :         {
    3866                 :           0 :           if (decl == NULL_TREE)
    3867                 :           0 :             decl = expr->symtree->n.sym->backend_decl;
    3868                 :             :           /* For class arrays the tree containing the class is stored in
    3869                 :             :              GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
    3870                 :             :              For all others it's sym's backend_decl directly.  */
    3871                 :           0 :           if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
    3872                 :           0 :             decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
    3873                 :             :         }
    3874                 :             :       else
    3875                 :         301 :         decl = gfc_get_class_from_gfc_expr (class_expr);
    3876                 :             : 
    3877                 :         301 :       if (POINTER_TYPE_P (TREE_TYPE (decl)))
    3878                 :           0 :         decl = build_fold_indirect_ref_loc (input_location, decl);
    3879                 :             : 
    3880                 :         301 :       if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
    3881                 :             :         return false;
    3882                 :             :     }
    3883                 :             : 
    3884                 :        3149 :   se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
    3885                 :             : 
    3886                 :        3149 :   size = gfc_class_vtab_size_get (decl);
    3887                 :             :   /* For unlimited polymorphic entities then _len component needs to be
    3888                 :             :      multiplied with the size.  */
    3889                 :        3149 :   size = gfc_resize_class_size_with_len (&se->pre, decl, size);
    3890                 :        3149 :   size = fold_convert (TREE_TYPE (index), size);
    3891                 :             : 
    3892                 :             :   /* Return the element in the se expression.  */
    3893                 :        3149 :   se->expr = gfc_build_spanned_array_ref (base, index, size);
    3894                 :        3149 :   return true;
    3895                 :             : }
    3896                 :             : 
    3897                 :             : 
    3898                 :             : /* Indicates that the tree EXPR is a reference to an array that can’t
    3899                 :             :    have any negative stride.  */
    3900                 :             : 
    3901                 :             : static bool
    3902                 :      261158 : non_negative_strides_array_p (tree expr)
    3903                 :             : {
    3904                 :      272932 :   if (expr == NULL_TREE)
    3905                 :             :     return false;
    3906                 :             : 
    3907                 :      272932 :   tree type = TREE_TYPE (expr);
    3908                 :      272932 :   if (POINTER_TYPE_P (type))
    3909                 :       61616 :     type = TREE_TYPE (type);
    3910                 :             : 
    3911                 :      272932 :   if (TYPE_LANG_SPECIFIC (type))
    3912                 :             :     {
    3913                 :      272932 :       gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
    3914                 :             : 
    3915                 :      272932 :       if (array_kind == GFC_ARRAY_ALLOCATABLE
    3916                 :      272932 :           || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
    3917                 :             :         return true;
    3918                 :             :     }
    3919                 :             : 
    3920                 :             :   /* An array with descriptor can have negative strides.
    3921                 :             :      We try to be conservative and return false by default here
    3922                 :             :      if we don’t recognize a contiguous array instead of
    3923                 :             :      returning false if we can identify a non-contiguous one.  */
    3924                 :      232381 :   if (!GFC_ARRAY_TYPE_P (type))
    3925                 :             :     return false;
    3926                 :             : 
    3927                 :             :   /* If the array was originally a dummy with a descriptor, strides can be
    3928                 :             :      negative.  */
    3929                 :      203213 :   if (DECL_P (expr)
    3930                 :      195280 :       && DECL_LANG_SPECIFIC (expr)
    3931                 :       44311 :       && GFC_DECL_SAVED_DESCRIPTOR (expr)
    3932                 :      215006 :       && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
    3933                 :       11774 :     return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
    3934                 :             : 
    3935                 :             :   return true;
    3936                 :             : }
    3937                 :             : 
    3938                 :             : 
    3939                 :             : /* Build a scalarized reference to an array.  */
    3940                 :             : 
    3941                 :             : static void
    3942                 :      150742 : gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
    3943                 :             :                                bool tmp_array = false)
    3944                 :             : {
    3945                 :      150742 :   gfc_array_info *info;
    3946                 :      150742 :   tree decl = NULL_TREE;
    3947                 :      150742 :   tree index;
    3948                 :      150742 :   tree base;
    3949                 :      150742 :   gfc_ss *ss;
    3950                 :      150742 :   gfc_expr *expr;
    3951                 :      150742 :   int n;
    3952                 :             : 
    3953                 :      150742 :   ss = se->ss;
    3954                 :      150742 :   expr = ss->info->expr;
    3955                 :      150742 :   info = &ss->info->data.array;
    3956                 :      150742 :   if (ar)
    3957                 :      103284 :     n = se->loop->order[0];
    3958                 :             :   else
    3959                 :             :     n = 0;
    3960                 :             : 
    3961                 :      150742 :   index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
    3962                 :             :   /* Add the offset for this dimension to the stored offset for all other
    3963                 :             :      dimensions.  */
    3964                 :      150742 :   if (info->offset && !integer_zerop (info->offset))
    3965                 :      109942 :     index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
    3966                 :             :                              index, info->offset);
    3967                 :             : 
    3968                 :      150742 :   base = build_fold_indirect_ref_loc (input_location, info->data);
    3969                 :             : 
    3970                 :             :   /* Use the vptr 'size' field to access the element of a class array.  */
    3971                 :      150742 :   if (build_class_array_ref (se, base, index))
    3972                 :        3149 :     return;
    3973                 :             : 
    3974                 :      147593 :   if (get_CFI_desc (NULL, expr, &decl, ar))
    3975                 :         442 :     decl = build_fold_indirect_ref_loc (input_location, decl);
    3976                 :             : 
    3977                 :             :   /* A pointer array component can be detected from its field decl. Fix
    3978                 :             :      the descriptor, mark the resulting variable decl and pass it to
    3979                 :             :      gfc_build_array_ref.  */
    3980                 :      147593 :   if (is_pointer_array (info->descriptor)
    3981                 :      147593 :       || (expr && expr->ts.deferred && info->descriptor
    3982                 :        2070 :           && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
    3983                 :             :     {
    3984                 :        7600 :       if (TREE_CODE (info->descriptor) == COMPONENT_REF)
    3985                 :        1238 :         decl = info->descriptor;
    3986                 :        6362 :       else if (INDIRECT_REF_P (info->descriptor))
    3987                 :        1368 :         decl = TREE_OPERAND (info->descriptor, 0);
    3988                 :             : 
    3989                 :        7600 :       if (decl == NULL_TREE)
    3990                 :        4994 :         decl = info->descriptor;
    3991                 :             :     }
    3992                 :             : 
    3993                 :      147593 :   bool non_negative_stride = tmp_array
    3994                 :      147593 :                              || non_negative_strides_array_p (info->descriptor);
    3995                 :      147593 :   se->expr = gfc_build_array_ref (base, index, decl,
    3996                 :             :                                   non_negative_stride);
    3997                 :             : }
    3998                 :             : 
    3999                 :             : 
    4000                 :             : /* Translate access of temporary array.  */
    4001                 :             : 
    4002                 :             : void
    4003                 :       47458 : gfc_conv_tmp_array_ref (gfc_se * se)
    4004                 :             : {
    4005                 :       47458 :   se->string_length = se->ss->info->string_length;
    4006                 :       47458 :   gfc_conv_scalarized_array_ref (se, NULL, true);
    4007                 :       47458 :   gfc_advance_se_ss_chain (se);
    4008                 :       47458 : }
    4009                 :             : 
    4010                 :             : /* Add T to the offset pair *OFFSET, *CST_OFFSET.  */
    4011                 :             : 
    4012                 :             : static void
    4013                 :      247307 : add_to_offset (tree *cst_offset, tree *offset, tree t)
    4014                 :             : {
    4015                 :      247307 :   if (TREE_CODE (t) == INTEGER_CST)
    4016                 :      124080 :     *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
    4017                 :             :   else
    4018                 :             :     {
    4019                 :      123227 :       if (!integer_zerop (*offset))
    4020                 :       45402 :         *offset = fold_build2_loc (input_location, PLUS_EXPR,
    4021                 :             :                                    gfc_array_index_type, *offset, t);
    4022                 :             :       else
    4023                 :       77825 :         *offset = t;
    4024                 :             :     }
    4025                 :      247307 : }
    4026                 :             : 
    4027                 :             : 
    4028                 :             : static tree
    4029                 :      160725 : build_array_ref (tree desc, tree offset, tree decl, tree vptr)
    4030                 :             : {
    4031                 :      160725 :   tree tmp;
    4032                 :      160725 :   tree type;
    4033                 :      160725 :   tree cdesc;
    4034                 :             : 
    4035                 :             :   /* For class arrays the class declaration is stored in the saved
    4036                 :             :      descriptor.  */
    4037                 :      160725 :   if (INDIRECT_REF_P (desc)
    4038                 :        6819 :       && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
    4039                 :      162878 :       && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
    4040                 :         739 :     cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
    4041                 :             :                                   TREE_OPERAND (desc, 0)));
    4042                 :             :   else
    4043                 :             :     cdesc = desc;
    4044                 :             : 
    4045                 :             :   /* Class container types do not always have the GFC_CLASS_TYPE_P
    4046                 :             :      but the canonical type does.  */
    4047                 :      160725 :   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
    4048                 :      160725 :       && TREE_CODE (cdesc) == COMPONENT_REF)
    4049                 :             :     {
    4050                 :        8018 :       type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
    4051                 :        8018 :       if (TYPE_CANONICAL (type)
    4052                 :        8018 :           && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
    4053                 :        2994 :         vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
    4054                 :             :     }
    4055                 :             : 
    4056                 :      160725 :   tmp = gfc_conv_array_data (desc);
    4057                 :      160725 :   tmp = build_fold_indirect_ref_loc (input_location, tmp);
    4058                 :      160725 :   tmp = gfc_build_array_ref (tmp, offset, decl,
    4059                 :      160725 :                              non_negative_strides_array_p (desc),
    4060                 :             :                              vptr);
    4061                 :      160725 :   return tmp;
    4062                 :             : }
    4063                 :             : 
    4064                 :             : 
    4065                 :             : /* Build an array reference.  se->expr already holds the array descriptor.
    4066                 :             :    This should be either a variable, indirect variable reference or component
    4067                 :             :    reference.  For arrays which do not have a descriptor, se->expr will be
    4068                 :             :    the data pointer.
    4069                 :             :    a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
    4070                 :             : 
    4071                 :             : void
    4072                 :      217808 : gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
    4073                 :             :                     locus * where)
    4074                 :             : {
    4075                 :      217808 :   int n;
    4076                 :      217808 :   tree offset, cst_offset;
    4077                 :      217808 :   tree tmp;
    4078                 :      217808 :   tree stride;
    4079                 :      217808 :   tree decl = NULL_TREE;
    4080                 :      217808 :   gfc_se indexse;
    4081                 :      217808 :   gfc_se tmpse;
    4082                 :      217808 :   gfc_symbol * sym = expr->symtree->n.sym;
    4083                 :      217808 :   char *var_name = NULL;
    4084                 :             : 
    4085                 :      217808 :   if (ar->dimen == 0)
    4086                 :             :     {
    4087                 :        4112 :       gcc_assert (ar->codimen || sym->attr.select_rank_temporary
    4088                 :             :                   || (ar->as && ar->as->corank));
    4089                 :             : 
    4090                 :        4112 :       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
    4091                 :         908 :         se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
    4092                 :             :       else
    4093                 :             :         {
    4094                 :        3204 :           if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
    4095                 :        3204 :               && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
    4096                 :        2394 :             se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
    4097                 :             : 
    4098                 :             :           /* Use the actual tree type and not the wrapped coarray.  */
    4099                 :        3204 :           if (!se->want_pointer)
    4100                 :        2416 :             se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
    4101                 :             :                                      se->expr);
    4102                 :             :         }
    4103                 :             : 
    4104                 :      107396 :       return;
    4105                 :             :     }
    4106                 :             : 
    4107                 :             :   /* Handle scalarized references separately.  */
    4108                 :      213696 :   if (ar->type != AR_ELEMENT)
    4109                 :             :     {
    4110                 :      103284 :       gfc_conv_scalarized_array_ref (se, ar);
    4111                 :      103284 :       gfc_advance_se_ss_chain (se);
    4112                 :      103284 :       return;
    4113                 :             :     }
    4114                 :             : 
    4115                 :      110412 :   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    4116                 :       11409 :     var_name = abridged_ref_name (expr, ar);
    4117                 :             : 
    4118                 :      110412 :   decl = se->expr;
    4119                 :      110412 :   if (UNLIMITED_POLY(sym)
    4120                 :          98 :       && IS_CLASS_ARRAY (sym)
    4121                 :          97 :       && sym->attr.dummy
    4122                 :          54 :       && ar->as->type != AS_DEFERRED)
    4123                 :          42 :     decl = sym->backend_decl;
    4124                 :             : 
    4125                 :      110412 :   cst_offset = offset = gfc_index_zero_node;
    4126                 :      110412 :   add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
    4127                 :             : 
    4128                 :             :   /* Calculate the offsets from all the dimensions.  Make sure to associate
    4129                 :             :      the final offset so that we form a chain of loop invariant summands.  */
    4130                 :      247307 :   for (n = ar->dimen - 1; n >= 0; n--)
    4131                 :             :     {
    4132                 :             :       /* Calculate the index for this dimension.  */
    4133                 :      136895 :       gfc_init_se (&indexse, se);
    4134                 :      136895 :       gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
    4135                 :      136895 :       gfc_add_block_to_block (&se->pre, &indexse.pre);
    4136                 :             : 
    4137                 :      136895 :       if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
    4138                 :             :         {
    4139                 :             :           /* Check array bounds.  */
    4140                 :       14911 :           tree cond;
    4141                 :       14911 :           char *msg;
    4142                 :             : 
    4143                 :             :           /* Evaluate the indexse.expr only once.  */
    4144                 :       14911 :           indexse.expr = save_expr (indexse.expr);
    4145                 :             : 
    4146                 :             :           /* Lower bound.  */
    4147                 :       14911 :           tmp = gfc_conv_array_lbound (decl, n);
    4148                 :       14911 :           if (sym->attr.temporary)
    4149                 :             :             {
    4150                 :          18 :               gfc_init_se (&tmpse, se);
    4151                 :          18 :               gfc_conv_expr_type (&tmpse, ar->as->lower[n],
    4152                 :             :                                   gfc_array_index_type);
    4153                 :          18 :               gfc_add_block_to_block (&se->pre, &tmpse.pre);
    4154                 :          18 :               tmp = tmpse.expr;
    4155                 :             :             }
    4156                 :             : 
    4157                 :       14911 :           cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    4158                 :             :                                   indexse.expr, tmp);
    4159                 :       14911 :           msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
    4160                 :             :                            "below lower bound of %%ld", n+1, var_name);
    4161                 :       14911 :           gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
    4162                 :             :                                    fold_convert (long_integer_type_node,
    4163                 :             :                                                  indexse.expr),
    4164                 :             :                                    fold_convert (long_integer_type_node, tmp));
    4165                 :       14911 :           free (msg);
    4166                 :             : 
    4167                 :             :           /* Upper bound, but not for the last dimension of assumed-size
    4168                 :             :              arrays.  */
    4169                 :       14911 :           if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
    4170                 :             :             {
    4171                 :       13178 :               tmp = gfc_conv_array_ubound (decl, n);
    4172                 :       13178 :               if (sym->attr.temporary)
    4173                 :             :                 {
    4174                 :          18 :                   gfc_init_se (&tmpse, se);
    4175                 :          18 :                   gfc_conv_expr_type (&tmpse, ar->as->upper[n],
    4176                 :             :                                       gfc_array_index_type);
    4177                 :          18 :                   gfc_add_block_to_block (&se->pre, &tmpse.pre);
    4178                 :          18 :                   tmp = tmpse.expr;
    4179                 :             :                 }
    4180                 :             : 
    4181                 :       13178 :               cond = fold_build2_loc (input_location, GT_EXPR,
    4182                 :             :                                       logical_type_node, indexse.expr, tmp);
    4183                 :       13178 :               msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
    4184                 :             :                                "above upper bound of %%ld", n+1, var_name);
    4185                 :       13178 :               gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
    4186                 :             :                                    fold_convert (long_integer_type_node,
    4187                 :             :                                                  indexse.expr),
    4188                 :             :                                    fold_convert (long_integer_type_node, tmp));
    4189                 :       13178 :               free (msg);
    4190                 :             :             }
    4191                 :             :         }
    4192                 :             : 
    4193                 :             :       /* Multiply the index by the stride.  */
    4194                 :      136895 :       stride = gfc_conv_array_stride (decl, n);
    4195                 :      136895 :       tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    4196                 :             :                              indexse.expr, stride);
    4197                 :             : 
    4198                 :             :       /* And add it to the total.  */
    4199                 :      136895 :       add_to_offset (&cst_offset, &offset, tmp);
    4200                 :             :     }
    4201                 :             : 
    4202                 :      110412 :   if (!integer_zerop (cst_offset))
    4203                 :       59255 :     offset = fold_build2_loc (input_location, PLUS_EXPR,
    4204                 :             :                               gfc_array_index_type, offset, cst_offset);
    4205                 :             : 
    4206                 :             :   /* A pointer array component can be detected from its field decl. Fix
    4207                 :             :      the descriptor, mark the resulting variable decl and pass it to
    4208                 :             :      build_array_ref.  */
    4209                 :      110412 :   decl = NULL_TREE;
    4210                 :      110412 :   if (get_CFI_desc (sym, expr, &decl, ar))
    4211                 :        3589 :     decl = build_fold_indirect_ref_loc (input_location, decl);
    4212                 :      109716 :   if (!expr->ts.deferred && !sym->attr.codimension
    4213                 :      218291 :       && is_pointer_array (se->expr))
    4214                 :             :     {
    4215                 :        3744 :       if (TREE_CODE (se->expr) == COMPONENT_REF)
    4216                 :        1102 :         decl = se->expr;
    4217                 :        2642 :       else if (INDIRECT_REF_P (se->expr))
    4218                 :         701 :         decl = TREE_OPERAND (se->expr, 0);
    4219                 :             :       else
    4220                 :        1941 :         decl = se->expr;
    4221                 :             :     }
    4222                 :      106668 :   else if (expr->ts.deferred
    4223                 :      105972 :            || (sym->ts.type == BT_CHARACTER
    4224                 :       14273 :                && sym->attr.select_type_temporary))
    4225                 :             :     {
    4226                 :        2364 :       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
    4227                 :             :         {
    4228                 :        2328 :           decl = se->expr;
    4229                 :        2328 :           if (INDIRECT_REF_P (decl))
    4230                 :          20 :             decl = TREE_OPERAND (decl, 0);
    4231                 :             :         }
    4232                 :             :       else
    4233                 :          36 :         decl = sym->backend_decl;
    4234                 :             :     }
    4235                 :      104304 :   else if (sym->ts.type == BT_CLASS)
    4236                 :             :     {
    4237                 :        2057 :       if (UNLIMITED_POLY (sym))
    4238                 :             :         {
    4239                 :          98 :           gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
    4240                 :          98 :           gfc_init_se (&tmpse, NULL);
    4241                 :          98 :           gfc_conv_expr (&tmpse, class_expr);
    4242                 :          98 :           if (!se->class_vptr)
    4243                 :          98 :             se->class_vptr = gfc_class_vptr_get (tmpse.expr);
    4244                 :          98 :           gfc_free_expr (class_expr);
    4245                 :          98 :           decl = tmpse.expr;
    4246                 :          98 :         }
    4247                 :             :       else
    4248                 :        1959 :         decl = NULL_TREE;
    4249                 :             :     }
    4250                 :             : 
    4251                 :      110412 :   free (var_name);
    4252                 :      110412 :   se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
    4253                 :             : }
    4254                 :             : 
    4255                 :             : 
    4256                 :             : /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
    4257                 :             :    LOOP_DIM dimension (if any) to array's offset.  */
    4258                 :             : 
    4259                 :             : static void
    4260                 :       33908 : add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
    4261                 :             :                   gfc_array_ref *ar, int array_dim, int loop_dim)
    4262                 :             : {
    4263                 :       33908 :   gfc_se se;
    4264                 :       33908 :   gfc_array_info *info;
    4265                 :       33908 :   tree stride, index;
    4266                 :             : 
    4267                 :       33908 :   info = &ss->info->data.array;
    4268                 :             : 
    4269                 :       33908 :   gfc_init_se (&se, NULL);
    4270                 :       33908 :   se.loop = loop;
    4271                 :       33908 :   se.expr = info->descriptor;
    4272                 :       33908 :   stride = gfc_conv_array_stride (info->descriptor, array_dim);
    4273                 :       33908 :   index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
    4274                 :       33908 :   gfc_add_block_to_block (pblock, &se.pre);
    4275                 :             : 
    4276                 :       33908 :   info->offset = fold_build2_loc (input_location, PLUS_EXPR,
    4277                 :             :                                   gfc_array_index_type,
    4278                 :             :                                   info->offset, index);
    4279                 :       33908 :   info->offset = gfc_evaluate_now (info->offset, pblock);
    4280                 :       33908 : }
    4281                 :             : 
    4282                 :             : 
    4283                 :             : /* Generate the code to be executed immediately before entering a
    4284                 :             :    scalarization loop.  */
    4285                 :             : 
    4286                 :             : static void
    4287                 :      109402 : gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
    4288                 :             :                          stmtblock_t * pblock)
    4289                 :             : {
    4290                 :      109402 :   tree stride;
    4291                 :      109402 :   gfc_ss_info *ss_info;
    4292                 :      109402 :   gfc_array_info *info;
    4293                 :      109402 :   gfc_ss_type ss_type;
    4294                 :      109402 :   gfc_ss *ss, *pss;
    4295                 :      109402 :   gfc_loopinfo *ploop;
    4296                 :      109402 :   gfc_array_ref *ar;
    4297                 :      109402 :   int i;
    4298                 :             : 
    4299                 :             :   /* This code will be executed before entering the scalarization loop
    4300                 :             :      for this dimension.  */
    4301                 :      330510 :   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    4302                 :             :     {
    4303                 :      221108 :       ss_info = ss->info;
    4304                 :             : 
    4305                 :      221108 :       if ((ss_info->useflags & flag) == 0)
    4306                 :        1284 :         continue;
    4307                 :             : 
    4308                 :      219824 :       ss_type = ss_info->type;
    4309                 :      264264 :       if (ss_type != GFC_SS_SECTION
    4310                 :             :           && ss_type != GFC_SS_FUNCTION
    4311                 :      219824 :           && ss_type != GFC_SS_CONSTRUCTOR
    4312                 :      219824 :           && ss_type != GFC_SS_COMPONENT)
    4313                 :       44440 :         continue;
    4314                 :             : 
    4315                 :      175384 :       info = &ss_info->data.array;
    4316                 :             : 
    4317                 :      175384 :       gcc_assert (dim < ss->dimen);
    4318                 :      175384 :       gcc_assert (ss->dimen == loop->dimen);
    4319                 :             : 
    4320                 :      175384 :       if (info->ref)
    4321                 :      120542 :         ar = &info->ref->u.ar;
    4322                 :             :       else
    4323                 :             :         ar = NULL;
    4324                 :             : 
    4325                 :      175384 :       if (dim == loop->dimen - 1 && loop->parent != NULL)
    4326                 :             :         {
    4327                 :             :           /* If we are in the outermost dimension of this loop, the previous
    4328                 :             :              dimension shall be in the parent loop.  */
    4329                 :         688 :           gcc_assert (ss->parent != NULL);
    4330                 :             : 
    4331                 :         688 :           pss = ss->parent;
    4332                 :         688 :           ploop = loop->parent;
    4333                 :             : 
    4334                 :             :           /* ss and ss->parent are about the same array.  */
    4335                 :         688 :           gcc_assert (ss_info == pss->info);
    4336                 :             :         }
    4337                 :             :       else
    4338                 :             :         {
    4339                 :             :           ploop = loop;
    4340                 :             :           pss = ss;
    4341                 :             :         }
    4342                 :             : 
    4343                 :      175384 :       if (dim == loop->dimen - 1)
    4344                 :             :         i = 0;
    4345                 :             :       else
    4346                 :       30415 :         i = dim + 1;
    4347                 :             : 
    4348                 :             :       /* For the time being, there is no loop reordering.  */
    4349                 :      175384 :       gcc_assert (i == ploop->order[i]);
    4350                 :      175384 :       i = ploop->order[i];
    4351                 :             : 
    4352                 :      175384 :       if (dim == loop->dimen - 1 && loop->parent == NULL)
    4353                 :             :         {
    4354                 :      288562 :           stride = gfc_conv_array_stride (info->descriptor,
    4355                 :      144281 :                                           innermost_ss (ss)->dim[i]);
    4356                 :             : 
    4357                 :             :           /* Calculate the stride of the innermost loop.  Hopefully this will
    4358                 :             :              allow the backend optimizers to do their stuff more effectively.
    4359                 :             :            */
    4360                 :      144281 :           info->stride0 = gfc_evaluate_now (stride, pblock);
    4361                 :             : 
    4362                 :             :           /* For the outermost loop calculate the offset due to any
    4363                 :             :              elemental dimensions.  It will have been initialized with the
    4364                 :             :              base offset of the array.  */
    4365                 :      144281 :           if (info->ref)
    4366                 :             :             {
    4367                 :      221090 :               for (i = 0; i < ar->dimen; i++)
    4368                 :             :                 {
    4369                 :      123219 :                   if (ar->dimen_type[i] != DIMEN_ELEMENT)
    4370                 :      120414 :                     continue;
    4371                 :             : 
    4372                 :        2805 :                   add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
    4373                 :             :                 }
    4374                 :             :             }
    4375                 :             :         }
    4376                 :             :       else
    4377                 :             :         /* Add the offset for the previous loop dimension.  */
    4378                 :       31103 :         add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
    4379                 :             : 
    4380                 :             :       /* Remember this offset for the second loop.  */
    4381                 :      175384 :       if (dim == loop->temp_dim - 1 && loop->parent == NULL)
    4382                 :       46559 :         info->saved_offset = info->offset;
    4383                 :             :     }
    4384                 :      109402 : }
    4385                 :             : 
    4386                 :             : 
    4387                 :             : /* Start a scalarized expression.  Creates a scope and declares loop
    4388                 :             :    variables.  */
    4389                 :             : 
    4390                 :             : void
    4391                 :       90399 : gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
    4392                 :             : {
    4393                 :       90399 :   int dim;
    4394                 :       90399 :   int n;
    4395                 :       90399 :   int flags;
    4396                 :             : 
    4397                 :       90399 :   gcc_assert (!loop->array_parameter);
    4398                 :             : 
    4399                 :      199683 :   for (dim = loop->dimen - 1; dim >= 0; dim--)
    4400                 :             :     {
    4401                 :      109284 :       n = loop->order[dim];
    4402                 :             : 
    4403                 :      109284 :       gfc_start_block (&loop->code[n]);
    4404                 :             : 
    4405                 :             :       /* Create the loop variable.  */
    4406                 :      109284 :       loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
    4407                 :             : 
    4408                 :      109284 :       if (dim < loop->temp_dim)
    4409                 :             :         flags = 3;
    4410                 :             :       else
    4411                 :       76786 :         flags = 1;
    4412                 :             :       /* Calculate values that will be constant within this loop.  */
    4413                 :      109284 :       gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
    4414                 :             :     }
    4415                 :       90399 :   gfc_start_block (pbody);
    4416                 :       90399 : }
    4417                 :             : 
    4418                 :             : 
    4419                 :             : /* Generates the actual loop code for a scalarization loop.  */
    4420                 :             : 
    4421                 :             : static void
    4422                 :      117583 : gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
    4423                 :             :                                stmtblock_t * pbody)
    4424                 :             : {
    4425                 :      117583 :   stmtblock_t block;
    4426                 :      117583 :   tree cond;
    4427                 :      117583 :   tree tmp;
    4428                 :      117583 :   tree loopbody;
    4429                 :      117583 :   tree exit_label;
    4430                 :      117583 :   tree stmt;
    4431                 :      117583 :   tree init;
    4432                 :      117583 :   tree incr;
    4433                 :             : 
    4434                 :      117583 :   if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
    4435                 :             :                       | OMPWS_SCALARIZER_BODY))
    4436                 :             :       == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
    4437                 :         108 :       && n == loop->dimen - 1)
    4438                 :             :     {
    4439                 :             :       /* We create an OMP_FOR construct for the outermost scalarized loop.  */
    4440                 :          80 :       init = make_tree_vec (1);
    4441                 :          80 :       cond = make_tree_vec (1);
    4442                 :          80 :       incr = make_tree_vec (1);
    4443                 :             : 
    4444                 :             :       /* Cycle statement is implemented with a goto.  Exit statement must not
    4445                 :             :          be present for this loop.  */
    4446                 :          80 :       exit_label = gfc_build_label_decl (NULL_TREE);
    4447                 :          80 :       TREE_USED (exit_label) = 1;
    4448                 :             : 
    4449                 :             :       /* Label for cycle statements (if needed).  */
    4450                 :          80 :       tmp = build1_v (LABEL_EXPR, exit_label);
    4451                 :          80 :       gfc_add_expr_to_block (pbody, tmp);
    4452                 :             : 
    4453                 :          80 :       stmt = make_node (OMP_FOR);
    4454                 :             : 
    4455                 :          80 :       TREE_TYPE (stmt) = void_type_node;
    4456                 :          80 :       OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
    4457                 :             : 
    4458                 :          80 :       OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
    4459                 :             :                                                  OMP_CLAUSE_SCHEDULE);
    4460                 :          80 :       OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
    4461                 :          80 :         = OMP_CLAUSE_SCHEDULE_STATIC;
    4462                 :          80 :       if (ompws_flags & OMPWS_NOWAIT)
    4463                 :          33 :         OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
    4464                 :          66 :           = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
    4465                 :             : 
    4466                 :             :       /* Initialize the loopvar.  */
    4467                 :          80 :       TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
    4468                 :             :                                          loop->from[n]);
    4469                 :          80 :       OMP_FOR_INIT (stmt) = init;
    4470                 :             :       /* The exit condition.  */
    4471                 :          80 :       TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
    4472                 :             :                                            logical_type_node,
    4473                 :             :                                            loop->loopvar[n], loop->to[n]);
    4474                 :          80 :       SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
    4475                 :          80 :       OMP_FOR_COND (stmt) = cond;
    4476                 :             :       /* Increment the loopvar.  */
    4477                 :          80 :       tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
    4478                 :             :                         loop->loopvar[n], gfc_index_one_node);
    4479                 :          80 :       TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
    4480                 :             :           void_type_node, loop->loopvar[n], tmp);
    4481                 :          80 :       OMP_FOR_INCR (stmt) = incr;
    4482                 :             : 
    4483                 :          80 :       ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
    4484                 :          80 :       gfc_add_expr_to_block (&loop->code[n], stmt);
    4485                 :             :     }
    4486                 :             :   else
    4487                 :             :     {
    4488                 :      235006 :       bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
    4489                 :      117503 :                              && (loop->temp_ss == NULL);
    4490                 :             : 
    4491                 :      117503 :       loopbody = gfc_finish_block (pbody);
    4492                 :             : 
    4493                 :      117503 :       if (reverse_loop)
    4494                 :         178 :         std::swap (loop->from[n], loop->to[n]);
    4495                 :             : 
    4496                 :             :       /* Initialize the loopvar.  */
    4497                 :      117503 :       if (loop->loopvar[n] != loop->from[n])
    4498                 :      114064 :         gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
    4499                 :             : 
    4500                 :      117503 :       exit_label = gfc_build_label_decl (NULL_TREE);
    4501                 :             : 
    4502                 :             :       /* Generate the loop body.  */
    4503                 :      117503 :       gfc_init_block (&block);
    4504                 :             : 
    4505                 :             :       /* The exit condition.  */
    4506                 :      234828 :       cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
    4507                 :             :                           logical_type_node, loop->loopvar[n], loop->to[n]);
    4508                 :      117503 :       tmp = build1_v (GOTO_EXPR, exit_label);
    4509                 :      117503 :       TREE_USED (exit_label) = 1;
    4510                 :      117503 :       tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
    4511                 :      117503 :       gfc_add_expr_to_block (&block, tmp);
    4512                 :             : 
    4513                 :             :       /* The main body.  */
    4514                 :      117503 :       gfc_add_expr_to_block (&block, loopbody);
    4515                 :             : 
    4516                 :             :       /* Increment the loopvar.  */
    4517                 :      234828 :       tmp = fold_build2_loc (input_location,
    4518                 :             :                              reverse_loop ? MINUS_EXPR : PLUS_EXPR,
    4519                 :             :                              gfc_array_index_type, loop->loopvar[n],
    4520                 :             :                              gfc_index_one_node);
    4521                 :             : 
    4522                 :      117503 :       gfc_add_modify (&block, loop->loopvar[n], tmp);
    4523                 :             : 
    4524                 :             :       /* Build the loop.  */
    4525                 :      117503 :       tmp = gfc_finish_block (&block);
    4526                 :      117503 :       tmp = build1_v (LOOP_EXPR, tmp);
    4527                 :      117503 :       gfc_add_expr_to_block (&loop->code[n], tmp);
    4528                 :             : 
    4529                 :             :       /* Add the exit label.  */
    4530                 :      117503 :       tmp = build1_v (LABEL_EXPR, exit_label);
    4531                 :      117503 :       gfc_add_expr_to_block (&loop->code[n], tmp);
    4532                 :             :     }
    4533                 :             : 
    4534                 :      117583 : }
    4535                 :             : 
    4536                 :             : 
    4537                 :             : /* Finishes and generates the loops for a scalarized expression.  */
    4538                 :             : 
    4539                 :             : void
    4540                 :       94263 : gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
    4541                 :             : {
    4542                 :       94263 :   int dim;
    4543                 :       94263 :   int n;
    4544                 :       94263 :   gfc_ss *ss;
    4545                 :       94263 :   stmtblock_t *pblock;
    4546                 :       94263 :   tree tmp;
    4547                 :             : 
    4548                 :       94263 :   pblock = body;
    4549                 :             :   /* Generate the loops.  */
    4550                 :      207397 :   for (dim = 0; dim < loop->dimen; dim++)
    4551                 :             :     {
    4552                 :      113134 :       n = loop->order[dim];
    4553                 :      113134 :       gfc_trans_scalarized_loop_end (loop, n, pblock);
    4554                 :      113134 :       loop->loopvar[n] = NULL_TREE;
    4555                 :      113134 :       pblock = &loop->code[n];
    4556                 :             :     }
    4557                 :             : 
    4558                 :       94263 :   tmp = gfc_finish_block (pblock);
    4559                 :       94263 :   gfc_add_expr_to_block (&loop->pre, tmp);
    4560                 :             : 
    4561                 :             :   /* Clear all the used flags.  */
    4562                 :      277117 :   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    4563                 :      182854 :     if (ss->parent == NULL)
    4564                 :      182107 :       ss->info->useflags = 0;
    4565                 :       94263 : }
    4566                 :             : 
    4567                 :             : 
    4568                 :             : /* Finish the main body of a scalarized expression, and start the secondary
    4569                 :             :    copying body.  */
    4570                 :             : 
    4571                 :             : void
    4572                 :        4331 : gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
    4573                 :             : {
    4574                 :        4331 :   int dim;
    4575                 :        4331 :   int n;
    4576                 :        4331 :   stmtblock_t *pblock;
    4577                 :        4331 :   gfc_ss *ss;
    4578                 :             : 
    4579                 :        4331 :   pblock = body;
    4580                 :             :   /* We finish as many loops as are used by the temporary.  */
    4581                 :        4449 :   for (dim = 0; dim < loop->temp_dim - 1; dim++)
    4582                 :             :     {
    4583                 :         118 :       n = loop->order[dim];
    4584                 :         118 :       gfc_trans_scalarized_loop_end (loop, n, pblock);
    4585                 :         118 :       loop->loopvar[n] = NULL_TREE;
    4586                 :         118 :       pblock = &loop->code[n];
    4587                 :             :     }
    4588                 :             : 
    4589                 :             :   /* We don't want to finish the outermost loop entirely.  */
    4590                 :        4331 :   n = loop->order[loop->temp_dim - 1];
    4591                 :        4331 :   gfc_trans_scalarized_loop_end (loop, n, pblock);
    4592                 :             : 
    4593                 :             :   /* Restore the initial offsets.  */
    4594                 :       12815 :   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    4595                 :             :     {
    4596                 :        8484 :       gfc_ss_type ss_type;
    4597                 :        8484 :       gfc_ss_info *ss_info;
    4598                 :             : 
    4599                 :        8484 :       ss_info = ss->info;
    4600                 :             : 
    4601                 :        8484 :       if ((ss_info->useflags & 2) == 0)
    4602                 :        1095 :         continue;
    4603                 :             : 
    4604                 :        7389 :       ss_type = ss_info->type;
    4605                 :        7429 :       if (ss_type != GFC_SS_SECTION
    4606                 :             :           && ss_type != GFC_SS_FUNCTION
    4607                 :        7389 :           && ss_type != GFC_SS_CONSTRUCTOR
    4608                 :        7389 :           && ss_type != GFC_SS_COMPONENT)
    4609                 :          40 :         continue;
    4610                 :             : 
    4611                 :        7349 :       ss_info->data.array.offset = ss_info->data.array.saved_offset;
    4612                 :             :     }
    4613                 :             : 
    4614                 :             :   /* Restart all the inner loops we just finished.  */
    4615                 :        4449 :   for (dim = loop->temp_dim - 2; dim >= 0; dim--)
    4616                 :             :     {
    4617                 :         118 :       n = loop->order[dim];
    4618                 :             : 
    4619                 :         118 :       gfc_start_block (&loop->code[n]);
    4620                 :             : 
    4621                 :         118 :       loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
    4622                 :             : 
    4623                 :         118 :       gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
    4624                 :             :     }
    4625                 :             : 
    4626                 :             :   /* Start a block for the secondary copying code.  */
    4627                 :        4331 :   gfc_start_block (body);
    4628                 :        4331 : }
    4629                 :             : 
    4630                 :             : 
    4631                 :             : /* Precalculate (either lower or upper) bound of an array section.
    4632                 :             :      BLOCK: Block in which the (pre)calculation code will go.
    4633                 :             :      BOUNDS[DIM]: Where the bound value will be stored once evaluated.
    4634                 :             :      VALUES[DIM]: Specified bound (NULL <=> unspecified).
    4635                 :             :      DESC: Array descriptor from which the bound will be picked if unspecified
    4636                 :             :        (either lower or upper bound according to LBOUND).  */
    4637                 :             : 
    4638                 :             : static void
    4639                 :      400626 : evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
    4640                 :             :                 tree desc, int dim, bool lbound, bool deferred)
    4641                 :             : {
    4642                 :      400626 :   gfc_se se;
    4643                 :      400626 :   gfc_expr * input_val = values[dim];
    4644                 :      400626 :   tree *output = &bounds[dim];
    4645                 :             : 
    4646                 :             : 
    4647                 :      400626 :   if (input_val)
    4648                 :             :     {
    4649                 :             :       /* Specified section bound.  */
    4650                 :       44830 :       gfc_init_se (&se, NULL);
    4651                 :       44830 :       gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
    4652                 :       44830 :       gfc_add_block_to_block (block, &se.pre);
    4653                 :       44830 :       *output = se.expr;
    4654                 :             :     }
    4655                 :      355796 :   else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
    4656                 :             :     {
    4657                 :             :       /* The gfc_conv_array_lbound () routine returns a constant zero for
    4658                 :             :          deferred length arrays, which in the scalarizer wreaks havoc, when
    4659                 :             :          copying to a (newly allocated) one-based array.
    4660                 :             :          Keep returning the actual result in sync for both bounds.  */
    4661                 :      112831 :       *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
    4662                 :             :                                                          gfc_rank_cst[dim]):
    4663                 :       37677 :                          gfc_conv_descriptor_ubound_get (desc,
    4664                 :             :                                                          gfc_rank_cst[dim]);
    4665                 :             :     }
    4666                 :             :   else
    4667                 :             :     {
    4668                 :             :       /* No specific bound specified so use the bound of the array.  */
    4669                 :      417496 :       *output = lbound ? gfc_conv_array_lbound (desc, dim) :
    4670                 :      136854 :                          gfc_conv_array_ubound (desc, dim);
    4671                 :             :     }
    4672                 :      400626 :   *output = gfc_evaluate_now (*output, block);
    4673                 :      400626 : }
    4674                 :             : 
    4675                 :             : 
    4676                 :             : /* Calculate the lower bound of an array section.  */
    4677                 :             : 
    4678                 :             : static void
    4679                 :      200859 : gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
    4680                 :             : {
    4681                 :      200859 :   gfc_expr *stride = NULL;
    4682                 :      200859 :   tree desc;
    4683                 :      200859 :   gfc_se se;
    4684                 :      200859 :   gfc_array_info *info;
    4685                 :      200859 :   gfc_array_ref *ar;
    4686                 :             : 
    4687                 :      200859 :   gcc_assert (ss->info->type == GFC_SS_SECTION);
    4688                 :             : 
    4689                 :      200859 :   info = &ss->info->data.array;
    4690                 :      200859 :   ar = &info->ref->u.ar;
    4691                 :             : 
    4692                 :      200859 :   if (ar->dimen_type[dim] == DIMEN_VECTOR)
    4693                 :             :     {
    4694                 :             :       /* We use a zero-based index to access the vector.  */
    4695                 :         744 :       info->start[dim] = gfc_index_zero_node;
    4696                 :         744 :       info->end[dim] = NULL;
    4697                 :         744 :       info->stride[dim] = gfc_index_one_node;
    4698                 :         744 :       return;
    4699                 :             :     }
    4700                 :             : 
    4701                 :      200115 :   gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
    4702                 :             :               || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
    4703                 :      200115 :   desc = info->descriptor;
    4704                 :      200115 :   stride = ar->stride[dim];
    4705                 :             : 
    4706                 :             : 
    4707                 :             :   /* Calculate the start of the range.  For vector subscripts this will
    4708                 :             :      be the range of the vector.  */
    4709                 :      200115 :   evaluate_bound (block, info->start, ar->start, desc, dim, true,
    4710                 :      200115 :                   ar->as->type == AS_DEFERRED);
    4711                 :             : 
    4712                 :             :   /* Similarly calculate the end.  Although this is not used in the
    4713                 :             :      scalarizer, it is needed when checking bounds and where the end
    4714                 :             :      is an expression with side-effects.  */
    4715                 :      200115 :   evaluate_bound (block, info->end, ar->end, desc, dim, false,
    4716                 :      200115 :                   ar->as->type == AS_DEFERRED);
    4717                 :             : 
    4718                 :             : 
    4719                 :             :   /* Calculate the stride.  */
    4720                 :      200115 :   if (stride == NULL)
    4721                 :      188646 :     info->stride[dim] = gfc_index_one_node;
    4722                 :             :   else
    4723                 :             :     {
    4724                 :       11469 :       gfc_init_se (&se, NULL);
    4725                 :       11469 :       gfc_conv_expr_type (&se, stride, gfc_array_index_type);
    4726                 :       11469 :       gfc_add_block_to_block (block, &se.pre);
    4727                 :       11469 :       info->stride[dim] = gfc_evaluate_now (se.expr, block);
    4728                 :             :     }
    4729                 :             : }
    4730                 :             : 
    4731                 :             : 
    4732                 :             : /* Calculates the range start and stride for a SS chain.  Also gets the
    4733                 :             :    descriptor and data pointer.  The range of vector subscripts is the size
    4734                 :             :    of the vector.  Array bounds are also checked.  */
    4735                 :             : 
    4736                 :             : void
    4737                 :      148302 : gfc_conv_ss_startstride (gfc_loopinfo * loop)
    4738                 :             : {
    4739                 :      148302 :   int n;
    4740                 :      148302 :   tree tmp;
    4741                 :      148302 :   gfc_ss *ss;
    4742                 :      148302 :   tree desc;
    4743                 :             : 
    4744                 :      148302 :   gfc_loopinfo * const outer_loop = outermost_loop (loop);
    4745                 :             : 
    4746                 :      148302 :   loop->dimen = 0;
    4747                 :             :   /* Determine the rank of the loop.  */
    4748                 :      165154 :   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    4749                 :             :     {
    4750                 :      165154 :       switch (ss->info->type)
    4751                 :             :         {
    4752                 :      143382 :         case GFC_SS_SECTION:
    4753                 :      143382 :         case GFC_SS_CONSTRUCTOR:
    4754                 :      143382 :         case GFC_SS_FUNCTION:
    4755                 :      143382 :         case GFC_SS_COMPONENT:
    4756                 :      143382 :           loop->dimen = ss->dimen;
    4757                 :      143382 :           goto done;
    4758                 :             : 
    4759                 :             :         /* As usual, lbound and ubound are exceptions!.  */
    4760                 :        4920 :         case GFC_SS_INTRINSIC:
    4761                 :        4920 :           switch (ss->info->expr->value.function.isym->id)
    4762                 :             :             {
    4763                 :        4920 :             case GFC_ISYM_LBOUND:
    4764                 :        4920 :             case GFC_ISYM_UBOUND:
    4765                 :        4920 :             case GFC_ISYM_LCOBOUND:
    4766                 :        4920 :             case GFC_ISYM_UCOBOUND:
    4767                 :        4920 :             case GFC_ISYM_SHAPE:
    4768                 :        4920 :             case GFC_ISYM_THIS_IMAGE:
    4769                 :        4920 :               loop->dimen = ss->dimen;
    4770                 :        4920 :               goto done;
    4771                 :             : 
    4772                 :             :             default:
    4773                 :             :               break;
    4774                 :             :             }
    4775                 :             : 
    4776                 :       16852 :         default:
    4777                 :       16852 :           break;
    4778                 :             :         }
    4779                 :             :     }
    4780                 :             : 
    4781                 :             :   /* We should have determined the rank of the expression by now.  If
    4782                 :             :      not, that's bad news.  */
    4783                 :           0 :   gcc_unreachable ();
    4784                 :             : 
    4785                 :             : done:
    4786                 :             :   /* Loop over all the SS in the chain.  */
    4787                 :      382491 :   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    4788                 :             :     {
    4789                 :      234189 :       gfc_ss_info *ss_info;
    4790                 :      234189 :       gfc_array_info *info;
    4791                 :      234189 :       gfc_expr *expr;
    4792                 :             : 
    4793                 :      234189 :       ss_info = ss->info;
    4794                 :      234189 :       expr = ss_info->expr;
    4795                 :      234189 :       info = &ss_info->data.array;
    4796                 :             : 
    4797                 :      234189 :       if (expr && expr->shape && !info->shape)
    4798                 :      140604 :         info->shape = expr->shape;
    4799                 :             : 
    4800                 :      234189 :       switch (ss_info->type)
    4801                 :             :         {
    4802                 :      150936 :         case GFC_SS_SECTION:
    4803                 :             :           /* Get the descriptor for the array.  If it is a cross loops array,
    4804                 :             :              we got the descriptor already in the outermost loop.  */
    4805                 :      150936 :           if (ss->parent == NULL)
    4806                 :      150299 :             gfc_conv_ss_descriptor (&outer_loop->pre, ss,
    4807                 :      150299 :                                     !loop->array_parameter);
    4808                 :             : 
    4809                 :      351274 :           for (n = 0; n < ss->dimen; n++)
    4810                 :      200338 :             gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
    4811                 :             :           break;
    4812                 :             : 
    4813                 :        5054 :         case GFC_SS_INTRINSIC:
    4814                 :        5054 :           switch (expr->value.function.isym->id)
    4815                 :             :             {
    4816                 :             :             /* Fall through to supply start and stride.  */
    4817                 :        2822 :             case GFC_ISYM_LBOUND:
    4818                 :        2822 :             case GFC_ISYM_UBOUND:
    4819                 :             :               /* This is the variant without DIM=...  */
    4820                 :        2822 :               gcc_assert (expr->value.function.actual->next->expr == NULL);
    4821                 :             :               /* Fall through.  */
    4822                 :             : 
    4823                 :        4847 :             case GFC_ISYM_SHAPE:
    4824                 :        4847 :               {
    4825                 :        4847 :                 gfc_expr *arg;
    4826                 :             : 
    4827                 :        4847 :                 arg = expr->value.function.actual->expr;
    4828                 :        4847 :                 if (arg->rank == -1)
    4829                 :             :                   {
    4830                 :        1151 :                     gfc_se se;
    4831                 :        1151 :                     tree rank, tmp;
    4832                 :             : 
    4833                 :             :                     /* The rank (hence the return value's shape) is unknown,
    4834                 :             :                        we have to retrieve it.  */
    4835                 :        1151 :                     gfc_init_se (&se, NULL);
    4836                 :        1151 :                     se.descriptor_only = 1;
    4837                 :        1151 :                     gfc_conv_expr (&se, arg);
    4838                 :             :                     /* This is a bare variable, so there is no preliminary
    4839                 :             :                        or cleanup code.  */
    4840                 :        1151 :                     gcc_assert (se.pre.head == NULL_TREE
    4841                 :             :                                 && se.post.head == NULL_TREE);
    4842                 :        1151 :                     rank = gfc_conv_descriptor_rank (se.expr);
    4843                 :        1151 :                     tmp = fold_build2_loc (input_location, MINUS_EXPR,
    4844                 :             :                                            gfc_array_index_type,
    4845                 :             :                                            fold_convert (gfc_array_index_type,
    4846                 :             :                                                          rank),
    4847                 :             :                                            gfc_index_one_node);
    4848                 :        1151 :                     info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
    4849                 :        1151 :                     info->start[0] = gfc_index_zero_node;
    4850                 :        1151 :                     info->stride[0] = gfc_index_one_node;
    4851                 :        1151 :                     continue;
    4852                 :        1151 :                   }
    4853                 :             :                   /* Otherwise fall through GFC_SS_FUNCTION.  */
    4854                 :             :                   gcc_fallthrough ();
    4855                 :             :               }
    4856                 :             :             case GFC_ISYM_LCOBOUND:
    4857                 :             :             case GFC_ISYM_UCOBOUND:
    4858                 :             :             case GFC_ISYM_THIS_IMAGE:
    4859                 :             :               break;
    4860                 :             : 
    4861                 :           0 :             default:
    4862                 :           0 :               continue;
    4863                 :           0 :             }
    4864                 :             : 
    4865                 :             :           /* FALLTHRU */
    4866                 :             :         case GFC_SS_CONSTRUCTOR:
    4867                 :             :         case GFC_SS_FUNCTION:
    4868                 :      102065 :           for (n = 0; n < ss->dimen; n++)
    4869                 :             :             {
    4870                 :       54497 :               int dim = ss->dim[n];
    4871                 :             : 
    4872                 :       54497 :               info->start[dim]  = gfc_index_zero_node;
    4873                 :       54497 :               info->end[dim]    = gfc_index_zero_node;
    4874                 :       54497 :               info->stride[dim] = gfc_index_one_node;
    4875                 :             :             }
    4876                 :             :           break;
    4877                 :             : 
    4878                 :             :         default:
    4879                 :             :           break;
    4880                 :             :         }
    4881                 :             :     }
    4882                 :             : 
    4883                 :             :   /* The rest is just runtime bounds checking.  */
    4884                 :      148302 :   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    4885                 :             :     {
    4886                 :       16624 :       stmtblock_t block;
    4887                 :       16624 :       tree lbound, ubound;
    4888                 :       16624 :       tree end;
    4889                 :       16624 :       tree size[GFC_MAX_DIMENSIONS];
    4890                 :       16624 :       tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
    4891                 :       16624 :       gfc_array_info *info;
    4892                 :       16624 :       char *msg;
    4893                 :       16624 :       int dim;
    4894                 :             : 
    4895                 :       16624 :       gfc_start_block (&block);
    4896                 :             : 
    4897                 :       53298 :       for (n = 0; n < loop->dimen; n++)
    4898                 :       20050 :         size[n] = NULL_TREE;
    4899                 :             : 
    4900                 :             :       /* If there is a constructor involved, derive size[] from its shape.  */
    4901                 :       38439 :       for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    4902                 :             :         {
    4903                 :       24201 :           gfc_ss_info *ss_info;
    4904                 :             : 
    4905                 :       24201 :           ss_info = ss->info;
    4906                 :       24201 :           info = &ss_info->data.array;
    4907                 :             : 
    4908                 :       24201 :           if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
    4909                 :             :             {
    4910                 :        5036 :               for (n = 0; n < loop->dimen; n++)
    4911                 :             :                 {
    4912                 :        2650 :                   if (size[n] == NULL)
    4913                 :             :                     {
    4914                 :        2650 :                       gcc_assert (info->shape[n]);
    4915                 :        2650 :                       size[n] = gfc_conv_mpz_to_tree (info->shape[n],
    4916                 :             :                                                       gfc_index_integer_kind);
    4917                 :             :                     }
    4918                 :             :                 }
    4919                 :             :               break;
    4920                 :             :             }
    4921                 :             :         }
    4922                 :             : 
    4923                 :       41149 :       for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    4924                 :             :         {
    4925                 :       24525 :           stmtblock_t inner;
    4926                 :       24525 :           gfc_ss_info *ss_info;
    4927                 :       24525 :           gfc_expr *expr;
    4928                 :       24525 :           locus *expr_loc;
    4929                 :       24525 :           const char *expr_name;
    4930                 :       24525 :           char *ref_name = NULL;
    4931                 :             : 
    4932                 :       24525 :           ss_info = ss->info;
    4933                 :       24525 :           if (ss_info->type != GFC_SS_SECTION)
    4934                 :        4400 :             continue;
    4935                 :             : 
    4936                 :             :           /* Catch allocatable lhs in f2003.  */
    4937                 :       20500 :           if (flag_realloc_lhs && ss->no_bounds_check)
    4938                 :         375 :             continue;
    4939                 :             : 
    4940                 :       20125 :           expr = ss_info->expr;
    4941                 :       20125 :           expr_loc = &expr->where;
    4942                 :       20125 :           if (expr->ref)
    4943                 :       20125 :             expr_name = ref_name = abridged_ref_name (expr, NULL);
    4944                 :             :           else
    4945                 :           0 :             expr_name = expr->symtree->name;
    4946                 :             : 
    4947                 :       20125 :           gfc_start_block (&inner);
    4948                 :             : 
    4949                 :             :           /* TODO: range checking for mapped dimensions.  */
    4950                 :       20125 :           info = &ss_info->data.array;
    4951                 :             : 
    4952                 :             :           /* This code only checks ranges.  Elemental and vector
    4953                 :             :              dimensions are checked later.  */
    4954                 :       43560 :           for (n = 0; n < loop->dimen; n++)
    4955                 :             :             {
    4956                 :       23435 :               bool check_upper;
    4957                 :             : 
    4958                 :       23435 :               dim = ss->dim[n];
    4959                 :       23435 :               if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
    4960                 :          14 :                 continue;
    4961                 :             : 
    4962                 :       23421 :               if (dim == info->ref->u.ar.dimen - 1
    4963                 :       20012 :                   && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
    4964                 :             :                 check_upper = false;
    4965                 :             :               else
    4966                 :       23131 :                 check_upper = true;
    4967                 :             : 
    4968                 :             :               /* Zero stride is not allowed.  */
    4969                 :       23421 :               tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    4970                 :             :                                      info->stride[dim], gfc_index_zero_node);
    4971                 :       23421 :               msg = xasprintf ("Zero stride is not allowed, for dimension %d "
    4972                 :             :                                "of array '%s'", dim + 1, expr_name);
    4973                 :       23421 :               gfc_trans_runtime_check (true, false, tmp, &inner,
    4974                 :             :                                        expr_loc, msg);
    4975                 :       23421 :               free (msg);
    4976                 :             : 
    4977                 :       23421 :               desc = info->descriptor;
    4978                 :             : 
    4979                 :             :               /* This is the run-time equivalent of resolve.cc's
    4980                 :             :                  check_dimension().  The logical is more readable there
    4981                 :             :                  than it is here, with all the trees.  */
    4982                 :       23421 :               lbound = gfc_conv_array_lbound (desc, dim);
    4983                 :       23421 :               end = info->end[dim];
    4984                 :       23421 :               if (check_upper)
    4985                 :       23131 :                 ubound = gfc_conv_array_ubound (desc, dim);
    4986                 :             :               else
    4987                 :             :                 ubound = NULL;
    4988                 :             : 
    4989                 :             :               /* non_zerosized is true when the selected range is not
    4990                 :             :                  empty.  */
    4991                 :       23421 :               stride_pos = fold_build2_loc (input_location, GT_EXPR,
    4992                 :             :                                         logical_type_node, info->stride[dim],
    4993                 :             :                                         gfc_index_zero_node);
    4994                 :       23421 :               tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
    4995                 :             :                                      info->start[dim], end);
    4996                 :       23421 :               stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
    4997                 :             :                                             logical_type_node, stride_pos, tmp);
    4998                 :             : 
    4999                 :       23421 :               stride_neg = fold_build2_loc (input_location, LT_EXPR,
    5000                 :             :                                      logical_type_node,
    5001                 :             :                                      info->stride[dim], gfc_index_zero_node);
    5002                 :       23421 :               tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
    5003                 :             :                                      info->start[dim], end);
    5004                 :       23421 :               stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
    5005                 :             :                                             logical_type_node,
    5006                 :             :                                             stride_neg, tmp);
    5007                 :       23421 :               non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
    5008                 :             :                                                logical_type_node,
    5009                 :             :                                                stride_pos, stride_neg);
    5010                 :             : 
    5011                 :             :               /* Check the start of the range against the lower and upper
    5012                 :             :                  bounds of the array, if the range is not empty.
    5013                 :             :                  If upper bound is present, include both bounds in the
    5014                 :             :                  error message.  */
    5015                 :       23421 :               if (check_upper)
    5016                 :             :                 {
    5017                 :       23131 :                   tmp = fold_build2_loc (input_location, LT_EXPR,
    5018                 :             :                                          logical_type_node,
    5019                 :             :                                          info->start[dim], lbound);
    5020                 :       23131 :                   tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
    5021                 :             :                                          logical_type_node,
    5022                 :             :                                          non_zerosized, tmp);
    5023                 :       23131 :                   tmp2 = fold_build2_loc (input_location, GT_EXPR,
    5024                 :             :                                           logical_type_node,
    5025                 :             :                                           info->start[dim], ubound);
    5026                 :       23131 :                   tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
    5027                 :             :                                           logical_type_node,
    5028                 :             :                                           non_zerosized, tmp2);
    5029                 :       23131 :                   msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
    5030                 :             :                                    "outside of expected range (%%ld:%%ld)",
    5031                 :             :                                    dim + 1, expr_name);
    5032                 :       23131 :                   gfc_trans_runtime_check (true, false, tmp, &inner,
    5033                 :             :                                            expr_loc, msg,
    5034                 :             :                      fold_convert (long_integer_type_node, info->start[dim]),
    5035                 :             :                      fold_convert (long_integer_type_node, lbound),
    5036                 :             :                      fold_convert (long_integer_type_node, ubound));
    5037                 :       23131 :                   gfc_trans_runtime_check (true, false, tmp2, &inner,
    5038                 :             :                                            expr_loc, msg,
    5039                 :             :                      fold_convert (long_integer_type_node, info->start[dim]),
    5040                 :             :                      fold_convert (long_integer_type_node, lbound),
    5041                 :             :                      fold_convert (long_integer_type_node, ubound));
    5042                 :       23131 :                   free (msg);
    5043                 :             :                 }
    5044                 :             :               else
    5045                 :             :                 {
    5046                 :         290 :                   tmp = fold_build2_loc (input_location, LT_EXPR,
    5047                 :             :                                          logical_type_node,
    5048                 :             :                                          info->start[dim], lbound);
    5049                 :         290 :                   tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
    5050                 :             :                                          logical_type_node, non_zerosized, tmp);
    5051                 :         290 :                   msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
    5052                 :             :                                    "below lower bound of %%ld",
    5053                 :             :                                    dim + 1, expr_name);
    5054                 :         290 :                   gfc_trans_runtime_check (true, false, tmp, &inner,
    5055                 :             :                                            expr_loc, msg,
    5056                 :             :                      fold_convert (long_integer_type_node, info->start[dim]),
    5057                 :             :                      fold_convert (long_integer_type_node, lbound));
    5058                 :         290 :                   free (msg);
    5059                 :             :                 }
    5060                 :             : 
    5061                 :             :               /* Compute the last element of the range, which is not
    5062                 :             :                  necessarily "end" (think 0:5:3, which doesn't contain 5)
    5063                 :             :                  and check it against both lower and upper bounds.  */
    5064                 :             : 
    5065                 :       23421 :               tmp = fold_build2_loc (input_location, MINUS_EXPR,
    5066                 :             :                                      gfc_array_index_type, end,
    5067                 :             :                                      info->start[dim]);
    5068                 :       23421 :               tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
    5069                 :             :                                      gfc_array_index_type, tmp,
    5070                 :             :                                      info->stride[dim]);
    5071                 :       23421 :               tmp = fold_build2_loc (input_location, MINUS_EXPR,
    5072                 :             :                                      gfc_array_index_type, end, tmp);
    5073                 :       23421 :               tmp2 = fold_build2_loc (input_location, LT_EXPR,
    5074                 :             :                                       logical_type_node, tmp, lbound);
    5075                 :       23421 :               tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
    5076                 :             :                                       logical_type_node, non_zerosized, tmp2);
    5077                 :       23421 :               if (check_upper)
    5078                 :             :                 {
    5079                 :       23131 :                   tmp3 = fold_build2_loc (input_location, GT_EXPR,
    5080                 :             :                                           logical_type_node, tmp, ubound);
    5081                 :       23131 :                   tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
    5082                 :             :                                           logical_type_node, non_zerosized, tmp3);
    5083                 :       23131 :                   msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
    5084                 :             :                                    "outside of expected range (%%ld:%%ld)",
    5085                 :             :                                    dim + 1, expr_name);
    5086                 :       23131 :                   gfc_trans_runtime_check (true, false, tmp2, &inner,
    5087                 :             :                                            expr_loc, msg,
    5088                 :             :                      fold_convert (long_integer_type_node, tmp),
    5089                 :             :                      fold_convert (long_integer_type_node, ubound),
    5090                 :             :                      fold_convert (long_integer_type_node, lbound));
    5091                 :       23131 :                   gfc_trans_runtime_check (true, false, tmp3, &inner,
    5092                 :             :                                            expr_loc, msg,
    5093                 :             :                      fold_convert (long_integer_type_node, tmp),
    5094                 :             :                      fold_convert (long_integer_type_node, ubound),
    5095                 :             :                      fold_convert (long_integer_type_node, lbound));
    5096                 :       23131 :                   free (msg);
    5097                 :             :                 }
    5098                 :             :               else
    5099                 :             :                 {
    5100                 :         290 :                   msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
    5101                 :             :                                    "below lower bound of %%ld",
    5102                 :             :                                    dim + 1, expr_name);
    5103                 :         290 :                   gfc_trans_runtime_check (true, false, tmp2, &inner,
    5104                 :             :                                            expr_loc, msg,
    5105                 :             :                      fold_convert (long_integer_type_node, tmp),
    5106                 :             :                      fold_convert (long_integer_type_node, lbound));
    5107                 :         290 :                   free (msg);
    5108                 :             :                 }
    5109                 :             : 
    5110                 :             :               /* Check the section sizes match.  */
    5111                 :       23421 :               tmp = fold_build2_loc (input_location, MINUS_EXPR,
    5112                 :             :                                      gfc_array_index_type, end,
    5113                 :             :                                      info->start[dim]);
    5114                 :       23421 :               tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
    5115                 :             :                                      gfc_array_index_type, tmp,
    5116                 :             :                                      info->stride[dim]);
    5117                 :       23421 :               tmp = fold_build2_loc (input_location, PLUS_EXPR,
    5118                 :             :                                      gfc_array_index_type,
    5119                 :             :                                      gfc_index_one_node, tmp);
    5120                 :       23421 :               tmp = fold_build2_loc (input_location, MAX_EXPR,
    5121                 :             :                                      gfc_array_index_type, tmp,
    5122                 :       23421 :                                      build_int_cst (gfc_array_index_type, 0));
    5123                 :             :               /* We remember the size of the first section, and check all the
    5124                 :             :                  others against this.  */
    5125                 :       23421 :               if (size[n])
    5126                 :             :                 {
    5127                 :        6969 :                   tmp3 = fold_build2_loc (input_location, NE_EXPR,
    5128                 :             :                                           logical_type_node, tmp, size[n]);
    5129                 :        6969 :                   msg = xasprintf ("Array bound mismatch for dimension %d "
    5130                 :             :                                    "of array '%s' (%%ld/%%ld)",
    5131                 :             :                                    dim + 1, expr_name);
    5132                 :             : 
    5133                 :        6969 :                   gfc_trans_runtime_check (true, false, tmp3, &inner,
    5134                 :             :                                            expr_loc, msg,
    5135                 :             :                         fold_convert (long_integer_type_node, tmp),
    5136                 :             :                         fold_convert (long_integer_type_node, size[n]));
    5137                 :             : 
    5138                 :        6969 :                   free (msg);
    5139                 :             :                 }
    5140                 :             :               else
    5141                 :       16452 :                 size[n] = gfc_evaluate_now (tmp, &inner);
    5142                 :             :             }
    5143                 :             : 
    5144                 :       20125 :           tmp = gfc_finish_block (&inner);
    5145                 :             : 
    5146                 :             :           /* For optional arguments, only check bounds if the argument is
    5147                 :             :              present.  */
    5148                 :       20125 :           if ((expr->symtree->n.sym->attr.optional
    5149                 :       20125 :                || expr->symtree->n.sym->attr.not_always_present)
    5150                 :         296 :               && expr->symtree->n.sym->attr.dummy)
    5151                 :         295 :             tmp = build3_v (COND_EXPR,
    5152                 :             :                             gfc_conv_expr_present (expr->symtree->n.sym),
    5153                 :             :                             tmp, build_empty_stmt (input_location));
    5154                 :             : 
    5155                 :       20125 :           gfc_add_expr_to_block (&block, tmp);
    5156                 :             : 
    5157                 :       20125 :           free (ref_name);
    5158                 :             :         }
    5159                 :             : 
    5160                 :       16624 :       tmp = gfc_finish_block (&block);
    5161                 :       16624 :       gfc_add_expr_to_block (&outer_loop->pre, tmp);
    5162                 :             :     }
    5163                 :             : 
    5164                 :      148855 :   for (loop = loop->nested; loop; loop = loop->next)
    5165                 :         553 :     gfc_conv_ss_startstride (loop);
    5166                 :      148302 : }
    5167                 :             : 
    5168                 :             : /* Return true if both symbols could refer to the same data object.  Does
    5169                 :             :    not take account of aliasing due to equivalence statements.  */
    5170                 :             : 
    5171                 :             : static bool
    5172                 :        9244 : symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
    5173                 :             :                      bool lsym_target, bool rsym_pointer, bool rsym_target)
    5174                 :             : {
    5175                 :             :   /* Aliasing isn't possible if the symbols have different base types.  */
    5176                 :        9244 :   if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
    5177                 :             :     return 0;
    5178                 :             : 
    5179                 :             :   /* Pointers can point to other pointers and target objects.  */
    5180                 :             : 
    5181                 :        7311 :   if ((lsym_pointer && (rsym_pointer || rsym_target))
    5182                 :        7127 :       || (rsym_pointer && (lsym_pointer || lsym_target)))
    5183                 :             :     return 1;
    5184                 :             : 
    5185                 :             :   /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
    5186                 :             :      and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
    5187                 :             :      checked above.  */
    5188                 :        7219 :   if (lsym_target && rsym_target
    5189                 :          14 :       && ((lsym->attr.dummy && !lsym->attr.contiguous
    5190                 :           0 :            && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
    5191                 :          14 :           || (rsym->attr.dummy && !rsym->attr.contiguous
    5192                 :           6 :               && (!rsym->attr.dimension
    5193                 :           6 :                   || rsym->as->type == AS_ASSUMED_SHAPE))))
    5194                 :           6 :     return 1;
    5195                 :             : 
    5196                 :             :   return 0;
    5197                 :             : }
    5198                 :             : 
    5199                 :             : 
    5200                 :             : /* Return true if the two SS could be aliased, i.e. both point to the same data
    5201                 :             :    object.  */
    5202                 :             : /* TODO: resolve aliases based on frontend expressions.  */
    5203                 :             : 
    5204                 :             : static int
    5205                 :        7990 : gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
    5206                 :             : {
    5207                 :        7990 :   gfc_ref *lref;
    5208                 :        7990 :   gfc_ref *rref;
    5209                 :        7990 :   gfc_expr *lexpr, *rexpr;
    5210                 :        7990 :   gfc_symbol *lsym;
    5211                 :        7990 :   gfc_symbol *rsym;
    5212                 :        7990 :   bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
    5213                 :             : 
    5214                 :        7990 :   lexpr = lss->info->expr;
    5215                 :        7990 :   rexpr = rss->info->expr;
    5216                 :             : 
    5217                 :        7990 :   lsym = lexpr->symtree->n.sym;
    5218                 :        7990 :   rsym = rexpr->symtree->n.sym;
    5219                 :             : 
    5220                 :        7990 :   lsym_pointer = lsym->attr.pointer;
    5221                 :        7990 :   lsym_target = lsym->attr.target;
    5222                 :        7990 :   rsym_pointer = rsym->attr.pointer;
    5223                 :        7990 :   rsym_target = rsym->attr.target;
    5224                 :             : 
    5225                 :        7990 :   if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
    5226                 :             :                            rsym_pointer, rsym_target))
    5227                 :             :     return 1;
    5228                 :             : 
    5229                 :        7924 :   if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
    5230                 :        7206 :       && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
    5231                 :             :     return 0;
    5232                 :             : 
    5233                 :             :   /* For derived types we must check all the component types.  We can ignore
    5234                 :             :      array references as these will have the same base type as the previous
    5235                 :             :      component ref.  */
    5236                 :        1530 :   for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
    5237                 :             :     {
    5238                 :         583 :       if (lref->type != REF_COMPONENT)
    5239                 :          65 :         continue;
    5240                 :             : 
    5241                 :         518 :       lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
    5242                 :         518 :       lsym_target  = lsym_target  || lref->u.c.sym->attr.target;
    5243                 :             : 
    5244                 :         518 :       if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
    5245                 :             :                                rsym_pointer, rsym_target))
    5246                 :             :         return 1;
    5247                 :             : 
    5248                 :         518 :       if ((lsym_pointer && (rsym_pointer || rsym_target))
    5249                 :         503 :           || (rsym_pointer && (lsym_pointer || lsym_target)))
    5250                 :             :         {
    5251                 :           6 :           if (gfc_compare_types (&lref->u.c.component->ts,
    5252                 :             :                                  &rsym->ts))
    5253                 :             :             return 1;
    5254                 :             :         }
    5255                 :             : 
    5256                 :         887 :       for (rref = rexpr->ref; rref != rss->info->data.array.ref;
    5257                 :         375 :            rref = rref->next)
    5258                 :             :         {
    5259                 :         376 :           if (rref->type != REF_COMPONENT)
    5260                 :          36 :             continue;
    5261                 :             : 
    5262                 :         340 :           rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
    5263                 :         340 :           rsym_target  = lsym_target  || rref->u.c.sym->attr.target;
    5264                 :             : 
    5265                 :         340 :           if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
    5266                 :             :                                    lsym_pointer, lsym_target,
    5267                 :             :                                    rsym_pointer, rsym_target))
    5268                 :             :             return 1;
    5269                 :             : 
    5270                 :         339 :           if ((lsym_pointer && (rsym_pointer || rsym_target))
    5271                 :         335 :               || (rsym_pointer && (lsym_pointer || lsym_target)))
    5272                 :             :             {
    5273                 :           0 :               if (gfc_compare_types (&lref->u.c.component->ts,
    5274                 :           0 :                                      &rref->u.c.sym->ts))
    5275                 :             :                 return 1;
    5276                 :           0 :               if (gfc_compare_types (&lref->u.c.sym->ts,
    5277                 :           0 :                                      &rref->u.c.component->ts))
    5278                 :             :                 return 1;
    5279                 :           0 :               if (gfc_compare_types (&lref->u.c.component->ts,
    5280                 :           0 :                                      &rref->u.c.component->ts))
    5281                 :             :                 return 1;
    5282                 :             :             }
    5283                 :             :         }
    5284                 :             :     }
    5285                 :             : 
    5286                 :         947 :   lsym_pointer = lsym->attr.pointer;
    5287                 :         947 :   lsym_target = lsym->attr.target;
    5288                 :             : 
    5289                 :        1337 :   for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
    5290                 :             :     {
    5291                 :         471 :       if (rref->type != REF_COMPONENT)
    5292                 :             :         break;
    5293                 :             : 
    5294                 :         396 :       rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
    5295                 :         396 :       rsym_target  = lsym_target  || rref->u.c.sym->attr.target;
    5296                 :             : 
    5297                 :         396 :       if (symbols_could_alias (rref->u.c.sym, lsym,
    5298                 :             :                                lsym_pointer, lsym_target,
    5299                 :             :                                rsym_pointer, rsym_target))
    5300                 :             :         return 1;
    5301                 :             : 
    5302                 :         396 :       if ((lsym_pointer && (rsym_pointer || rsym_target))
    5303                 :         378 :           || (rsym_pointer && (lsym_pointer || lsym_target)))
    5304                 :             :         {
    5305                 :           6 :           if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
    5306                 :             :             return 1;
    5307                 :             :         }
    5308                 :             :     }
    5309                 :             : 
    5310                 :             :   return 0;
    5311                 :             : }
    5312                 :             : 
    5313                 :             : 
    5314                 :             : /* Resolve array data dependencies.  Creates a temporary if required.  */
    5315                 :             : /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
    5316                 :             :    dependency.cc.  */
    5317                 :             : 
    5318                 :             : void
    5319                 :       31947 : gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
    5320                 :             :                                gfc_ss * rss)
    5321                 :             : {
    5322                 :       31947 :   gfc_ss *ss;
    5323                 :       31947 :   gfc_ref *lref;
    5324                 :       31947 :   gfc_ref *rref;
    5325                 :       31947 :   gfc_ss_info *ss_info;
    5326                 :       31947 :   gfc_expr *dest_expr;
    5327                 :       31947 :   gfc_expr *ss_expr;
    5328                 :       31947 :   int nDepend = 0;
    5329                 :       31947 :   int i, j;
    5330                 :             : 
    5331                 :       31947 :   loop->temp_ss = NULL;
    5332                 :       31947 :   dest_expr = dest->info->expr;
    5333                 :             : 
    5334                 :       66950 :   for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
    5335                 :             :     {
    5336                 :       35895 :       ss_info = ss->info;
    5337                 :       35895 :       ss_expr = ss_info->expr;
    5338                 :             : 
    5339                 :       35895 :       if (ss_info->array_outer_dependency)
    5340                 :             :         {
    5341                 :             :           nDepend = 1;
    5342                 :             :           break;
    5343                 :             :         }
    5344                 :             : 
    5345                 :       35785 :       if (ss_info->type != GFC_SS_SECTION)
    5346                 :             :         {
    5347                 :       25524 :           if (flag_realloc_lhs
    5348                 :       24655 :               && dest_expr != ss_expr
    5349                 :       24655 :               && gfc_is_reallocatable_lhs (dest_expr)
    5350                 :       29688 :               && ss_expr->rank)
    5351                 :        1940 :             nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
    5352                 :             : 
    5353                 :             :           /* Check for cases like   c(:)(1:2) = c(2)(2:3)  */
    5354                 :       25524 :           if (!nDepend && dest_expr->rank > 0
    5355                 :       25188 :               && dest_expr->ts.type == BT_CHARACTER
    5356                 :        3980 :               && ss_expr->expr_type == EXPR_VARIABLE)
    5357                 :             : 
    5358                 :         163 :             nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
    5359                 :             : 
    5360                 :       25524 :           if (ss_info->type == GFC_SS_REFERENCE
    5361                 :       25524 :               && gfc_check_dependency (dest_expr, ss_expr, false))
    5362                 :         182 :             ss_info->data.scalar.needs_temporary = 1;
    5363                 :             : 
    5364                 :       25524 :           if (nDepend)
    5365                 :             :             break;
    5366                 :             :           else
    5367                 :       25176 :             continue;
    5368                 :             :         }
    5369                 :             : 
    5370                 :       10261 :       if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
    5371                 :             :         {
    5372                 :        7990 :           if (gfc_could_be_alias (dest, ss)
    5373                 :        7990 :               || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
    5374                 :             :             {
    5375                 :             :               nDepend = 1;
    5376                 :             :               break;
    5377                 :             :             }
    5378                 :             :         }
    5379                 :             :       else
    5380                 :             :         {
    5381                 :        2271 :           lref = dest_expr->ref;
    5382                 :        2271 :           rref = ss_expr->ref;
    5383                 :             : 
    5384                 :        2271 :           nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
    5385                 :             : 
    5386                 :        2271 :           if (nDepend == 1)
    5387                 :             :             break;
    5388                 :             : 
    5389                 :        4565 :           for (i = 0; i < dest->dimen; i++)
    5390                 :        6212 :             for (j = 0; j < ss->dimen; j++)
    5391                 :        3704 :               if (i != j
    5392                 :        1133 :                   && dest->dim[i] == ss->dim[j])
    5393                 :             :                 {
    5394                 :             :                   /* If we don't access array elements in the same order,
    5395                 :             :                      there is a dependency.  */
    5396                 :          63 :                   nDepend = 1;
    5397                 :          63 :                   goto temporary;
    5398                 :             :                 }
    5399                 :             : #if 0
    5400                 :             :           /* TODO : loop shifting.  */
    5401                 :             :           if (nDepend == 1)
    5402                 :             :             {
    5403                 :             :               /* Mark the dimensions for LOOP SHIFTING */
    5404                 :             :               for (n = 0; n < loop->dimen; n++)
    5405                 :             :                 {
    5406                 :             :                   int dim = dest->data.info.dim[n];
    5407                 :             : 
    5408                 :             :                   if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
    5409                 :             :                     depends[n] = 2;
    5410                 :             :                   else if (! gfc_is_same_range (&lref->u.ar,
    5411                 :             :                                                 &rref->u.ar, dim, 0))
    5412                 :             :                     depends[n] = 1;
    5413                 :             :                  }
    5414                 :             : 
    5415                 :             :               /* Put all the dimensions with dependencies in the
    5416                 :             :                  innermost loops.  */
    5417                 :             :               dim = 0;
    5418                 :             :               for (n = 0; n < loop->dimen; n++)
    5419                 :             :                 {
    5420                 :             :                   gcc_assert (loop->order[n] == n);
    5421                 :             :                   if (depends[n])
    5422                 :             :                   loop->order[dim++] = n;
    5423                 :             :                 }
    5424                 :             :               for (n = 0; n < loop->dimen; n++)
    5425                 :             :                 {
    5426                 :             :                   if (! depends[n])
    5427                 :             :                   loop->order[dim++] = n;
    5428                 :             :                 }
    5429                 :             : 
    5430                 :             :               gcc_assert (dim == loop->dimen);
    5431                 :             :               break;
    5432                 :             :             }
    5433                 :             : #endif
    5434                 :             :         }
    5435                 :             :     }
    5436                 :             : 
    5437                 :         562 : temporary:
    5438                 :             : 
    5439                 :       31947 :   if (nDepend == 1)
    5440                 :             :     {
    5441                 :         892 :       tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
    5442                 :         892 :       if (GFC_ARRAY_TYPE_P (base_type)
    5443                 :         892 :           || GFC_DESCRIPTOR_TYPE_P (base_type))
    5444                 :           0 :         base_type = gfc_get_element_type (base_type);
    5445                 :         892 :       loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
    5446                 :             :                                        loop->dimen);
    5447                 :         892 :       gfc_add_ss_to_loop (loop, loop->temp_ss);
    5448                 :             :     }
    5449                 :             :   else
    5450                 :       31055 :     loop->temp_ss = NULL;
    5451                 :       31947 : }
    5452                 :             : 
    5453                 :             : 
    5454                 :             : /* Browse through each array's information from the scalarizer and set the loop
    5455                 :             :    bounds according to the "best" one (per dimension), i.e. the one which
    5456                 :             :    provides the most information (constant bounds, shape, etc.).  */
    5457                 :             : 
    5458                 :             : static void
    5459                 :      148302 : set_loop_bounds (gfc_loopinfo *loop)
    5460                 :             : {
    5461                 :      148302 :   int n, dim, spec_dim;
    5462                 :      148302 :   gfc_array_info *info;
    5463                 :      148302 :   gfc_array_info *specinfo;
    5464                 :      148302 :   gfc_ss *ss;
    5465                 :      148302 :   tree tmp;
    5466                 :      148302 :   gfc_ss **loopspec;
    5467                 :      148302 :   bool dynamic[GFC_MAX_DIMENSIONS];
    5468                 :      148302 :   mpz_t *cshape;
    5469                 :      148302 :   mpz_t i;
    5470                 :      148302 :   bool nonoptional_arr;
    5471                 :             : 
    5472                 :      148302 :   gfc_loopinfo * const outer_loop = outermost_loop (loop);
    5473                 :             : 
    5474                 :      148302 :   loopspec = loop->specloop;
    5475                 :             : 
    5476                 :      148302 :   mpz_init (i);
    5477                 :      343948 :   for (n = 0; n < loop->dimen; n++)
    5478                 :             :     {
    5479                 :      195646 :       loopspec[n] = NULL;
    5480                 :      195646 :       dynamic[n] = false;
    5481                 :             : 
    5482                 :             :       /* If there are both optional and nonoptional array arguments, scalarize
    5483                 :             :          over the nonoptional; otherwise, it does not matter as then all
    5484                 :             :          (optional) arrays have to be present per F2008, 125.2.12p3(6).  */
    5485                 :             : 
    5486                 :      195646 :       nonoptional_arr = false;
    5487                 :             : 
    5488                 :      227706 :       for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    5489                 :      227686 :         if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
    5490                 :      196641 :             && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
    5491                 :             :           {
    5492                 :             :             nonoptional_arr = true;
    5493                 :             :             break;
    5494                 :             :           }
    5495                 :             : 
    5496                 :             :       /* We use one SS term, and use that to determine the bounds of the
    5497                 :             :          loop for this dimension.  We try to pick the simplest term.  */
    5498                 :      504736 :       for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    5499                 :             :         {
    5500                 :      309090 :           gfc_ss_type ss_type;
    5501                 :             : 
    5502                 :      309090 :           ss_type = ss->info->type;
    5503                 :      361417 :           if (ss_type == GFC_SS_SCALAR
    5504                 :      309090 :               || ss_type == GFC_SS_TEMP
    5505                 :      258933 :               || ss_type == GFC_SS_REFERENCE
    5506                 :      256982 :               || (ss->info->can_be_null_ref && nonoptional_arr))
    5507                 :       52327 :             continue;
    5508                 :             : 
    5509                 :      256763 :           info = &ss->info->data.array;
    5510                 :      256763 :           dim = ss->dim[n];
    5511                 :             : 
    5512                 :      256763 :           if (loopspec[n] != NULL)
    5513                 :             :             {
    5514                 :       61117 :               specinfo = &loopspec[n]->info->data.array;
    5515                 :       61117 :               spec_dim = loopspec[n]->dim[n];
    5516                 :             :             }
    5517                 :             :           else
    5518                 :             :             {
    5519                 :             :               /* Silence uninitialized warnings.  */
    5520                 :             :               specinfo = NULL;
    5521                 :             :               spec_dim = 0;
    5522                 :             :             }
    5523                 :             : 
    5524                 :      256763 :           if (info->shape)
    5525                 :             :             {
    5526                 :             :               /* The frontend has worked out the size for us.  */
    5527                 :      179839 :               if (!loopspec[n]
    5528                 :       47001 :                   || !specinfo->shape
    5529                 :      218627 :                   || !integer_zerop (specinfo->start[spec_dim]))
    5530                 :             :                 /* Prefer zero-based descriptors if possible.  */
    5531                 :      165835 :                 loopspec[n] = ss;
    5532                 :      179839 :               continue;
    5533                 :             :             }
    5534                 :             : 
    5535                 :       76924 :           if (ss_type == GFC_SS_CONSTRUCTOR)
    5536                 :             :             {
    5537                 :        1121 :               gfc_constructor_base base;
    5538                 :             :               /* An unknown size constructor will always be rank one.
    5539                 :             :                  Higher rank constructors will either have known shape,
    5540                 :             :                  or still be wrapped in a call to reshape.  */
    5541                 :        1121 :               gcc_assert (loop->dimen == 1);
    5542                 :             : 
    5543                 :             :               /* Always prefer to use the constructor bounds if the size
    5544                 :             :                  can be determined at compile time.  Prefer not to otherwise,
    5545                 :             :                  since the general case involves realloc, and it's better to
    5546                 :             :                  avoid that overhead if possible.  */
    5547                 :        1121 :               base = ss->info->expr->value.constructor;
    5548                 :        1121 :               dynamic[n] = gfc_get_array_constructor_size (&i, base);
    5549                 :        1121 :               if (!dynamic[n] || !loopspec[n])
    5550                 :        1002 :                 loopspec[n] = ss;
    5551                 :        1121 :               continue;
    5552                 :        1121 :             }
    5553                 :             : 
    5554                 :             :           /* Avoid using an allocatable lhs in an assignment, since
    5555                 :             :              there might be a reallocation coming.  */
    5556                 :       75803 :           if (loopspec[n] && ss->is_alloc_lhs)
    5557                 :        5120 :             continue;
    5558                 :             : 
    5559                 :       70683 :           if (!loopspec[n])
    5560                 :       61806 :             loopspec[n] = ss;
    5561                 :             :           /* Criteria for choosing a loop specifier (most important first):
    5562                 :             :              doesn't need realloc
    5563                 :             :              stride of one
    5564                 :             :              known stride
    5565                 :             :              known lower bound
    5566                 :             :              known upper bound
    5567                 :             :            */
    5568                 :        8877 :           else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
    5569                 :         158 :             loopspec[n] = ss;
    5570                 :        8719 :           else if (integer_onep (info->stride[dim])
    5571                 :        8719 :                    && !integer_onep (specinfo->stride[spec_dim]))
    5572                 :          78 :             loopspec[n] = ss;
    5573                 :        8641 :           else if (INTEGER_CST_P (info->stride[dim])
    5574                 :        8471 :                    && !INTEGER_CST_P (specinfo->stride[spec_dim]))
    5575                 :           0 :             loopspec[n] = ss;
    5576                 :        8641 :           else if (INTEGER_CST_P (info->start[dim])
    5577                 :        3870 :                    && !INTEGER_CST_P (specinfo->start[spec_dim])
    5578                 :         502 :                    && integer_onep (info->stride[dim])
    5579                 :         251 :                       == integer_onep (specinfo->stride[spec_dim])
    5580                 :        8641 :                    && INTEGER_CST_P (info->stride[dim])
    5581                 :         224 :                       == INTEGER_CST_P (specinfo->stride[spec_dim]))
    5582                 :         224 :             loopspec[n] = ss;
    5583                 :             :           /* We don't work out the upper bound.
    5584                 :             :              else if (INTEGER_CST_P (info->finish[n])
    5585                 :             :              && ! INTEGER_CST_P (specinfo->finish[n]))
    5586                 :             :              loopspec[n] = ss; */
    5587                 :             :         }
    5588                 :             : 
    5589                 :             :       /* We should have found the scalarization loop specifier.  If not,
    5590                 :             :          that's bad news.  */
    5591                 :      195646 :       gcc_assert (loopspec[n]);
    5592                 :             : 
    5593                 :      195646 :       info = &loopspec[n]->info->data.array;
    5594                 :      195646 :       dim = loopspec[n]->dim[n];
    5595                 :             : 
    5596                 :             :       /* Set the extents of this range.  */
    5597                 :      195646 :       cshape = info->shape;
    5598                 :      195646 :       if (cshape && INTEGER_CST_P (info->start[dim])
    5599                 :      140756 :           && INTEGER_CST_P (info->stride[dim]))
    5600                 :             :         {
    5601                 :      140756 :           loop->from[n] = info->start[dim];
    5602                 :      140756 :           mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
    5603                 :      140756 :           mpz_sub_ui (i, i, 1);
    5604                 :             :           /* To = from + (size - 1) * stride.  */
    5605                 :      140756 :           tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
    5606                 :      140756 :           if (!integer_onep (info->stride[dim]))
    5607                 :        8331 :             tmp = fold_build2_loc (input_location, MULT_EXPR,
    5608                 :             :                                    gfc_array_index_type, tmp,
    5609                 :             :                                    info->stride[dim]);
    5610                 :      140756 :           loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
    5611                 :             :                                          gfc_array_index_type,
    5612                 :             :                                          loop->from[n], tmp);
    5613                 :             :         }
    5614                 :             :       else
    5615                 :             :         {
    5616                 :       54890 :           loop->from[n] = info->start[dim];
    5617                 :       54890 :           switch (loopspec[n]->info->type)
    5618                 :             :             {
    5619                 :         745 :             case GFC_SS_CONSTRUCTOR:
    5620                 :             :               /* The upper bound is calculated when we expand the
    5621                 :             :                  constructor.  */
    5622                 :         745 :               gcc_assert (loop->to[n] == NULL_TREE);
    5623                 :             :               break;
    5624                 :             : 
    5625                 :       49361 :             case GFC_SS_SECTION:
    5626                 :             :               /* Use the end expression if it exists and is not constant,
    5627                 :             :                  so that it is only evaluated once.  */
    5628                 :       49361 :               loop->to[n] = info->end[dim];
    5629                 :       49361 :               break;
    5630                 :             : 
    5631                 :        4029 :             case GFC_SS_FUNCTION:
    5632                 :             :               /* The loop bound will be set when we generate the call.  */
    5633                 :        4029 :               gcc_assert (loop->to[n] == NULL_TREE);
    5634                 :             :               break;
    5635                 :             : 
    5636                 :         749 :             case GFC_SS_INTRINSIC:
    5637                 :         749 :               {
    5638                 :         749 :                 gfc_expr *expr = loopspec[n]->info->expr;
    5639                 :             : 
    5640                 :             :                 /* The {l,u}bound of an assumed rank.  */
    5641                 :         749 :                 if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
    5642                 :         237 :                   gcc_assert (expr->value.function.actual->expr->rank == -1);
    5643                 :             :                 else
    5644                 :         512 :                   gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
    5645                 :             :                                || expr->value.function.isym->id == GFC_ISYM_UBOUND)
    5646                 :             :                               && expr->value.function.actual->next->expr == NULL
    5647                 :             :                               && expr->value.function.actual->expr->rank == -1);
    5648                 :             : 
    5649                 :         749 :                 loop->to[n] = info->end[dim];
    5650                 :         749 :                 break;
    5651                 :             :               }
    5652                 :             : 
    5653                 :           6 :             case GFC_SS_COMPONENT:
    5654                 :           6 :               {
    5655                 :           6 :                 if (info->end[dim] != NULL_TREE)
    5656                 :             :                   {
    5657                 :           6 :                     loop->to[n] = info->end[dim];
    5658                 :           6 :                     break;
    5659                 :             :                   }
    5660                 :             :                 else
    5661                 :           0 :                   gcc_unreachable ();
    5662                 :             :               }
    5663                 :             : 
    5664                 :           0 :             default:
    5665                 :           0 :               gcc_unreachable ();
    5666                 :             :             }
    5667                 :             :         }
    5668                 :             : 
    5669                 :             :       /* Transform everything so we have a simple incrementing variable.  */
    5670                 :      195646 :       if (integer_onep (info->stride[dim]))
    5671                 :      185679 :         info->delta[dim] = gfc_index_zero_node;
    5672                 :             :       else
    5673                 :             :         {
    5674                 :             :           /* Set the delta for this section.  */
    5675                 :        9967 :           info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
    5676                 :             :           /* Number of iterations is (end - start + step) / step.
    5677                 :             :              with start = 0, this simplifies to
    5678                 :             :              last = end / step;
    5679                 :             :              for (i = 0; i<=last; i++){...};  */
    5680                 :        9967 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
    5681                 :             :                                  gfc_array_index_type, loop->to[n],
    5682                 :             :                                  loop->from[n]);
    5683                 :        9967 :           tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
    5684                 :             :                                  gfc_array_index_type, tmp, info->stride[dim]);
    5685                 :        9967 :           tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
    5686                 :        9967 :                                  tmp, build_int_cst (gfc_array_index_type, -1));
    5687                 :        9967 :           loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
    5688                 :             :           /* Make the loop variable start at 0.  */
    5689                 :        9967 :           loop->from[n] = gfc_index_zero_node;
    5690                 :             :         }
    5691                 :             :     }
    5692                 :      148302 :   mpz_clear (i);
    5693                 :             : 
    5694                 :      148855 :   for (loop = loop->nested; loop; loop = loop->next)
    5695                 :         553 :     set_loop_bounds (loop);
    5696                 :      148302 : }
    5697                 :             : 
    5698                 :             : 
    5699                 :             : /* Initialize the scalarization loop.  Creates the loop variables.  Determines
    5700                 :             :    the range of the loop variables.  Creates a temporary if required.
    5701                 :             :    Also generates code for scalar expressions which have been
    5702                 :             :    moved outside the loop.  */
    5703                 :             : 
    5704                 :             : void
    5705                 :      147749 : gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
    5706                 :             : {
    5707                 :      147749 :   gfc_ss *tmp_ss;
    5708                 :      147749 :   tree tmp;
    5709                 :             : 
    5710                 :      147749 :   set_loop_bounds (loop);
    5711                 :             : 
    5712                 :             :   /* Add all the scalar code that can be taken out of the loops.
    5713                 :             :      This may include calculating the loop bounds, so do it before
    5714                 :             :      allocating the temporary.  */
    5715                 :      147749 :   gfc_add_loop_ss_code (loop, loop->ss, false, where);
    5716                 :             : 
    5717                 :      147749 :   tmp_ss = loop->temp_ss;
    5718                 :             :   /* If we want a temporary then create it.  */
    5719                 :      147749 :   if (tmp_ss != NULL)
    5720                 :             :     {
    5721                 :        8581 :       gfc_ss_info *tmp_ss_info;
    5722                 :             : 
    5723                 :        8581 :       tmp_ss_info = tmp_ss->info;
    5724                 :        8581 :       gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
    5725                 :        8581 :       gcc_assert (loop->parent == NULL);
    5726                 :             : 
    5727                 :             :       /* Make absolutely sure that this is a complete type.  */
    5728                 :        8581 :       if (tmp_ss_info->string_length)
    5729                 :        2563 :         tmp_ss_info->data.temp.type
    5730                 :        2563 :                 = gfc_get_character_type_len_for_eltype
    5731                 :        2563 :                         (TREE_TYPE (tmp_ss_info->data.temp.type),
    5732                 :             :                          tmp_ss_info->string_length);
    5733                 :             : 
    5734                 :        8581 :       tmp = tmp_ss_info->data.temp.type;
    5735                 :        8581 :       memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
    5736                 :        8581 :       tmp_ss_info->type = GFC_SS_SECTION;
    5737                 :             : 
    5738                 :        8581 :       gcc_assert (tmp_ss->dimen != 0);
    5739                 :             : 
    5740                 :        8581 :       gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
    5741                 :             :                                    NULL_TREE, false, true, false, where);
    5742                 :             :     }
    5743                 :             : 
    5744                 :             :   /* For array parameters we don't have loop variables, so don't calculate the
    5745                 :             :      translations.  */
    5746                 :      147749 :   if (!loop->array_parameter)
    5747                 :       89997 :     gfc_set_delta (loop);
    5748                 :      147749 : }
    5749                 :             : 
    5750                 :             : 
    5751                 :             : /* Calculates how to transform from loop variables to array indices for each
    5752                 :             :    array: once loop bounds are chosen, sets the difference (DELTA field) between
    5753                 :             :    loop bounds and array reference bounds, for each array info.  */
    5754                 :             : 
    5755                 :             : void
    5756                 :       90729 : gfc_set_delta (gfc_loopinfo *loop)
    5757                 :             : {
    5758                 :       90729 :   gfc_ss *ss, **loopspec;
    5759                 :       90729 :   gfc_array_info *info;
    5760                 :       90729 :   tree tmp;
    5761                 :       90729 :   int n, dim;
    5762                 :             : 
    5763                 :       90729 :   gfc_loopinfo * const outer_loop = outermost_loop (loop);
    5764                 :             : 
    5765                 :       90729 :   loopspec = loop->specloop;
    5766                 :             : 
    5767                 :             :   /* Calculate the translation from loop variables to array indices.  */
    5768                 :      274459 :   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
    5769                 :             :     {
    5770                 :      183730 :       gfc_ss_type ss_type;
    5771                 :             : 
    5772                 :      183730 :       ss_type = ss->info->type;
    5773                 :      183730 :       if (ss_type != GFC_SS_SECTION
    5774                 :      183730 :           && ss_type != GFC_SS_COMPONENT
    5775                 :       74460 :           && ss_type != GFC_SS_CONSTRUCTOR)
    5776                 :       44663 :         continue;
    5777                 :             : 
    5778                 :      305769 :       info = &ss->info->data.array;
    5779                 :             : 
    5780                 :      305769 :       for (n = 0; n < ss->dimen; n++)
    5781                 :             :         {
    5782                 :             :           /* If we are specifying the range the delta is already set.  */
    5783                 :      166702 :           if (loopspec[n] != ss)
    5784                 :             :             {
    5785                 :       86763 :               dim = ss->dim[n];
    5786                 :             : 
    5787                 :             :               /* Calculate the offset relative to the loop variable.
    5788                 :             :                  First multiply by the stride.  */
    5789                 :       86763 :               tmp = loop->from[n];
    5790                 :       86763 :               if (!integer_onep (info->stride[dim]))
    5791                 :        2433 :                 tmp = fold_build2_loc (input_location, MULT_EXPR,
    5792                 :             :                                        gfc_array_index_type,
    5793                 :             :                                        tmp, info->stride[dim]);
    5794                 :             : 
    5795                 :             :               /* Then subtract this from our starting value.  */
    5796                 :       86763 :               tmp = fold_build2_loc (input_location, MINUS_EXPR,
    5797                 :             :                                      gfc_array_index_type,
    5798                 :             :                                      info->start[dim], tmp);
    5799                 :             : 
    5800                 :       86763 :               info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
    5801                 :             :             }
    5802                 :             :         }
    5803                 :             :     }
    5804                 :             : 
    5805                 :       91306 :   for (loop = loop->nested; loop; loop = loop->next)
    5806                 :         577 :     gfc_set_delta (loop);
    5807                 :       90729 : }
    5808                 :             : 
    5809                 :             : 
    5810                 :             : /* Calculate the size of a given array dimension from the bounds.  This
    5811                 :             :    is simply (ubound - lbound + 1) if this expression is positive
    5812                 :             :    or 0 if it is negative (pick either one if it is zero).  Optionally
    5813                 :             :    (if or_expr is present) OR the (expression != 0) condition to it.  */
    5814                 :             : 
    5815                 :             : tree
    5816                 :       16663 : gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
    5817                 :             : {
    5818                 :       16663 :   tree res;
    5819                 :       16663 :   tree cond;
    5820                 :             : 
    5821                 :             :   /* Calculate (ubound - lbound + 1).  */
    5822                 :       16663 :   res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    5823                 :             :                          ubound, lbound);
    5824                 :       16663 :   res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
    5825                 :             :                          gfc_index_one_node);
    5826                 :             : 
    5827                 :             :   /* Check whether the size for this dimension is negative.  */
    5828                 :       16663 :   cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
    5829                 :             :                           gfc_index_zero_node);
    5830                 :       16663 :   res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
    5831                 :             :                          gfc_index_zero_node, res);
    5832                 :             : 
    5833                 :             :   /* Build OR expression.  */
    5834                 :       16663 :   if (or_expr)
    5835                 :       13828 :     *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
    5836                 :             :                                 logical_type_node, *or_expr, cond);
    5837                 :             : 
    5838                 :       16663 :   return res;
    5839                 :             : }
    5840                 :             : 
    5841                 :             : 
    5842                 :             : /* For an array descriptor, get the total number of elements.  This is just
    5843                 :             :    the product of the extents along from_dim to to_dim.  */
    5844                 :             : 
    5845                 :             : static tree
    5846                 :         478 : gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
    5847                 :             : {
    5848                 :         478 :   tree res;
    5849                 :         478 :   int dim;
    5850                 :             : 
    5851                 :         478 :   res = gfc_index_one_node;
    5852                 :             : 
    5853                 :        1166 :   for (dim = from_dim; dim < to_dim; ++dim)
    5854                 :             :     {
    5855                 :         688 :       tree lbound;
    5856                 :         688 :       tree ubound;
    5857                 :         688 :       tree extent;
    5858                 :             : 
    5859                 :         688 :       lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
    5860                 :         688 :       ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
    5861                 :             : 
    5862                 :         688 :       extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
    5863                 :         688 :       res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    5864                 :             :                              res, extent);
    5865                 :             :     }
    5866                 :             : 
    5867                 :         478 :   return res;
    5868                 :             : }
    5869                 :             : 
    5870                 :             : 
    5871                 :             : /* Full size of an array.  */
    5872                 :             : 
    5873                 :             : tree
    5874                 :         452 : gfc_conv_descriptor_size (tree desc, int rank)
    5875                 :             : {
    5876                 :         452 :   return gfc_conv_descriptor_size_1 (desc, 0, rank);
    5877                 :             : }
    5878                 :             : 
    5879                 :             : 
    5880                 :             : /* Size of a coarray for all dimensions but the last.  */
    5881                 :             : 
    5882                 :             : tree
    5883                 :          26 : gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
    5884                 :             : {
    5885                 :          26 :   return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
    5886                 :             : }
    5887                 :             : 
    5888                 :             : 
    5889                 :             : /* Fills in an array descriptor, and returns the size of the array.
    5890                 :             :    The size will be a simple_val, ie a variable or a constant.  Also
    5891                 :             :    calculates the offset of the base.  The pointer argument overflow,
    5892                 :             :    which should be of integer type, will increase in value if overflow
    5893                 :             :    occurs during the size calculation.  Returns the size of the array.
    5894                 :             :    {
    5895                 :             :     stride = 1;
    5896                 :             :     offset = 0;
    5897                 :             :     for (n = 0; n < rank; n++)
    5898                 :             :       {
    5899                 :             :         a.lbound[n] = specified_lower_bound;
    5900                 :             :         offset = offset + a.lbond[n] * stride;
    5901                 :             :         size = 1 - lbound;
    5902                 :             :         a.ubound[n] = specified_upper_bound;
    5903                 :             :         a.stride[n] = stride;
    5904                 :             :         size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
    5905                 :             :         overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
    5906                 :             :         stride = stride * size;
    5907                 :             :       }
    5908                 :             :     for (n = rank; n < rank+corank; n++)
    5909                 :             :       (Set lcobound/ucobound as above.)
    5910                 :             :     element_size = sizeof (array element);
    5911                 :             :     if (!rank)
    5912                 :             :       return element_size
    5913                 :             :     stride = (size_t) stride;
    5914                 :             :     overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
    5915                 :             :     stride = stride * element_size;
    5916                 :             :     return (stride);
    5917                 :             :    }  */
    5918                 :             : /*GCC ARRAYS*/
    5919                 :             : 
    5920                 :             : static tree
    5921                 :       10210 : gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
    5922                 :             :                      gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
    5923                 :             :                      stmtblock_t * descriptor_block, tree * overflow,
    5924                 :             :                      tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
    5925                 :             :                      tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
    5926                 :             :                      tree *element_size)
    5927                 :             : {
    5928                 :       10210 :   tree type;
    5929                 :       10210 :   tree tmp;
    5930                 :       10210 :   tree size;
    5931                 :       10210 :   tree offset;
    5932                 :       10210 :   tree stride;
    5933                 :       10210 :   tree or_expr;
    5934                 :       10210 :   tree thencase;
    5935                 :       10210 :   tree elsecase;
    5936                 :       10210 :   tree cond;
    5937                 :       10210 :   tree var;
    5938                 :       10210 :   stmtblock_t thenblock;
    5939                 :       10210 :   stmtblock_t elseblock;
    5940                 :       10210 :   gfc_expr *ubound;
    5941                 :       10210 :   gfc_se se;
    5942                 :       10210 :   int n;
    5943                 :             : 
    5944                 :       10210 :   type = TREE_TYPE (descriptor);
    5945                 :             : 
    5946                 :       10210 :   stride = gfc_index_one_node;
    5947                 :       10210 :   offset = gfc_index_zero_node;
    5948                 :             : 
    5949                 :             :   /* Set the dtype before the alloc, because registration of coarrays needs
    5950                 :             :      it initialized.  */
    5951                 :       10210 :   if (expr->ts.type == BT_CHARACTER
    5952                 :         967 :       && expr->ts.deferred
    5953                 :         462 :       && VAR_P (expr->ts.u.cl->backend_decl))
    5954                 :             :     {
    5955                 :         285 :       type = gfc_typenode_for_spec (&expr->ts);
    5956                 :         285 :       tmp = gfc_conv_descriptor_dtype (descriptor);
    5957                 :         285 :       gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
    5958                 :             :     }
    5959                 :        9925 :   else if (expr->ts.type == BT_CHARACTER
    5960                 :         682 :            && expr->ts.deferred
    5961                 :         177 :            && TREE_CODE (descriptor) == COMPONENT_REF)
    5962                 :             :     {
    5963                 :             :       /* Deferred character components have their string length tucked away
    5964                 :             :          in a hidden field of the derived type. Obtain that and use it to
    5965                 :             :          set the dtype. The charlen backend decl is zero because the field
    5966                 :             :          type is zero length.  */
    5967                 :         159 :       gfc_ref *ref;
    5968                 :         159 :       tmp = NULL_TREE;
    5969                 :         159 :       for (ref = expr->ref; ref; ref = ref->next)
    5970                 :         159 :         if (ref->type == REF_COMPONENT
    5971                 :         159 :             && gfc_deferred_strlen (ref->u.c.component, &tmp))
    5972                 :             :           break;
    5973                 :         159 :       gcc_assert (tmp != NULL_TREE);
    5974                 :         159 :       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
    5975                 :         159 :                              TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
    5976                 :         159 :       tmp = fold_convert (gfc_charlen_type_node, tmp);
    5977                 :         159 :       type = gfc_get_character_type_len (expr->ts.kind, tmp);
    5978                 :         159 :       tmp = gfc_conv_descriptor_dtype (descriptor);
    5979                 :         159 :       gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
    5980                 :         159 :     }
    5981                 :        9766 :   else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
    5982                 :             :     {
    5983                 :         871 :       tmp = gfc_conv_descriptor_dtype (descriptor);
    5984                 :         871 :       gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
    5985                 :             :     }
    5986                 :             :   else
    5987                 :             :     {
    5988                 :        8895 :       tmp = gfc_conv_descriptor_dtype (descriptor);
    5989                 :        8895 :       gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
    5990                 :             :     }
    5991                 :             : 
    5992                 :       10210 :   or_expr = logical_false_node;
    5993                 :             : 
    5994                 :       24038 :   for (n = 0; n < rank; n++)
    5995                 :             :     {
    5996                 :       13828 :       tree conv_lbound;
    5997                 :       13828 :       tree conv_ubound;
    5998                 :             : 
    5999                 :             :       /* We have 3 possibilities for determining the size of the array:
    6000                 :             :          lower == NULL    => lbound = 1, ubound = upper[n]
    6001                 :             :          upper[n] = NULL  => lbound = 1, ubound = lower[n]
    6002                 :             :          upper[n] != NULL => lbound = lower[n], ubound = upper[n]  */
    6003                 :       13828 :       ubound = upper[n];
    6004                 :             : 
    6005                 :             :       /* Set lower bound.  */
    6006                 :       13828 :       gfc_init_se (&se, NULL);
    6007                 :       13828 :       if (expr3_desc != NULL_TREE)
    6008                 :             :         {
    6009                 :        1302 :           if (e3_has_nodescriptor)
    6010                 :             :             /* The lbound of nondescriptor arrays like array constructors,
    6011                 :             :                nonallocatable/nonpointer function results/variables,
    6012                 :             :                start at zero, but when allocating it, the standard expects
    6013                 :             :                the array to start at one.  */
    6014                 :         849 :             se.expr = gfc_index_one_node;
    6015                 :             :           else
    6016                 :         453 :             se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
    6017                 :             :                                                       gfc_rank_cst[n]);
    6018                 :             :         }
    6019                 :       12526 :       else if (lower == NULL)
    6020                 :        9801 :         se.expr = gfc_index_one_node;
    6021                 :             :       else
    6022                 :             :         {
    6023                 :        2725 :           gcc_assert (lower[n]);
    6024                 :        2725 :           if (ubound)
    6025                 :             :             {
    6026                 :        2176 :               gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
    6027                 :        2176 :               gfc_add_block_to_block (pblock, &se.pre);
    6028                 :             :             }
    6029                 :             :           else
    6030                 :             :             {
    6031                 :         549 :               se.expr = gfc_index_one_node;
    6032                 :         549 :               ubound = lower[n];
    6033                 :             :             }
    6034                 :             :         }
    6035                 :       13828 :       gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
    6036                 :             :                                       gfc_rank_cst[n], se.expr);
    6037                 :       13828 :       conv_lbound = se.expr;
    6038                 :             : 
    6039                 :             :       /* Work out the offset for this component.  */
    6040                 :       13828 :       tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    6041                 :             :                              se.expr, stride);
    6042                 :       13828 :       offset = fold_build2_loc (input_location, MINUS_EXPR,
    6043                 :             :                                 gfc_array_index_type, offset, tmp);
    6044                 :             : 
    6045                 :             :       /* Set upper bound.  */
    6046                 :       13828 :       gfc_init_se (&se, NULL);
    6047                 :       13828 :       if (expr3_desc != NULL_TREE)
    6048                 :             :         {
    6049                 :        1302 :           if (e3_has_nodescriptor)
    6050                 :             :             {
    6051                 :             :               /* The lbound of nondescriptor arrays like array constructors,
    6052                 :             :                  nonallocatable/nonpointer function results/variables,
    6053                 :             :                  start at zero, but when allocating it, the standard expects
    6054                 :             :                  the array to start at one.  Therefore fix the upper bound to be
    6055                 :             :                  (desc.ubound - desc.lbound) + 1.  */
    6056                 :         849 :               tmp = fold_build2_loc (input_location, MINUS_EXPR,
    6057                 :             :                                      gfc_array_index_type,
    6058                 :             :                                      gfc_conv_descriptor_ubound_get (
    6059                 :             :                                        expr3_desc, gfc_rank_cst[n]),
    6060                 :             :                                      gfc_conv_descriptor_lbound_get (
    6061                 :             :                                        expr3_desc, gfc_rank_cst[n]));
    6062                 :         849 :               tmp = fold_build2_loc (input_location, PLUS_EXPR,
    6063                 :             :                                      gfc_array_index_type, tmp,
    6064                 :             :                                      gfc_index_one_node);
    6065                 :         849 :               se.expr = gfc_evaluate_now (tmp, pblock);
    6066                 :             :             }
    6067                 :             :           else
    6068                 :         453 :             se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
    6069                 :             :                                                       gfc_rank_cst[n]);
    6070                 :             :         }
    6071                 :             :       else
    6072                 :             :         {
    6073                 :       12526 :           gcc_assert (ubound);
    6074                 :       12526 :           gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
    6075                 :       12526 :           gfc_add_block_to_block (pblock, &se.pre);
    6076                 :       12526 :           if (ubound->expr_type == EXPR_FUNCTION)
    6077                 :         735 :             se.expr = gfc_evaluate_now (se.expr, pblock);
    6078                 :             :         }
    6079                 :       13828 :       gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
    6080                 :             :                                       gfc_rank_cst[n], se.expr);
    6081                 :       13828 :       conv_ubound = se.expr;
    6082                 :             : 
    6083                 :             :       /* Store the stride.  */
    6084                 :       13828 :       gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
    6085                 :             :                                       gfc_rank_cst[n], stride);
    6086                 :             : 
    6087                 :             :       /* Calculate size and check whether extent is negative.  */
    6088                 :       13828 :       size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
    6089                 :       13828 :       size = gfc_evaluate_now (size, pblock);
    6090                 :             : 
    6091                 :             :       /* Check whether multiplying the stride by the number of
    6092                 :             :          elements in this dimension would overflow. We must also check
    6093                 :             :          whether the current dimension has zero size in order to avoid
    6094                 :             :          division by zero.
    6095                 :             :       */
    6096                 :       13828 :       tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
    6097                 :             :                              gfc_array_index_type,
    6098                 :       13828 :                              fold_convert (gfc_array_index_type,
    6099                 :             :                                            TYPE_MAX_VALUE (gfc_array_index_type)),
    6100                 :             :                                            size);
    6101                 :       13828 :       cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
    6102                 :             :                                             logical_type_node, tmp, stride),
    6103                 :             :                            PRED_FORTRAN_OVERFLOW);
    6104                 :       13828 :       tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
    6105                 :             :                              integer_one_node, integer_zero_node);
    6106                 :       13828 :       cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
    6107                 :             :                                             logical_type_node, size,
    6108                 :             :                                             gfc_index_zero_node),
    6109                 :             :                            PRED_FORTRAN_SIZE_ZERO);
    6110                 :       13828 :       tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
    6111                 :             :                              integer_zero_node, tmp);
    6112                 :       13828 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
    6113                 :             :                              *overflow, tmp);
    6114                 :       13828 :       *overflow = gfc_evaluate_now (tmp, pblock);
    6115                 :             : 
    6116                 :             :       /* Multiply the stride by the number of elements in this dimension.  */
    6117                 :       13828 :       stride = fold_build2_loc (input_location, MULT_EXPR,
    6118                 :             :                                 gfc_array_index_type, stride, size);
    6119                 :       13828 :       stride = gfc_evaluate_now (stride, pblock);
    6120                 :             :     }
    6121                 :             : 
    6122                 :       10695 :   for (n = rank; n < rank + corank; n++)
    6123                 :             :     {
    6124                 :         485 :       ubound = upper[n];
    6125                 :             : 
    6126                 :             :       /* Set lower bound.  */
    6127                 :         485 :       gfc_init_se (&se, NULL);
    6128                 :         485 :       if (lower == NULL || lower[n] == NULL)
    6129                 :             :         {
    6130                 :         269 :           gcc_assert (n == rank + corank - 1);
    6131                 :         269 :           se.expr = gfc_index_one_node;
    6132                 :             :         }
    6133                 :             :       else
    6134                 :             :         {
    6135                 :         216 :           if (ubound || n == rank + corank - 1)
    6136                 :             :             {
    6137                 :         142 :               gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
    6138                 :         142 :               gfc_add_block_to_block (pblock, &se.pre);
    6139                 :             :             }
    6140                 :             :           else
    6141                 :             :             {
    6142                 :          74 :               se.expr = gfc_index_one_node;
    6143                 :          74 :               ubound = lower[n];
    6144                 :             :             }
    6145                 :             :         }
    6146                 :         485 :       gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
    6147                 :             :                                       gfc_rank_cst[n], se.expr);
    6148                 :             : 
    6149                 :         485 :       if (n < rank + corank - 1)
    6150                 :             :         {
    6151                 :         143 :           gfc_init_se (&se, NULL);
    6152                 :         143 :           gcc_assert (ubound);
    6153                 :         143 :           gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
    6154                 :         143 :           gfc_add_block_to_block (pblock, &se.pre);
    6155                 :         143 :           gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
    6156                 :             :                                           gfc_rank_cst[n], se.expr);
    6157                 :             :         }
    6158                 :             :     }
    6159                 :             : 
    6160                 :             :   /* The stride is the number of elements in the array, so multiply by the
    6161                 :             :      size of an element to get the total size.  Obviously, if there is a
    6162                 :             :      SOURCE expression (expr3) we must use its element size.  */
    6163                 :       10210 :   if (expr3_elem_size != NULL_TREE)
    6164                 :        2739 :     tmp = expr3_elem_size;
    6165                 :        7471 :   else if (expr3 != NULL)
    6166                 :             :     {
    6167                 :           0 :       if (expr3->ts.type == BT_CLASS)
    6168                 :             :         {
    6169                 :           0 :           gfc_se se_sz;
    6170                 :           0 :           gfc_expr *sz = gfc_copy_expr (expr3);
    6171                 :           0 :           gfc_add_vptr_component (sz);
    6172                 :           0 :           gfc_add_size_component (sz);
    6173                 :           0 :           gfc_init_se (&se_sz, NULL);
    6174                 :           0 :           gfc_conv_expr (&se_sz, sz);
    6175                 :           0 :           gfc_free_expr (sz);
    6176                 :           0 :           tmp = se_sz.expr;
    6177                 :             :         }
    6178                 :             :       else
    6179                 :             :         {
    6180                 :           0 :           tmp = gfc_typenode_for_spec (&expr3->ts);
    6181                 :           0 :           tmp = TYPE_SIZE_UNIT (tmp);
    6182                 :             :         }
    6183                 :             :     }
    6184                 :             :   else
    6185                 :        7471 :     tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
    6186                 :             : 
    6187                 :             :   /* Convert to size_t.  */
    6188                 :       10210 :   *element_size = fold_convert (size_type_node, tmp);
    6189                 :             : 
    6190                 :       10210 :   if (rank == 0)
    6191                 :             :     return *element_size;
    6192                 :             : 
    6193                 :       10061 :   *nelems = gfc_evaluate_now (stride, pblock);
    6194                 :       10061 :   stride = fold_convert (size_type_node, stride);
    6195                 :             : 
    6196                 :             :   /* First check for overflow. Since an array of type character can
    6197                 :             :      have zero element_size, we must check for that before
    6198                 :             :      dividing.  */
    6199                 :       10061 :   tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
    6200                 :             :                          size_type_node,
    6201                 :       10061 :                          TYPE_MAX_VALUE (size_type_node), *element_size);
    6202                 :       10061 :   cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
    6203                 :             :                                         logical_type_node, tmp, stride),
    6204                 :             :                        PRED_FORTRAN_OVERFLOW);
    6205                 :       10061 :   tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
    6206                 :             :                          integer_one_node, integer_zero_node);
    6207                 :       10061 :   cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
    6208                 :             :                                         logical_type_node, *element_size,
    6209                 :       10061 :                                         build_int_cst (size_type_node, 0)),
    6210                 :             :                        PRED_FORTRAN_SIZE_ZERO);
    6211                 :       10061 :   tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
    6212                 :             :                          integer_zero_node, tmp);
    6213                 :       10061 :   tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
    6214                 :             :                          *overflow, tmp);
    6215                 :       10061 :   *overflow = gfc_evaluate_now (tmp, pblock);
    6216                 :             : 
    6217                 :       10061 :   size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
    6218                 :             :                           stride, *element_size);
    6219                 :             : 
    6220                 :       10061 :   if (poffset != NULL)
    6221                 :             :     {
    6222                 :       10061 :       offset = gfc_evaluate_now (offset, pblock);
    6223                 :       10061 :       *poffset = offset;
    6224                 :             :     }
    6225                 :             : 
    6226                 :       10061 :   if (integer_zerop (or_expr))
    6227                 :             :     return size;
    6228                 :        3192 :   if (integer_onep (or_expr))
    6229                 :         340 :     return build_int_cst (size_type_node, 0);
    6230                 :             : 
    6231                 :        2852 :   var = gfc_create_var (TREE_TYPE (size), "size");
    6232                 :        2852 :   gfc_start_block (&thenblock);
    6233                 :        2852 :   gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
    6234                 :        2852 :   thencase = gfc_finish_block (&thenblock);
    6235                 :             : 
    6236                 :        2852 :   gfc_start_block (&elseblock);
    6237                 :        2852 :   gfc_add_modify (&elseblock, var, size);
    6238                 :        2852 :   elsecase = gfc_finish_block (&elseblock);
    6239                 :             : 
    6240                 :        2852 :   tmp = gfc_evaluate_now (or_expr, pblock);
    6241                 :        2852 :   tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
    6242                 :        2852 :   gfc_add_expr_to_block (pblock, tmp);
    6243                 :             : 
    6244                 :        2852 :   return var;
    6245                 :             : }
    6246                 :             : 
    6247                 :             : 
    6248                 :             : /* Retrieve the last ref from the chain.  This routine is specific to
    6249                 :             :    gfc_array_allocate ()'s needs.  */
    6250                 :             : 
    6251                 :             : bool
    6252                 :       16133 : retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
    6253                 :             : {
    6254                 :       16133 :   gfc_ref *ref, *prev_ref;
    6255                 :             : 
    6256                 :       16133 :   ref = *ref_in;
    6257                 :             :   /* Prevent warnings for uninitialized variables.  */
    6258                 :       16133 :   prev_ref = *prev_ref_in;
    6259                 :       22221 :   while (ref && ref->next != NULL)
    6260                 :             :     {
    6261                 :        6088 :       gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
    6262                 :             :                   || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
    6263                 :             :       prev_ref = ref;
    6264                 :             :       ref = ref->next;
    6265                 :             :     }
    6266                 :             : 
    6267                 :       16133 :   if (ref == NULL || ref->type != REF_ARRAY)
    6268                 :             :     return false;
    6269                 :             : 
    6270                 :       11326 :   *ref_in = ref;
    6271                 :       11326 :   *prev_ref_in = prev_ref;
    6272                 :       11326 :   return true;
    6273                 :             : }
    6274                 :             : 
    6275                 :             : /* Initializes the descriptor and generates a call to _gfor_allocate.  Does
    6276                 :             :    the work for an ALLOCATE statement.  */
    6277                 :             : /*GCC ARRAYS*/
    6278                 :             : 
    6279                 :             : bool
    6280                 :       15017 : gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
    6281                 :             :                     tree errlen, tree label_finish, tree expr3_elem_size,
    6282                 :             :                     tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
    6283                 :             :                     bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc)
    6284                 :             : {
    6285                 :       15017 :   tree tmp;
    6286                 :       15017 :   tree pointer;
    6287                 :       15017 :   tree offset = NULL_TREE;
    6288                 :       15017 :   tree token = NULL_TREE;
    6289                 :       15017 :   tree size;
    6290                 :       15017 :   tree msg;
    6291                 :       15017 :   tree error = NULL_TREE;
    6292                 :       15017 :   tree overflow; /* Boolean storing whether size calculation overflows.  */
    6293                 :       15017 :   tree var_overflow = NULL_TREE;
    6294                 :       15017 :   tree cond;
    6295                 :       15017 :   tree set_descriptor;
    6296                 :       15017 :   tree not_prev_allocated = NULL_TREE;
    6297                 :       15017 :   tree element_size = NULL_TREE;
    6298                 :       15017 :   stmtblock_t set_descriptor_block;
    6299                 :       15017 :   stmtblock_t elseblock;
    6300                 :       15017 :   gfc_expr **lower;
    6301                 :       15017 :   gfc_expr **upper;
    6302                 :       15017 :   gfc_ref *ref, *prev_ref = NULL, *coref;
    6303                 :       15017 :   bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
    6304                 :             :       non_ulimate_coarray_ptr_comp;
    6305                 :       15017 :   tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE;
    6306                 :             : 
    6307                 :       15017 :   ref = expr->ref;
    6308                 :             : 
    6309                 :             :   /* Find the last reference in the chain.  */
    6310                 :       15017 :   if (!retrieve_last_ref (&ref, &prev_ref))
    6311                 :             :     return false;
    6312                 :             : 
    6313                 :             :   /* Take the allocatable and coarray properties solely from the expr-ref's
    6314                 :             :      attributes and not from source=-expression.  */
    6315                 :       10210 :   if (!prev_ref)
    6316                 :             :     {
    6317                 :        6921 :       allocatable = expr->symtree->n.sym->attr.allocatable;
    6318                 :        6921 :       dimension = expr->symtree->n.sym->attr.dimension;
    6319                 :        6921 :       non_ulimate_coarray_ptr_comp = false;
    6320                 :             :     }
    6321                 :             :   else
    6322                 :             :     {
    6323                 :        3289 :       allocatable = prev_ref->u.c.component->attr.allocatable;
    6324                 :             :       /* Pointer components in coarrayed derived types must be treated
    6325                 :             :          specially in that they are registered without a check if the are
    6326                 :             :          already associated.  This does not hold for ultimate coarray
    6327                 :             :          pointers.  */
    6328                 :        3289 :       non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
    6329                 :        3289 :               && !prev_ref->u.c.component->attr.codimension);
    6330                 :        3289 :       dimension = prev_ref->u.c.component->attr.dimension;
    6331                 :             :     }
    6332                 :             : 
    6333                 :             :   /* For allocatable/pointer arrays in derived types, one of the refs has to be
    6334                 :             :      a coarray.  In this case it does not matter whether we are on this_image
    6335                 :             :      or not.  */
    6336                 :       10210 :   coarray = false;
    6337                 :       24448 :   for (coref = expr->ref; coref; coref = coref->next)
    6338                 :       14742 :     if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
    6339                 :             :       {
    6340                 :             :         coarray = true;
    6341                 :             :         break;
    6342                 :             :       }
    6343                 :             : 
    6344                 :       10210 :   if (!dimension)
    6345                 :         149 :     gcc_assert (coarray);
    6346                 :             : 
    6347                 :       10210 :   if (ref->u.ar.type == AR_FULL && expr3 != NULL)
    6348                 :             :     {
    6349                 :        1116 :       gfc_ref *old_ref = ref;
    6350                 :             :       /* F08:C633: Array shape from expr3.  */
    6351                 :        1116 :       ref = expr3->ref;
    6352                 :             : 
    6353                 :             :       /* Find the last reference in the chain.  */
    6354                 :        1116 :       if (!retrieve_last_ref (&ref, &prev_ref))
    6355                 :             :         {
    6356                 :           0 :           if (expr3->expr_type == EXPR_FUNCTION
    6357                 :           0 :               && gfc_expr_attr (expr3).dimension)
    6358                 :           0 :             ref = old_ref;
    6359                 :             :           else
    6360                 :           0 :             return false;
    6361                 :             :         }
    6362                 :             :       alloc_w_e3_arr_spec = true;
    6363                 :             :     }
    6364                 :             : 
    6365                 :             :   /* Figure out the size of the array.  */
    6366                 :       10210 :   switch (ref->u.ar.type)
    6367                 :             :     {
    6368                 :        7596 :     case AR_ELEMENT:
    6369                 :        7596 :       if (!coarray)
    6370                 :             :         {
    6371                 :        7138 :           lower = NULL;
    6372                 :        7138 :           upper = ref->u.ar.start;
    6373                 :        7138 :           break;
    6374                 :             :         }
    6375                 :             :       /* Fall through.  */
    6376                 :             : 
    6377                 :        1986 :     case AR_SECTION:
    6378                 :        1986 :       lower = ref->u.ar.start;
    6379                 :        1986 :       upper = ref->u.ar.end;
    6380                 :        1986 :       break;
    6381                 :             : 
    6382                 :        1086 :     case AR_FULL:
    6383                 :        1086 :       gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
    6384                 :             :                   || alloc_w_e3_arr_spec);
    6385                 :             : 
    6386                 :        1086 :       lower = ref->u.ar.as->lower;
    6387                 :        1086 :       upper = ref->u.ar.as->upper;
    6388                 :        1086 :       break;
    6389                 :             : 
    6390                 :           0 :     default:
    6391                 :           0 :       gcc_unreachable ();
    6392                 :       10210 :       break;
    6393                 :             :     }
    6394                 :             : 
    6395                 :       10210 :   overflow = integer_zero_node;
    6396                 :             : 
    6397                 :       10210 :   if (expr->ts.type == BT_CHARACTER
    6398                 :         967 :       && TREE_CODE (se->string_length) == COMPONENT_REF
    6399                 :         159 :       && expr->ts.u.cl->backend_decl != se->string_length
    6400                 :         159 :       && VAR_P (expr->ts.u.cl->backend_decl))
    6401                 :           0 :     gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
    6402                 :           0 :                     fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
    6403                 :             :                                   se->string_length));
    6404                 :             : 
    6405                 :       10210 :   gfc_init_block (&set_descriptor_block);
    6406                 :             :   /* Take the corank only from the actual ref and not from the coref.  The
    6407                 :             :      later will mislead the generation of the array dimensions for allocatable/
    6408                 :             :      pointer components in derived types.  */
    6409                 :       19808 :   size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
    6410                 :        9094 :                                                            : ref->u.ar.as->rank,
    6411                 :         504 :                               coarray ? ref->u.ar.as->corank : 0,
    6412                 :             :                               &offset, lower, upper,
    6413                 :             :                               &se->pre, &set_descriptor_block, &overflow,
    6414                 :             :                               expr3_elem_size, nelems, expr3, e3_arr_desc,
    6415                 :             :                               e3_has_nodescriptor, expr, &element_size);
    6416                 :             : 
    6417                 :       10210 :   if (dimension)
    6418                 :             :     {
    6419                 :       10061 :       var_overflow = gfc_create_var (integer_type_node, "overflow");
    6420                 :       10061 :       gfc_add_modify (&se->pre, var_overflow, overflow);
    6421                 :             : 
    6422                 :       10061 :       if (status == NULL_TREE)
    6423                 :             :         {
    6424                 :             :           /* Generate the block of code handling overflow.  */
    6425                 :        9847 :           msg = gfc_build_addr_expr (pchar_type_node,
    6426                 :             :                     gfc_build_localized_cstring_const
    6427                 :             :                         ("Integer overflow when calculating the amount of "
    6428                 :             :                          "memory to allocate"));
    6429                 :        9847 :           error = build_call_expr_loc (input_location,
    6430                 :             :                                        gfor_fndecl_runtime_error, 1, msg);
    6431                 :             :         }
    6432                 :             :       else
    6433                 :             :         {
    6434                 :         214 :           tree status_type = TREE_TYPE (status);
    6435                 :         214 :           stmtblock_t set_status_block;
    6436                 :             : 
    6437                 :         214 :           gfc_start_block (&set_status_block);
    6438                 :         214 :           gfc_add_modify (&set_status_block, status,
    6439                 :         214 :                           build_int_cst (status_type, LIBERROR_ALLOCATION));
    6440                 :         214 :           error = gfc_finish_block (&set_status_block);
    6441                 :             :         }
    6442                 :             :     }
    6443                 :             : 
    6444                 :             :   /* Allocate memory to store the data.  */
    6445                 :       10210 :   if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
    6446                 :           0 :     se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
    6447                 :             : 
    6448                 :       10210 :   if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
    6449                 :             :     {
    6450                 :         284 :       pointer = non_ulimate_coarray_ptr_comp ? se->expr
    6451                 :         215 :                                       : gfc_conv_descriptor_data_get (se->expr);
    6452                 :         284 :       token = gfc_conv_descriptor_token (se->expr);
    6453                 :         284 :       token = gfc_build_addr_expr (NULL_TREE, token);
    6454                 :             :     }
    6455                 :             :   else
    6456                 :             :     {
    6457                 :        9926 :       pointer = gfc_conv_descriptor_data_get (se->expr);
    6458                 :        9926 :       if (omp_alloc)
    6459                 :          30 :         omp_cond = boolean_true_node;
    6460                 :             :     }
    6461                 :       10210 :   STRIP_NOPS (pointer);
    6462                 :             : 
    6463                 :       10210 :   if (allocatable)
    6464                 :             :     {
    6465                 :        8202 :       not_prev_allocated = gfc_create_var (logical_type_node,
    6466                 :             :                                            "not_prev_allocated");
    6467                 :        8202 :       tmp = fold_build2_loc (input_location, EQ_EXPR,
    6468                 :             :                              logical_type_node, pointer,
    6469                 :        8202 :                              build_int_cst (TREE_TYPE (pointer), 0));
    6470                 :             : 
    6471                 :        8202 :       gfc_add_modify (&se->pre, not_prev_allocated, tmp);
    6472                 :             :     }
    6473                 :             : 
    6474                 :       10210 :   gfc_start_block (&elseblock);
    6475                 :             : 
    6476                 :       10210 :   tree succ_add_expr = NULL_TREE;
    6477                 :       10210 :   if (omp_cond)
    6478                 :             :     {
    6479                 :          30 :       tree align, alloc, sz;
    6480                 :          30 :       gfc_se se2;
    6481                 :          30 :       if (omp_alloc->u2.allocator)
    6482                 :             :         {
    6483                 :           7 :           gfc_init_se (&se2, NULL);
    6484                 :           7 :           gfc_conv_expr (&se2, omp_alloc->u2.allocator);
    6485                 :           7 :           gfc_add_block_to_block (&elseblock, &se2.pre);
    6486                 :           7 :           alloc = gfc_evaluate_now (se2.expr, &elseblock);
    6487                 :           7 :           gfc_add_block_to_block (&elseblock, &se2.post);
    6488                 :             :         }
    6489                 :             :       else
    6490                 :          23 :         alloc = build_zero_cst (ptr_type_node);
    6491                 :          30 :       tmp = TREE_TYPE (TREE_TYPE (pointer));
    6492                 :          30 :       if (tmp == void_type_node)
    6493                 :          30 :         tmp = gfc_typenode_for_spec (&expr->ts, 0);
    6494                 :          30 :       if (omp_alloc->u.align)
    6495                 :             :         {
    6496                 :          15 :           gfc_init_se (&se2, NULL);
    6497                 :          15 :           gfc_conv_expr (&se2, omp_alloc->u.align);
    6498                 :          15 :           gcc_assert (CONSTANT_CLASS_P (se2.expr)
    6499                 :             :                       && se2.pre.head == NULL
    6500                 :             :                       && se2.post.head == NULL);
    6501                 :          15 :           align = build_int_cst (size_type_node,
    6502                 :          15 :                                  MAX (tree_to_uhwi (se2.expr),
    6503                 :             :                                       TYPE_ALIGN_UNIT (tmp)));
    6504                 :             :         }
    6505                 :             :       else
    6506                 :          15 :         align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
    6507                 :          30 :       sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
    6508                 :             :                             fold_convert (size_type_node, size),
    6509                 :          30 :                             build_int_cst (size_type_node, 1));
    6510                 :          30 :       omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
    6511                 :          30 :       DECL_ATTRIBUTES (omp_alt_alloc)
    6512                 :          30 :         = tree_cons (get_identifier ("omp allocator"),
    6513                 :             :                      build_tree_list (NULL_TREE, alloc),
    6514                 :          30 :                      DECL_ATTRIBUTES (omp_alt_alloc));
    6515                 :          30 :       omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
    6516                 :          30 :       succ_add_expr = fold_build2_loc (input_location, MODIFY_EXPR,
    6517                 :             :                                        void_type_node,
    6518                 :             :                                        gfc_conv_descriptor_version (se->expr),
    6519                 :          30 :                                        build_int_cst (integer_type_node, 1));
    6520                 :             :     }
    6521                 :             : 
    6522                 :             :   /* The allocatable variant takes the old pointer as first argument.  */
    6523                 :       10210 :   if (allocatable)
    6524                 :        8634 :     gfc_allocate_allocatable (&elseblock, pointer, size, token,
    6525                 :             :                               status, errmsg, errlen, label_finish, expr,
    6526                 :         432 :                               coref != NULL ? coref->u.ar.as->corank : 0,
    6527                 :             :                               omp_cond, omp_alt_alloc, succ_add_expr);
    6528                 :        2008 :   else if (non_ulimate_coarray_ptr_comp && token)
    6529                 :             :     /* The token is set only for GFC_FCOARRAY_LIB mode.  */
    6530                 :          69 :     gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
    6531                 :             :                                 errmsg, errlen,
    6532                 :             :                                 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
    6533                 :             :   else
    6534                 :        1939 :     gfc_allocate_using_malloc (&elseblock, pointer, size, status,
    6535                 :             :                                omp_cond, omp_alt_alloc, succ_add_expr);
    6536                 :             : 
    6537                 :       10210 :   if (dimension)
    6538                 :             :     {
    6539                 :       10061 :       cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
    6540                 :             :                            logical_type_node, var_overflow, integer_zero_node),
    6541                 :             :                            PRED_FORTRAN_OVERFLOW);
    6542                 :       10061 :       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
    6543                 :             :                              error, gfc_finish_block (&elseblock));
    6544                 :             :     }
    6545                 :             :   else
    6546                 :         149 :     tmp = gfc_finish_block (&elseblock);
    6547                 :             : 
    6548                 :       10210 :   gfc_add_expr_to_block (&se->pre, tmp);
    6549                 :             : 
    6550                 :             :   /* Update the array descriptor with the offset and the span.  */
    6551                 :       10210 :   if (dimension)
    6552                 :             :     {
    6553                 :       10061 :       gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
    6554                 :       10061 :       tmp = fold_convert (gfc_array_index_type, element_size);
    6555                 :       10061 :       gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
    6556                 :             :     }
    6557                 :             : 
    6558                 :       10210 :   set_descriptor = gfc_finish_block (&set_descriptor_block);
    6559                 :       10210 :   if (status != NULL_TREE)
    6560                 :             :     {
    6561                 :         228 :       cond = fold_build2_loc (input_location, EQ_EXPR,
    6562                 :             :                           logical_type_node, status,
    6563                 :         228 :                           build_int_cst (TREE_TYPE (status), 0));
    6564                 :             : 
    6565                 :         228 :       if (not_prev_allocated != NULL_TREE)
    6566                 :         207 :         cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
    6567                 :             :                                 logical_type_node, cond, not_prev_allocated);
    6568                 :             : 
    6569                 :         228 :       gfc_add_expr_to_block (&se->pre,
    6570                 :             :                  fold_build3_loc (input_location, COND_EXPR, void_type_node,
    6571                 :             :                                   cond,
    6572                 :             :                                   set_descriptor,
    6573                 :             :                                   build_empty_stmt (input_location)));
    6574                 :             :     }
    6575                 :             :   else
    6576                 :        9982 :       gfc_add_expr_to_block (&se->pre, set_descriptor);
    6577                 :             : 
    6578                 :             :   return true;
    6579                 :             : }
    6580                 :             : 
    6581                 :             : 
    6582                 :             : /* Create an array constructor from an initialization expression.
    6583                 :             :    We assume the frontend already did any expansions and conversions.  */
    6584                 :             : 
    6585                 :             : tree
    6586                 :        6616 : gfc_conv_array_initializer (tree type, gfc_expr * expr)
    6587                 :             : {
    6588                 :        6616 :   gfc_constructor *c;
    6589                 :        6616 :   tree tmp;
    6590                 :        6616 :   gfc_se se;
    6591                 :        6616 :   tree index, range;
    6592                 :        6616 :   vec<constructor_elt, va_gc> *v = NULL;
    6593                 :             : 
    6594                 :        6616 :   if (expr->expr_type == EXPR_VARIABLE
    6595                 :           0 :       && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
    6596                 :           0 :       && expr->symtree->n.sym->value)
    6597                 :        6616 :     expr = expr->symtree->n.sym->value;
    6598                 :             : 
    6599                 :        6616 :   switch (expr->expr_type)
    6600                 :             :     {
    6601                 :        1047 :     case EXPR_CONSTANT:
    6602                 :        1047 :     case EXPR_STRUCTURE:
    6603                 :             :       /* A single scalar or derived type value.  Create an array with all
    6604                 :             :          elements equal to that value.  */
    6605                 :        1047 :       gfc_init_se (&se, NULL);
    6606                 :             : 
    6607                 :        1047 :       if (expr->expr_type == EXPR_CONSTANT)
    6608                 :         365 :         gfc_conv_constant (&se, expr);
    6609                 :             :       else
    6610                 :         682 :         gfc_conv_structure (&se, expr, 1);
    6611                 :             : 
    6612                 :        2094 :       if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
    6613                 :        1047 :                            TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
    6614                 :             :         break;
    6615                 :        2070 :       else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
    6616                 :        1035 :                                    TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
    6617                 :         144 :         range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
    6618                 :             :       else
    6619                 :        1782 :         range = build2 (RANGE_EXPR, gfc_array_index_type,
    6620                 :         891 :                         TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
    6621                 :         891 :                         TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
    6622                 :        1035 :       CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
    6623                 :        1035 :       break;
    6624                 :             : 
    6625                 :        5569 :     case EXPR_ARRAY:
    6626                 :             :       /* Create a vector of all the elements.  */
    6627                 :        5569 :       for (c = gfc_constructor_first (expr->value.constructor);
    6628                 :      149049 :            c && c->expr; c = gfc_constructor_next (c))
    6629                 :             :         {
    6630                 :      143480 :           if (c->iterator)
    6631                 :             :             {
    6632                 :             :               /* Problems occur when we get something like
    6633                 :             :                  integer :: a(lots) = (/(i, i=1, lots)/)  */
    6634                 :           0 :               gfc_fatal_error ("The number of elements in the array "
    6635                 :             :                                "constructor at %L requires an increase of "
    6636                 :             :                                "the allowed %d upper limit. See "
    6637                 :             :                                "%<-fmax-array-constructor%> option",
    6638                 :             :                                &expr->where, flag_max_array_constructor);
    6639                 :             :               return NULL_TREE;
    6640                 :             :             }
    6641                 :      143480 :           if (mpz_cmp_si (c->offset, 0) != 0)
    6642                 :      138144 :             index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
    6643                 :             :           else
    6644                 :             :             index = NULL_TREE;
    6645                 :             : 
    6646                 :      143480 :           if (mpz_cmp_si (c->repeat, 1) > 0)
    6647                 :             :             {
    6648                 :         152 :               tree tmp1, tmp2;
    6649                 :         152 :               mpz_t maxval;
    6650                 :             : 
    6651                 :         152 :               mpz_init (maxval);
    6652                 :         152 :               mpz_add (maxval, c->offset, c->repeat);
    6653                 :         152 :               mpz_sub_ui (maxval, maxval, 1);
    6654                 :         152 :               tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
    6655                 :         152 :               if (mpz_cmp_si (c->offset, 0) != 0)
    6656                 :             :                 {
    6657                 :          27 :                   mpz_add_ui (maxval, c->offset, 1);
    6658                 :          27 :                   tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
    6659                 :             :                 }
    6660                 :             :               else
    6661                 :         125 :                 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
    6662                 :             : 
    6663                 :         152 :               range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
    6664                 :         152 :               mpz_clear (maxval);
    6665                 :             :             }
    6666                 :             :           else
    6667                 :             :             range = NULL;
    6668                 :             : 
    6669                 :      143480 :           gfc_init_se (&se, NULL);
    6670                 :      143480 :           switch (c->expr->expr_type)
    6671                 :             :             {
    6672                 :      142280 :             case EXPR_CONSTANT:
    6673                 :      142280 :               gfc_conv_constant (&se, c->expr);
    6674                 :             : 
    6675                 :             :               /* See gfortran.dg/charlen_15.f90 for instance.  */
    6676                 :      142280 :               if (TREE_CODE (se.expr) == STRING_CST
    6677                 :        4929 :                   && TREE_CODE (type) == ARRAY_TYPE)
    6678                 :             :                 {
    6679                 :             :                   tree atype = type;
    6680                 :        9858 :                   while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
    6681                 :        4929 :                     atype = TREE_TYPE (atype);
    6682                 :        4929 :                   gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
    6683                 :             :                                        == INTEGER_TYPE);
    6684                 :        4929 :                   gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
    6685                 :             :                                        == TREE_TYPE (atype));
    6686                 :        4929 :                   if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
    6687                 :        4929 :                       > tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
    6688                 :             :                     {
    6689                 :           0 :                       unsigned HOST_WIDE_INT size
    6690                 :           0 :                         = tree_to_uhwi (TYPE_SIZE_UNIT (atype));
    6691                 :           0 :                       const char *p = TREE_STRING_POINTER (se.expr);
    6692                 :             : 
    6693                 :           0 :                       se.expr = build_string (size, p);
    6694                 :             :                     }
    6695                 :        4929 :                   TREE_TYPE (se.expr) = atype;
    6696                 :             :                 }
    6697                 :             :               break;
    6698                 :             : 
    6699                 :        1200 :             case EXPR_STRUCTURE:
    6700                 :        1200 :               gfc_conv_structure (&se, c->expr, 1);
    6701                 :        1200 :               break;
    6702                 :             : 
    6703                 :           0 :             default:
    6704                 :             :               /* Catch those occasional beasts that do not simplify
    6705                 :             :                  for one reason or another, assuming that if they are
    6706                 :             :                  standard defying the frontend will catch them.  */
    6707                 :           0 :               gfc_conv_expr (&se, c->expr);
    6708                 :           0 :               break;
    6709                 :             :             }
    6710                 :             : 
    6711                 :      143480 :           if (range == NULL_TREE)
    6712                 :      143328 :             CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
    6713                 :             :           else
    6714                 :             :             {
    6715                 :         152 :               if (index != NULL_TREE)
    6716                 :          27 :                 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
    6717                 :      143632 :               CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
    6718                 :             :             }
    6719                 :             :         }
    6720                 :             :       break;
    6721                 :             : 
    6722                 :           0 :     case EXPR_NULL:
    6723                 :           0 :       return gfc_build_null_descriptor (type);
    6724                 :             : 
    6725                 :           0 :     default:
    6726                 :           0 :       gcc_unreachable ();
    6727                 :             :     }
    6728                 :             : 
    6729                 :             :   /* Create a constructor from the list of elements.  */
    6730                 :        6616 :   tmp = build_constructor (type, v);
    6731                 :        6616 :   TREE_CONSTANT (tmp) = 1;
    6732                 :        6616 :   return tmp;
    6733                 :             : }
    6734                 :             : 
    6735                 :             : 
    6736                 :             : /* Generate code to evaluate non-constant coarray cobounds.  */
    6737                 :             : 
    6738                 :             : void
    6739                 :       18087 : gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
    6740                 :             :                           const gfc_symbol *sym)
    6741                 :             : {
    6742                 :       18087 :   int dim;
    6743                 :       18087 :   tree ubound;
    6744                 :       18087 :   tree lbound;
    6745                 :       18087 :   gfc_se se;
    6746                 :       18087 :   gfc_array_spec *as;
    6747                 :             : 
    6748                 :       18087 :   as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
    6749                 :             : 
    6750                 :       18688 :   for (dim = as->rank; dim < as->rank + as->corank; dim++)
    6751                 :             :     {
    6752                 :             :       /* Evaluate non-constant array bound expressions.
    6753                 :             :          F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
    6754                 :             :          references a function, the result is finalized before execution of the
    6755                 :             :          executable constructs in the scoping unit.
    6756                 :             :          Adding the finalblocks enables this.  */
    6757                 :         601 :       lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
    6758                 :         601 :       if (as->lower[dim] && !INTEGER_CST_P (lbound))
    6759                 :             :         {
    6760                 :          96 :           gfc_init_se (&se, NULL);
    6761                 :          96 :           gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
    6762                 :          96 :           gfc_add_block_to_block (pblock, &se.pre);
    6763                 :          96 :           gfc_add_block_to_block (pblock, &se.finalblock);
    6764                 :          96 :           gfc_add_modify (pblock, lbound, se.expr);
    6765                 :             :         }
    6766                 :         601 :       ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
    6767                 :         601 :       if (as->upper[dim] && !INTEGER_CST_P (ubound))
    6768                 :             :         {
    6769                 :          50 :           gfc_init_se (&se, NULL);
    6770                 :          50 :           gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
    6771                 :          50 :           gfc_add_block_to_block (pblock, &se.pre);
    6772                 :          50 :           gfc_add_block_to_block (pblock, &se.finalblock);
    6773                 :          50 :           gfc_add_modify (pblock, ubound, se.expr);
    6774                 :             :         }
    6775                 :             :     }
    6776                 :       18087 : }
    6777                 :             : 
    6778                 :             : 
    6779                 :             : /* Generate code to evaluate non-constant array bounds.  Sets *poffset and
    6780                 :             :    returns the size (in elements) of the array.  */
    6781                 :             : 
    6782                 :             : tree
    6783                 :       11674 : gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
    6784                 :             :                         stmtblock_t * pblock)
    6785                 :             : {
    6786                 :       11674 :   gfc_array_spec *as;
    6787                 :       11674 :   tree size;
    6788                 :       11674 :   tree stride;
    6789                 :       11674 :   tree offset;
    6790                 :       11674 :   tree ubound;
    6791                 :       11674 :   tree lbound;
    6792                 :       11674 :   tree tmp;
    6793                 :       11674 :   gfc_se se;
    6794                 :             : 
    6795                 :       11674 :   int dim;
    6796                 :             : 
    6797                 :       11674 :   as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
    6798                 :             : 
    6799                 :       11674 :   size = gfc_index_one_node;
    6800                 :       11674 :   offset = gfc_index_zero_node;
    6801                 :       26637 :   for (dim = 0; dim < as->rank; dim++)
    6802                 :             :     {
    6803                 :             :       /* Evaluate non-constant array bound expressions.
    6804                 :             :          F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
    6805                 :             :          references a function, the result is finalized before execution of the
    6806                 :             :          executable constructs in the scoping unit.
    6807                 :             :          Adding the finalblocks enables this.  */
    6808                 :       14963 :       lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
    6809                 :       14963 :       if (as->lower[dim] && !INTEGER_CST_P (lbound))
    6810                 :             :         {
    6811                 :         484 :           gfc_init_se (&se, NULL);
    6812                 :         484 :           gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
    6813                 :         484 :           gfc_add_block_to_block (pblock, &se.pre);
    6814                 :         484 :           gfc_add_block_to_block (pblock, &se.finalblock);
    6815                 :         484 :           gfc_add_modify (pblock, lbound, se.expr);
    6816                 :             :         }
    6817                 :       14963 :       ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
    6818                 :       14963 :       if (as->upper[dim] && !INTEGER_CST_P (ubound))
    6819                 :             :         {
    6820                 :        8942 :           gfc_init_se (&se, NULL);
    6821                 :        8942 :           gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
    6822                 :        8942 :           gfc_add_block_to_block (pblock, &se.pre);
    6823                 :        8942 :           gfc_add_block_to_block (pblock, &se.finalblock);
    6824                 :        8942 :           gfc_add_modify (pblock, ubound, se.expr);
    6825                 :             :         }
    6826                 :             :       /* The offset of this dimension.  offset = offset - lbound * stride.  */
    6827                 :       14963 :       tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    6828                 :             :                              lbound, size);
    6829                 :       14963 :       offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    6830                 :             :                                 offset, tmp);
    6831                 :             : 
    6832                 :             :       /* The size of this dimension, and the stride of the next.  */
    6833                 :       14963 :       if (dim + 1 < as->rank)
    6834                 :        3330 :         stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
    6835                 :             :       else
    6836                 :       11633 :         stride = GFC_TYPE_ARRAY_SIZE (type);
    6837                 :             : 
    6838                 :       14963 :       if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
    6839                 :             :         {
    6840                 :             :           /* Calculate stride = size * (ubound + 1 - lbound).  */
    6841                 :        9082 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
    6842                 :             :                                  gfc_array_index_type,
    6843                 :             :                                  gfc_index_one_node, lbound);
    6844                 :        9082 :           tmp = fold_build2_loc (input_location, PLUS_EXPR,
    6845                 :             :                                  gfc_array_index_type, ubound, tmp);
    6846                 :        9082 :           tmp = fold_build2_loc (input_location, MULT_EXPR,
    6847                 :             :                                  gfc_array_index_type, size, tmp);
    6848                 :        9082 :           if (stride)
    6849                 :        9082 :             gfc_add_modify (pblock, stride, tmp);
    6850                 :             :           else
    6851                 :           0 :             stride = gfc_evaluate_now (tmp, pblock);
    6852                 :             : 
    6853                 :             :           /* Make sure that negative size arrays are translated
    6854                 :             :              to being zero size.  */
    6855                 :        9082 :           tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
    6856                 :             :                                  stride, gfc_index_zero_node);
    6857                 :        9082 :           tmp = fold_build3_loc (input_location, COND_EXPR,
    6858                 :             :                                  gfc_array_index_type, tmp,
    6859                 :             :                                  stride, gfc_index_zero_node);
    6860                 :        9082 :           gfc_add_modify (pblock, stride, tmp);
    6861                 :             :         }
    6862                 :             : 
    6863                 :             :       size = stride;
    6864                 :             :     }
    6865                 :             : 
    6866                 :       11674 :   gfc_trans_array_cobounds (type, pblock, sym);
    6867                 :       11674 :   gfc_trans_vla_type_sizes (sym, pblock);
    6868                 :             : 
    6869                 :       11674 :   *poffset = offset;
    6870                 :       11674 :   return size;
    6871                 :             : }
    6872                 :             : 
    6873                 :             : 
    6874                 :             : /* Generate code to initialize/allocate an array variable.  */
    6875                 :             : 
    6876                 :             : void
    6877                 :       26847 : gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
    6878                 :             :                                  gfc_wrapped_block * block)
    6879                 :             : {
    6880                 :       26847 :   stmtblock_t init;
    6881                 :       26847 :   tree type;
    6882                 :       26847 :   tree tmp = NULL_TREE;
    6883                 :       26847 :   tree size;
    6884                 :       26847 :   tree offset;
    6885                 :       26847 :   tree space;
    6886                 :       26847 :   tree inittree;
    6887                 :       26847 :   bool onstack;
    6888                 :             : 
    6889                 :       26847 :   gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
    6890                 :             : 
    6891                 :             :   /* Do nothing for USEd variables.  */
    6892                 :       26847 :   if (sym->attr.use_assoc)
    6893                 :       22238 :     return;
    6894                 :             : 
    6895                 :       26807 :   type = TREE_TYPE (decl);
    6896                 :       26807 :   gcc_assert (GFC_ARRAY_TYPE_P (type));
    6897                 :       26807 :   onstack = TREE_CODE (type) != POINTER_TYPE;
    6898                 :             : 
    6899                 :       26807 :   gfc_init_block (&init);
    6900                 :             : 
    6901                 :             :   /* Evaluate character string length.  */
    6902                 :       26807 :   if (sym->ts.type == BT_CHARACTER
    6903                 :        2869 :       && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
    6904                 :             :     {
    6905                 :          43 :       gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
    6906                 :             : 
    6907                 :          43 :       gfc_trans_vla_type_sizes (sym, &init);
    6908                 :             : 
    6909                 :             :       /* Emit a DECL_EXPR for this variable, which will cause the
    6910                 :             :          gimplifier to allocate storage, and all that good stuff.  */
    6911                 :          43 :       tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
    6912                 :          43 :       gfc_add_expr_to_block (&init, tmp);
    6913                 :          43 :       if (sym->attr.omp_allocate)
    6914                 :             :         {
    6915                 :             :           /* Save location of size calculation to ensure GOMP_alloc is placed
    6916                 :             :              after it.  */
    6917                 :           0 :           tree omp_alloc = lookup_attribute ("omp allocate",
    6918                 :           0 :                                              DECL_ATTRIBUTES (decl));
    6919                 :           0 :           TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
    6920                 :           0 :             = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
    6921                 :             :         }
    6922                 :             :     }
    6923                 :             : 
    6924                 :       26611 :   if (onstack)
    6925                 :             :     {
    6926                 :       22058 :       gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
    6927                 :       22058 :       return;
    6928                 :             :     }
    6929                 :             : 
    6930                 :        4749 :   type = TREE_TYPE (type);
    6931                 :             : 
    6932                 :        4749 :   gcc_assert (!sym->attr.use_assoc);
    6933                 :        4749 :   gcc_assert (!sym->module);
    6934                 :             : 
    6935                 :        4749 :   if (sym->ts.type == BT_CHARACTER
    6936                 :         196 :       && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
    6937                 :          88 :     gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
    6938                 :             : 
    6939                 :        4749 :   size = gfc_trans_array_bounds (type, sym, &offset, &init);
    6940                 :             : 
    6941                 :             :   /* Don't actually allocate space for Cray Pointees.  */
    6942                 :        4749 :   if (sym->attr.cray_pointee)
    6943                 :             :     {
    6944                 :         140 :       if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
    6945                 :          49 :         gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
    6946                 :             : 
    6947                 :         140 :       gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
    6948                 :         140 :       return;
    6949                 :             :     }
    6950                 :        4609 :   if (sym->attr.omp_allocate)
    6951                 :             :     {
    6952                 :             :       /* The size is the number of elements in the array, so multiply by the
    6953                 :             :          size of an element to get the total size.  */
    6954                 :           7 :       tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
    6955                 :           7 :       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    6956                 :             :                               size, fold_convert (gfc_array_index_type, tmp));
    6957                 :           7 :       size = gfc_evaluate_now (size, &init);
    6958                 :             : 
    6959                 :           7 :       tree omp_alloc = lookup_attribute ("omp allocate",
    6960                 :           7 :                                          DECL_ATTRIBUTES (decl));
    6961                 :           7 :       TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
    6962                 :           7 :         = build_tree_list (size, NULL_TREE);
    6963                 :           7 :       space = NULL_TREE;
    6964                 :             :     }
    6965                 :        4602 :   else if (flag_stack_arrays)
    6966                 :             :     {
    6967                 :          11 :       gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
    6968                 :          11 :       space = build_decl (gfc_get_location (&sym->declared_at),
    6969                 :             :                           VAR_DECL, create_tmp_var_name ("A"),
    6970                 :          11 :                           TREE_TYPE (TREE_TYPE (decl)));
    6971                 :          11 :       gfc_trans_vla_type_sizes (sym, &init);
    6972                 :             :     }
    6973                 :             :   else
    6974                 :             :     {
    6975                 :             :       /* The size is the number of elements in the array, so multiply by the
    6976                 :             :          size of an element to get the total size.  */
    6977                 :        4591 :       tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
    6978                 :        4591 :       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    6979                 :             :                               size, fold_convert (gfc_array_index_type, tmp));
    6980                 :             : 
    6981                 :             :       /* Allocate memory to hold the data.  */
    6982                 :        4591 :       tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
    6983                 :        4591 :       gfc_add_modify (&init, decl, tmp);
    6984                 :             : 
    6985                 :             :       /* Free the temporary.  */
    6986                 :        4591 :       tmp = gfc_call_free (decl);
    6987                 :        4591 :       space = NULL_TREE;
    6988                 :             :     }
    6989                 :             : 
    6990                 :             :   /* Set offset of the array.  */
    6991                 :        4609 :   if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
    6992                 :         398 :     gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
    6993                 :             : 
    6994                 :             :   /* Automatic arrays should not have initializers.  */
    6995                 :        4609 :   gcc_assert (!sym->value);
    6996                 :             : 
    6997                 :        4609 :   inittree = gfc_finish_block (&init);
    6998                 :             : 
    6999                 :        4609 :   if (space)
    7000                 :             :     {
    7001                 :          11 :       tree addr;
    7002                 :          11 :       pushdecl (space);
    7003                 :             : 
    7004                 :             :       /* Don't create new scope, emit the DECL_EXPR in exactly the scope
    7005                 :             :          where also space is located.  */
    7006                 :          11 :       gfc_init_block (&init);
    7007                 :          11 :       tmp = fold_build1_loc (input_location, DECL_EXPR,
    7008                 :          11 :                              TREE_TYPE (space), space);
    7009                 :          11 :       gfc_add_expr_to_block (&init, tmp);
    7010                 :          11 :       addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
    7011                 :          11 :                               ADDR_EXPR, TREE_TYPE (decl), space);
    7012                 :          11 :       gfc_add_modify (&init, decl, addr);
    7013                 :          11 :       gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
    7014                 :          11 :       tmp = NULL_TREE;
    7015                 :             :     }
    7016                 :        4609 :   gfc_add_init_cleanup (block, inittree, tmp);
    7017                 :             : }
    7018                 :             : 
    7019                 :             : 
    7020                 :             : /* Generate entry and exit code for g77 calling convention arrays.  */
    7021                 :             : 
    7022                 :             : void
    7023                 :        6671 : gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
    7024                 :             : {
    7025                 :        6671 :   tree parm;
    7026                 :        6671 :   tree type;
    7027                 :        6671 :   locus loc;
    7028                 :        6671 :   tree offset;
    7029                 :        6671 :   tree tmp;
    7030                 :        6671 :   tree stmt;
    7031                 :        6671 :   stmtblock_t init;
    7032                 :             : 
    7033                 :        6671 :   gfc_save_backend_locus (&loc);
    7034                 :        6671 :   gfc_set_backend_locus (&sym->declared_at);
    7035                 :             : 
    7036                 :             :   /* Descriptor type.  */
    7037                 :        6671 :   parm = sym->backend_decl;
    7038                 :        6671 :   type = TREE_TYPE (parm);
    7039                 :        6671 :   gcc_assert (GFC_ARRAY_TYPE_P (type));
    7040                 :             : 
    7041                 :        6671 :   gfc_start_block (&init);
    7042                 :             : 
    7043                 :        6671 :   if (sym->ts.type == BT_CHARACTER
    7044                 :         618 :       && VAR_P (sym->ts.u.cl->backend_decl))
    7045                 :          79 :     gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
    7046                 :             : 
    7047                 :             :   /* Evaluate the bounds of the array.  */
    7048                 :        6671 :   gfc_trans_array_bounds (type, sym, &offset, &init);
    7049                 :             : 
    7050                 :             :   /* Set the offset.  */
    7051                 :        6671 :   if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
    7052                 :        1067 :     gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
    7053                 :             : 
    7054                 :             :   /* Set the pointer itself if we aren't using the parameter directly.  */
    7055                 :        6671 :   if (TREE_CODE (parm) != PARM_DECL)
    7056                 :             :     {
    7057                 :         344 :       tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
    7058                 :         344 :       if (sym->ts.type == BT_CLASS)
    7059                 :             :         {
    7060                 :          72 :           tmp = build_fold_indirect_ref_loc (input_location, tmp);
    7061                 :          72 :           tmp = gfc_class_data_get (tmp);
    7062                 :          72 :           tmp = gfc_conv_descriptor_data_get (tmp);
    7063                 :             :         }
    7064                 :         344 :       tmp = convert (TREE_TYPE (parm), tmp);
    7065                 :         344 :       gfc_add_modify (&init, parm, tmp);
    7066                 :             :     }
    7067                 :        6671 :   stmt = gfc_finish_block (&init);
    7068                 :             : 
    7069                 :        6671 :   gfc_restore_backend_locus (&loc);
    7070                 :             : 
    7071                 :             :   /* Add the initialization code to the start of the function.  */
    7072                 :             : 
    7073                 :        6671 :   if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
    7074                 :             :       || sym->attr.optional
    7075                 :        6671 :       || sym->attr.not_always_present)
    7076                 :             :     {
    7077                 :         490 :       tree nullify;
    7078                 :         490 :       if (TREE_CODE (parm) != PARM_DECL)
    7079                 :          49 :         nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
    7080                 :             :                                    parm, null_pointer_node);
    7081                 :             :       else
    7082                 :         441 :         nullify = build_empty_stmt (input_location);
    7083                 :         490 :       tmp = gfc_conv_expr_present (sym, true);
    7084                 :         490 :       stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
    7085                 :             :     }
    7086                 :             : 
    7087                 :        6671 :   gfc_add_init_cleanup (block, stmt, NULL_TREE);
    7088                 :        6671 : }
    7089                 :             : 
    7090                 :             : 
    7091                 :             : /* Modify the descriptor of an array parameter so that it has the
    7092                 :             :    correct lower bound.  Also move the upper bound accordingly.
    7093                 :             :    If the array is not packed, it will be copied into a temporary.
    7094                 :             :    For each dimension we set the new lower and upper bounds.  Then we copy the
    7095                 :             :    stride and calculate the offset for this dimension.  We also work out
    7096                 :             :    what the stride of a packed array would be, and see it the two match.
    7097                 :             :    If the array need repacking, we set the stride to the values we just
    7098                 :             :    calculated, recalculate the offset and copy the array data.
    7099                 :             :    Code is also added to copy the data back at the end of the function.
    7100                 :             :    */
    7101                 :             : 
    7102                 :             : void
    7103                 :       11532 : gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
    7104                 :             :                             gfc_wrapped_block * block)
    7105                 :             : {
    7106                 :       11532 :   tree size;
    7107                 :       11532 :   tree type;
    7108                 :       11532 :   tree offset;
    7109                 :       11532 :   locus loc;
    7110                 :       11532 :   stmtblock_t init;
    7111                 :       11532 :   tree stmtInit, stmtCleanup;
    7112                 :       11532 :   tree lbound;
    7113                 :       11532 :   tree ubound;
    7114                 :       11532 :   tree dubound;
    7115                 :       11532 :   tree dlbound;
    7116                 :       11532 :   tree dumdesc;
    7117                 :       11532 :   tree tmp;
    7118                 :       11532 :   tree stride, stride2;
    7119                 :       11532 :   tree stmt_packed;
    7120                 :       11532 :   tree stmt_unpacked;
    7121                 :       11532 :   tree partial;
    7122                 :       11532 :   gfc_se se;
    7123                 :       11532 :   int n;
    7124                 :       11532 :   int checkparm;
    7125                 :       11532 :   int no_repack;
    7126                 :       11532 :   bool optional_arg;
    7127                 :       11532 :   gfc_array_spec *as;
    7128                 :       11532 :   bool is_classarray = IS_CLASS_ARRAY (sym);
    7129                 :             : 
    7130                 :             :   /* Do nothing for pointer and allocatable arrays.  */
    7131                 :       11532 :   if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
    7132                 :       11435 :       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
    7133                 :       11435 :       || sym->attr.allocatable
    7134                 :       11314 :       || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
    7135                 :        5405 :     return;
    7136                 :             : 
    7137                 :       10722 :   if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
    7138                 :             :     {
    7139                 :        5187 :       gfc_trans_g77_array (sym, block);
    7140                 :        5187 :       return;
    7141                 :             :     }
    7142                 :             : 
    7143                 :        6127 :   loc.nextc = NULL;
    7144                 :        6127 :   gfc_save_backend_locus (&loc);
    7145                 :             :   /* loc.nextc is not set by save_backend_locus but the location routines
    7146                 :             :      depend on it.  */
    7147                 :        6127 :   if (loc.nextc == NULL)
    7148                 :        6127 :     loc.nextc = loc.lb->line;
    7149                 :        6127 :   gfc_set_backend_locus (&sym->declared_at);
    7150                 :             : 
    7151                 :             :   /* Descriptor type.  */
    7152                 :        6127 :   type = TREE_TYPE (tmpdesc);
    7153                 :        6127 :   gcc_assert (GFC_ARRAY_TYPE_P (type));
    7154                 :        6127 :   dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
    7155                 :        6127 :   if (is_classarray)
    7156                 :             :     /* For a class array the dummy array descriptor is in the _class
    7157                 :             :        component.  */
    7158                 :         592 :     dumdesc = gfc_class_data_get (dumdesc);
    7159                 :             :   else
    7160                 :        5535 :     dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
    7161                 :        6127 :   as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
    7162                 :        6127 :   gfc_start_block (&init);
    7163                 :             : 
    7164                 :        6127 :   if (sym->ts.type == BT_CHARACTER
    7165                 :         738 :       && VAR_P (sym->ts.u.cl->backend_decl))
    7166                 :          87 :     gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
    7167                 :             : 
    7168                 :             :   /* TODO: Fix the exclusion of class arrays from extent checking.  */
    7169                 :        1025 :   checkparm = (as->type == AS_EXPLICIT && !is_classarray
    7170                 :        7076 :                && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
    7171                 :             : 
    7172                 :        6127 :   no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
    7173                 :        6126 :                 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
    7174                 :             : 
    7175                 :        6127 :   if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
    7176                 :             :     {
    7177                 :             :       /* For non-constant shape arrays we only check if the first dimension
    7178                 :             :          is contiguous.  Repacking higher dimensions wouldn't gain us
    7179                 :             :          anything as we still don't know the array stride.  */
    7180                 :           1 :       partial = gfc_create_var (logical_type_node, "partial");
    7181                 :           1 :       TREE_USED (partial) = 1;
    7182                 :           1 :       tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
    7183                 :           1 :       tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
    7184                 :             :                              gfc_index_one_node);
    7185                 :           1 :       gfc_add_modify (&init, partial, tmp);
    7186                 :             :     }
    7187                 :             :   else
    7188                 :             :     partial = NULL_TREE;
    7189                 :             : 
    7190                 :             :   /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
    7191                 :             :      here, however I think it does the right thing.  */
    7192                 :        6127 :   if (no_repack)
    7193                 :             :     {
    7194                 :             :       /* Set the first stride.  */
    7195                 :        6125 :       stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
    7196                 :        6125 :       stride = gfc_evaluate_now (stride, &init);
    7197                 :             : 
    7198                 :        6125 :       tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    7199                 :             :                              stride, gfc_index_zero_node);
    7200                 :        6125 :       tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
    7201                 :             :                              tmp, gfc_index_one_node, stride);
    7202                 :        6125 :       stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
    7203                 :        6125 :       gfc_add_modify (&init, stride, tmp);
    7204                 :             : 
    7205                 :             :       /* Allow the user to disable array repacking.  */
    7206                 :        6125 :       stmt_unpacked = NULL_TREE;
    7207                 :             :     }
    7208                 :             :   else
    7209                 :             :     {
    7210                 :           2 :       gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
    7211                 :             :       /* A library call to repack the array if necessary.  */
    7212                 :           2 :       tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
    7213                 :           2 :       stmt_unpacked = build_call_expr_loc (input_location,
    7214                 :             :                                        gfor_fndecl_in_pack, 1, tmp);
    7215                 :             : 
    7216                 :           2 :       stride = gfc_index_one_node;
    7217                 :             : 
    7218                 :           2 :       if (warn_array_temporaries)
    7219                 :           1 :         gfc_warning (OPT_Warray_temporaries,
    7220                 :             :                      "Creating array temporary at %L", &loc);
    7221                 :             :     }
    7222                 :             : 
    7223                 :             :   /* This is for the case where the array data is used directly without
    7224                 :             :      calling the repack function.  */
    7225                 :        6127 :   if (no_repack || partial != NULL_TREE)
    7226                 :        6126 :     stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
    7227                 :             :   else
    7228                 :             :     stmt_packed = NULL_TREE;
    7229                 :             : 
    7230                 :             :   /* Assign the data pointer.  */
    7231                 :        6127 :   if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
    7232                 :             :     {
    7233                 :             :       /* Don't repack unknown shape arrays when the first stride is 1.  */
    7234                 :           1 :       tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
    7235                 :             :                              partial, stmt_packed, stmt_unpacked);
    7236                 :             :     }
    7237                 :             :   else
    7238                 :        6126 :     tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
    7239                 :        6127 :   gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
    7240                 :             : 
    7241                 :        6127 :   offset = gfc_index_zero_node;
    7242                 :        6127 :   size = gfc_index_one_node;
    7243                 :             : 
    7244                 :             :   /* Evaluate the bounds of the array.  */
    7245                 :       14120 :   for (n = 0; n < as->rank; n++)
    7246                 :             :     {
    7247                 :        7993 :       if (checkparm || !as->upper[n])
    7248                 :             :         {
    7249                 :             :           /* Get the bounds of the actual parameter.  */
    7250                 :        6733 :           dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
    7251                 :        6733 :           dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
    7252                 :             :         }
    7253                 :             :       else
    7254                 :             :         {
    7255                 :             :           dubound = NULL_TREE;
    7256                 :             :           dlbound = NULL_TREE;
    7257                 :             :         }
    7258                 :             : 
    7259                 :        7993 :       lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
    7260                 :        7993 :       if (!INTEGER_CST_P (lbound))
    7261                 :             :         {
    7262                 :          45 :           gfc_init_se (&se, NULL);
    7263                 :          45 :           gfc_conv_expr_type (&se, as->lower[n],
    7264                 :             :                               gfc_array_index_type);
    7265                 :          45 :           gfc_add_block_to_block (&init, &se.pre);
    7266                 :          45 :           gfc_add_modify (&init, lbound, se.expr);
    7267                 :             :         }
    7268                 :             : 
    7269                 :        7993 :       ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
    7270                 :             :       /* Set the desired upper bound.  */
    7271                 :        7993 :       if (as->upper[n])
    7272                 :             :         {
    7273                 :             :           /* We know what we want the upper bound to be.  */
    7274                 :        1318 :           if (!INTEGER_CST_P (ubound))
    7275                 :             :             {
    7276                 :         635 :               gfc_init_se (&se, NULL);
    7277                 :         635 :               gfc_conv_expr_type (&se, as->upper[n],
    7278                 :             :                                   gfc_array_index_type);
    7279                 :         635 :               gfc_add_block_to_block (&init, &se.pre);
    7280                 :         635 :               gfc_add_modify (&init, ubound, se.expr);
    7281                 :             :             }
    7282                 :             : 
    7283                 :             :           /* Check the sizes match.  */
    7284                 :        1318 :           if (checkparm)
    7285                 :             :             {
    7286                 :             :               /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)).  */
    7287                 :          58 :               char * msg;
    7288                 :          58 :               tree temp;
    7289                 :             : 
    7290                 :          58 :               temp = fold_build2_loc (input_location, MINUS_EXPR,
    7291                 :             :                                       gfc_array_index_type, ubound, lbound);
    7292                 :          58 :               temp = fold_build2_loc (input_location, PLUS_EXPR,
    7293                 :             :                                       gfc_array_index_type,
    7294                 :             :                                       gfc_index_one_node, temp);
    7295                 :          58 :               stride2 = fold_build2_loc (input_location, MINUS_EXPR,
    7296                 :             :                                          gfc_array_index_type, dubound,
    7297                 :             :                                          dlbound);
    7298                 :          58 :               stride2 = fold_build2_loc (input_location, PLUS_EXPR,
    7299                 :             :                                          gfc_array_index_type,
    7300                 :             :                                          gfc_index_one_node, stride2);
    7301                 :          58 :               tmp = fold_build2_loc (input_location, NE_EXPR,
    7302                 :             :                                      gfc_array_index_type, temp, stride2);
    7303                 :          58 :               msg = xasprintf ("Dimension %d of array '%s' has extent "
    7304                 :             :                                "%%ld instead of %%ld", n+1, sym->name);
    7305                 :             : 
    7306                 :          58 :               gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
    7307                 :             :                         fold_convert (long_integer_type_node, temp),
    7308                 :             :                         fold_convert (long_integer_type_node, stride2));
    7309                 :             : 
    7310                 :          58 :               free (msg);
    7311                 :             :             }
    7312                 :             :         }
    7313                 :             :       else
    7314                 :             :         {
    7315                 :             :           /* For assumed shape arrays move the upper bound by the same amount
    7316                 :             :              as the lower bound.  */
    7317                 :        6675 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
    7318                 :             :                                  gfc_array_index_type, dubound, dlbound);
    7319                 :        6675 :           tmp = fold_build2_loc (input_location, PLUS_EXPR,
    7320                 :             :                                  gfc_array_index_type, tmp, lbound);
    7321                 :        6675 :           gfc_add_modify (&init, ubound, tmp);
    7322                 :             :         }
    7323                 :             :       /* The offset of this dimension.  offset = offset - lbound * stride.  */
    7324                 :        7993 :       tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    7325                 :             :                              lbound, stride);
    7326                 :        7993 :       offset = fold_build2_loc (input_location, MINUS_EXPR,
    7327                 :             :                                 gfc_array_index_type, offset, tmp);
    7328                 :             : 
    7329                 :             :       /* The size of this dimension, and the stride of the next.  */
    7330                 :        7993 :       if (n + 1 < as->rank)
    7331                 :             :         {
    7332                 :        1866 :           stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
    7333                 :             : 
    7334                 :        1866 :           if (no_repack || partial != NULL_TREE)
    7335                 :        1865 :             stmt_unpacked =
    7336                 :        1865 :               gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
    7337                 :             : 
    7338                 :             :           /* Figure out the stride if not a known constant.  */
    7339                 :        1866 :           if (!INTEGER_CST_P (stride))
    7340                 :             :             {
    7341                 :        1865 :               if (no_repack)
    7342                 :             :                 stmt_packed = NULL_TREE;
    7343                 :             :               else
    7344                 :             :                 {
    7345                 :             :                   /* Calculate stride = size * (ubound + 1 - lbound).  */
    7346                 :           0 :                   tmp = fold_build2_loc (input_location, MINUS_EXPR,
    7347                 :             :                                          gfc_array_index_type,
    7348                 :             :                                          gfc_index_one_node, lbound);
    7349                 :           0 :                   tmp = fold_build2_loc (input_location, PLUS_EXPR,
    7350                 :             :                                          gfc_array_index_type, ubound, tmp);
    7351                 :           0 :                   size = fold_build2_loc (input_location, MULT_EXPR,
    7352                 :             :                                           gfc_array_index_type, size, tmp);
    7353                 :           0 :                   stmt_packed = size;
    7354                 :             :                 }
    7355                 :             : 
    7356                 :             :               /* Assign the stride.  */
    7357                 :        1865 :               if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
    7358                 :           0 :                 tmp = fold_build3_loc (input_location, COND_EXPR,
    7359                 :             :                                        gfc_array_index_type, partial,
    7360                 :             :                                        stmt_unpacked, stmt_packed);
    7361                 :             :               else
    7362                 :        1865 :                 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
    7363                 :        1865 :               gfc_add_modify (&init, stride, tmp);
    7364                 :             :             }
    7365                 :             :         }
    7366                 :             :       else
    7367                 :             :         {
    7368                 :        6127 :           stride = GFC_TYPE_ARRAY_SIZE (type);
    7369                 :             :