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