LCOV - code coverage report
Current view: top level - gcc/fortran - trans-expr.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 94.6 % 6345 6005
Test Date: 2023-09-09 13:19:57 Functions: 95.1 % 143 136
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* Expression translation
       2                 :             :    Copyright (C) 2002-2023 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-expr.cc-- generate GENERIC trees for gfc_expr.  */
      23                 :             : 
      24                 :             : #include "config.h"
      25                 :             : #include "system.h"
      26                 :             : #include "coretypes.h"
      27                 :             : #include "options.h"
      28                 :             : #include "tree.h"
      29                 :             : #include "gfortran.h"
      30                 :             : #include "trans.h"
      31                 :             : #include "stringpool.h"
      32                 :             : #include "diagnostic-core.h"  /* For fatal_error.  */
      33                 :             : #include "fold-const.h"
      34                 :             : #include "langhooks.h"
      35                 :             : #include "arith.h"
      36                 :             : #include "constructor.h"
      37                 :             : #include "trans-const.h"
      38                 :             : #include "trans-types.h"
      39                 :             : #include "trans-array.h"
      40                 :             : /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
      41                 :             : #include "trans-stmt.h"
      42                 :             : #include "dependency.h"
      43                 :             : #include "gimplify.h"
      44                 :             : #include "tm.h"               /* For CHAR_TYPE_SIZE.  */
      45                 :             : 
      46                 :             : 
      47                 :             : /* Calculate the number of characters in a string.  */
      48                 :             : 
      49                 :             : static tree
      50                 :       31309 : gfc_get_character_len (tree type)
      51                 :             : {
      52                 :       31309 :   tree len;
      53                 :             : 
      54                 :       31309 :   gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
      55                 :             :               && TYPE_STRING_FLAG (type));
      56                 :             : 
      57                 :       31309 :   len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
      58                 :       31309 :   len = (len) ? (len) : (integer_zero_node);
      59                 :       31309 :   return fold_convert (gfc_charlen_type_node, len);
      60                 :             : }
      61                 :             : 
      62                 :             : 
      63                 :             : 
      64                 :             : /* Calculate the number of bytes in a string.  */
      65                 :             : 
      66                 :             : tree
      67                 :       31309 : gfc_get_character_len_in_bytes (tree type)
      68                 :             : {
      69                 :       31309 :   tree tmp, len;
      70                 :             : 
      71                 :       31309 :   gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
      72                 :             :               && TYPE_STRING_FLAG (type));
      73                 :             : 
      74                 :       31309 :   tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
      75                 :       31309 :   tmp = (tmp && !integer_zerop (tmp))
      76                 :       62618 :     ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
      77                 :       31309 :   len = gfc_get_character_len (type);
      78                 :       31309 :   if (tmp && len && !integer_zerop (len))
      79                 :       30653 :     len = fold_build2_loc (input_location, MULT_EXPR,
      80                 :             :                            gfc_charlen_type_node, len, tmp);
      81                 :       31309 :   return len;
      82                 :             : }
      83                 :             : 
      84                 :             : 
      85                 :             : /* Convert a scalar to an array descriptor. To be used for assumed-rank
      86                 :             :    arrays.  */
      87                 :             : 
      88                 :             : static tree
      89                 :        5314 : get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
      90                 :             : {
      91                 :        5314 :   enum gfc_array_kind akind;
      92                 :             : 
      93                 :        5314 :   if (attr.pointer)
      94                 :             :     akind = GFC_ARRAY_POINTER_CONT;
      95                 :        5073 :   else if (attr.allocatable)
      96                 :             :     akind = GFC_ARRAY_ALLOCATABLE;
      97                 :             :   else
      98                 :        4457 :     akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
      99                 :             : 
     100                 :        5314 :   if (POINTER_TYPE_P (TREE_TYPE (scalar)))
     101                 :        3978 :     scalar = TREE_TYPE (scalar);
     102                 :        5314 :   return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
     103                 :        5314 :                                     akind, !(attr.pointer || attr.target));
     104                 :             : }
     105                 :             : 
     106                 :             : tree
     107                 :        4646 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
     108                 :             : {
     109                 :        4646 :   tree desc, type, etype;
     110                 :             : 
     111                 :        4646 :   type = get_scalar_to_descriptor_type (scalar, attr);
     112                 :        4646 :   etype = TREE_TYPE (scalar);
     113                 :        4646 :   desc = gfc_create_var (type, "desc");
     114                 :        4646 :   DECL_ARTIFICIAL (desc) = 1;
     115                 :             : 
     116                 :        4646 :   if (CONSTANT_CLASS_P (scalar))
     117                 :             :     {
     118                 :          91 :       tree tmp;
     119                 :          91 :       tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
     120                 :          91 :       gfc_add_modify (&se->pre, tmp, scalar);
     121                 :          91 :       scalar = tmp;
     122                 :             :     }
     123                 :        4646 :   if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
     124                 :        1336 :     scalar = gfc_build_addr_expr (NULL_TREE, scalar);
     125                 :        3310 :   else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
     126                 :          98 :     etype = TREE_TYPE (etype);
     127                 :        4646 :   gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
     128                 :             :                   gfc_get_dtype_rank_type (0, etype));
     129                 :        4646 :   gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
     130                 :        4646 :   gfc_conv_descriptor_span_set (&se->pre, desc,
     131                 :             :                                 gfc_conv_descriptor_elem_len (desc));
     132                 :             : 
     133                 :             :   /* Copy pointer address back - but only if it could have changed and
     134                 :             :      if the actual argument is a pointer and not, e.g., NULL().  */
     135                 :        4646 :   if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
     136                 :         618 :     gfc_add_modify (&se->post, scalar,
     137                 :         309 :                     fold_convert (TREE_TYPE (scalar),
     138                 :             :                                   gfc_conv_descriptor_data_get (desc)));
     139                 :        4646 :   return desc;
     140                 :             : }
     141                 :             : 
     142                 :             : 
     143                 :             : /* Get the coarray token from the ultimate array or component ref.
     144                 :             :    Returns a NULL_TREE, when the ref object is not allocatable or pointer.  */
     145                 :             : 
     146                 :             : tree
     147                 :         404 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
     148                 :             : {
     149                 :         404 :   gfc_symbol *sym = expr->symtree->n.sym;
     150                 :         404 :   bool is_coarray = sym->attr.codimension;
     151                 :         404 :   gfc_expr *caf_expr = gfc_copy_expr (expr);
     152                 :         404 :   gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
     153                 :             : 
     154                 :        1373 :   while (ref)
     155                 :             :     {
     156                 :         969 :       if (ref->type == REF_COMPONENT
     157                 :         394 :           && (ref->u.c.component->attr.allocatable
     158                 :         394 :               || ref->u.c.component->attr.pointer)
     159                 :         394 :           && (is_coarray || ref->u.c.component->attr.codimension))
     160                 :         969 :           last_caf_ref = ref;
     161                 :         969 :       ref = ref->next;
     162                 :             :     }
     163                 :             : 
     164                 :         404 :   if (last_caf_ref == NULL)
     165                 :             :     return NULL_TREE;
     166                 :             : 
     167                 :         305 :   tree comp = last_caf_ref->u.c.component->caf_token, caf;
     168                 :         305 :   gfc_se se;
     169                 :         305 :   bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
     170                 :         305 :   if (comp == NULL_TREE && comp_ref)
     171                 :             :     return NULL_TREE;
     172                 :         275 :   gfc_init_se (&se, outerse);
     173                 :         275 :   gfc_free_ref_list (last_caf_ref->next);
     174                 :         275 :   last_caf_ref->next = NULL;
     175                 :         275 :   caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
     176                 :         275 :   se.want_pointer = comp_ref;
     177                 :         275 :   gfc_conv_expr (&se, caf_expr);
     178                 :         275 :   gfc_add_block_to_block (&outerse->pre, &se.pre);
     179                 :             : 
     180                 :         275 :   if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
     181                 :         152 :     se.expr = TREE_OPERAND (se.expr, 0);
     182                 :         275 :   gfc_free_expr (caf_expr);
     183                 :             : 
     184                 :         275 :   if (comp_ref)
     185                 :         152 :     caf = fold_build3_loc (input_location, COMPONENT_REF,
     186                 :         152 :                            TREE_TYPE (comp), se.expr, comp, NULL_TREE);
     187                 :             :   else
     188                 :         123 :     caf = gfc_conv_descriptor_token (se.expr);
     189                 :         275 :   return gfc_build_addr_expr (NULL_TREE, caf);
     190                 :             : }
     191                 :             : 
     192                 :             : 
     193                 :             : /* This is the seed for an eventual trans-class.c
     194                 :             : 
     195                 :             :    The following parameters should not be used directly since they might
     196                 :             :    in future implementations.  Use the corresponding APIs.  */
     197                 :             : #define CLASS_DATA_FIELD 0
     198                 :             : #define CLASS_VPTR_FIELD 1
     199                 :             : #define CLASS_LEN_FIELD 2
     200                 :             : #define VTABLE_HASH_FIELD 0
     201                 :             : #define VTABLE_SIZE_FIELD 1
     202                 :             : #define VTABLE_EXTENDS_FIELD 2
     203                 :             : #define VTABLE_DEF_INIT_FIELD 3
     204                 :             : #define VTABLE_COPY_FIELD 4
     205                 :             : #define VTABLE_FINAL_FIELD 5
     206                 :             : #define VTABLE_DEALLOCATE_FIELD 6
     207                 :             : 
     208                 :             : 
     209                 :             : tree
     210                 :          39 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
     211                 :             : {
     212                 :          39 :   tree tmp;
     213                 :          39 :   tree field;
     214                 :          39 :   vec<constructor_elt, va_gc> *init = NULL;
     215                 :             : 
     216                 :          39 :   field = TYPE_FIELDS (TREE_TYPE (decl));
     217                 :          39 :   tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
     218                 :          39 :   CONSTRUCTOR_APPEND_ELT (init, tmp, data);
     219                 :             : 
     220                 :          39 :   tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
     221                 :          39 :   CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
     222                 :             : 
     223                 :          39 :   return build_constructor (TREE_TYPE (decl), init);
     224                 :             : }
     225                 :             : 
     226                 :             : 
     227                 :             : tree
     228                 :       24113 : gfc_class_data_get (tree decl)
     229                 :             : {
     230                 :       24113 :   tree data;
     231                 :       24113 :   if (POINTER_TYPE_P (TREE_TYPE (decl)))
     232                 :        4413 :     decl = build_fold_indirect_ref_loc (input_location, decl);
     233                 :       24113 :   data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
     234                 :             :                             CLASS_DATA_FIELD);
     235                 :       24113 :   return fold_build3_loc (input_location, COMPONENT_REF,
     236                 :       24113 :                           TREE_TYPE (data), decl, data,
     237                 :       24113 :                           NULL_TREE);
     238                 :             : }
     239                 :             : 
     240                 :             : 
     241                 :             : tree
     242                 :       32672 : gfc_class_vptr_get (tree decl)
     243                 :             : {
     244                 :       32672 :   tree vptr;
     245                 :             :   /* For class arrays decl may be a temporary descriptor handle, the vptr is
     246                 :             :      then available through the saved descriptor.  */
     247                 :       19637 :   if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
     248                 :       34003 :       && GFC_DECL_SAVED_DESCRIPTOR (decl))
     249                 :        1029 :     decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
     250                 :       32672 :   if (POINTER_TYPE_P (TREE_TYPE (decl)))
     251                 :        2124 :     decl = build_fold_indirect_ref_loc (input_location, decl);
     252                 :       32672 :   vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
     253                 :             :                             CLASS_VPTR_FIELD);
     254                 :       32672 :   return fold_build3_loc (input_location, COMPONENT_REF,
     255                 :       32672 :                           TREE_TYPE (vptr), decl, vptr,
     256                 :       32672 :                           NULL_TREE);
     257                 :             : }
     258                 :             : 
     259                 :             : 
     260                 :             : tree
     261                 :        4803 : gfc_class_len_get (tree decl)
     262                 :             : {
     263                 :        4803 :   tree len;
     264                 :             :   /* For class arrays decl may be a temporary descriptor handle, the len is
     265                 :             :      then available through the saved descriptor.  */
     266                 :        3377 :   if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
     267                 :        4937 :       && GFC_DECL_SAVED_DESCRIPTOR (decl))
     268                 :           6 :     decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
     269                 :        4803 :   if (POINTER_TYPE_P (TREE_TYPE (decl)))
     270                 :         440 :     decl = build_fold_indirect_ref_loc (input_location, decl);
     271                 :        4803 :   len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
     272                 :             :                            CLASS_LEN_FIELD);
     273                 :        4803 :   return fold_build3_loc (input_location, COMPONENT_REF,
     274                 :        4803 :                           TREE_TYPE (len), decl, len,
     275                 :        4803 :                           NULL_TREE);
     276                 :             : }
     277                 :             : 
     278                 :             : 
     279                 :             : /* Try to get the _len component of a class.  When the class is not unlimited
     280                 :             :    poly, i.e. no _len field exists, then return a zero node.  */
     281                 :             : 
     282                 :             : static tree
     283                 :        3276 : gfc_class_len_or_zero_get (tree decl)
     284                 :             : {
     285                 :        3276 :   tree len;
     286                 :             :   /* For class arrays decl may be a temporary descriptor handle, the vptr is
     287                 :             :      then available through the saved descriptor.  */
     288                 :        2102 :   if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
     289                 :        3306 :       && GFC_DECL_SAVED_DESCRIPTOR (decl))
     290                 :           0 :     decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
     291                 :        3276 :   if (POINTER_TYPE_P (TREE_TYPE (decl)))
     292                 :           0 :     decl = build_fold_indirect_ref_loc (input_location, decl);
     293                 :        3276 :   len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
     294                 :             :                            CLASS_LEN_FIELD);
     295                 :        4056 :   return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
     296                 :         780 :                                              TREE_TYPE (len), decl, len,
     297                 :             :                                              NULL_TREE)
     298                 :        2496 :     : build_zero_cst (gfc_charlen_type_node);
     299                 :             : }
     300                 :             : 
     301                 :             : 
     302                 :             : tree
     303                 :        3149 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
     304                 :             : {
     305                 :        3149 :   tree tmp;
     306                 :        3149 :   tree tmp2;
     307                 :        3149 :   tree type;
     308                 :             : 
     309                 :        3149 :   tmp = gfc_class_len_or_zero_get (class_expr);
     310                 :             : 
     311                 :             :   /* Include the len value in the element size if present.  */
     312                 :        3149 :   if (!integer_zerop (tmp))
     313                 :             :     {
     314                 :         653 :       type = TREE_TYPE (size);
     315                 :         653 :       if (block)
     316                 :             :         {
     317                 :         585 :           size = gfc_evaluate_now (size, block);
     318                 :         585 :           tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
     319                 :             :         }
     320                 :         653 :       tmp2 = fold_build2_loc (input_location, MULT_EXPR,
     321                 :             :                               type, size, tmp);
     322                 :         653 :       tmp = fold_build2_loc (input_location, GT_EXPR,
     323                 :             :                              logical_type_node, tmp,
     324                 :             :                              build_zero_cst (type));
     325                 :         653 :       size = fold_build3_loc (input_location, COND_EXPR,
     326                 :             :                               type, tmp, tmp2, size);
     327                 :             :     }
     328                 :             :   else
     329                 :             :     return size;
     330                 :             : 
     331                 :         653 :   if (block)
     332                 :         585 :     size = gfc_evaluate_now (size, block);
     333                 :             : 
     334                 :             :   return size;
     335                 :             : }
     336                 :             : 
     337                 :             : 
     338                 :             : /* Get the specified FIELD from the VPTR.  */
     339                 :             : 
     340                 :             : static tree
     341                 :       15648 : vptr_field_get (tree vptr, int fieldno)
     342                 :             : {
     343                 :       15648 :   tree field;
     344                 :       15648 :   vptr = build_fold_indirect_ref_loc (input_location, vptr);
     345                 :       15648 :   field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
     346                 :             :                              fieldno);
     347                 :       15648 :   field = fold_build3_loc (input_location, COMPONENT_REF,
     348                 :       15648 :                            TREE_TYPE (field), vptr, field,
     349                 :             :                            NULL_TREE);
     350                 :       15648 :   gcc_assert (field);
     351                 :       15648 :   return field;
     352                 :             : }
     353                 :             : 
     354                 :             : 
     355                 :             : /* Get the field from the class' vptr.  */
     356                 :             : 
     357                 :             : static tree
     358                 :        7352 : class_vtab_field_get (tree decl, int fieldno)
     359                 :             : {
     360                 :        7352 :   tree vptr;
     361                 :        7352 :   vptr = gfc_class_vptr_get (decl);
     362                 :        7352 :   return vptr_field_get (vptr, fieldno);
     363                 :             : }
     364                 :             : 
     365                 :             : 
     366                 :             : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
     367                 :             :    unison.  */
     368                 :             : #define VTAB_GET_FIELD_GEN(name, field) tree \
     369                 :             : gfc_class_vtab_## name ##_get (tree cl) \
     370                 :             : { \
     371                 :             :   return class_vtab_field_get (cl, field); \
     372                 :             : } \
     373                 :             :  \
     374                 :             : tree \
     375                 :             : gfc_vptr_## name ##_get (tree vptr) \
     376                 :             : { \
     377                 :             :   return vptr_field_get (vptr, field); \
     378                 :             : }
     379                 :             : 
     380                 :         171 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
     381                 :           0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
     382                 :           0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
     383                 :        3502 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
     384                 :        1155 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
     385                 :         390 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
     386                 :             : #undef VTAB_GET_FIELD_GEN
     387                 :             : 
     388                 :             : /* The size field is returned as an array index type.  Therefore treat
     389                 :             :    it and only it specially.  */
     390                 :             : 
     391                 :             : tree
     392                 :        5847 : gfc_class_vtab_size_get (tree cl)
     393                 :             : {
     394                 :        5847 :   tree size;
     395                 :        5847 :   size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
     396                 :             :   /* Always return size as an array index type.  */
     397                 :        5847 :   size = fold_convert (gfc_array_index_type, size);
     398                 :        5847 :   gcc_assert (size);
     399                 :        5847 :   return size;
     400                 :             : }
     401                 :             : 
     402                 :             : tree
     403                 :        4583 : gfc_vptr_size_get (tree vptr)
     404                 :             : {
     405                 :        4583 :   tree size;
     406                 :        4583 :   size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
     407                 :             :   /* Always return size as an array index type.  */
     408                 :        4583 :   size = fold_convert (gfc_array_index_type, size);
     409                 :        4583 :   gcc_assert (size);
     410                 :        4583 :   return size;
     411                 :             : }
     412                 :             : 
     413                 :             : 
     414                 :             : #undef CLASS_DATA_FIELD
     415                 :             : #undef CLASS_VPTR_FIELD
     416                 :             : #undef CLASS_LEN_FIELD
     417                 :             : #undef VTABLE_HASH_FIELD
     418                 :             : #undef VTABLE_SIZE_FIELD
     419                 :             : #undef VTABLE_EXTENDS_FIELD
     420                 :             : #undef VTABLE_DEF_INIT_FIELD
     421                 :             : #undef VTABLE_COPY_FIELD
     422                 :             : #undef VTABLE_FINAL_FIELD
     423                 :             : 
     424                 :             : 
     425                 :             : /* IF ts is null (default), search for the last _class ref in the chain
     426                 :             :    of references of the expression and cut the chain there.  Although
     427                 :             :    this routine is similiar to class.cc:gfc_add_component_ref (), there
     428                 :             :    is a significant difference: gfc_add_component_ref () concentrates
     429                 :             :    on an array ref that is the last ref in the chain and is oblivious
     430                 :             :    to the kind of refs following.
     431                 :             :    ELSE IF ts is non-null the cut is at the class entity or component
     432                 :             :    that is followed by an array reference, which is not an element.
     433                 :             :    These calls come from trans-array.cc:build_class_array_ref, which
     434                 :             :    handles scalarized class array references.*/
     435                 :             : 
     436                 :             : gfc_expr *
     437                 :        7070 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
     438                 :             :                                     gfc_typespec **ts)
     439                 :             : {
     440                 :        7070 :   gfc_expr *base_expr;
     441                 :        7070 :   gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
     442                 :             : 
     443                 :             :   /* Find the last class reference.  */
     444                 :        7070 :   class_ref = NULL;
     445                 :        7070 :   array_ref = NULL;
     446                 :             : 
     447                 :        7070 :   if (ts)
     448                 :             :     {
     449                 :         311 :       if (e->symtree
     450                 :         286 :           && e->symtree->n.sym->ts.type == BT_CLASS)
     451                 :         286 :         *ts = &e->symtree->n.sym->ts;
     452                 :             :       else
     453                 :          25 :         *ts = NULL;
     454                 :             :     }
     455                 :             : 
     456                 :       17665 :   for (ref = e->ref; ref; ref = ref->next)
     457                 :             :     {
     458                 :       10891 :       if (ts)
     459                 :             :         {
     460                 :         738 :           if (ref->type == REF_COMPONENT
     461                 :         340 :               && ref->u.c.component->ts.type == BT_CLASS
     462                 :           0 :               && ref->next && ref->next->type == REF_COMPONENT
     463                 :           0 :               && !strcmp (ref->next->u.c.component->name, "_data")
     464                 :           0 :               && ref->next->next
     465                 :           0 :               && ref->next->next->type == REF_ARRAY
     466                 :           0 :               && ref->next->next->u.ar.type != AR_ELEMENT)
     467                 :             :             {
     468                 :           0 :               *ts = &ref->u.c.component->ts;
     469                 :           0 :               class_ref = ref;
     470                 :           0 :               break;
     471                 :             :             }
     472                 :             : 
     473                 :         738 :           if (ref->next == NULL)
     474                 :             :             break;
     475                 :             :         }
     476                 :             :       else
     477                 :             :         {
     478                 :       10153 :           if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
     479                 :       10153 :             array_ref = ref;
     480                 :             : 
     481                 :       10153 :           if (ref->type == REF_COMPONENT
     482                 :        6324 :               && ref->u.c.component->ts.type == BT_CLASS)
     483                 :             :             {
     484                 :             :               /* Component to the right of a part reference with nonzero
     485                 :             :                  rank must not have the ALLOCATABLE attribute.  If attempts
     486                 :             :                  are made to reference such a component reference, an error
     487                 :             :                  results followed by an ICE.  */
     488                 :        1365 :               if (array_ref
     489                 :          10 :                   && CLASS_DATA (ref->u.c.component)->attr.allocatable)
     490                 :             :                 return NULL;
     491                 :             :               class_ref = ref;
     492                 :             :             }
     493                 :             :         }
     494                 :             :     }
     495                 :             : 
     496                 :        7060 :   if (ts && *ts == NULL)
     497                 :             :     return NULL;
     498                 :             : 
     499                 :             :   /* Remove and store all subsequent references after the
     500                 :             :      CLASS reference.  */
     501                 :        7035 :   if (class_ref)
     502                 :             :     {
     503                 :        1199 :       tail = class_ref->next;
     504                 :        1199 :       class_ref->next = NULL;
     505                 :             :     }
     506                 :        5836 :   else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
     507                 :             :     {
     508                 :        5818 :       tail = e->ref;
     509                 :        5818 :       e->ref = NULL;
     510                 :             :     }
     511                 :             : 
     512                 :        7035 :   if (is_mold)
     513                 :          59 :     base_expr = gfc_expr_to_initialize (e);
     514                 :             :   else
     515                 :        6976 :     base_expr = gfc_copy_expr (e);
     516                 :             : 
     517                 :             :   /* Restore the original tail expression.  */
     518                 :        7035 :   if (class_ref)
     519                 :             :     {
     520                 :        1199 :       gfc_free_ref_list (class_ref->next);
     521                 :        1199 :       class_ref->next = tail;
     522                 :             :     }
     523                 :        5836 :   else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
     524                 :             :     {
     525                 :        5818 :       gfc_free_ref_list (e->ref);
     526                 :        5818 :       e->ref = tail;
     527                 :             :     }
     528                 :             :   return base_expr;
     529                 :             : }
     530                 :             : 
     531                 :             : 
     532                 :             : /* Reset the vptr to the declared type, e.g. after deallocation.
     533                 :             :    Use the variable in CLASS_CONTAINER if available.  Otherwise, recreate
     534                 :             :    one with E.  The generated assignment code is added at the end of BLOCK.  */
     535                 :             : 
     536                 :             : void
     537                 :        1663 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container)
     538                 :             : {
     539                 :        1663 :   tree vptr = NULL_TREE;
     540                 :             : 
     541                 :        1663 :   if (class_container != NULL_TREE)
     542                 :         109 :     vptr = gfc_get_vptr_from_expr (class_container);
     543                 :             : 
     544                 :         109 :   if (vptr == NULL_TREE)
     545                 :             :     {
     546                 :        1560 :       gfc_se se;
     547                 :             : 
     548                 :             :       /* Evaluate the expression and obtain the vptr from it.  */
     549                 :        1560 :       gfc_init_se (&se, NULL);
     550                 :        1560 :       if (e->rank)
     551                 :         792 :         gfc_conv_expr_descriptor (&se, e);
     552                 :             :       else
     553                 :         768 :         gfc_conv_expr (&se, e);
     554                 :        1560 :       gfc_add_block_to_block (block, &se.pre);
     555                 :             : 
     556                 :        1560 :       vptr = gfc_get_vptr_from_expr (se.expr);
     557                 :             :     }
     558                 :             : 
     559                 :             :   /* If a vptr is not found, we can do nothing more.  */
     560                 :        1560 :   if (vptr == NULL_TREE)
     561                 :             :     return;
     562                 :             : 
     563                 :        1653 :   if (UNLIMITED_POLY (e))
     564                 :         411 :     gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
     565                 :             :   else
     566                 :             :     {
     567                 :        1242 :       gfc_symbol *vtab;
     568                 :        1242 :       tree vtable;
     569                 :             : 
     570                 :             :       /* Return the vptr to the address of the declared type.  */
     571                 :        1242 :       vtab = gfc_find_derived_vtab (e->ts.u.derived);
     572                 :        1242 :       vtable = vtab->backend_decl;
     573                 :        1242 :       if (vtable == NULL_TREE)
     574                 :          21 :         vtable = gfc_get_symbol_decl (vtab);
     575                 :        1242 :       vtable = gfc_build_addr_expr (NULL, vtable);
     576                 :        1242 :       vtable = fold_convert (TREE_TYPE (vptr), vtable);
     577                 :        1242 :       gfc_add_modify (block, vptr, vtable);
     578                 :             :     }
     579                 :             : }
     580                 :             : 
     581                 :             : 
     582                 :             : /* Reset the len for unlimited polymorphic objects.  */
     583                 :             : 
     584                 :             : void
     585                 :         387 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
     586                 :             : {
     587                 :         387 :   gfc_expr *e;
     588                 :         387 :   gfc_se se_len;
     589                 :         387 :   e = gfc_find_and_cut_at_last_class_ref (expr);
     590                 :         387 :   if (e == NULL)
     591                 :           0 :     return;
     592                 :         387 :   gfc_add_len_component (e);
     593                 :         387 :   gfc_init_se (&se_len, NULL);
     594                 :         387 :   gfc_conv_expr (&se_len, e);
     595                 :         387 :   gfc_add_modify (block, se_len.expr,
     596                 :         387 :                   fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
     597                 :         387 :   gfc_free_expr (e);
     598                 :             : }
     599                 :             : 
     600                 :             : 
     601                 :             : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
     602                 :             :    reference is found. Note that it is up to the caller to avoid using this
     603                 :             :    for expressions other than variables.  */
     604                 :             : 
     605                 :             : tree
     606                 :         753 : gfc_get_class_from_gfc_expr (gfc_expr *e)
     607                 :             : {
     608                 :         753 :   gfc_expr *class_expr;
     609                 :         753 :   gfc_se cse;
     610                 :         753 :   class_expr = gfc_find_and_cut_at_last_class_ref (e);
     611                 :         753 :   if (class_expr == NULL)
     612                 :             :     return NULL_TREE;
     613                 :         753 :   gfc_init_se (&cse, NULL);
     614                 :         753 :   gfc_conv_expr (&cse, class_expr);
     615                 :         753 :   gfc_free_expr (class_expr);
     616                 :         753 :   return cse.expr;
     617                 :             : }
     618                 :             : 
     619                 :             : 
     620                 :             : /* Obtain the last class reference in an expression.
     621                 :             :    Return NULL_TREE if no class reference is found.  */
     622                 :             : 
     623                 :             : tree
     624                 :       69658 : gfc_get_class_from_expr (tree expr)
     625                 :             : {
     626                 :       69658 :   tree tmp;
     627                 :       69658 :   tree type;
     628                 :             : 
     629                 :      195826 :   for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
     630                 :             :     {
     631                 :      195826 :       if (CONSTANT_CLASS_P (tmp))
     632                 :             :         return NULL_TREE;
     633                 :             : 
     634                 :      195789 :       type = TREE_TYPE (tmp);
     635                 :      229524 :       while (type)
     636                 :             :         {
     637                 :      223400 :           if (GFC_CLASS_TYPE_P (type))
     638                 :        8078 :             return tmp;
     639                 :      215322 :           if (type != TYPE_CANONICAL (type))
     640                 :       33735 :             type = TYPE_CANONICAL (type);
     641                 :             :           else
     642                 :             :             type = NULL_TREE;
     643                 :             :         }
     644                 :      187711 :       if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
     645                 :             :         break;
     646                 :             :     }
     647                 :             : 
     648                 :       61543 :   if (POINTER_TYPE_P (TREE_TYPE (tmp)))
     649                 :       37687 :     tmp = build_fold_indirect_ref_loc (input_location, tmp);
     650                 :             : 
     651                 :       61543 :   if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
     652                 :             :     return tmp;
     653                 :             : 
     654                 :             :   return NULL_TREE;
     655                 :             : }
     656                 :             : 
     657                 :             : 
     658                 :             : /* Obtain the vptr of the last class reference in an expression.
     659                 :             :    Return NULL_TREE if no class reference is found.  */
     660                 :             : 
     661                 :             : tree
     662                 :        1873 : gfc_get_vptr_from_expr (tree expr)
     663                 :             : {
     664                 :        1873 :   tree tmp;
     665                 :             : 
     666                 :        1873 :   tmp = gfc_get_class_from_expr (expr);
     667                 :             : 
     668                 :        1873 :   if (tmp != NULL_TREE)
     669                 :        1851 :     return gfc_class_vptr_get (tmp);
     670                 :             : 
     671                 :             :   return NULL_TREE;
     672                 :             : }
     673                 :             : 
     674                 :             : 
     675                 :             : static void
     676                 :        1118 : class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
     677                 :             :                          bool lhs_type)
     678                 :             : {
     679                 :        1118 :   tree tmp, tmp2, type;
     680                 :             : 
     681                 :        1118 :   gfc_conv_descriptor_data_set (block, lhs_desc,
     682                 :             :                                 gfc_conv_descriptor_data_get (rhs_desc));
     683                 :        1118 :   gfc_conv_descriptor_offset_set (block, lhs_desc,
     684                 :             :                                   gfc_conv_descriptor_offset_get (rhs_desc));
     685                 :             : 
     686                 :        1118 :   gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
     687                 :             :                   gfc_conv_descriptor_dtype (rhs_desc));
     688                 :             : 
     689                 :             :   /* Assign the dimension as range-ref.  */
     690                 :        1118 :   tmp = gfc_get_descriptor_dimension (lhs_desc);
     691                 :        1118 :   tmp2 = gfc_get_descriptor_dimension (rhs_desc);
     692                 :             : 
     693                 :        1118 :   type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
     694                 :        1118 :   tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
     695                 :             :                     gfc_index_zero_node, NULL_TREE, NULL_TREE);
     696                 :        1118 :   tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
     697                 :             :                      gfc_index_zero_node, NULL_TREE, NULL_TREE);
     698                 :        1118 :   gfc_add_modify (block, tmp, tmp2);
     699                 :        1118 : }
     700                 :             : 
     701                 :             : 
     702                 :             : /* Takes a derived type expression and returns the address of a temporary
     703                 :             :    class object of the 'declared' type.  If vptr is not NULL, this is
     704                 :             :    used for the temporary class object.
     705                 :             :    optional_alloc_ptr is false when the dummy is neither allocatable
     706                 :             :    nor a pointer; that's only relevant for the optional handling.
     707                 :             :    The optional argument 'derived_array' is used to preserve the parmse
     708                 :             :    expression for deallocation of allocatable components. Assumed rank
     709                 :             :    formal arguments made this necessary.  */
     710                 :             : void
     711                 :        4235 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
     712                 :             :                            gfc_typespec class_ts, tree vptr, bool optional,
     713                 :             :                            bool optional_alloc_ptr,
     714                 :             :                            tree *derived_array)
     715                 :             : {
     716                 :        4235 :   gfc_symbol *vtab;
     717                 :        4235 :   tree cond_optional = NULL_TREE;
     718                 :        4235 :   gfc_ss *ss;
     719                 :        4235 :   tree ctree;
     720                 :        4235 :   tree var;
     721                 :        4235 :   tree tmp;
     722                 :        4235 :   int dim;
     723                 :             : 
     724                 :             :   /* The derived type needs to be converted to a temporary
     725                 :             :      CLASS object.  */
     726                 :        4235 :   tmp = gfc_typenode_for_spec (&class_ts);
     727                 :        4235 :   var = gfc_create_var (tmp, "class");
     728                 :             : 
     729                 :             :   /* Set the vptr.  */
     730                 :        4235 :   ctree =  gfc_class_vptr_get (var);
     731                 :             : 
     732                 :        4235 :   if (vptr != NULL_TREE)
     733                 :             :     {
     734                 :             :       /* Use the dynamic vptr.  */
     735                 :             :       tmp = vptr;
     736                 :             :     }
     737                 :             :   else
     738                 :             :     {
     739                 :             :       /* In this case the vtab corresponds to the derived type and the
     740                 :             :          vptr must point to it.  */
     741                 :        4127 :       vtab = gfc_find_derived_vtab (e->ts.u.derived);
     742                 :        4127 :       gcc_assert (vtab);
     743                 :        4127 :       tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
     744                 :             :     }
     745                 :        4235 :   gfc_add_modify (&parmse->pre, ctree,
     746                 :        4235 :                   fold_convert (TREE_TYPE (ctree), tmp));
     747                 :             : 
     748                 :             :   /* Now set the data field.  */
     749                 :        4235 :   ctree =  gfc_class_data_get (var);
     750                 :             : 
     751                 :        4235 :   if (optional)
     752                 :         576 :     cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
     753                 :             : 
     754                 :        4235 :   if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
     755                 :             :     {
     756                 :             :       /* If there is a ready made pointer to a derived type, use it
     757                 :             :          rather than evaluating the expression again.  */
     758                 :         454 :       tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
     759                 :         454 :       gfc_add_modify (&parmse->pre, ctree, tmp);
     760                 :             :     }
     761                 :        3781 :   else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
     762                 :             :     {
     763                 :             :       /* For an array reference in an elemental procedure call we need
     764                 :             :          to retain the ss to provide the scalarized array reference.  */
     765                 :         221 :       gfc_conv_expr_reference (parmse, e);
     766                 :         221 :       tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
     767                 :         221 :       if (optional)
     768                 :           0 :         tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
     769                 :             :                           cond_optional, tmp,
     770                 :           0 :                           fold_convert (TREE_TYPE (tmp), null_pointer_node));
     771                 :         221 :       gfc_add_modify (&parmse->pre, ctree, tmp);
     772                 :             :     }
     773                 :             :   else
     774                 :             :     {
     775                 :        3560 :       ss = gfc_walk_expr (e);
     776                 :        3560 :       if (ss == gfc_ss_terminator)
     777                 :             :         {
     778                 :        2539 :           parmse->ss = NULL;
     779                 :        2539 :           gfc_conv_expr_reference (parmse, e);
     780                 :             : 
     781                 :             :           /* Scalar to an assumed-rank array.  */
     782                 :        2539 :           if (class_ts.u.derived->components->as)
     783                 :             :             {
     784                 :         318 :               tree type;
     785                 :         318 :               type = get_scalar_to_descriptor_type (parmse->expr,
     786                 :             :                                                     gfc_expr_attr (e));
     787                 :         318 :               gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
     788                 :             :                               gfc_get_dtype (type));
     789                 :         318 :               if (optional)
     790                 :         192 :                 parmse->expr = build3_loc (input_location, COND_EXPR,
     791                 :          96 :                                            TREE_TYPE (parmse->expr),
     792                 :             :                                            cond_optional, parmse->expr,
     793                 :          96 :                                            fold_convert (TREE_TYPE (parmse->expr),
     794                 :             :                                                          null_pointer_node));
     795                 :         318 :               gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
     796                 :             :             }
     797                 :             :           else
     798                 :             :             {
     799                 :        2221 :               tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
     800                 :        2221 :               if (optional)
     801                 :         132 :                 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
     802                 :             :                                   cond_optional, tmp,
     803                 :         132 :                                   fold_convert (TREE_TYPE (tmp),
     804                 :             :                                                 null_pointer_node));
     805                 :        2221 :               gfc_add_modify (&parmse->pre, ctree, tmp);
     806                 :             :             }
     807                 :             :         }
     808                 :             :       else
     809                 :             :         {
     810                 :        1021 :           stmtblock_t block;
     811                 :        1021 :           gfc_init_block (&block);
     812                 :        1021 :           gfc_ref *ref;
     813                 :             : 
     814                 :        1021 :           parmse->ss = ss;
     815                 :        1021 :           parmse->use_offset = 1;
     816                 :        1021 :           gfc_conv_expr_descriptor (parmse, e);
     817                 :             : 
     818                 :             :           /* Detect any array references with vector subscripts.  */
     819                 :        2042 :           for (ref = e->ref; ref; ref = ref->next)
     820                 :        1027 :             if (ref->type == REF_ARRAY
     821                 :         985 :                 && ref->u.ar.type != AR_ELEMENT
     822                 :         985 :                 && ref->u.ar.type != AR_FULL)
     823                 :             :               {
     824                 :         126 :                 for (dim = 0; dim < ref->u.ar.dimen; dim++)
     825                 :          78 :                   if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
     826                 :             :                     break;
     827                 :          54 :                 if (dim < ref->u.ar.dimen)
     828                 :             :                   break;
     829                 :             :               }
     830                 :             : 
     831                 :             :           /* Array references with vector subscripts and non-variable expressions
     832                 :             :              need be converted to a one-based descriptor.  */
     833                 :        1021 :           if (ref || e->expr_type != EXPR_VARIABLE)
     834                 :             :             {
     835                 :          84 :               for (dim = 0; dim < e->rank; ++dim)
     836                 :          42 :                 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
     837                 :             :                                                   gfc_index_one_node);
     838                 :             :             }
     839                 :             : 
     840                 :        1021 :           if (e->rank != class_ts.u.derived->components->as->rank)
     841                 :             :             {
     842                 :         396 :               gcc_assert (class_ts.u.derived->components->as->type
     843                 :             :                           == AS_ASSUMED_RANK);
     844                 :         396 :               if (derived_array
     845                 :         396 :                   && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
     846                 :             :                 {
     847                 :         396 :                   *derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
     848                 :             :                                                    "array");
     849                 :         396 :                   gfc_add_modify (&block, *derived_array , parmse->expr);
     850                 :             :                 }
     851                 :         396 :               class_array_data_assign (&block, ctree, parmse->expr, false);
     852                 :             :             }
     853                 :             :           else
     854                 :             :             {
     855                 :         625 :               if (gfc_expr_attr (e).codimension)
     856                 :          72 :                 parmse->expr = fold_build1_loc (input_location,
     857                 :             :                                                 VIEW_CONVERT_EXPR,
     858                 :          72 :                                                 TREE_TYPE (ctree),
     859                 :             :                                                 parmse->expr);
     860                 :         625 :               gfc_add_modify (&block, ctree, parmse->expr);
     861                 :             :             }
     862                 :             : 
     863                 :        1021 :           if (optional)
     864                 :             :             {
     865                 :         348 :               tmp = gfc_finish_block (&block);
     866                 :             : 
     867                 :         348 :               gfc_init_block (&block);
     868                 :         348 :               gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
     869                 :         348 :               if (derived_array && *derived_array != NULL_TREE)
     870                 :         132 :                 gfc_conv_descriptor_data_set (&block, *derived_array,
     871                 :             :                                               null_pointer_node);
     872                 :             : 
     873                 :         348 :               tmp = build3_v (COND_EXPR, cond_optional, tmp,
     874                 :             :                               gfc_finish_block (&block));
     875                 :         348 :               gfc_add_expr_to_block (&parmse->pre, tmp);
     876                 :             :             }
     877                 :             :           else
     878                 :         673 :             gfc_add_block_to_block (&parmse->pre, &block);
     879                 :             :         }
     880                 :             :     }
     881                 :             : 
     882                 :        4235 :   if (class_ts.u.derived->components->ts.type == BT_DERIVED
     883                 :        4235 :       && class_ts.u.derived->components->ts.u.derived
     884                 :        4235 :                  ->attr.unlimited_polymorphic)
     885                 :             :     {
     886                 :             :       /* Take care about initializing the _len component correctly.  */
     887                 :         288 :       ctree = gfc_class_len_get (var);
     888                 :         288 :       if (UNLIMITED_POLY (e))
     889                 :             :         {
     890                 :           6 :           gfc_expr *len;
     891                 :           6 :           gfc_se se;
     892                 :             : 
     893                 :           6 :           len = gfc_find_and_cut_at_last_class_ref (e);
     894                 :           6 :           gfc_add_len_component (len);
     895                 :           6 :           gfc_init_se (&se, NULL);
     896                 :           6 :           gfc_conv_expr (&se, len);
     897                 :           6 :           if (optional)
     898                 :           0 :             tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
     899                 :             :                               cond_optional, se.expr,
     900                 :           0 :                               fold_convert (TREE_TYPE (se.expr),
     901                 :             :                                             integer_zero_node));
     902                 :             :           else
     903                 :           6 :             tmp = se.expr;
     904                 :           6 :           gfc_free_expr (len);
     905                 :           6 :         }
     906                 :             :       else
     907                 :         282 :         tmp = integer_zero_node;
     908                 :         288 :       gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
     909                 :             :                                                           tmp));
     910                 :             :     }
     911                 :             :   /* Pass the address of the class object.  */
     912                 :        4235 :   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
     913                 :             : 
     914                 :        4235 :   if (optional && optional_alloc_ptr)
     915                 :         168 :     parmse->expr = build3_loc (input_location, COND_EXPR,
     916                 :          84 :                                TREE_TYPE (parmse->expr),
     917                 :             :                                cond_optional, parmse->expr,
     918                 :          84 :                                fold_convert (TREE_TYPE (parmse->expr),
     919                 :             :                                              null_pointer_node));
     920                 :        4235 : }
     921                 :             : 
     922                 :             : 
     923                 :             : /* Create a new class container, which is required as scalar coarrays
     924                 :             :    have an array descriptor while normal scalars haven't. Optionally,
     925                 :             :    NULL pointer checks are added if the argument is OPTIONAL.  */
     926                 :             : 
     927                 :             : static void
     928                 :          48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
     929                 :             :                                gfc_typespec class_ts, bool optional)
     930                 :             : {
     931                 :          48 :   tree var, ctree, tmp;
     932                 :          48 :   stmtblock_t block;
     933                 :          48 :   gfc_ref *ref;
     934                 :          48 :   gfc_ref *class_ref;
     935                 :             : 
     936                 :          48 :   gfc_init_block (&block);
     937                 :             : 
     938                 :          48 :   class_ref = NULL;
     939                 :         144 :   for (ref = e->ref; ref; ref = ref->next)
     940                 :             :     {
     941                 :          96 :       if (ref->type == REF_COMPONENT
     942                 :          48 :             && ref->u.c.component->ts.type == BT_CLASS)
     943                 :          96 :         class_ref = ref;
     944                 :             :     }
     945                 :             : 
     946                 :          48 :   if (class_ref == NULL
     947                 :          48 :         && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
     948                 :          48 :     tmp = e->symtree->n.sym->backend_decl;
     949                 :             :   else
     950                 :             :     {
     951                 :             :       /* Remove everything after the last class reference, convert the
     952                 :             :          expression and then recover its tailend once more.  */
     953                 :           0 :       gfc_se tmpse;
     954                 :           0 :       ref = class_ref->next;
     955                 :           0 :       class_ref->next = NULL;
     956                 :           0 :       gfc_init_se (&tmpse, NULL);
     957                 :           0 :       gfc_conv_expr (&tmpse, e);
     958                 :           0 :       class_ref->next = ref;
     959                 :           0 :       tmp = tmpse.expr;
     960                 :             :     }
     961                 :             : 
     962                 :          48 :   var = gfc_typenode_for_spec (&class_ts);
     963                 :          48 :   var = gfc_create_var (var, "class");
     964                 :             : 
     965                 :          48 :   ctree = gfc_class_vptr_get (var);
     966                 :          96 :   gfc_add_modify (&block, ctree,
     967                 :          48 :                   fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
     968                 :             : 
     969                 :          48 :   ctree = gfc_class_data_get (var);
     970                 :          48 :   tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
     971                 :          48 :   gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
     972                 :             : 
     973                 :             :   /* Pass the address of the class object.  */
     974                 :          48 :   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
     975                 :             : 
     976                 :          48 :   if (optional)
     977                 :             :     {
     978                 :          48 :       tree cond = gfc_conv_expr_present (e->symtree->n.sym);
     979                 :          48 :       tree tmp2;
     980                 :             : 
     981                 :          48 :       tmp = gfc_finish_block (&block);
     982                 :             : 
     983                 :          48 :       gfc_init_block (&block);
     984                 :          48 :       tmp2 = gfc_class_data_get (var);
     985                 :          48 :       gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
     986                 :             :                                                   null_pointer_node));
     987                 :          48 :       tmp2 = gfc_finish_block (&block);
     988                 :             : 
     989                 :          48 :       tmp = build3_loc (input_location, COND_EXPR, void_type_node,
     990                 :             :                         cond, tmp, tmp2);
     991                 :          48 :       gfc_add_expr_to_block (&parmse->pre, tmp);
     992                 :             :     }
     993                 :             :   else
     994                 :           0 :     gfc_add_block_to_block (&parmse->pre, &block);
     995                 :          48 : }
     996                 :             : 
     997                 :             : 
     998                 :             : /* Takes an intrinsic type expression and returns the address of a temporary
     999                 :             :    class object of the 'declared' type.  */
    1000                 :             : void
    1001                 :         697 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
    1002                 :             :                              gfc_typespec class_ts)
    1003                 :             : {
    1004                 :         697 :   gfc_symbol *vtab;
    1005                 :         697 :   gfc_ss *ss;
    1006                 :         697 :   tree ctree;
    1007                 :         697 :   tree var;
    1008                 :         697 :   tree tmp;
    1009                 :         697 :   int dim;
    1010                 :         697 :   bool unlimited_poly;
    1011                 :             : 
    1012                 :        1394 :   unlimited_poly = class_ts.type == BT_CLASS
    1013                 :         697 :                    && class_ts.u.derived->components->ts.type == BT_DERIVED
    1014                 :         697 :                    && class_ts.u.derived->components->ts.u.derived
    1015                 :         697 :                                                 ->attr.unlimited_polymorphic;
    1016                 :             : 
    1017                 :             :   /* The intrinsic type needs to be converted to a temporary
    1018                 :             :      CLASS object.  */
    1019                 :         697 :   tmp = gfc_typenode_for_spec (&class_ts);
    1020                 :         697 :   var = gfc_create_var (tmp, "class");
    1021                 :             : 
    1022                 :             :   /* Set the vptr.  */
    1023                 :         697 :   ctree = gfc_class_vptr_get (var);
    1024                 :             : 
    1025                 :         697 :   vtab = gfc_find_vtab (&e->ts);
    1026                 :         697 :   gcc_assert (vtab);
    1027                 :         697 :   tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
    1028                 :         697 :   gfc_add_modify (&parmse->pre, ctree,
    1029                 :         697 :                   fold_convert (TREE_TYPE (ctree), tmp));
    1030                 :             : 
    1031                 :             :   /* Now set the data field.  */
    1032                 :         697 :   ctree = gfc_class_data_get (var);
    1033                 :         697 :   if (parmse->ss && parmse->ss->info->useflags)
    1034                 :             :     {
    1035                 :             :       /* For an array reference in an elemental procedure call we need
    1036                 :             :          to retain the ss to provide the scalarized array reference.  */
    1037                 :           0 :       gfc_conv_expr_reference (parmse, e);
    1038                 :           0 :       tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
    1039                 :           0 :       gfc_add_modify (&parmse->pre, ctree, tmp);
    1040                 :             :     }
    1041                 :             :   else
    1042                 :             :     {
    1043                 :         697 :       ss = gfc_walk_expr (e);
    1044                 :         697 :       if (ss == gfc_ss_terminator)
    1045                 :             :         {
    1046                 :         202 :           parmse->ss = NULL;
    1047                 :         202 :           gfc_conv_expr_reference (parmse, e);
    1048                 :         202 :           if (class_ts.u.derived->components->as
    1049                 :          24 :               && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
    1050                 :             :             {
    1051                 :          24 :               tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
    1052                 :             :                                                    gfc_expr_attr (e));
    1053                 :          24 :               tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
    1054                 :          24 :                                      TREE_TYPE (ctree), tmp);
    1055                 :             :             }
    1056                 :             :           else
    1057                 :         178 :               tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
    1058                 :         202 :           gfc_add_modify (&parmse->pre, ctree, tmp);
    1059                 :             :         }
    1060                 :             :       else
    1061                 :             :         {
    1062                 :         495 :           parmse->ss = ss;
    1063                 :         495 :           parmse->use_offset = 1;
    1064                 :         495 :           gfc_conv_expr_descriptor (parmse, e);
    1065                 :             : 
    1066                 :             :           /* Array references with vector subscripts and non-variable expressions
    1067                 :             :              need be converted to a one-based descriptor.  */
    1068                 :         495 :           if (e->expr_type != EXPR_VARIABLE)
    1069                 :             :             {
    1070                 :         368 :               for (dim = 0; dim < e->rank; ++dim)
    1071                 :         193 :                 gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
    1072                 :             :                                                   dim, gfc_index_one_node);
    1073                 :             :             }
    1074                 :             : 
    1075                 :         495 :           if (class_ts.u.derived->components->as->rank != e->rank)
    1076                 :             :             {
    1077                 :          49 :               tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
    1078                 :          49 :                                      TREE_TYPE (ctree), parmse->expr);
    1079                 :          49 :               gfc_add_modify (&parmse->pre, ctree, tmp);
    1080                 :             :             }
    1081                 :             :           else
    1082                 :         446 :             gfc_add_modify (&parmse->pre, ctree, parmse->expr);
    1083                 :             :         }
    1084                 :             :     }
    1085                 :             : 
    1086                 :         697 :   gcc_assert (class_ts.type == BT_CLASS);
    1087                 :         697 :   if (unlimited_poly)
    1088                 :             :     {
    1089                 :         697 :       ctree = gfc_class_len_get (var);
    1090                 :             :       /* When the actual arg is a char array, then set the _len component of the
    1091                 :             :          unlimited polymorphic entity to the length of the string.  */
    1092                 :         697 :       if (e->ts.type == BT_CHARACTER)
    1093                 :             :         {
    1094                 :             :           /* Start with parmse->string_length because this seems to be set to a
    1095                 :             :            correct value more often.  */
    1096                 :         110 :           if (parmse->string_length)
    1097                 :             :             tmp = parmse->string_length;
    1098                 :             :           /* When the string_length is not yet set, then try the backend_decl of
    1099                 :             :            the cl.  */
    1100                 :           0 :           else if (e->ts.u.cl->backend_decl)
    1101                 :             :             tmp = e->ts.u.cl->backend_decl;
    1102                 :             :           /* If both of the above approaches fail, then try to generate an
    1103                 :             :            expression from the input, which is only feasible currently, when the
    1104                 :             :            expression can be evaluated to a constant one.  */
    1105                 :             :           else
    1106                 :             :             {
    1107                 :             :               /* Try to simplify the expression.  */
    1108                 :           0 :               gfc_simplify_expr (e, 0);
    1109                 :           0 :               if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
    1110                 :             :                 {
    1111                 :             :                   /* Amazingly all data is present to compute the length of a
    1112                 :             :                    constant string, but the expression is not yet there.  */
    1113                 :           0 :                   e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
    1114                 :             :                                                               gfc_charlen_int_kind,
    1115                 :             :                                                               &e->where);
    1116                 :           0 :                   mpz_set_ui (e->ts.u.cl->length->value.integer,
    1117                 :           0 :                               e->value.character.length);
    1118                 :           0 :                   gfc_conv_const_charlen (e->ts.u.cl);
    1119                 :           0 :                   e->ts.u.cl->resolved = 1;
    1120                 :           0 :                   tmp = e->ts.u.cl->backend_decl;
    1121                 :             :                 }
    1122                 :             :               else
    1123                 :             :                 {
    1124                 :           0 :                   gfc_error ("Cannot compute the length of the char array "
    1125                 :             :                              "at %L.", &e->where);
    1126                 :             :                 }
    1127                 :             :             }
    1128                 :             :         }
    1129                 :             :       else
    1130                 :         587 :         tmp = integer_zero_node;
    1131                 :             : 
    1132                 :         697 :       gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
    1133                 :             :     }
    1134                 :             :   else if (unlimited_poly)
    1135                 :             :     {
    1136                 :             :       ctree = gfc_class_len_get (var);
    1137                 :             :       gfc_add_modify (&parmse->pre, ctree,
    1138                 :             :                       fold_convert (TREE_TYPE (ctree),
    1139                 :             :                                     integer_zero_node));
    1140                 :             :     }
    1141                 :             :   /* Pass the address of the class object.  */
    1142                 :         697 :   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
    1143                 :         697 : }
    1144                 :             : 
    1145                 :             : 
    1146                 :             : /* Takes a scalarized class array expression and returns the
    1147                 :             :    address of a temporary scalar class object of the 'declared'
    1148                 :             :    type.
    1149                 :             :    OOP-TODO: This could be improved by adding code that branched on
    1150                 :             :    the dynamic type being the same as the declared type. In this case
    1151                 :             :    the original class expression can be passed directly.
    1152                 :             :    optional_alloc_ptr is false when the dummy is neither allocatable
    1153                 :             :    nor a pointer; that's relevant for the optional handling.
    1154                 :             :    Set copyback to true if class container's _data and _vtab pointers
    1155                 :             :    might get modified.  */
    1156                 :             : 
    1157                 :             : void
    1158                 :        3116 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
    1159                 :             :                          bool elemental, bool copyback, bool optional,
    1160                 :             :                          bool optional_alloc_ptr)
    1161                 :             : {
    1162                 :        3116 :   tree ctree;
    1163                 :        3116 :   tree var;
    1164                 :        3116 :   tree tmp;
    1165                 :        3116 :   tree vptr;
    1166                 :        3116 :   tree cond = NULL_TREE;
    1167                 :        3116 :   tree slen = NULL_TREE;
    1168                 :        3116 :   gfc_ref *ref;
    1169                 :        3116 :   gfc_ref *class_ref;
    1170                 :        3116 :   stmtblock_t block;
    1171                 :        3116 :   bool full_array = false;
    1172                 :             : 
    1173                 :        3116 :   gfc_init_block (&block);
    1174                 :             : 
    1175                 :        3116 :   class_ref = NULL;
    1176                 :        6256 :   for (ref = e->ref; ref; ref = ref->next)
    1177                 :             :     {
    1178                 :        5901 :       if (ref->type == REF_COMPONENT
    1179                 :        3173 :             && ref->u.c.component->ts.type == BT_CLASS)
    1180                 :        5901 :         class_ref = ref;
    1181                 :             : 
    1182                 :        5901 :       if (ref->next == NULL)
    1183                 :             :         break;
    1184                 :             :     }
    1185                 :             : 
    1186                 :        3116 :   if ((ref == NULL || class_ref == ref)
    1187                 :         466 :       && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
    1188                 :        3570 :       && (!class_ts.u.derived->components->as
    1189                 :         372 :           || class_ts.u.derived->components->as->rank != -1))
    1190                 :         128 :     return;
    1191                 :             : 
    1192                 :             :   /* Test for FULL_ARRAY.  */
    1193                 :        2988 :   if (e->rank == 0
    1194                 :        2988 :       && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
    1195                 :         478 :           || (class_ts.u.derived->components->as
    1196                 :         350 :               && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
    1197                 :         397 :     full_array = true;
    1198                 :             :   else
    1199                 :        2591 :     gfc_is_class_array_ref (e, &full_array);
    1200                 :             : 
    1201                 :             :   /* The derived type needs to be converted to a temporary
    1202                 :             :      CLASS object.  */
    1203                 :        2988 :   tmp = gfc_typenode_for_spec (&class_ts);
    1204                 :        2988 :   var = gfc_create_var (tmp, "class");
    1205                 :             : 
    1206                 :             :   /* Set the data.  */
    1207                 :        2988 :   ctree = gfc_class_data_get (var);
    1208                 :        2988 :   if (class_ts.u.derived->components->as
    1209                 :        2734 :       && e->rank != class_ts.u.derived->components->as->rank)
    1210                 :             :     {
    1211                 :         904 :       if (e->rank == 0)
    1212                 :             :         {
    1213                 :         350 :           tree type = get_scalar_to_descriptor_type (parmse->expr,
    1214                 :             :                                                      gfc_expr_attr (e));
    1215                 :         350 :           gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
    1216                 :             :                           gfc_get_dtype (type));
    1217                 :             : 
    1218                 :         350 :           tmp = gfc_class_data_get (parmse->expr);
    1219                 :         350 :           if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
    1220                 :          12 :             tmp = gfc_build_addr_expr (NULL_TREE, tmp);
    1221                 :             : 
    1222                 :         350 :           gfc_conv_descriptor_data_set (&block, ctree, tmp);
    1223                 :             :         }
    1224                 :             :       else
    1225                 :         554 :         class_array_data_assign (&block, ctree, parmse->expr, false);
    1226                 :             :     }
    1227                 :             :   else
    1228                 :             :     {
    1229                 :        2084 :       if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
    1230                 :        1189 :         parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
    1231                 :        1189 :                                         TREE_TYPE (ctree), parmse->expr);
    1232                 :        2084 :       gfc_add_modify (&block, ctree, parmse->expr);
    1233                 :             :     }
    1234                 :             : 
    1235                 :             :   /* Return the data component, except in the case of scalarized array
    1236                 :             :      references, where nullification of the cannot occur and so there
    1237                 :             :      is no need.  */
    1238                 :        2988 :   if (!elemental && full_array && copyback)
    1239                 :             :     {
    1240                 :        1004 :       if (class_ts.u.derived->components->as
    1241                 :        1004 :           && e->rank != class_ts.u.derived->components->as->rank)
    1242                 :             :         {
    1243                 :         270 :           if (e->rank == 0)
    1244                 :             :             {
    1245                 :         102 :               tmp = gfc_class_data_get (parmse->expr);
    1246                 :         204 :               gfc_add_modify (&parmse->post, tmp,
    1247                 :         102 :                               fold_convert (TREE_TYPE (tmp),
    1248                 :             :                                          gfc_conv_descriptor_data_get (ctree)));
    1249                 :             :             }
    1250                 :             :           else
    1251                 :         168 :             class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
    1252                 :             :         }
    1253                 :             :       else
    1254                 :         734 :         gfc_add_modify (&parmse->post, parmse->expr, ctree);
    1255                 :             :     }
    1256                 :             : 
    1257                 :             :   /* Set the vptr.  */
    1258                 :        2988 :   ctree = gfc_class_vptr_get (var);
    1259                 :             : 
    1260                 :             :   /* The vptr is the second field of the actual argument.
    1261                 :             :      First we have to find the corresponding class reference.  */
    1262                 :             : 
    1263                 :        2988 :   tmp = NULL_TREE;
    1264                 :        2988 :   if (gfc_is_class_array_function (e)
    1265                 :        2988 :       && parmse->class_vptr != NULL_TREE)
    1266                 :             :     tmp = parmse->class_vptr;
    1267                 :        2976 :   else if (class_ref == NULL
    1268                 :        2545 :            && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
    1269                 :             :     {
    1270                 :        2545 :       tmp = e->symtree->n.sym->backend_decl;
    1271                 :             : 
    1272                 :        2545 :       if (TREE_CODE (tmp) == FUNCTION_DECL)
    1273                 :           6 :         tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
    1274                 :             : 
    1275                 :        2545 :       if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
    1276                 :         303 :         tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
    1277                 :             : 
    1278                 :        2545 :       slen = build_zero_cst (size_type_node);
    1279                 :             :     }
    1280                 :         431 :   else if (parmse->class_container != NULL_TREE)
    1281                 :             :     /* Don't redundantly evaluate the expression if the required information
    1282                 :             :        is already available.  */
    1283                 :             :     tmp = parmse->class_container;
    1284                 :             :   else
    1285                 :             :     {
    1286                 :             :       /* Remove everything after the last class reference, convert the
    1287                 :             :          expression and then recover its tailend once more.  */
    1288                 :          18 :       gfc_se tmpse;
    1289                 :          18 :       ref = class_ref->next;
    1290                 :          18 :       class_ref->next = NULL;
    1291                 :          18 :       gfc_init_se (&tmpse, NULL);
    1292                 :          18 :       gfc_conv_expr (&tmpse, e);
    1293                 :          18 :       class_ref->next = ref;
    1294                 :          18 :       tmp = tmpse.expr;
    1295                 :          18 :       slen = tmpse.string_length;
    1296                 :             :     }
    1297                 :             : 
    1298                 :        2988 :   gcc_assert (tmp != NULL_TREE);
    1299                 :             : 
    1300                 :             :   /* Dereference if needs be.  */
    1301                 :        2988 :   if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
    1302                 :         267 :     tmp = build_fold_indirect_ref_loc (input_location, tmp);
    1303                 :             : 
    1304                 :        2988 :   if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
    1305                 :        2976 :     vptr = gfc_class_vptr_get (tmp);
    1306                 :             :   else
    1307                 :             :     vptr = tmp;
    1308                 :             : 
    1309                 :        2988 :   gfc_add_modify (&block, ctree,
    1310                 :        2988 :                   fold_convert (TREE_TYPE (ctree), vptr));
    1311                 :             : 
    1312                 :             :   /* Return the vptr component, except in the case of scalarized array
    1313                 :             :      references, where the dynamic type cannot change.  */
    1314                 :        2988 :   if (!elemental && full_array && copyback)
    1315                 :        1004 :     gfc_add_modify (&parmse->post, vptr,
    1316                 :        1004 :                     fold_convert (TREE_TYPE (vptr), ctree));
    1317                 :             : 
    1318                 :             :   /* For unlimited polymorphic objects also set the _len component.  */
    1319                 :        2988 :   if (class_ts.type == BT_CLASS
    1320                 :        2988 :       && class_ts.u.derived->components
    1321                 :        2988 :       && class_ts.u.derived->components->ts.u
    1322                 :        2988 :                       .derived->attr.unlimited_polymorphic)
    1323                 :             :     {
    1324                 :         838 :       ctree = gfc_class_len_get (var);
    1325                 :         838 :       if (UNLIMITED_POLY (e))
    1326                 :         636 :         tmp = gfc_class_len_get (tmp);
    1327                 :         202 :       else if (e->ts.type == BT_CHARACTER)
    1328                 :             :         {
    1329                 :           0 :           gcc_assert (slen != NULL_TREE);
    1330                 :             :           tmp = slen;
    1331                 :             :         }
    1332                 :             :       else
    1333                 :         202 :         tmp = build_zero_cst (size_type_node);
    1334                 :         838 :       gfc_add_modify (&parmse->pre, ctree,
    1335                 :         838 :                       fold_convert (TREE_TYPE (ctree), tmp));
    1336                 :             : 
    1337                 :             :       /* Return the len component, except in the case of scalarized array
    1338                 :             :         references, where the dynamic type cannot change.  */
    1339                 :         838 :       if (!elemental && full_array && copyback
    1340                 :         380 :           && (UNLIMITED_POLY (e) || VAR_P (tmp)))
    1341                 :         338 :           gfc_add_modify (&parmse->post, tmp,
    1342                 :         338 :                           fold_convert (TREE_TYPE (tmp), ctree));
    1343                 :             :     }
    1344                 :             : 
    1345                 :        2988 :   if (optional)
    1346                 :             :     {
    1347                 :         486 :       tree tmp2;
    1348                 :             : 
    1349                 :         486 :       cond = gfc_conv_expr_present (e->symtree->n.sym);
    1350                 :             :       /* parmse->pre may contain some preparatory instructions for the
    1351                 :             :          temporary array descriptor.  Those may only be executed when the
    1352                 :             :          optional argument is set, therefore add parmse->pre's instructions
    1353                 :             :          to block, which is later guarded by an if (optional_arg_given).  */
    1354                 :         486 :       gfc_add_block_to_block (&parmse->pre, &block);
    1355                 :         486 :       block.head = parmse->pre.head;
    1356                 :         486 :       parmse->pre.head = NULL_TREE;
    1357                 :         486 :       tmp = gfc_finish_block (&block);
    1358                 :             : 
    1359                 :         486 :       if (optional_alloc_ptr)
    1360                 :          78 :         tmp2 = build_empty_stmt (input_location);
    1361                 :             :       else
    1362                 :             :         {
    1363                 :         408 :           gfc_init_block (&block);
    1364                 :             : 
    1365                 :         408 :           tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
    1366                 :         408 :           gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
    1367                 :             :                                                       null_pointer_node));
    1368                 :         408 :           tmp2 = gfc_finish_block (&block);
    1369                 :             :         }
    1370                 :             : 
    1371                 :         486 :       tmp = build3_loc (input_location, COND_EXPR, void_type_node,
    1372                 :             :                         cond, tmp, tmp2);
    1373                 :         486 :       gfc_add_expr_to_block (&parmse->pre, tmp);
    1374                 :             :     }
    1375                 :             :   else
    1376                 :        2502 :     gfc_add_block_to_block (&parmse->pre, &block);
    1377                 :             : 
    1378                 :             :   /* Pass the address of the class object.  */
    1379                 :        2988 :   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
    1380                 :             : 
    1381                 :        2988 :   if (optional && optional_alloc_ptr)
    1382                 :         156 :     parmse->expr = build3_loc (input_location, COND_EXPR,
    1383                 :          78 :                                TREE_TYPE (parmse->expr),
    1384                 :             :                                cond, parmse->expr,
    1385                 :          78 :                                fold_convert (TREE_TYPE (parmse->expr),
    1386                 :             :                                              null_pointer_node));
    1387                 :             : }
    1388                 :             : 
    1389                 :             : 
    1390                 :             : /* Given a class array declaration and an index, returns the address
    1391                 :             :    of the referenced element.  */
    1392                 :             : 
    1393                 :             : static tree
    1394                 :         534 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
    1395                 :             :                          bool unlimited)
    1396                 :             : {
    1397                 :         534 :   tree data, size, tmp, ctmp, offset, ptr;
    1398                 :             : 
    1399                 :         534 :   data = data_comp != NULL_TREE ? data_comp :
    1400                 :           0 :                                   gfc_class_data_get (class_decl);
    1401                 :         534 :   size = gfc_class_vtab_size_get (class_decl);
    1402                 :             : 
    1403                 :         534 :   if (unlimited)
    1404                 :             :     {
    1405                 :         138 :       tmp = fold_convert (gfc_array_index_type,
    1406                 :             :                           gfc_class_len_get (class_decl));
    1407                 :         138 :       ctmp = fold_build2_loc (input_location, MULT_EXPR,
    1408                 :             :                               gfc_array_index_type, size, tmp);
    1409                 :         138 :       tmp = fold_build2_loc (input_location, GT_EXPR,
    1410                 :             :                              logical_type_node, tmp,
    1411                 :         138 :                              build_zero_cst (TREE_TYPE (tmp)));
    1412                 :         138 :       size = fold_build3_loc (input_location, COND_EXPR,
    1413                 :             :                               gfc_array_index_type, tmp, ctmp, size);
    1414                 :             :     }
    1415                 :             : 
    1416                 :         534 :   offset = fold_build2_loc (input_location, MULT_EXPR,
    1417                 :             :                             gfc_array_index_type,
    1418                 :             :                             index, size);
    1419                 :             : 
    1420                 :         534 :   data = gfc_conv_descriptor_data_get (data);
    1421                 :         534 :   ptr = fold_convert (pvoid_type_node, data);
    1422                 :         534 :   ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
    1423                 :         534 :   return fold_convert (TREE_TYPE (data), ptr);
    1424                 :             : }
    1425                 :             : 
    1426                 :             : 
    1427                 :             : /* Copies one class expression to another, assuming that if either
    1428                 :             :    'to' or 'from' are arrays they are packed.  Should 'from' be
    1429                 :             :    NULL_TREE, the initialization expression for 'to' is used, assuming
    1430                 :             :    that the _vptr is set.  */
    1431                 :             : 
    1432                 :             : tree
    1433                 :         619 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
    1434                 :             : {
    1435                 :         619 :   tree fcn;
    1436                 :         619 :   tree fcn_type;
    1437                 :         619 :   tree from_data;
    1438                 :         619 :   tree from_len;
    1439                 :         619 :   tree to_data;
    1440                 :         619 :   tree to_len;
    1441                 :         619 :   tree to_ref;
    1442                 :         619 :   tree from_ref;
    1443                 :         619 :   vec<tree, va_gc> *args;
    1444                 :         619 :   tree tmp;
    1445                 :         619 :   tree stdcopy;
    1446                 :         619 :   tree extcopy;
    1447                 :         619 :   tree index;
    1448                 :         619 :   bool is_from_desc = false, is_to_class = false;
    1449                 :             : 
    1450                 :         619 :   args = NULL;
    1451                 :             :   /* To prevent warnings on uninitialized variables.  */
    1452                 :         619 :   from_len = to_len = NULL_TREE;
    1453                 :             : 
    1454                 :         619 :   if (from != NULL_TREE)
    1455                 :         619 :     fcn = gfc_class_vtab_copy_get (from);
    1456                 :             :   else
    1457                 :           0 :     fcn = gfc_class_vtab_copy_get (to);
    1458                 :             : 
    1459                 :         619 :   fcn_type = TREE_TYPE (TREE_TYPE (fcn));
    1460                 :             : 
    1461                 :         619 :   if (from != NULL_TREE)
    1462                 :             :     {
    1463                 :         619 :       is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
    1464                 :         619 :       if (is_from_desc)
    1465                 :             :         {
    1466                 :           0 :           from_data = from;
    1467                 :           0 :           from = GFC_DECL_SAVED_DESCRIPTOR (from);
    1468                 :             :         }
    1469                 :             :       else
    1470                 :             :         {
    1471                 :             :           /* Check that from is a class.  When the class is part of a coarray,
    1472                 :             :              then from is a common pointer and is to be used as is.  */
    1473                 :        1238 :           tmp = POINTER_TYPE_P (TREE_TYPE (from))
    1474                 :         619 :               ? build_fold_indirect_ref (from) : from;
    1475                 :        1238 :           from_data =
    1476                 :         619 :               (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
    1477                 :           0 :                || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
    1478                 :         619 :               ? gfc_class_data_get (from) : from;
    1479                 :         619 :           is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
    1480                 :             :         }
    1481                 :             :      }
    1482                 :             :   else
    1483                 :           0 :     from_data = gfc_class_vtab_def_init_get (to);
    1484                 :             : 
    1485                 :         619 :   if (unlimited)
    1486                 :             :     {
    1487                 :         127 :       if (from != NULL_TREE && unlimited)
    1488                 :         127 :         from_len = gfc_class_len_or_zero_get (from);
    1489                 :             :       else
    1490                 :           0 :         from_len = build_zero_cst (size_type_node);
    1491                 :             :     }
    1492                 :             : 
    1493                 :         619 :   if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
    1494                 :             :     {
    1495                 :         619 :       is_to_class = true;
    1496                 :         619 :       to_data = gfc_class_data_get (to);
    1497                 :         619 :       if (unlimited)
    1498                 :         127 :         to_len = gfc_class_len_get (to);
    1499                 :             :     }
    1500                 :             :   else
    1501                 :             :     /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to.  */
    1502                 :           0 :     to_data = to;
    1503                 :             : 
    1504                 :         619 :   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
    1505                 :             :     {
    1506                 :         267 :       stmtblock_t loopbody;
    1507                 :         267 :       stmtblock_t body;
    1508                 :         267 :       stmtblock_t ifbody;
    1509                 :         267 :       gfc_loopinfo loop;
    1510                 :         267 :       tree orig_nelems = nelems; /* Needed for bounds check.  */
    1511                 :             : 
    1512                 :         267 :       gfc_init_block (&body);
    1513                 :         267 :       tmp = fold_build2_loc (input_location, MINUS_EXPR,
    1514                 :             :                              gfc_array_index_type, nelems,
    1515                 :             :                              gfc_index_one_node);
    1516                 :         267 :       nelems = gfc_evaluate_now (tmp, &body);
    1517                 :         267 :       index = gfc_create_var (gfc_array_index_type, "S");
    1518                 :             : 
    1519                 :         267 :       if (is_from_desc)
    1520                 :             :         {
    1521                 :         267 :           from_ref = gfc_get_class_array_ref (index, from, from_data,
    1522                 :             :                                               unlimited);
    1523                 :         267 :           vec_safe_push (args, from_ref);
    1524                 :             :         }
    1525                 :             :       else
    1526                 :           0 :         vec_safe_push (args, from_data);
    1527                 :             : 
    1528                 :         267 :       if (is_to_class)
    1529                 :         267 :         to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
    1530                 :             :       else
    1531                 :             :         {
    1532                 :           0 :           tmp = gfc_conv_array_data (to);
    1533                 :           0 :           tmp = build_fold_indirect_ref_loc (input_location, tmp);
    1534                 :           0 :           to_ref = gfc_build_addr_expr (NULL_TREE,
    1535                 :             :                                         gfc_build_array_ref (tmp, index, to));
    1536                 :             :         }
    1537                 :         267 :       vec_safe_push (args, to_ref);
    1538                 :             : 
    1539                 :             :       /* Add bounds check.  */
    1540                 :         267 :       if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
    1541                 :             :         {
    1542                 :           1 :           char *msg;
    1543                 :           1 :           const char *name = "<<unknown>>";
    1544                 :           1 :           tree from_len;
    1545                 :             : 
    1546                 :           1 :           if (DECL_P (to))
    1547                 :           0 :             name = (const char *)(DECL_NAME (to)->identifier.id.str);
    1548                 :             : 
    1549                 :           1 :           from_len = gfc_conv_descriptor_size (from_data, 1);
    1550                 :           1 :           from_len = fold_convert (TREE_TYPE (orig_nelems), from_len);
    1551                 :           1 :           tmp = fold_build2_loc (input_location, NE_EXPR,
    1552                 :             :                                   logical_type_node, from_len, orig_nelems);
    1553                 :           1 :           msg = xasprintf ("Array bound mismatch for dimension %d "
    1554                 :             :                            "of array '%s' (%%ld/%%ld)",
    1555                 :             :                            1, name);
    1556                 :             : 
    1557                 :           1 :           gfc_trans_runtime_check (true, false, tmp, &body,
    1558                 :             :                                    &gfc_current_locus, msg,
    1559                 :             :                              fold_convert (long_integer_type_node, orig_nelems),
    1560                 :             :                                fold_convert (long_integer_type_node, from_len));
    1561                 :             : 
    1562                 :           1 :           free (msg);
    1563                 :             :         }
    1564                 :             : 
    1565                 :         267 :       tmp = build_call_vec (fcn_type, fcn, args);
    1566                 :             : 
    1567                 :             :       /* Build the body of the loop.  */
    1568                 :         267 :       gfc_init_block (&loopbody);
    1569                 :         267 :       gfc_add_expr_to_block (&loopbody, tmp);
    1570                 :             : 
    1571                 :             :       /* Build the loop and return.  */
    1572                 :         267 :       gfc_init_loopinfo (&loop);
    1573                 :         267 :       loop.dimen = 1;
    1574                 :         267 :       loop.from[0] = gfc_index_zero_node;
    1575                 :         267 :       loop.loopvar[0] = index;
    1576                 :         267 :       loop.to[0] = nelems;
    1577                 :         267 :       gfc_trans_scalarizing_loops (&loop, &loopbody);
    1578                 :         267 :       gfc_init_block (&ifbody);
    1579                 :         267 :       gfc_add_block_to_block (&ifbody, &loop.pre);
    1580                 :         267 :       stdcopy = gfc_finish_block (&ifbody);
    1581                 :             :       /* In initialization mode from_len is a constant zero.  */
    1582                 :         267 :       if (unlimited && !integer_zerop (from_len))
    1583                 :             :         {
    1584                 :          69 :           vec_safe_push (args, from_len);
    1585                 :          69 :           vec_safe_push (args, to_len);
    1586                 :          69 :           tmp = build_call_vec (fcn_type, fcn, args);
    1587                 :             :           /* Build the body of the loop.  */
    1588                 :          69 :           gfc_init_block (&loopbody);
    1589                 :          69 :           gfc_add_expr_to_block (&loopbody, tmp);
    1590                 :             : 
    1591                 :             :           /* Build the loop and return.  */
    1592                 :          69 :           gfc_init_loopinfo (&loop);
    1593                 :          69 :           loop.dimen = 1;
    1594                 :          69 :           loop.from[0] = gfc_index_zero_node;
    1595                 :          69 :           loop.loopvar[0] = index;
    1596                 :          69 :           loop.to[0] = nelems;
    1597                 :          69 :           gfc_trans_scalarizing_loops (&loop, &loopbody);
    1598                 :          69 :           gfc_init_block (&ifbody);
    1599                 :          69 :           gfc_add_block_to_block (&ifbody, &loop.pre);
    1600                 :          69 :           extcopy = gfc_finish_block (&ifbody);
    1601                 :             : 
    1602                 :          69 :           tmp = fold_build2_loc (input_location, GT_EXPR,
    1603                 :             :                                  logical_type_node, from_len,
    1604                 :          69 :                                  build_zero_cst (TREE_TYPE (from_len)));
    1605                 :          69 :           tmp = fold_build3_loc (input_location, COND_EXPR,
    1606                 :             :                                  void_type_node, tmp, extcopy, stdcopy);
    1607                 :          69 :           gfc_add_expr_to_block (&body, tmp);
    1608                 :          69 :           tmp = gfc_finish_block (&body);
    1609                 :             :         }
    1610                 :             :       else
    1611                 :             :         {
    1612                 :         198 :           gfc_add_expr_to_block (&body, stdcopy);
    1613                 :         198 :           tmp = gfc_finish_block (&body);
    1614                 :             :         }
    1615                 :         267 :       gfc_cleanup_loop (&loop);
    1616                 :             :     }
    1617                 :             :   else
    1618                 :             :     {
    1619                 :         352 :       gcc_assert (!is_from_desc);
    1620                 :         352 :       vec_safe_push (args, from_data);
    1621                 :         352 :       vec_safe_push (args, to_data);
    1622                 :         352 :       stdcopy = build_call_vec (fcn_type, fcn, args);
    1623                 :             : 
    1624                 :             :       /* In initialization mode from_len is a constant zero.  */
    1625                 :         352 :       if (unlimited && !integer_zerop (from_len))
    1626                 :             :         {
    1627                 :          58 :           vec_safe_push (args, from_len);
    1628                 :          58 :           vec_safe_push (args, to_len);
    1629                 :          58 :           extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
    1630                 :          58 :           tmp = fold_build2_loc (input_location, GT_EXPR,
    1631                 :             :                                  logical_type_node, from_len,
    1632                 :          58 :                                  build_zero_cst (TREE_TYPE (from_len)));
    1633                 :          58 :           tmp = fold_build3_loc (input_location, COND_EXPR,
    1634                 :             :                                  void_type_node, tmp, extcopy, stdcopy);
    1635                 :             :         }
    1636                 :             :       else
    1637                 :             :         tmp = stdcopy;
    1638                 :             :     }
    1639                 :             : 
    1640                 :             :   /* Only copy _def_init to to_data, when it is not a NULL-pointer.  */
    1641                 :         619 :   if (from == NULL_TREE)
    1642                 :             :     {
    1643                 :           0 :       tree cond;
    1644                 :           0 :       cond = fold_build2_loc (input_location, NE_EXPR,
    1645                 :             :                               logical_type_node,
    1646                 :             :                               from_data, null_pointer_node);
    1647                 :           0 :       tmp = fold_build3_loc (input_location, COND_EXPR,
    1648                 :             :                              void_type_node, cond,
    1649                 :             :                              tmp, build_empty_stmt (input_location));
    1650                 :             :     }
    1651                 :             : 
    1652                 :         619 :   return tmp;
    1653                 :             : }
    1654                 :             : 
    1655                 :             : 
    1656                 :             : static tree
    1657                 :          93 : gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
    1658                 :             : {
    1659                 :          93 :   gfc_actual_arglist *actual;
    1660                 :          93 :   gfc_expr *ppc;
    1661                 :          93 :   gfc_code *ppc_code;
    1662                 :          93 :   tree res;
    1663                 :             : 
    1664                 :          93 :   actual = gfc_get_actual_arglist ();
    1665                 :          93 :   actual->expr = gfc_copy_expr (rhs);
    1666                 :          93 :   actual->next = gfc_get_actual_arglist ();
    1667                 :          93 :   actual->next->expr = gfc_copy_expr (lhs);
    1668                 :          93 :   ppc = gfc_copy_expr (obj);
    1669                 :          93 :   gfc_add_vptr_component (ppc);
    1670                 :          93 :   gfc_add_component_ref (ppc, "_copy");
    1671                 :          93 :   ppc_code = gfc_get_code (EXEC_CALL);
    1672                 :          93 :   ppc_code->resolved_sym = ppc->symtree->n.sym;
    1673                 :             :   /* Although '_copy' is set to be elemental in class.cc, it is
    1674                 :             :      not staying that way.  Find out why, sometime....  */
    1675                 :          93 :   ppc_code->resolved_sym->attr.elemental = 1;
    1676                 :          93 :   ppc_code->ext.actual = actual;
    1677                 :          93 :   ppc_code->expr1 = ppc;
    1678                 :             :   /* Since '_copy' is elemental, the scalarizer will take care
    1679                 :             :      of arrays in gfc_trans_call.  */
    1680                 :          93 :   res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
    1681                 :          93 :   gfc_free_statements (ppc_code);
    1682                 :             : 
    1683                 :          93 :   if (UNLIMITED_POLY(obj))
    1684                 :             :     {
    1685                 :             :       /* Check if rhs is non-NULL. */
    1686                 :          18 :       gfc_se src;
    1687                 :          18 :       gfc_init_se (&src, NULL);
    1688                 :          18 :       gfc_conv_expr (&src, rhs);
    1689                 :          18 :       src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
    1690                 :          18 :       tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    1691                 :          18 :                                    src.expr, fold_convert (TREE_TYPE (src.expr),
    1692                 :             :                                                            null_pointer_node));
    1693                 :          18 :       res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
    1694                 :             :                         build_empty_stmt (input_location));
    1695                 :             :     }
    1696                 :             : 
    1697                 :          93 :   return res;
    1698                 :             : }
    1699                 :             : 
    1700                 :             : /* Special case for initializing a polymorphic dummy with INTENT(OUT).
    1701                 :             :    A MEMCPY is needed to copy the full data from the default initializer
    1702                 :             :    of the dynamic type.  */
    1703                 :             : 
    1704                 :             : tree
    1705                 :         380 : gfc_trans_class_init_assign (gfc_code *code)
    1706                 :             : {
    1707                 :         380 :   stmtblock_t block;
    1708                 :         380 :   tree tmp;
    1709                 :         380 :   gfc_se dst,src,memsz;
    1710                 :         380 :   gfc_expr *lhs, *rhs, *sz;
    1711                 :             : 
    1712                 :         380 :   gfc_start_block (&block);
    1713                 :             : 
    1714                 :         380 :   lhs = gfc_copy_expr (code->expr1);
    1715                 :             : 
    1716                 :         380 :   rhs = gfc_copy_expr (code->expr1);
    1717                 :         380 :   gfc_add_vptr_component (rhs);
    1718                 :             : 
    1719                 :             :   /* Make sure that the component backend_decls have been built, which
    1720                 :             :      will not have happened if the derived types concerned have not
    1721                 :             :      been referenced.  */
    1722                 :         380 :   gfc_get_derived_type (rhs->ts.u.derived);
    1723                 :         380 :   gfc_add_def_init_component (rhs);
    1724                 :             :   /* The _def_init is always scalar.  */
    1725                 :         380 :   rhs->rank = 0;
    1726                 :             : 
    1727                 :         380 :   if (code->expr1->ts.type == BT_CLASS
    1728                 :         359 :       && CLASS_DATA (code->expr1)->attr.dimension)
    1729                 :             :     {
    1730                 :          93 :       gfc_array_spec *tmparr = gfc_get_array_spec ();
    1731                 :          93 :       *tmparr = *CLASS_DATA (code->expr1)->as;
    1732                 :             :       /* Adding the array ref to the class expression results in correct
    1733                 :             :          indexing to the dynamic type.  */
    1734                 :          93 :       gfc_add_full_array_ref (lhs, tmparr);
    1735                 :          93 :       tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
    1736                 :          93 :     }
    1737                 :             :   else
    1738                 :             :     {
    1739                 :             :       /* Scalar initialization needs the _data component.  */
    1740                 :         287 :       gfc_add_data_component (lhs);
    1741                 :         287 :       sz = gfc_copy_expr (code->expr1);
    1742                 :         287 :       gfc_add_vptr_component (sz);
    1743                 :         287 :       gfc_add_size_component (sz);
    1744                 :             : 
    1745                 :         287 :       gfc_init_se (&dst, NULL);
    1746                 :         287 :       gfc_init_se (&src, NULL);
    1747                 :         287 :       gfc_init_se (&memsz, NULL);
    1748                 :         287 :       gfc_conv_expr (&dst, lhs);
    1749                 :         287 :       gfc_conv_expr (&src, rhs);
    1750                 :         287 :       gfc_conv_expr (&memsz, sz);
    1751                 :         287 :       gfc_add_block_to_block (&block, &src.pre);
    1752                 :         287 :       src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
    1753                 :             : 
    1754                 :         287 :       tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
    1755                 :             : 
    1756                 :         287 :       if (UNLIMITED_POLY(code->expr1))
    1757                 :             :         {
    1758                 :             :           /* Check if _def_init is non-NULL. */
    1759                 :           7 :           tree cond = fold_build2_loc (input_location, NE_EXPR,
    1760                 :             :                                        logical_type_node, src.expr,
    1761                 :           7 :                                        fold_convert (TREE_TYPE (src.expr),
    1762                 :             :                                                      null_pointer_node));
    1763                 :           7 :           tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
    1764                 :             :                             tmp, build_empty_stmt (input_location));
    1765                 :             :         }
    1766                 :             :     }
    1767                 :             : 
    1768                 :         380 :   if (code->expr1->symtree->n.sym->attr.dummy
    1769                 :         329 :       && (code->expr1->symtree->n.sym->attr.optional
    1770                 :         323 :           || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
    1771                 :             :     {
    1772                 :           6 :       tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
    1773                 :           6 :       tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
    1774                 :             :                         present, tmp,
    1775                 :             :                         build_empty_stmt (input_location));
    1776                 :             :     }
    1777                 :             : 
    1778                 :         380 :   gfc_add_expr_to_block (&block, tmp);
    1779                 :             : 
    1780                 :         380 :   return gfc_finish_block (&block);
    1781                 :             : }
    1782                 :             : 
    1783                 :             : 
    1784                 :             : /* Class valued elemental function calls or class array elements arriving
    1785                 :             :    in gfc_trans_scalar_assign come here.  Wherever possible the vptr copy
    1786                 :             :    is used to ensure that the rhs dynamic type is assigned to the lhs.  */
    1787                 :             : 
    1788                 :             : static bool
    1789                 :         606 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
    1790                 :             : {
    1791                 :         606 :   tree fcn;
    1792                 :         606 :   tree rse_expr;
    1793                 :         606 :   tree class_data;
    1794                 :         606 :   tree tmp;
    1795                 :         606 :   tree zero;
    1796                 :         606 :   tree cond;
    1797                 :         606 :   tree final_cond;
    1798                 :         606 :   stmtblock_t inner_block;
    1799                 :         606 :   bool is_descriptor;
    1800                 :         606 :   bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
    1801                 :         606 :   bool not_lhs_array_type;
    1802                 :             : 
    1803                 :             :   /* Temporaries arising from dependencies in assignment get cast as a
    1804                 :             :      character type of the dynamic size of the rhs. Use the vptr copy
    1805                 :             :      for this case.  */
    1806                 :         606 :   tmp = TREE_TYPE (lse->expr);
    1807                 :         606 :   not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
    1808                 :           0 :                          && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
    1809                 :             : 
    1810                 :             :   /* Use ordinary assignment if the rhs is not a call expression or
    1811                 :             :      the lhs is not a class entity or an array(ie. character) type.  */
    1812                 :         576 :   if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
    1813                 :         824 :       && not_lhs_array_type)
    1814                 :             :     return false;
    1815                 :             : 
    1816                 :             :   /* Ordinary assignment can be used if both sides are class expressions
    1817                 :             :      since the dynamic type is preserved by copying the vptr.  This
    1818                 :             :      should only occur, where temporaries are involved.  */
    1819                 :         388 :   if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
    1820                 :         388 :       && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
    1821                 :             :     return false;
    1822                 :             : 
    1823                 :             :   /* Fix the class expression and the class data of the rhs.  */
    1824                 :         351 :   if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
    1825                 :         351 :       || not_call_expr)
    1826                 :             :     {
    1827                 :         351 :       tmp = gfc_get_class_from_expr (rse->expr);
    1828                 :         351 :       if (tmp == NULL_TREE)
    1829                 :             :         return false;
    1830                 :         116 :       rse_expr = gfc_evaluate_now (tmp, block);
    1831                 :             :     }
    1832                 :             :   else
    1833                 :           0 :     rse_expr = gfc_evaluate_now (rse->expr, block);
    1834                 :             : 
    1835                 :         116 :   class_data = gfc_class_data_get (rse_expr);
    1836                 :             : 
    1837                 :             :   /* Check that the rhs data is not null.  */
    1838                 :         116 :   is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
    1839                 :         116 :   if (is_descriptor)
    1840                 :         116 :     class_data = gfc_conv_descriptor_data_get (class_data);
    1841                 :         116 :   class_data = gfc_evaluate_now (class_data, block);
    1842                 :             : 
    1843                 :         116 :   zero = build_int_cst (TREE_TYPE (class_data), 0);
    1844                 :         116 :   cond = fold_build2_loc (input_location, NE_EXPR,
    1845                 :             :                           logical_type_node,
    1846                 :             :                           class_data, zero);
    1847                 :             : 
    1848                 :             :   /* Copy the rhs to the lhs.  */
    1849                 :         116 :   fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
    1850                 :         116 :   fcn = build_fold_indirect_ref_loc (input_location, fcn);
    1851                 :         116 :   tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
    1852                 :         116 :   tmp = is_descriptor ? tmp : class_data;
    1853                 :         116 :   tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
    1854                 :             :                              gfc_build_addr_expr (NULL, lse->expr));
    1855                 :         116 :   gfc_add_expr_to_block (block, tmp);
    1856                 :             : 
    1857                 :             :   /* Only elemental function results need to be finalised and freed.  */
    1858                 :         116 :   if (not_call_expr)
    1859                 :             :     return true;
    1860                 :             : 
    1861                 :             :   /* Finalize the class data if needed.  */
    1862                 :           0 :   gfc_init_block (&inner_block);
    1863                 :           0 :   fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
    1864                 :           0 :   zero = build_int_cst (TREE_TYPE (fcn), 0);
    1865                 :           0 :   final_cond = fold_build2_loc (input_location, NE_EXPR,
    1866                 :             :                                 logical_type_node, fcn, zero);
    1867                 :           0 :   fcn = build_fold_indirect_ref_loc (input_location, fcn);
    1868                 :           0 :   tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
    1869                 :           0 :   tmp = build3_v (COND_EXPR, final_cond,
    1870                 :             :                   tmp, build_empty_stmt (input_location));
    1871                 :           0 :   gfc_add_expr_to_block (&inner_block, tmp);
    1872                 :             : 
    1873                 :             :   /* Free the class data.  */
    1874                 :           0 :   tmp = gfc_call_free (class_data);
    1875                 :           0 :   tmp = build3_v (COND_EXPR, cond, tmp,
    1876                 :             :                   build_empty_stmt (input_location));
    1877                 :           0 :   gfc_add_expr_to_block (&inner_block, tmp);
    1878                 :             : 
    1879                 :             :   /* Finish the inner block and subject it to the condition on the
    1880                 :             :      class data being non-zero.  */
    1881                 :           0 :   tmp = gfc_finish_block (&inner_block);
    1882                 :           0 :   tmp = build3_v (COND_EXPR, cond, tmp,
    1883                 :             :                   build_empty_stmt (input_location));
    1884                 :           0 :   gfc_add_expr_to_block (block, tmp);
    1885                 :             : 
    1886                 :           0 :   return true;
    1887                 :             : }
    1888                 :             : 
    1889                 :             : /* End of prototype trans-class.c  */
    1890                 :             : 
    1891                 :             : 
    1892                 :             : static void
    1893                 :        6188 : realloc_lhs_warning (bt type, bool array, locus *where)
    1894                 :             : {
    1895                 :        6188 :   if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
    1896                 :          35 :     gfc_warning (OPT_Wrealloc_lhs,
    1897                 :             :                  "Code for reallocating the allocatable array at %L will "
    1898                 :             :                  "be added", where);
    1899                 :        6153 :   else if (warn_realloc_lhs_all)
    1900                 :           4 :     gfc_warning (OPT_Wrealloc_lhs_all,
    1901                 :             :                  "Code for reallocating the allocatable variable at %L "
    1902                 :             :                  "will be added", where);
    1903                 :        6188 : }
    1904                 :             : 
    1905                 :             : 
    1906                 :             : static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
    1907                 :             :                                                  gfc_expr *);
    1908                 :             : 
    1909                 :             : /* Copy the scalarization loop variables.  */
    1910                 :             : 
    1911                 :             : static void
    1912                 :      898131 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
    1913                 :             : {
    1914                 :      898131 :   dest->ss = src->ss;
    1915                 :      898131 :   dest->loop = src->loop;
    1916                 :      898131 : }
    1917                 :             : 
    1918                 :             : 
    1919                 :             : /* Initialize a simple expression holder.
    1920                 :             : 
    1921                 :             :    Care must be taken when multiple se are created with the same parent.
    1922                 :             :    The child se must be kept in sync.  The easiest way is to delay creation
    1923                 :             :    of a child se until after the previous se has been translated.  */
    1924                 :             : 
    1925                 :             : void
    1926                 :     3400092 : gfc_init_se (gfc_se * se, gfc_se * parent)
    1927                 :             : {
    1928                 :     3400092 :   memset (se, 0, sizeof (gfc_se));
    1929                 :     3400092 :   gfc_init_block (&se->pre);
    1930                 :     3400092 :   gfc_init_block (&se->finalblock);
    1931                 :     3400092 :   gfc_init_block (&se->post);
    1932                 :             : 
    1933                 :     3400092 :   se->parent = parent;
    1934                 :             : 
    1935                 :     3400092 :   if (parent)
    1936                 :      898131 :     gfc_copy_se_loopvars (se, parent);
    1937                 :     3400092 : }
    1938                 :             : 
    1939                 :             : 
    1940                 :             : /* Advances to the next SS in the chain.  Use this rather than setting
    1941                 :             :    se->ss = se->ss->next because all the parents needs to be kept in sync.
    1942                 :             :    See gfc_init_se.  */
    1943                 :             : 
    1944                 :             : void
    1945                 :      178124 : gfc_advance_se_ss_chain (gfc_se * se)
    1946                 :             : {
    1947                 :      178124 :   gfc_se *p;
    1948                 :      178124 :   gfc_ss *ss;
    1949                 :             : 
    1950                 :      178124 :   gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
    1951                 :             : 
    1952                 :             :   p = se;
    1953                 :             :   /* Walk down the parent chain.  */
    1954                 :      458299 :   while (p != NULL)
    1955                 :             :     {
    1956                 :             :       /* Simple consistency check.  */
    1957                 :      280175 :       gcc_assert (p->parent == NULL || p->parent->ss == p->ss
    1958                 :             :                   || p->parent->ss->nested_ss == p->ss);
    1959                 :             : 
    1960                 :             :       /* If we were in a nested loop, the next scalarized expression can be
    1961                 :             :          on the parent ss' next pointer.  Thus we should not take the next
    1962                 :             :          pointer blindly, but rather go up one nest level as long as next
    1963                 :             :          is the end of chain.  */
    1964                 :      280175 :       ss = p->ss;
    1965                 :      281395 :       while (ss->next == gfc_ss_terminator && ss->parent != NULL)
    1966                 :             :         ss = ss->parent;
    1967                 :             : 
    1968                 :      280175 :       p->ss = ss->next;
    1969                 :             : 
    1970                 :      280175 :       p = p->parent;
    1971                 :             :     }
    1972                 :      178124 : }
    1973                 :             : 
    1974                 :             : 
    1975                 :             : /* Ensures the result of the expression as either a temporary variable
    1976                 :             :    or a constant so that it can be used repeatedly.  */
    1977                 :             : 
    1978                 :             : void
    1979                 :        7888 : gfc_make_safe_expr (gfc_se * se)
    1980                 :             : {
    1981                 :        7888 :   tree var;
    1982                 :             : 
    1983                 :        7888 :   if (CONSTANT_CLASS_P (se->expr))
    1984                 :             :     return;
    1985                 :             : 
    1986                 :             :   /* We need a temporary for this result.  */
    1987                 :         202 :   var = gfc_create_var (TREE_TYPE (se->expr), NULL);
    1988                 :         202 :   gfc_add_modify (&se->pre, var, se->expr);
    1989                 :         202 :   se->expr = var;
    1990                 :             : }
    1991                 :             : 
    1992                 :             : 
    1993                 :             : /* Return an expression which determines if a dummy parameter is present.
    1994                 :             :    Also used for arguments to procedures with multiple entry points.  */
    1995                 :             : 
    1996                 :             : tree
    1997                 :        7454 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
    1998                 :             : {
    1999                 :        7454 :   tree decl, orig_decl, cond;
    2000                 :             : 
    2001                 :        7454 :   gcc_assert (sym->attr.dummy);
    2002                 :        7454 :   orig_decl = decl = gfc_get_symbol_decl (sym);
    2003                 :             : 
    2004                 :             :   /* Intrinsic scalars with VALUE attribute which are passed by value
    2005                 :             :      use a hidden argument to denote the present status.  */
    2006                 :        7454 :   if (sym->attr.value && !sym->attr.dimension
    2007                 :         490 :       && sym->ts.type != BT_CLASS && !gfc_bt_struct (sym->ts.type))
    2008                 :             :     {
    2009                 :         490 :       char name[GFC_MAX_SYMBOL_LEN + 2];
    2010                 :         490 :       tree tree_name;
    2011                 :             : 
    2012                 :         490 :       gcc_assert (TREE_CODE (decl) == PARM_DECL);
    2013                 :         490 :       name[0] = '.';
    2014                 :         490 :       strcpy (&name[1], sym->name);
    2015                 :         490 :       tree_name = get_identifier (name);
    2016                 :             : 
    2017                 :             :       /* Walk function argument list to find hidden arg.  */
    2018                 :         490 :       cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
    2019                 :        3308 :       for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
    2020                 :        3308 :         if (DECL_NAME (cond) == tree_name
    2021                 :        3308 :             && DECL_ARTIFICIAL (cond))
    2022                 :             :           break;
    2023                 :             : 
    2024                 :         490 :       gcc_assert (cond);
    2025                 :         490 :       return cond;
    2026                 :             :     }
    2027                 :             : 
    2028                 :             :   /* Assumed-shape arrays use a local variable for the array data;
    2029                 :             :      the actual PARAM_DECL is in a saved decl.  As the local variable
    2030                 :             :      is NULL, it can be checked instead, unless use_saved_desc is
    2031                 :             :      requested.  */
    2032                 :             : 
    2033                 :        6964 :   if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
    2034                 :             :     {
    2035                 :         615 :       gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
    2036                 :             :              || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
    2037                 :         615 :       decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
    2038                 :             :     }
    2039                 :             : 
    2040                 :        6964 :   cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
    2041                 :        6964 :                           fold_convert (TREE_TYPE (decl), null_pointer_node));
    2042                 :             : 
    2043                 :             :   /* Fortran 2008 allows to pass null pointers and non-associated pointers
    2044                 :             :      as actual argument to denote absent dummies. For array descriptors,
    2045                 :             :      we thus also need to check the array descriptor.  For BT_CLASS, it
    2046                 :             :      can also occur for scalars and F2003 due to type->class wrapping and
    2047                 :             :      class->class wrapping.  Note further that BT_CLASS always uses an
    2048                 :             :      array descriptor for arrays, also for explicit-shape/assumed-size.
    2049                 :             :      For assumed-rank arrays, no local variable is generated, hence,
    2050                 :             :      the following also applies with !use_saved_desc.  */
    2051                 :             : 
    2052                 :        6964 :   if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
    2053                 :        5240 :       && !sym->attr.allocatable
    2054                 :        4433 :       && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
    2055                 :        1942 :           || (sym->ts.type == BT_CLASS
    2056                 :         990 :               && !CLASS_DATA (sym)->attr.allocatable
    2057                 :         990 :               && !CLASS_DATA (sym)->attr.class_pointer))
    2058                 :        2743 :       && ((gfc_option.allow_std & GFC_STD_F2008) != 0
    2059                 :           6 :           || sym->ts.type == BT_CLASS))
    2060                 :             :     {
    2061                 :        2737 :       tree tmp;
    2062                 :             : 
    2063                 :        2737 :       if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
    2064                 :         942 :                        || sym->as->type == AS_ASSUMED_RANK
    2065                 :         871 :                        || sym->attr.codimension))
    2066                 :        2084 :           || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
    2067                 :             :         {
    2068                 :         869 :           tmp = build_fold_indirect_ref_loc (input_location, decl);
    2069                 :         869 :           if (sym->ts.type == BT_CLASS)
    2070                 :         216 :             tmp = gfc_class_data_get (tmp);
    2071                 :         869 :           tmp = gfc_conv_array_data (tmp);
    2072                 :             :         }
    2073                 :        1868 :       else if (sym->ts.type == BT_CLASS)
    2074                 :          36 :         tmp = gfc_class_data_get (decl);
    2075                 :             :       else
    2076                 :             :         tmp = NULL_TREE;
    2077                 :             : 
    2078                 :         905 :       if (tmp != NULL_TREE)
    2079                 :             :         {
    2080                 :         905 :           tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
    2081                 :         905 :                                  fold_convert (TREE_TYPE (tmp), null_pointer_node));
    2082                 :         905 :           cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
    2083                 :             :                                   logical_type_node, cond, tmp);
    2084                 :             :         }
    2085                 :             :     }
    2086                 :             : 
    2087                 :             :   return cond;
    2088                 :             : }
    2089                 :             : 
    2090                 :             : 
    2091                 :             : /* Converts a missing, dummy argument into a null or zero.  */
    2092                 :             : 
    2093                 :             : void
    2094                 :         310 : gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
    2095                 :             : {
    2096                 :         310 :   tree present;
    2097                 :         310 :   tree tmp;
    2098                 :             : 
    2099                 :         310 :   present = gfc_conv_expr_present (arg->symtree->n.sym);
    2100                 :             : 
    2101                 :         310 :   if (kind > 0)
    2102                 :             :     {
    2103                 :             :       /* Create a temporary and convert it to the correct type.  */
    2104                 :          54 :       tmp = gfc_get_int_type (kind);
    2105                 :          54 :       tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
    2106                 :             :                                                         se->expr));
    2107                 :             : 
    2108                 :             :       /* Test for a NULL value.  */
    2109                 :          54 :       tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
    2110                 :          54 :                         tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
    2111                 :          54 :       tmp = gfc_evaluate_now (tmp, &se->pre);
    2112                 :          54 :       se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
    2113                 :             :     }
    2114                 :             :   else
    2115                 :             :     {
    2116                 :         256 :       tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
    2117                 :             :                         present, se->expr,
    2118                 :         256 :                         build_zero_cst (TREE_TYPE (se->expr)));
    2119                 :         256 :       tmp = gfc_evaluate_now (tmp, &se->pre);
    2120                 :         256 :       se->expr = tmp;
    2121                 :             :     }
    2122                 :             : 
    2123                 :         310 :   if (ts.type == BT_CHARACTER)
    2124                 :             :     {
    2125                 :           6 :       tmp = build_int_cst (gfc_charlen_type_node, 0);
    2126                 :           6 :       tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
    2127                 :             :                              present, se->string_length, tmp);
    2128                 :           6 :       tmp = gfc_evaluate_now (tmp, &se->pre);
    2129                 :           6 :       se->string_length = tmp;
    2130                 :             :     }
    2131                 :         310 :   return;
    2132                 :             : }
    2133                 :             : 
    2134                 :             : 
    2135                 :             : /* Get the character length of an expression, looking through gfc_refs
    2136                 :             :    if necessary.  */
    2137                 :             : 
    2138                 :             : tree
    2139                 :       17259 : gfc_get_expr_charlen (gfc_expr *e)
    2140                 :             : {
    2141                 :       17259 :   gfc_ref *r;
    2142                 :       17259 :   tree length;
    2143                 :       17259 :   tree previous = NULL_TREE;
    2144                 :       17259 :   gfc_se se;
    2145                 :             : 
    2146                 :       17259 :   gcc_assert (e->expr_type == EXPR_VARIABLE
    2147                 :             :               && e->ts.type == BT_CHARACTER);
    2148                 :             : 
    2149                 :       17259 :   length = NULL; /* To silence compiler warning.  */
    2150                 :             : 
    2151                 :       17259 :   if (is_subref_array (e) && e->ts.u.cl->length)
    2152                 :             :     {
    2153                 :         742 :       gfc_se tmpse;
    2154                 :         742 :       gfc_init_se (&tmpse, NULL);
    2155                 :         742 :       gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
    2156                 :         742 :       e->ts.u.cl->backend_decl = tmpse.expr;
    2157                 :         742 :       return tmpse.expr;
    2158                 :             :     }
    2159                 :             : 
    2160                 :             :   /* First candidate: if the variable is of type CHARACTER, the
    2161                 :             :      expression's length could be the length of the character
    2162                 :             :      variable.  */
    2163                 :       16517 :   if (e->symtree->n.sym->ts.type == BT_CHARACTER)
    2164                 :       16261 :     length = e->symtree->n.sym->ts.u.cl->backend_decl;
    2165                 :             : 
    2166                 :             :   /* Look through the reference chain for component references.  */
    2167                 :       33127 :   for (r = e->ref; r; r = r->next)
    2168                 :             :     {
    2169                 :       16610 :       previous = length;
    2170                 :       16610 :       switch (r->type)
    2171                 :             :         {
    2172                 :         256 :         case REF_COMPONENT:
    2173                 :         256 :           if (r->u.c.component->ts.type == BT_CHARACTER)
    2174                 :         256 :             length = r->u.c.component->ts.u.cl->backend_decl;
    2175                 :             :           break;
    2176                 :             : 
    2177                 :             :         case REF_ARRAY:
    2178                 :             :           /* Do nothing.  */
    2179                 :             :           break;
    2180                 :             : 
    2181                 :          12 :         case REF_SUBSTRING:
    2182                 :          12 :           gfc_init_se (&se, NULL);
    2183                 :          12 :           gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
    2184                 :          12 :           length = se.expr;
    2185                 :          12 :           if (r->u.ss.end)
    2186                 :           6 :             gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
    2187                 :             :           else
    2188                 :           6 :             se.expr = previous;
    2189                 :          12 :           length = fold_build2_loc (input_location, MINUS_EXPR,
    2190                 :             :                                     gfc_charlen_type_node,
    2191                 :             :                                     se.expr, length);
    2192                 :          12 :           length = fold_build2_loc (input_location, PLUS_EXPR,
    2193                 :             :                                     gfc_charlen_type_node, length,
    2194                 :             :                                     gfc_index_one_node);
    2195                 :          12 :           break;
    2196                 :             : 
    2197                 :           0 :         default:
    2198                 :           0 :           gcc_unreachable ();
    2199                 :       16610 :           break;
    2200                 :             :         }
    2201                 :             :     }
    2202                 :             : 
    2203                 :       16517 :   gcc_assert (length != NULL);
    2204                 :             :   return length;
    2205                 :             : }
    2206                 :             : 
    2207                 :             : 
    2208                 :             : /* Return for an expression the backend decl of the coarray.  */
    2209                 :             : 
    2210                 :             : tree
    2211                 :        1432 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
    2212                 :             : {
    2213                 :        1432 :   tree caf_decl;
    2214                 :        1432 :   bool found = false;
    2215                 :        1432 :   gfc_ref *ref;
    2216                 :             : 
    2217                 :        1432 :   gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
    2218                 :             : 
    2219                 :             :   /* Not-implemented diagnostic.  */
    2220                 :        1432 :   if (expr->symtree->n.sym->ts.type == BT_CLASS
    2221                 :          17 :       && UNLIMITED_POLY (expr->symtree->n.sym)
    2222                 :           0 :       && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
    2223                 :           0 :     gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
    2224                 :             :                "%L is not supported", &expr->where);
    2225                 :             : 
    2226                 :        4893 :   for (ref = expr->ref; ref; ref = ref->next)
    2227                 :        3461 :     if (ref->type == REF_COMPONENT)
    2228                 :             :       {
    2229                 :        1312 :         if (ref->u.c.component->ts.type == BT_CLASS
    2230                 :           0 :             && UNLIMITED_POLY (ref->u.c.component)
    2231                 :           0 :             && CLASS_DATA (ref->u.c.component)->attr.codimension)
    2232                 :           0 :           gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
    2233                 :             :                      "component at %L is not supported", &expr->where);
    2234                 :             :       }
    2235                 :             : 
    2236                 :             :   /* Make sure the backend_decl is present before accessing it.  */
    2237                 :        2864 :   caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
    2238                 :        1432 :       ? gfc_get_symbol_decl (expr->symtree->n.sym)
    2239                 :             :       : expr->symtree->n.sym->backend_decl;
    2240                 :             : 
    2241                 :        1432 :   if (expr->symtree->n.sym->ts.type == BT_CLASS)
    2242                 :             :     {
    2243                 :          17 :       if (expr->ref && expr->ref->type == REF_ARRAY)
    2244                 :             :         {
    2245                 :           0 :           caf_decl = gfc_class_data_get (caf_decl);
    2246                 :           0 :           if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
    2247                 :             :             return caf_decl;
    2248                 :             :         }
    2249                 :          37 :       for (ref = expr->ref; ref; ref = ref->next)
    2250                 :             :         {
    2251                 :          34 :           if (ref->type == REF_COMPONENT
    2252                 :          17 :               && strcmp (ref->u.c.component->name, "_data") != 0)
    2253                 :             :             {
    2254                 :           0 :               caf_decl = gfc_class_data_get (caf_decl);
    2255                 :           0 :               if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
    2256                 :             :                 return caf_decl;
    2257                 :             :               break;
    2258                 :             :             }
    2259                 :          34 :           else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
    2260                 :             :             break;
    2261                 :             :         }
    2262                 :             :     }
    2263                 :        1432 :   if (expr->symtree->n.sym->attr.codimension)
    2264                 :             :     return caf_decl;
    2265                 :             : 
    2266                 :             :   /* The following code assumes that the coarray is a component reachable via
    2267                 :             :      only scalar components/variables; the Fortran standard guarantees this.  */
    2268                 :             : 
    2269                 :          35 :   for (ref = expr->ref; ref; ref = ref->next)
    2270                 :          35 :     if (ref->type == REF_COMPONENT)
    2271                 :             :       {
    2272                 :          35 :         gfc_component *comp = ref->u.c.component;
    2273                 :             : 
    2274                 :          35 :         if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
    2275                 :          12 :           caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
    2276                 :          35 :         caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
    2277                 :          35 :                                     TREE_TYPE (comp->backend_decl), caf_decl,
    2278                 :             :                                     comp->backend_decl, NULL_TREE);
    2279                 :          35 :         if (comp->ts.type == BT_CLASS)
    2280                 :             :           {
    2281                 :           0 :             caf_decl = gfc_class_data_get (caf_decl);
    2282                 :           0 :             if (CLASS_DATA (comp)->attr.codimension)
    2283                 :             :               {
    2284                 :             :                 found = true;
    2285                 :             :                 break;
    2286                 :             :               }
    2287                 :             :           }
    2288                 :          35 :         if (comp->attr.codimension)
    2289                 :             :           {
    2290                 :             :             found = true;
    2291                 :             :             break;
    2292                 :             :           }
    2293                 :             :       }
    2294                 :          35 :   gcc_assert (found && caf_decl);
    2295                 :             :   return caf_decl;
    2296                 :             : }
    2297                 :             : 
    2298                 :             : 
    2299                 :             : /* Obtain the Coarray token - and optionally also the offset.  */
    2300                 :             : 
    2301                 :             : void
    2302                 :        1353 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
    2303                 :             :                           tree se_expr, gfc_expr *expr)
    2304                 :             : {
    2305                 :        1353 :   tree tmp;
    2306                 :             : 
    2307                 :             :   /* Coarray token.  */
    2308                 :        1353 :   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
    2309                 :             :     {
    2310                 :         264 :       gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
    2311                 :             :                     == GFC_ARRAY_ALLOCATABLE
    2312                 :             :                   || expr->symtree->n.sym->attr.select_type_temporary);
    2313                 :         264 :       *token = gfc_conv_descriptor_token (caf_decl);
    2314                 :             :     }
    2315                 :        1089 :   else if (DECL_LANG_SPECIFIC (caf_decl)
    2316                 :        1089 :            && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
    2317                 :           3 :     *token = GFC_DECL_TOKEN (caf_decl);
    2318                 :             :   else
    2319                 :             :     {
    2320                 :        1086 :       gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
    2321                 :             :                   && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
    2322                 :        1086 :       *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
    2323                 :             :     }
    2324                 :             : 
    2325                 :        1353 :   if (offset == NULL)
    2326                 :             :     return;
    2327                 :             : 
    2328                 :             :   /* Offset between the coarray base address and the address wanted.  */
    2329                 :         468 :   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
    2330                 :         468 :       && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
    2331                 :          48 :           || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
    2332                 :          79 :     *offset = build_int_cst (gfc_array_index_type, 0);
    2333                 :         389 :   else if (DECL_LANG_SPECIFIC (caf_decl)
    2334                 :         389 :            && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
    2335                 :           3 :     *offset = GFC_DECL_CAF_OFFSET (caf_decl);
    2336                 :         386 :   else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
    2337                 :           0 :     *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
    2338                 :             :   else
    2339                 :         386 :     *offset = build_int_cst (gfc_array_index_type, 0);
    2340                 :             : 
    2341                 :         468 :   if (POINTER_TYPE_P (TREE_TYPE (se_expr))
    2342                 :         468 :       && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
    2343                 :             :     {
    2344                 :         377 :       tmp = build_fold_indirect_ref_loc (input_location, se_expr);
    2345                 :         377 :       tmp = gfc_conv_descriptor_data_get (tmp);
    2346                 :             :     }
    2347                 :          91 :   else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
    2348                 :           0 :     tmp = gfc_conv_descriptor_data_get (se_expr);
    2349                 :             :   else
    2350                 :             :     {
    2351                 :          91 :       gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
    2352                 :             :       tmp = se_expr;
    2353                 :             :     }
    2354                 :             : 
    2355                 :         468 :   *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
    2356                 :             :                              *offset, fold_convert (gfc_array_index_type, tmp));
    2357                 :             : 
    2358                 :         468 :   if (expr->symtree->n.sym->ts.type == BT_DERIVED
    2359                 :         115 :       && expr->symtree->n.sym->attr.codimension
    2360                 :         115 :       && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
    2361                 :             :     {
    2362                 :           0 :       gfc_expr *base_expr = gfc_copy_expr (expr);
    2363                 :           0 :       gfc_ref *ref = base_expr->ref;
    2364                 :           0 :       gfc_se base_se;
    2365                 :             : 
    2366                 :             :       // Iterate through the refs until the last one.
    2367                 :           0 :       while (ref->next)
    2368                 :             :           ref = ref->next;
    2369                 :             : 
    2370                 :           0 :       if (ref->type == REF_ARRAY
    2371                 :           0 :           && ref->u.ar.type != AR_FULL)
    2372                 :             :         {
    2373                 :           0 :           const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
    2374                 :           0 :           int i;
    2375                 :           0 :           for (i = 0; i < ranksum; ++i)
    2376                 :             :             {
    2377                 :           0 :               ref->u.ar.start[i] = NULL;
    2378                 :           0 :               ref->u.ar.end[i] = NULL;
    2379                 :             :             }
    2380                 :           0 :           ref->u.ar.type = AR_FULL;
    2381                 :             :         }
    2382                 :           0 :       gfc_init_se (&base_se, NULL);
    2383                 :           0 :       if (gfc_caf_attr (base_expr).dimension)
    2384                 :             :         {
    2385                 :           0 :           gfc_conv_expr_descriptor (&base_se, base_expr);
    2386                 :           0 :           tmp = gfc_conv_descriptor_data_get (base_se.expr);
    2387                 :             :         }
    2388                 :             :       else
    2389                 :             :         {
    2390                 :           0 :           gfc_conv_expr (&base_se, base_expr);
    2391                 :           0 :           tmp = base_se.expr;
    2392                 :             :         }
    2393                 :             : 
    2394                 :           0 :       gfc_free_expr (base_expr);
    2395                 :           0 :       gfc_add_block_to_block (&se->pre, &base_se.pre);
    2396                 :           0 :       gfc_add_block_to_block (&se->post, &base_se.post);
    2397                 :           0 :     }
    2398                 :         468 :   else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
    2399                 :          97 :     tmp = gfc_conv_descriptor_data_get (caf_decl);
    2400                 :             :   else
    2401                 :             :    {
    2402                 :         371 :      gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
    2403                 :             :      tmp = caf_decl;
    2404                 :             :    }
    2405                 :             : 
    2406                 :         468 :   *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    2407                 :             :                             fold_convert (gfc_array_index_type, *offset),
    2408                 :             :                             fold_convert (gfc_array_index_type, tmp));
    2409                 :             : }
    2410                 :             : 
    2411                 :             : 
    2412                 :             : /* Convert the coindex of a coarray into an image index; the result is
    2413                 :             :    image_num =  (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
    2414                 :             :               + (idx(3)-lcobound(3))*extend(1)*extent(2) + ...  */
    2415                 :             : 
    2416                 :             : tree
    2417                 :        1151 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
    2418                 :             : {
    2419                 :        1151 :   gfc_ref *ref;
    2420                 :        1151 :   tree lbound, ubound, extent, tmp, img_idx;
    2421                 :        1151 :   gfc_se se;
    2422                 :        1151 :   int i;
    2423                 :             : 
    2424                 :        1175 :   for (ref = e->ref; ref; ref = ref->next)
    2425                 :        1175 :     if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
    2426                 :             :       break;
    2427                 :        1151 :   gcc_assert (ref != NULL);
    2428                 :             : 
    2429                 :        1151 :   if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
    2430                 :             :     {
    2431                 :           6 :       return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
    2432                 :           6 :                                   integer_zero_node);
    2433                 :             :     }
    2434                 :             : 
    2435                 :        1145 :   img_idx = build_zero_cst (gfc_array_index_type);
    2436                 :        1145 :   extent = build_one_cst (gfc_array_index_type);
    2437                 :        1145 :   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
    2438                 :         366 :     for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
    2439                 :             :       {
    2440                 :         183 :         gfc_init_se (&se, NULL);
    2441                 :         183 :         gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
    2442                 :         183 :         gfc_add_block_to_block (block, &se.pre);
    2443                 :         183 :         lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
    2444                 :         183 :         tmp = fold_build2_loc (input_location, MINUS_EXPR,
    2445                 :         183 :                                TREE_TYPE (lbound), se.expr, lbound);
    2446                 :         183 :         tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
    2447                 :             :                                extent, tmp);
    2448                 :         183 :         img_idx = fold_build2_loc (input_location, PLUS_EXPR,
    2449                 :         183 :                                    TREE_TYPE (tmp), img_idx, tmp);
    2450                 :         183 :         if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
    2451                 :             :           {
    2452                 :           0 :             ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
    2453                 :           0 :             tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
    2454                 :           0 :             extent = fold_build2_loc (input_location, MULT_EXPR,
    2455                 :           0 :                                       TREE_TYPE (tmp), extent, tmp);
    2456                 :             :           }
    2457                 :             :       }
    2458                 :             :   else
    2459                 :        1932 :     for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
    2460                 :             :       {
    2461                 :         970 :         gfc_init_se (&se, NULL);
    2462                 :         970 :         gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
    2463                 :         970 :         gfc_add_block_to_block (block, &se.pre);
    2464                 :         970 :         lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
    2465                 :         970 :         tmp = fold_build2_loc (input_location, MINUS_EXPR,
    2466                 :         970 :                                TREE_TYPE (lbound), se.expr, lbound);
    2467                 :         970 :         tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
    2468                 :             :                                extent, tmp);
    2469                 :         970 :         img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
    2470                 :             :                                    img_idx, tmp);
    2471                 :         970 :         if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
    2472                 :             :           {
    2473                 :           8 :             ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
    2474                 :           8 :             tmp = fold_build2_loc (input_location, MINUS_EXPR,
    2475                 :           8 :                                    TREE_TYPE (ubound), ubound, lbound);
    2476                 :           8 :             tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
    2477                 :           8 :                                    tmp, build_one_cst (TREE_TYPE (tmp)));
    2478                 :           8 :             extent = fold_build2_loc (input_location, MULT_EXPR,
    2479                 :           8 :                                       TREE_TYPE (tmp), extent, tmp);
    2480                 :             :           }
    2481                 :             :       }
    2482                 :        1145 :   img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
    2483                 :        1145 :                              img_idx, build_one_cst (TREE_TYPE (img_idx)));
    2484                 :        1145 :   return fold_convert (integer_type_node, img_idx);
    2485                 :             : }
    2486                 :             : 
    2487                 :             : 
    2488                 :             : /* For each character array constructor subexpression without a ts.u.cl->length,
    2489                 :             :    replace it by its first element (if there aren't any elements, the length
    2490                 :             :    should already be set to zero).  */
    2491                 :             : 
    2492                 :             : static void
    2493                 :         123 : flatten_array_ctors_without_strlen (gfc_expr* e)
    2494                 :             : {
    2495                 :         123 :   gfc_actual_arglist* arg;
    2496                 :         123 :   gfc_constructor* c;
    2497                 :             : 
    2498                 :         123 :   if (!e)
    2499                 :             :     return;
    2500                 :             : 
    2501                 :         123 :   switch (e->expr_type)
    2502                 :             :     {
    2503                 :             : 
    2504                 :           0 :     case EXPR_OP:
    2505                 :           0 :       flatten_array_ctors_without_strlen (e->value.op.op1);
    2506                 :           0 :       flatten_array_ctors_without_strlen (e->value.op.op2);
    2507                 :           0 :       break;
    2508                 :             : 
    2509                 :           0 :     case EXPR_COMPCALL:
    2510                 :             :       /* TODO: Implement as with EXPR_FUNCTION when needed.  */
    2511                 :           0 :       gcc_unreachable ();
    2512                 :             : 
    2513                 :          12 :     case EXPR_FUNCTION:
    2514                 :          36 :       for (arg = e->value.function.actual; arg; arg = arg->next)
    2515                 :          24 :         flatten_array_ctors_without_strlen (arg->expr);
    2516                 :             :       break;
    2517                 :             : 
    2518                 :           0 :     case EXPR_ARRAY:
    2519                 :             : 
    2520                 :             :       /* We've found what we're looking for.  */
    2521                 :           0 :       if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
    2522                 :             :         {
    2523                 :           0 :           gfc_constructor *c;
    2524                 :           0 :           gfc_expr* new_expr;
    2525                 :             : 
    2526                 :           0 :           gcc_assert (e->value.constructor);
    2527                 :             : 
    2528                 :           0 :           c = gfc_constructor_first (e->value.constructor);
    2529                 :           0 :           new_expr = c->expr;
    2530                 :           0 :           c->expr = NULL;
    2531                 :             : 
    2532                 :           0 :           flatten_array_ctors_without_strlen (new_expr);
    2533                 :           0 :           gfc_replace_expr (e, new_expr);
    2534                 :           0 :           break;
    2535                 :             :         }
    2536                 :             : 
    2537                 :             :       /* Otherwise, fall through to handle constructor elements.  */
    2538                 :           0 :       gcc_fallthrough ();
    2539                 :           0 :     case EXPR_STRUCTURE:
    2540                 :           0 :       for (c = gfc_constructor_first (e->value.constructor);
    2541                 :           0 :            c; c = gfc_constructor_next (c))
    2542                 :           0 :         flatten_array_ctors_without_strlen (c->expr);
    2543                 :             :       break;
    2544                 :             : 
    2545                 :             :     default:
    2546                 :             :       break;
    2547                 :             : 
    2548                 :             :     }
    2549                 :             : }
    2550                 :             : 
    2551                 :             : 
    2552                 :             : /* Generate code to initialize a string length variable. Returns the
    2553                 :             :    value.  For array constructors, cl->length might be NULL and in this case,
    2554                 :             :    the first element of the constructor is needed.  expr is the original
    2555                 :             :    expression so we can access it but can be NULL if this is not needed.  */
    2556                 :             : 
    2557                 :             : void
    2558                 :        3137 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
    2559                 :             : {
    2560                 :        3137 :   gfc_se se;
    2561                 :             : 
    2562                 :        3137 :   gfc_init_se (&se, NULL);
    2563                 :             : 
    2564                 :        3137 :   if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
    2565                 :         991 :     return;
    2566                 :             : 
    2567                 :             :   /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
    2568                 :             :      "flatten" array constructors by taking their first element; all elements
    2569                 :             :      should be the same length or a cl->length should be present.  */
    2570                 :        2162 :   if (!cl->length)
    2571                 :             :     {
    2572                 :         115 :       gfc_expr* expr_flat;
    2573                 :         115 :       if (!expr)
    2574                 :             :         return;
    2575                 :          99 :       expr_flat = gfc_copy_expr (expr);
    2576                 :          99 :       flatten_array_ctors_without_strlen (expr_flat);
    2577                 :          99 :       gfc_resolve_expr (expr_flat);
    2578                 :          99 :       if (expr_flat->rank)
    2579                 :          30 :         gfc_conv_expr_descriptor (&se, expr_flat);
    2580                 :             :       else
    2581                 :          69 :         gfc_conv_expr (&se, expr_flat);
    2582                 :          99 :       if (expr_flat->expr_type != EXPR_VARIABLE)
    2583                 :          75 :         gfc_add_block_to_block (pblock, &se.pre);
    2584                 :          99 :       se.expr = convert (gfc_charlen_type_node, se.string_length);
    2585                 :          99 :       gfc_add_block_to_block (pblock, &se.post);
    2586                 :          99 :       gfc_free_expr (expr_flat);
    2587                 :             :     }
    2588                 :             :   else
    2589                 :             :     {
    2590                 :             :       /* Convert cl->length.  */
    2591                 :        2047 :       gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
    2592                 :        2047 :       se.expr = fold_build2_loc (input_location, MAX_EXPR,
    2593                 :             :                                  gfc_charlen_type_node, se.expr,
    2594                 :        2047 :                                  build_zero_cst (TREE_TYPE (se.expr)));
    2595                 :        2047 :       gfc_add_block_to_block (pblock, &se.pre);
    2596                 :             :     }
    2597                 :             : 
    2598                 :        2146 :   if (cl->backend_decl && VAR_P (cl->backend_decl))
    2599                 :        1414 :     gfc_add_modify (pblock, cl->backend_decl, se.expr);
    2600                 :             :   else
    2601                 :         732 :     cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
    2602                 :             : }
    2603                 :             : 
    2604                 :             : 
    2605                 :             : static void
    2606                 :        6371 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
    2607                 :             :                     const char *name, locus *where)
    2608                 :             : {
    2609                 :        6371 :   tree tmp;
    2610                 :        6371 :   tree type;
    2611                 :        6371 :   tree fault;
    2612                 :        6371 :   gfc_se start;
    2613                 :        6371 :   gfc_se end;
    2614                 :        6371 :   char *msg;
    2615                 :        6371 :   mpz_t length;
    2616                 :             : 
    2617                 :        6371 :   type = gfc_get_character_type (kind, ref->u.ss.length);
    2618                 :        6371 :   type = build_pointer_type (type);
    2619                 :             : 
    2620                 :        6371 :   gfc_init_se (&start, se);
    2621                 :        6371 :   gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
    2622                 :        6371 :   gfc_add_block_to_block (&se->pre, &start.pre);
    2623                 :             : 
    2624                 :        6371 :   if (integer_onep (start.expr))
    2625                 :        2036 :     gfc_conv_string_parameter (se);
    2626                 :             :   else
    2627                 :             :     {
    2628                 :        4335 :       tmp = start.expr;
    2629                 :        4335 :       STRIP_NOPS (tmp);
    2630                 :             :       /* Avoid multiple evaluation of substring start.  */
    2631                 :        4335 :       if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
    2632                 :        1617 :         start.expr = gfc_evaluate_now (start.expr, &se->pre);
    2633                 :             : 
    2634                 :             :       /* Change the start of the string.  */
    2635                 :        4335 :       if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
    2636                 :        1070 :            || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
    2637                 :        4455 :           && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
    2638                 :             :         tmp = se->expr;
    2639                 :             :       else
    2640                 :         950 :         tmp = build_fold_indirect_ref_loc (input_location,
    2641                 :             :                                        se->expr);
    2642                 :             :       /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE.  */
    2643                 :        4335 :       if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
    2644                 :             :         {
    2645                 :        4215 :           tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
    2646                 :        4215 :           se->expr = gfc_build_addr_expr (type, tmp);
    2647                 :             :         }
    2648                 :             :     }
    2649                 :             : 
    2650                 :             :   /* Length = end + 1 - start.  */
    2651                 :        6371 :   gfc_init_se (&end, se);
    2652                 :        6371 :   if (ref->u.ss.end == NULL)
    2653                 :         177 :     end.expr = se->string_length;
    2654                 :             :   else
    2655                 :             :     {
    2656                 :        6194 :       gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
    2657                 :        6194 :       gfc_add_block_to_block (&se->pre, &end.pre);
    2658                 :             :     }
    2659                 :        6371 :   tmp = end.expr;
    2660                 :        6371 :   STRIP_NOPS (tmp);
    2661                 :        6371 :   if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
    2662                 :        2243 :     end.expr = gfc_evaluate_now (end.expr, &se->pre);
    2663                 :             : 
    2664                 :        6371 :   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    2665                 :         416 :       && (ref->u.ss.start->symtree
    2666                 :         167 :           && !ref->u.ss.start->symtree->n.sym->attr.implied_index))
    2667                 :             :     {
    2668                 :         160 :       tree nonempty = fold_build2_loc (input_location, LE_EXPR,
    2669                 :             :                                        logical_type_node, start.expr,
    2670                 :             :                                        end.expr);
    2671                 :             : 
    2672                 :             :       /* Check lower bound.  */
    2673                 :         160 :       fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    2674                 :             :                                start.expr,
    2675                 :         160 :                                build_one_cst (TREE_TYPE (start.expr)));
    2676                 :         160 :       fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
    2677                 :             :                                logical_type_node, nonempty, fault);
    2678                 :         160 :       if (name)
    2679                 :         159 :         msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
    2680                 :             :                          "is less than one", name);
    2681                 :             :       else
    2682                 :           1 :         msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
    2683                 :             :                          "is less than one");
    2684                 :         160 :       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
    2685                 :             :                                fold_convert (long_integer_type_node,
    2686                 :             :                                              start.expr));
    2687                 :         160 :       free (msg);
    2688                 :             : 
    2689                 :             :       /* Check upper bound.  */
    2690                 :         160 :       fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    2691                 :             :                                end.expr, se->string_length);
    2692                 :         160 :       fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
    2693                 :             :                                logical_type_node, nonempty, fault);
    2694                 :         160 :       if (name)
    2695                 :         159 :         msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
    2696                 :             :                          "exceeds string length (%%ld)", name);
    2697                 :             :       else
    2698                 :           1 :         msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
    2699                 :             :                          "exceeds string length (%%ld)");
    2700                 :         160 :       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
    2701                 :             :                                fold_convert (long_integer_type_node, end.expr),
    2702                 :             :                                fold_convert (long_integer_type_node,
    2703                 :             :                                              se->string_length));
    2704                 :         160 :       free (msg);
    2705                 :             :     }
    2706                 :             : 
    2707                 :             :   /* Try to calculate the length from the start and end expressions.  */
    2708                 :        6371 :   if (ref->u.ss.end
    2709                 :        6371 :       && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
    2710                 :             :     {
    2711                 :        5201 :       HOST_WIDE_INT i_len;
    2712                 :             : 
    2713                 :        5201 :       i_len = gfc_mpz_get_hwi (length) + 1;
    2714                 :        5201 :       if (i_len < 0)
    2715                 :             :         i_len = 0;
    2716                 :             : 
    2717                 :        5201 :       tmp = build_int_cst (gfc_charlen_type_node, i_len);
    2718                 :        5201 :       mpz_clear (length);  /* Was initialized by gfc_dep_difference.  */
    2719                 :             :     }
    2720                 :             :   else
    2721                 :             :     {
    2722                 :        1170 :       tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
    2723                 :             :                              fold_convert (gfc_charlen_type_node, end.expr),
    2724                 :             :                              fold_convert (gfc_charlen_type_node, start.expr));
    2725                 :        1170 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
    2726                 :        1170 :                              build_int_cst (gfc_charlen_type_node, 1), tmp);
    2727                 :        1170 :       tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
    2728                 :        1170 :                              tmp, build_int_cst (gfc_charlen_type_node, 0));
    2729                 :             :     }
    2730                 :             : 
    2731                 :        6371 :   se->string_length = tmp;
    2732                 :        6371 : }
    2733                 :             : 
    2734                 :             : 
    2735                 :             : /* Convert a derived type component reference.  */
    2736                 :             : 
    2737                 :             : void
    2738                 :      139047 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
    2739                 :             : {
    2740                 :      139047 :   gfc_component *c;
    2741                 :      139047 :   tree tmp;
    2742                 :      139047 :   tree decl;
    2743                 :      139047 :   tree field;
    2744                 :      139047 :   tree context;
    2745                 :             : 
    2746                 :      139047 :   c = ref->u.c.component;
    2747                 :             : 
    2748                 :      139047 :   if (c->backend_decl == NULL_TREE
    2749                 :           6 :       && ref->u.c.sym != NULL)
    2750                 :           6 :     gfc_get_derived_type (ref->u.c.sym);
    2751                 :             : 
    2752                 :      139047 :   field = c->backend_decl;
    2753                 :      139047 :   gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
    2754                 :      139047 :   decl = se->expr;
    2755                 :      139047 :   context = DECL_FIELD_CONTEXT (field);
    2756                 :             : 
    2757                 :             :   /* Components can correspond to fields of different containing
    2758                 :             :      types, as components are created without context, whereas
    2759                 :             :      a concrete use of a component has the type of decl as context.
    2760                 :             :      So, if the type doesn't match, we search the corresponding
    2761                 :             :      FIELD_DECL in the parent type.  To not waste too much time
    2762                 :             :      we cache this result in norestrict_decl.
    2763                 :             :      On the other hand, if the context is a UNION or a MAP (a
    2764                 :             :      RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL.  */
    2765                 :             : 
    2766                 :      139047 :   if (context != TREE_TYPE (decl)
    2767                 :      139047 :       && !(   TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
    2768                 :        9090 :            || TREE_CODE (context) == UNION_TYPE))         /* Field is map */
    2769                 :             :     {
    2770                 :        9090 :       tree f2 = c->norestrict_decl;
    2771                 :       15709 :       if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
    2772                 :        4794 :         for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
    2773                 :        4794 :           if (TREE_CODE (f2) == FIELD_DECL
    2774                 :        4794 :               && DECL_NAME (f2) == DECL_NAME (field))
    2775                 :             :             break;
    2776                 :        9090 :       gcc_assert (f2);
    2777                 :        9090 :       c->norestrict_decl = f2;
    2778                 :        9090 :       field = f2;
    2779                 :             :     }
    2780                 :             : 
    2781                 :      139047 :   if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
    2782                 :           0 :       && strcmp ("_data", c->name) == 0)
    2783                 :             :     {
    2784                 :             :       /* Found a ref to the _data component.  Store the associated ref to
    2785                 :             :          the vptr in se->class_vptr.  */
    2786                 :           0 :       se->class_vptr = gfc_class_vptr_get (decl);
    2787                 :             :     }
    2788                 :             :   else
    2789                 :      139047 :     se->class_vptr = NULL_TREE;
    2790                 :             : 
    2791                 :      139047 :   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
    2792                 :             :                          decl, field, NULL_TREE);
    2793                 :             : 
    2794                 :      139047 :   se->expr = tmp;
    2795                 :             : 
    2796                 :             :   /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
    2797                 :             :      strlen () conditional below.  */
    2798                 :      139047 :   if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
    2799                 :        7567 :       && !c->ts.deferred
    2800                 :        4985 :       && !c->attr.pdt_string)
    2801                 :             :     {
    2802                 :        4859 :       tmp = c->ts.u.cl->backend_decl;
    2803                 :             :       /* Components must always be constant length.  */
    2804                 :        4859 :       gcc_assert (tmp && INTEGER_CST_P (tmp));
    2805                 :        4859 :       se->string_length = tmp;
    2806                 :             :     }
    2807                 :             : 
    2808                 :      139047 :   if (gfc_deferred_strlen (c, &field))
    2809                 :             :     {
    2810                 :        2708 :       tmp = fold_build3_loc (input_location, COMPONENT_REF,
    2811                 :        2708 :                              TREE_TYPE (field),
    2812                 :             :                              decl, field, NULL_TREE);
    2813                 :        2708 :       se->string_length = tmp;
    2814                 :             :     }
    2815                 :             : 
    2816                 :      139047 :   if (((c->attr.pointer || c->attr.allocatable)
    2817                 :       79703 :        && (!c->attr.dimension && !c->attr.codimension)
    2818                 :       48015 :        && c->ts.type != BT_CHARACTER)
    2819                 :       92839 :       || c->attr.proc_pointer)
    2820                 :       51001 :     se->expr = build_fold_indirect_ref_loc (input_location,
    2821                 :             :                                         se->expr);
    2822                 :      139047 : }
    2823                 :             : 
    2824                 :             : 
    2825                 :             : /* This function deals with component references to components of the
    2826                 :             :    parent type for derived type extensions.  */
    2827                 :             : void
    2828                 :       55912 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
    2829                 :             : {
    2830                 :       55912 :   gfc_component *c;
    2831                 :       55912 :   gfc_component *cmp;
    2832                 :       55912 :   gfc_symbol *dt;
    2833                 :       55912 :   gfc_ref parent;
    2834                 :             : 
    2835                 :       55912 :   dt = ref->u.c.sym;
    2836                 :       55912 :   c = ref->u.c.component;
    2837                 :             : 
    2838                 :             :   /* Return if the component is in this type, i.e. not in the parent type.  */
    2839                 :       97477 :   for (cmp = dt->components; cmp; cmp = cmp->next)
    2840                 :       88540 :     if (c == cmp)
    2841                 :       46975 :       return;
    2842                 :             : 
    2843                 :             :   /* Build a gfc_ref to recursively call gfc_conv_component_ref.  */
    2844                 :        8937 :   parent.type = REF_COMPONENT;
    2845                 :        8937 :   parent.next = NULL;
    2846                 :        8937 :   parent.u.c.sym = dt;
    2847                 :        8937 :   parent.u.c.component = dt->components;
    2848                 :             : 
    2849                 :        8937 :   if (dt->backend_decl == NULL)
    2850                 :           0 :     gfc_get_derived_type (dt);
    2851                 :             : 
    2852                 :             :   /* Build the reference and call self.  */
    2853                 :        8937 :   gfc_conv_component_ref (se, &parent);
    2854                 :        8937 :   parent.u.c.sym = dt->components->ts.u.derived;
    2855                 :        8937 :   parent.u.c.component = c;
    2856                 :        8937 :   conv_parent_component_references (se, &parent);
    2857                 :             : }
    2858                 :             : 
    2859                 :             : 
    2860                 :             : static void
    2861                 :         234 : conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
    2862                 :             : {
    2863                 :         234 :   tree res = se->expr;
    2864                 :             : 
    2865                 :         234 :   switch (ref->u.i)
    2866                 :             :     {
    2867                 :         104 :     case INQUIRY_RE:
    2868                 :         208 :       res = fold_build1_loc (input_location, REALPART_EXPR,
    2869                 :         104 :                              TREE_TYPE (TREE_TYPE (res)), res);
    2870                 :         104 :       break;
    2871                 :             : 
    2872                 :         103 :     case INQUIRY_IM:
    2873                 :         206 :       res = fold_build1_loc (input_location, IMAGPART_EXPR,
    2874                 :         103 :                              TREE_TYPE (TREE_TYPE (res)), res);
    2875                 :         103 :       break;
    2876                 :             : 
    2877                 :           7 :     case INQUIRY_KIND:
    2878                 :           7 :       res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
    2879                 :           7 :                            ts->kind);
    2880                 :           7 :       se->string_length = NULL_TREE;
    2881                 :           7 :       break;
    2882                 :             : 
    2883                 :          20 :     case INQUIRY_LEN:
    2884                 :          20 :       res = fold_convert (gfc_typenode_for_spec (&expr->ts),
    2885                 :             :                           se->string_length);
    2886                 :          20 :       se->string_length = NULL_TREE;
    2887                 :          20 :       break;
    2888                 :             : 
    2889                 :           0 :     default:
    2890                 :           0 :       gcc_unreachable ();
    2891                 :             :     }
    2892                 :         234 :   se->expr = res;
    2893                 :         234 : }
    2894                 :             : 
    2895                 :             : /* Dereference VAR where needed if it is a pointer, reference, etc.
    2896                 :             :    according to Fortran semantics.  */
    2897                 :             : 
    2898                 :             : tree
    2899                 :     1022062 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
    2900                 :             :                            bool is_classarray)
    2901                 :             : {
    2902                 :     1022062 :   if (!POINTER_TYPE_P (TREE_TYPE (var)))
    2903                 :             :     return var;
    2904                 :      246078 :   if (is_CFI_desc (sym, NULL))
    2905                 :       11780 :     return build_fold_indirect_ref_loc (input_location, var);
    2906                 :             : 
    2907                 :             :   /* Characters are entirely different from other types, they are treated
    2908                 :             :      separately.  */
    2909                 :      234298 :   if (sym->ts.type == BT_CHARACTER)
    2910                 :             :     {
    2911                 :             :       /* Dereference character pointer dummy arguments
    2912                 :             :          or results.  */
    2913                 :       26118 :       if ((sym->attr.pointer || sym->attr.allocatable
    2914                 :       15678 :            || (sym->as && sym->as->type == AS_ASSUMED_RANK))
    2915                 :       10776 :           && (sym->attr.dummy
    2916                 :             :               || sym->attr.function
    2917                 :       10776 :               || sym->attr.result))
    2918                 :        3453 :         var = build_fold_indirect_ref_loc (input_location, var);
    2919                 :             :     }
    2920                 :      208180 :   else if (!sym->attr.value)
    2921                 :             :     {
    2922                 :             :       /* Dereference temporaries for class array dummy arguments.  */
    2923                 :      146387 :       if (sym->attr.dummy && is_classarray
    2924                 :      213349 :           && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
    2925                 :             :         {
    2926                 :        4051 :           if (!descriptor_only_p)
    2927                 :        2011 :             var = GFC_DECL_SAVED_DESCRIPTOR (var);
    2928                 :             : 
    2929                 :        4051 :           var = build_fold_indirect_ref_loc (input_location, var);
    2930                 :             :         }
    2931                 :             : 
    2932                 :             :       /* Dereference non-character scalar dummy arguments.  */
    2933                 :      207503 :       if (sym->attr.dummy && !sym->attr.dimension
    2934                 :       90277 :           && !(sym->attr.codimension && sym->attr.allocatable)
    2935                 :       90215 :           && (sym->ts.type != BT_CLASS
    2936                 :       16379 :               || (!CLASS_DATA (sym)->attr.dimension
    2937                 :        9818 :                   && !(CLASS_DATA (sym)->attr.codimension
    2938                 :             :                        && CLASS_DATA (sym)->attr.allocatable))))
    2939                 :       83522 :         var = build_fold_indirect_ref_loc (input_location, var);
    2940                 :             : 
    2941                 :             :       /* Dereference scalar hidden result.  */
    2942                 :      207503 :       if (flag_f2c && sym->ts.type == BT_COMPLEX
    2943                 :         306 :           && (sym->attr.function || sym->attr.result)
    2944                 :         108 :           && !sym->attr.dimension && !sym->attr.pointer
    2945                 :          60 :           && !sym->attr.always_explicit)
    2946                 :          36 :         var = build_fold_indirect_ref_loc (input_location, var);
    2947                 :             : 
    2948                 :             :       /* Dereference non-character, non-class pointer variables.
    2949                 :             :          These must be dummies, results, or scalars.  */
    2950                 :      207503 :       if (!is_classarray
    2951                 :      201332 :           && (sym->attr.pointer || sym->attr.allocatable
    2952                 :      160931 :               || gfc_is_associate_pointer (sym)
    2953                 :      157040 :               || (sym->as && sym->as->type == AS_ASSUMED_RANK))
    2954                 :      207503 :           && (sym->attr.dummy
    2955                 :             :               || sym->attr.function
    2956                 :       61037 :               || sym->attr.result
    2957                 :       27828 :               || (!sym->attr.dimension
    2958                 :       27827 :                   && (!sym->attr.codimension || !sym->attr.allocatable))))
    2959                 :       61036 :         var = build_fold_indirect_ref_loc (input_location, var);
    2960                 :             :       /* Now treat the class array pointer variables accordingly.  */
    2961                 :      146467 :       else if (sym->ts.type == BT_CLASS
    2962                 :       16704 :                && sym->attr.dummy
    2963                 :       16379 :                && (CLASS_DATA (sym)->attr.dimension
    2964                 :       16379 :                    || CLASS_DATA (sym)->attr.codimension)
    2965                 :        6797 :                && ((CLASS_DATA (sym)->as
    2966                 :        6797 :                     && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
    2967                 :             :                    || CLASS_DATA (sym)->attr.allocatable
    2968                 :        5898 :                    || CLASS_DATA (sym)->attr.class_pointer))
    2969                 :        2642 :         var = build_fold_indirect_ref_loc (input_location, var);
    2970                 :             :       /* And the case where a non-dummy, non-result, non-function,
    2971                 :             :          non-allocable and non-pointer classarray is present.  This case was
    2972                 :             :          previously covered by the first if, but with introducing the
    2973                 :             :          condition !is_classarray there, that case has to be covered
    2974                 :             :          explicitly.  */
    2975                 :      143825 :       else if (sym->ts.type == BT_CLASS
    2976                 :             :                && !sym->attr.dummy
    2977                 :             :                && !sym->attr.function
    2978                 :       14062 :                && !sym->attr.result
    2979                 :         325 :                && (CLASS_DATA (sym)->attr.dimension
    2980                 :         325 :                    || CLASS_DATA (sym)->attr.codimension)
    2981                 :         325 :                && (sym->assoc
    2982                 :           0 :                    || !CLASS_DATA (sym)->attr.allocatable)
    2983                 :         325 :                && !CLASS_DATA (sym)->attr.class_pointer)
    2984                 :         325 :         var = build_fold_indirect_ref_loc (input_location, var);
    2985                 :             :     }
    2986                 :             : 
    2987                 :             :   return var;
    2988                 :             : }
    2989                 :             : 
    2990                 :             : /* Return the contents of a variable. Also handles reference/pointer
    2991                 :             :    variables (all Fortran pointer references are implicit).  */
    2992                 :             : 
    2993                 :             : static void
    2994                 :     1138214 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
    2995                 :             : {
    2996                 :     1138214 :   gfc_ss *ss;
    2997                 :     1138214 :   gfc_ref *ref;
    2998                 :     1138214 :   gfc_symbol *sym;
    2999                 :     1138214 :   tree parent_decl = NULL_TREE;
    3000                 :     1138214 :   int parent_flag;
    3001                 :     1138214 :   bool return_value;
    3002                 :     1138214 :   bool alternate_entry;
    3003                 :     1138214 :   bool entry_master;
    3004                 :     1138214 :   bool is_classarray;
    3005                 :     1138214 :   bool first_time = true;
    3006                 :             : 
    3007                 :     1138214 :   sym = expr->symtree->n.sym;
    3008                 :     1138214 :   is_classarray = IS_CLASS_ARRAY (sym);
    3009                 :     1138214 :   ss = se->ss;
    3010                 :     1138214 :   if (ss != NULL)
    3011                 :             :     {
    3012                 :       99719 :       gfc_ss_info *ss_info = ss->info;
    3013                 :             : 
    3014                 :             :       /* Check that something hasn't gone horribly wrong.  */
    3015                 :       99719 :       gcc_assert (ss != gfc_ss_terminator);
    3016                 :       99719 :       gcc_assert (ss_info->expr == expr);
    3017                 :             : 
    3018                 :             :       /* A scalarized term.  We already know the descriptor.  */
    3019                 :       99719 :       se->expr = ss_info->data.array.descriptor;
    3020                 :       99719 :       se->string_length = ss_info->string_length;
    3021                 :       99719 :       ref = ss_info->data.array.ref;
    3022                 :       99719 :       if (ref)
    3023                 :       99577 :         gcc_assert (ref->type == REF_ARRAY
    3024                 :             :                     && ref->u.ar.type != AR_ELEMENT);
    3025                 :             :       else
    3026                 :         142 :         gfc_conv_tmp_array_ref (se);
    3027                 :             :     }
    3028                 :             :   else
    3029                 :             :     {
    3030                 :     1038495 :       tree se_expr = NULL_TREE;
    3031                 :             : 
    3032                 :     1038495 :       se->expr = gfc_get_symbol_decl (sym);
    3033                 :             : 
    3034                 :             :       /* Deal with references to a parent results or entries by storing
    3035                 :             :          the current_function_decl and moving to the parent_decl.  */
    3036                 :     1038495 :       return_value = sym->attr.function && sym->result == sym;
    3037                 :       17890 :       alternate_entry = sym->attr.function && sym->attr.entry
    3038                 :     1039569 :                         && sym->result == sym;
    3039                 :     2076990 :       entry_master = sym->attr.result
    3040                 :        9240 :                      && sym->ns->proc_name->attr.entry_master
    3041                 :     1038876 :                      && !gfc_return_by_reference (sym->ns->proc_name);
    3042                 :     1038495 :       if (current_function_decl)
    3043                 :     1021653 :         parent_decl = DECL_CONTEXT (current_function_decl);
    3044                 :             : 
    3045                 :     1038495 :       if ((se->expr == parent_decl && return_value)
    3046                 :     1038384 :            || (sym->ns && sym->ns->proc_name
    3047                 :     1034081 :                && parent_decl
    3048                 :     1017239 :                && sym->ns->proc_name->backend_decl == parent_decl
    3049                 :       29919 :                && (alternate_entry || entry_master)))
    3050                 :             :         parent_flag = 1;
    3051                 :             :       else
    3052                 :     1038351 :         parent_flag = 0;
    3053                 :             : 
    3054                 :             :       /* Special case for assigning the return value of a function.
    3055                 :             :          Self recursive functions must have an explicit return value.  */
    3056                 :     1038495 :       if (return_value && (se->expr == current_function_decl || parent_flag))
    3057                 :       10918 :         se_expr = gfc_get_fake_result_decl (sym, parent_flag);
    3058                 :             : 
    3059                 :             :       /* Similarly for alternate entry points.  */
    3060                 :     1027577 :       else if (alternate_entry
    3061                 :        1041 :                && (sym->ns->proc_name->backend_decl == current_function_decl
    3062                 :           0 :                    || parent_flag))
    3063                 :             :         {
    3064                 :        1041 :           gfc_entry_list *el = NULL;
    3065                 :             : 
    3066                 :        1608 :           for (el = sym->ns->entries; el; el = el->next)
    3067                 :        1608 :             if (sym == el->sym)
    3068                 :             :               {
    3069                 :        1041 :                 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
    3070                 :        1041 :                 break;
    3071                 :             :               }
    3072                 :             :         }
    3073                 :             : 
    3074                 :     1026536 :       else if (entry_master
    3075                 :         295 :                && (sym->ns->proc_name->backend_decl == current_function_decl
    3076                 :           0 :                    || parent_flag))
    3077                 :         295 :         se_expr = gfc_get_fake_result_decl (sym, parent_flag);
    3078                 :             : 
    3079                 :       12254 :       if (se_expr)
    3080                 :       12254 :         se->expr = se_expr;
    3081                 :             : 
    3082                 :             :       /* Procedure actual arguments.  Look out for temporary variables
    3083                 :             :          with the same attributes as function values.  */
    3084                 :     1026241 :       else if (!sym->attr.temporary
    3085                 :     1026173 :                && sym->attr.flavor == FL_PROCEDURE
    3086                 :       17243 :                && se->expr != current_function_decl)
    3087                 :             :         {
    3088                 :       17217 :           if (!sym->attr.dummy && !sym->attr.proc_pointer)
    3089                 :             :             {
    3090                 :       15725 :               gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
    3091                 :       15725 :               se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
    3092                 :             :             }
    3093                 :       17217 :           return;
    3094                 :             :         }
    3095                 :             : 
    3096                 :     1021278 :       if (sym->ts.type == BT_CLASS
    3097                 :       58540 :           && sym->attr.class_ok
    3098                 :       58352 :           && sym->ts.u.derived->attr.is_class)
    3099                 :       58352 :         se->class_container = se->expr;
    3100                 :             : 
    3101                 :             :       /* Dereference the expression, where needed.  */
    3102                 :     1021278 :       se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
    3103                 :             :                                             is_classarray);
    3104                 :             : 
    3105                 :     1021278 :       ref = expr->ref;
    3106                 :             :     }
    3107                 :             : 
    3108                 :             :   /* For character variables, also get the length.  */
    3109                 :     1120997 :   if (sym->ts.type == BT_CHARACTER)
    3110                 :             :     {
    3111                 :             :       /* If the character length of an entry isn't set, get the length from
    3112                 :             :          the master function instead.  */
    3113                 :      145648 :       if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
    3114                 :           0 :         se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
    3115                 :             :       else
    3116                 :      145648 :         se->string_length = sym->ts.u.cl->backend_decl;
    3117                 :      145648 :       gcc_assert (se->string_length);
    3118                 :             :     }
    3119                 :             : 
    3120                 :     1120997 :   gfc_typespec *ts = &sym->ts;
    3121                 :     1467253 :   while (ref)
    3122                 :             :     {
    3123                 :      616799 :       switch (ref->type)
    3124                 :             :         {
    3125                 :      479408 :         case REF_ARRAY:
    3126                 :             :           /* Return the descriptor if that's what we want and this is an array
    3127                 :             :              section reference.  */
    3128                 :      479408 :           if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
    3129                 :             :             return;
    3130                 :             : /* TODO: Pointers to single elements of array sections, eg elemental subs.  */
    3131                 :             :           /* Return the descriptor for array pointers and allocations.  */
    3132                 :      216331 :           if (se->want_pointer
    3133                 :       19667 :               && ref->next == NULL && (se->descriptor_only))
    3134                 :             :             return;
    3135                 :             : 
    3136                 :      208865 :           gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
    3137                 :             :           /* Return a pointer to an element.  */
    3138                 :      208865 :           break;
    3139                 :             : 
    3140                 :      131059 :         case REF_COMPONENT:
    3141                 :      131059 :           ts = &ref->u.c.component->ts;
    3142                 :      131059 :           if (first_time && is_classarray && sym->attr.dummy
    3143                 :        4686 :               && se->descriptor_only
    3144                 :        3342 :               && !CLASS_DATA (sym)->attr.allocatable
    3145                 :        3342 :               && !CLASS_DATA (sym)->attr.class_pointer
    3146                 :        2445 :               && CLASS_DATA (sym)->as
    3147                 :        2445 :               && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
    3148                 :        2040 :               && strcmp ("_data", ref->u.c.component->name) == 0)
    3149                 :             :             /* Skip the first ref of a _data component, because for class
    3150                 :             :                arrays that one is already done by introducing a temporary
    3151                 :             :                array descriptor.  */
    3152                 :             :             break;
    3153                 :             : 
    3154                 :      129019 :           if (ref->u.c.sym->attr.extension)
    3155                 :       46884 :             conv_parent_component_references (se, ref);
    3156                 :             : 
    3157                 :      129019 :           gfc_conv_component_ref (se, ref);
    3158                 :             : 
    3159                 :      129019 :           if (ref->u.c.component->ts.type == BT_CLASS
    3160                 :       10091 :               && ref->u.c.component->attr.class_ok
    3161                 :       10091 :               && ref->u.c.component->ts.u.derived->attr.is_class)
    3162                 :       10091 :             se->class_container = se->expr;
    3163                 :      118928 :           else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
    3164                 :      116434 :                      && ref->u.c.sym->attr.is_class))
    3165                 :       62673 :             se->class_container = NULL_TREE;
    3166                 :             : 
    3167                 :      129019 :           if (!ref->next && ref->u.c.sym->attr.codimension
    3168                 :           0 :               && se->want_pointer && se->descriptor_only)
    3169                 :             :             return;
    3170                 :             : 
    3171                 :             :           break;
    3172                 :             : 
    3173                 :        6098 :         case REF_SUBSTRING:
    3174                 :        6098 :           gfc_conv_substring (se, ref, expr->ts.kind,
    3175                 :        6098 :                               expr->symtree->name, &expr->where);
    3176                 :        6098 :           break;
    3177                 :             : 
    3178                 :         234 :         case REF_INQUIRY:
    3179                 :         234 :           conv_inquiry (se, ref, expr, ts);
    3180                 :         234 :           break;
    3181                 :             : 
    3182                 :           0 :         default:
    3183                 :           0 :           gcc_unreachable ();
    3184                 :      346256 :           break;
    3185                 :             :         }
    3186                 :      346256 :       first_time = false;
    3187                 :      346256 :       ref = ref->next;
    3188                 :             :     }
    3189                 :             :   /* Pointer assignment, allocation or pass by reference.  Arrays are handled
    3190                 :             :      separately.  */
    3191                 :      850454 :   if (se->want_pointer)
    3192                 :             :     {
    3193                 :      116363 :       if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
    3194                 :        6326 :         gfc_conv_string_parameter (se);
    3195                 :             :       else
    3196                 :      110037 :         se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
    3197                 :             :     }
    3198                 :             : }
    3199                 :             : 
    3200                 :             : 
    3201                 :             : /* Unary ops are easy... Or they would be if ! was a valid op.  */
    3202                 :             : 
    3203                 :             : static void
    3204                 :       26439 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
    3205                 :             : {
    3206                 :       26439 :   gfc_se operand;
    3207                 :       26439 :   tree type;
    3208                 :             : 
    3209                 :       26439 :   gcc_assert (expr->ts.type != BT_CHARACTER);
    3210                 :             :   /* Initialize the operand.  */
    3211                 :       26439 :   gfc_init_se (&operand, se);
    3212                 :       26439 :   gfc_conv_expr_val (&operand, expr->value.op.op1);
    3213                 :       26439 :   gfc_add_block_to_block (&se->pre, &operand.pre);
    3214                 :             : 
    3215                 :       26439 :   type = gfc_typenode_for_spec (&expr->ts);
    3216                 :             : 
    3217                 :             :   /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
    3218                 :             :      We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
    3219                 :             :      All other unary operators have an equivalent GIMPLE unary operator.  */
    3220                 :       26439 :   if (code == TRUTH_NOT_EXPR)
    3221                 :       18220 :     se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
    3222                 :       18220 :                                 build_int_cst (type, 0));
    3223                 :             :   else
    3224                 :        8219 :     se->expr = fold_build1_loc (input_location, code, type, operand.expr);
    3225                 :             : 
    3226                 :       26439 : }
    3227                 :             : 
    3228                 :             : /* Expand power operator to optimal multiplications when a value is raised
    3229                 :             :    to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
    3230                 :             :    Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
    3231                 :             :    Programming", 3rd Edition, 1998.  */
    3232                 :             : 
    3233                 :             : /* This code is mostly duplicated from expand_powi in the backend.
    3234                 :             :    We establish the "optimal power tree" lookup table with the defined size.
    3235                 :             :    The items in the table are the exponents used to calculate the index
    3236                 :             :    exponents. Any integer n less than the value can get an "addition chain",
    3237                 :             :    with the first node being one.  */
    3238                 :             : #define POWI_TABLE_SIZE 256
    3239                 :             : 
    3240                 :             : /* The table is from builtins.cc.  */
    3241                 :             : static const unsigned char powi_table[POWI_TABLE_SIZE] =
    3242                 :             :   {
    3243                 :             :       0,   1,   1,   2,   2,   3,   3,   4,  /*   0 -   7 */
    3244                 :             :       4,   6,   5,   6,   6,  10,   7,   9,  /*   8 -  15 */
    3245                 :             :       8,  16,   9,  16,  10,  12,  11,  13,  /*  16 -  23 */
    3246                 :             :      12,  17,  13,  18,  14,  24,  15,  26,  /*  24 -  31 */
    3247                 :             :      16,  17,  17,  19,  18,  33,  19,  26,  /*  32 -  39 */
    3248                 :             :      20,  25,  21,  40,  22,  27,  23,  44,  /*  40 -  47 */
    3249                 :             :      24,  32,  25,  34,  26,  29,  27,  44,  /*  48 -  55 */
    3250                 :             :      28,  31,  29,  34,  30,  60,  31,  36,  /*  56 -  63 */
    3251                 :             :      32,  64,  33,  34,  34,  46,  35,  37,  /*  64 -  71 */
    3252                 :             :      36,  65,  37,  50,  38,  48,  39,  69,  /*  72 -  79 */
    3253                 :             :      40,  49,  41,  43,  42,  51,  43,  58,  /*  80 -  87 */
    3254                 :             :      44,  64,  45,  47,  46,  59,  47,  76,  /*  88 -  95 */
    3255                 :             :      48,  65,  49,  66,  50,  67,  51,  66,  /*  96 - 103 */
    3256                 :             :      52,  70,  53,  74,  54, 104,  55,  74,  /* 104 - 111 */
    3257                 :             :      56,  64,  57,  69,  58,  78,  59,  68,  /* 112 - 119 */
    3258                 :             :      60,  61,  61,  80,  62,  75,  63,  68,  /* 120 - 127 */
    3259                 :             :      64,  65,  65, 128,  66, 129,  67,  90,  /* 128 - 135 */
    3260                 :             :      68,  73,  69, 131,  70,  94,  71,  88,  /* 136 - 143 */
    3261                 :             :      72, 128,  73,  98,  74, 132,  75, 121,  /* 144 - 151 */
    3262                 :             :      76, 102,  77, 124,  78, 132,  79, 106,  /* 152 - 159 */
    3263                 :             :      80,  97,  81, 160,  82,  99,  83, 134,  /* 160 - 167 */
    3264                 :             :      84,  86,  85,  95,  86, 160,  87, 100,  /* 168 - 175 */
    3265                 :             :      88, 113,  89,  98,  90, 107,  91, 122,  /* 176 - 183 */
    3266                 :             :      92, 111,  93, 102,  94, 126,  95, 150,  /* 184 - 191 */
    3267                 :             :      96, 128,  97, 130,  98, 133,  99, 195,  /* 192 - 199 */
    3268                 :             :     100, 128, 101, 123, 102, 164, 103, 138,  /* 200 - 207 */
    3269                 :             :     104, 145, 105, 146, 106, 109, 107, 149,  /* 208 - 215 */
    3270                 :             :     108, 200, 109, 146, 110, 170, 111, 157,  /* 216 - 223 */
    3271                 :             :     112, 128, 113, 130, 114, 182, 115, 132,  /* 224 - 231 */
    3272                 :             :     116, 200, 117, 132, 118, 158, 119, 206,  /* 232 - 239 */
    3273                 :             :     120, 240, 121, 162, 122, 147, 123, 152,  /* 240 - 247 */
    3274                 :             :     124, 166, 125, 214, 126, 138, 127, 153,  /* 248 - 255 */
    3275                 :             :   };
    3276                 :             : 
    3277                 :             : /* If n is larger than lookup table's max index, we use the "window
    3278                 :             :    method".  */
    3279                 :             : #define POWI_WINDOW_SIZE 3
    3280                 :             : 
    3281                 :             : /* Recursive function to expand the power operator. The temporary
    3282                 :             :    values are put in tmpvar. The function returns tmpvar[1] ** n.  */
    3283                 :             : static tree
    3284                 :        4368 : gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
    3285                 :             : {
    3286                 :        4368 :   tree op0;
    3287                 :        4368 :   tree op1;
    3288                 :        4368 :   tree tmp;
    3289                 :        4368 :   int digit;
    3290                 :             : 
    3291                 :        4368 :   if (n < POWI_TABLE_SIZE)
    3292                 :             :     {
    3293                 :        3509 :       if (tmpvar[n])
    3294                 :             :         return tmpvar[n];
    3295                 :             : 
    3296                 :        1177 :       op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
    3297                 :        1177 :       op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
    3298                 :             :     }
    3299                 :         859 :   else if (n & 1)
    3300                 :             :     {
    3301                 :         223 :       digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
    3302                 :         223 :       op0 = gfc_conv_powi (se, n - digit, tmpvar);
    3303                 :         223 :       op1 = gfc_conv_powi (se, digit, tmpvar);
    3304                 :             :     }
    3305                 :             :   else
    3306                 :             :     {
    3307                 :         636 :       op0 = gfc_conv_powi (se, n >> 1, tmpvar);
    3308                 :         636 :       op1 = op0;
    3309                 :             :     }
    3310                 :             : 
    3311                 :        2036 :   tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
    3312                 :        2036 :   tmp = gfc_evaluate_now (tmp, &se->pre);
    3313                 :             : 
    3314                 :        2036 :   if (n < POWI_TABLE_SIZE)
    3315                 :        1177 :     tmpvar[n] = tmp;
    3316                 :             : 
    3317                 :             :   return tmp;
    3318                 :             : }
    3319                 :             : 
    3320                 :             : 
    3321                 :             : /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
    3322                 :             :    return 1. Else return 0 and a call to runtime library functions
    3323                 :             :    will have to be built.  */
    3324                 :             : static int
    3325                 :        1727 : gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
    3326                 :             : {
    3327                 :        1727 :   tree cond;
    3328                 :        1727 :   tree tmp;
    3329                 :        1727 :   tree type;
    3330                 :        1727 :   tree vartmp[POWI_TABLE_SIZE];
    3331                 :        1727 :   HOST_WIDE_INT m;
    3332                 :        1727 :   unsigned HOST_WIDE_INT n;
    3333                 :        1727 :   int sgn;
    3334                 :        1727 :   wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
    3335                 :             : 
    3336                 :             :   /* If exponent is too large, we won't expand it anyway, so don't bother
    3337                 :             :      with large integer values.  */
    3338                 :        1727 :   if (!wi::fits_shwi_p (wrhs))
    3339                 :             :     return 0;
    3340                 :             : 
    3341                 :        1727 :   m = wrhs.to_shwi ();
    3342                 :             :   /* Use the wide_int's routine to reliably get the absolute value on all
    3343                 :             :      platforms.  Then convert it to a HOST_WIDE_INT like above.  */
    3344                 :        1727 :   n = wi::abs (wrhs).to_shwi ();
    3345                 :             : 
    3346                 :        1727 :   type = TREE_TYPE (lhs);
    3347                 :        1727 :   sgn = tree_int_cst_sgn (rhs);
    3348                 :             : 
    3349                 :        1727 :   if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
    3350                 :        3454 :        || optimize_size) && (m > 2 || m < -1))
    3351                 :             :     return 0;
    3352                 :             : 
    3353                 :             :   /* rhs == 0  */
    3354                 :        1251 :   if (sgn == 0)
    3355                 :             :     {
    3356                 :         167 :       se->expr = gfc_build_const (type, integer_one_node);
    3357                 :         167 :       return 1;
    3358                 :             :     }
    3359                 :             : 
    3360                 :             :   /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1.  */
    3361                 :        1084 :   if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
    3362                 :             :     {
    3363                 :         152 :       tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    3364                 :         152 :                              lhs, build_int_cst (TREE_TYPE (lhs), -1));
    3365                 :         152 :       cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    3366                 :         152 :                               lhs, build_int_cst (TREE_TYPE (lhs), 1));
    3367                 :             : 
    3368                 :             :       /* If rhs is even,
    3369                 :             :          result = (lhs == 1 || lhs == -1) ? 1 : 0.  */
    3370                 :         152 :       if ((n & 1) == 0)
    3371                 :             :         {
    3372                 :          72 :           tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
    3373                 :             :                                  logical_type_node, tmp, cond);
    3374                 :          72 :           se->expr = fold_build3_loc (input_location, COND_EXPR, type,
    3375                 :          72 :                                       tmp, build_int_cst (type, 1),
    3376                 :          72 :                                       build_int_cst (type, 0));
    3377                 :          72 :           return 1;
    3378                 :             :         }
    3379                 :             :       /* If rhs is odd,
    3380                 :             :          result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0.  */
    3381                 :          80 :       tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
    3382                 :          80 :                              build_int_cst (type, -1),
    3383                 :          80 :                              build_int_cst (type, 0));
    3384                 :          80 :       se->expr = fold_build3_loc (input_location, COND_EXPR, type,
    3385                 :          80 :                                   cond, build_int_cst (type, 1), tmp);
    3386                 :          80 :       return 1;
    3387                 :             :     }
    3388                 :             : 
    3389                 :         932 :   memset (vartmp, 0, sizeof (vartmp));
    3390                 :         932 :   vartmp[1] = lhs;
    3391                 :         932 :   if (sgn == -1)
    3392                 :             :     {
    3393                 :          91 :       tmp = gfc_build_const (type, integer_one_node);
    3394                 :          91 :       vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
    3395                 :             :                                    vartmp[1]);
    3396                 :             :     }
    3397                 :             : 
    3398                 :         932 :   se->expr = gfc_conv_powi (se, n, vartmp);
    3399                 :             : 
    3400                 :         932 :   return 1;
    3401                 :             : }
    3402                 :             : 
    3403                 :             : 
    3404                 :             : /* Power op (**).  Constant integer exponent has special handling.  */
    3405                 :             : 
    3406                 :             : static void
    3407                 :        3180 : gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
    3408                 :             : {
    3409                 :        3180 :   tree gfc_int4_type_node;
    3410                 :        3180 :   int kind;
    3411                 :        3180 :   int ikind;
    3412                 :        3180 :   int res_ikind_1, res_ikind_2;
    3413                 :        3180 :   gfc_se lse;
    3414                 :        3180 :   gfc_se rse;
    3415                 :        3180 :   tree fndecl = NULL;
    3416                 :             : 
    3417                 :        3180 :   gfc_init_se (&lse, se);
    3418                 :        3180 :   gfc_conv_expr_val (&lse, expr->value.op.op1);
    3419                 :        3180 :   lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
    3420                 :        3180 :   gfc_add_block_to_block (&se->pre, &lse.pre);
    3421                 :             : 
    3422                 :        3180 :   gfc_init_se (&rse, se);
    3423                 :        3180 :   gfc_conv_expr_val (&rse, expr->value.op.op2);
    3424                 :        3180 :   gfc_add_block_to_block (&se->pre, &rse.pre);
    3425                 :             : 
    3426                 :        3180 :   if (expr->value.op.op2->ts.type == BT_INTEGER
    3427                 :        2316 :       && expr->value.op.op2->expr_type == EXPR_CONSTANT)
    3428                 :        1727 :     if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
    3429                 :        1476 :       return;
    3430                 :             : 
    3431                 :        1929 :   if (INTEGER_CST_P (lse.expr)
    3432                 :        1929 :       && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
    3433                 :             :     {
    3434                 :         231 :       wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
    3435                 :         231 :       HOST_WIDE_INT v;
    3436                 :         231 :       unsigned HOST_WIDE_INT w;
    3437                 :         231 :       int kind, ikind, bit_size;
    3438                 :             : 
    3439                 :         231 :       v = wlhs.to_shwi ();
    3440                 :         231 :       w = absu_hwi (v);
    3441                 :             : 
    3442                 :         231 :       kind = expr->value.op.op1->ts.kind;
    3443                 :         231 :       ikind = gfc_validate_kind (BT_INTEGER, kind, false);
    3444                 :         231 :       bit_size = gfc_integer_kinds[ikind].bit_size;
    3445                 :             : 
    3446                 :         231 :       if (v == 1)
    3447                 :             :         {
    3448                 :             :           /* 1**something is always 1.  */
    3449                 :          35 :           se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
    3450                 :         225 :           return;
    3451                 :             :         }
    3452                 :         196 :       else if (v == -1)
    3453                 :             :         {
    3454                 :             :           /* (-1)**n is 1 - ((n & 1) << 1) */
    3455                 :          44 :           tree type;
    3456                 :          44 :           tree tmp;
    3457                 :             : 
    3458                 :          44 :           type = TREE_TYPE (lse.expr);
    3459                 :          44 :           tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
    3460                 :          44 :                                  rse.expr, build_int_cst (type, 1));
    3461                 :          44 :           tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
    3462                 :          44 :                                  tmp, build_int_cst (type, 1));
    3463                 :          44 :           tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
    3464                 :          44 :                                  build_int_cst (type, 1), tmp);
    3465                 :          44 :           se->expr = tmp;
    3466                 :          44 :           return;
    3467                 :             :         }
    3468                 :         152 :       else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
    3469                 :             :         {
    3470                 :             :           /* Here v is +/- 2**e.  The further simplification uses
    3471                 :             :              2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
    3472                 :             :              1<<(4*n), etc., but we have to make sure to return zero
    3473                 :             :              if the number of bits is too large. */
    3474                 :         146 :           tree lshift;
    3475                 :         146 :           tree type;
    3476                 :         146 :           tree shift;
    3477                 :         146 :           tree ge;
    3478                 :         146 :           tree cond;
    3479                 :         146 :           tree num_bits;
    3480                 :         146 :           tree cond2;
    3481                 :         146 :           tree tmp1;
    3482                 :             : 
    3483                 :         146 :           type = TREE_TYPE (lse.expr);
    3484                 :             : 
    3485                 :         146 :           if (w == 2)
    3486                 :          86 :             shift = rse.expr;
    3487                 :          60 :           else if (w == 4)
    3488                 :          12 :             shift = fold_build2_loc (input_location, PLUS_EXPR,
    3489                 :          12 :                                      TREE_TYPE (rse.expr),
    3490                 :             :                                        rse.expr, rse.expr);
    3491                 :             :           else
    3492                 :             :             {
    3493                 :             :               /* use popcount for fast log2(w) */
    3494                 :          48 :               int e = wi::popcount (w-1);
    3495                 :          96 :               shift = fold_build2_loc (input_location, MULT_EXPR,
    3496                 :          48 :                                        TREE_TYPE (rse.expr),
    3497                 :          48 :                                        build_int_cst (TREE_TYPE (rse.expr), e),
    3498                 :             :                                        rse.expr);
    3499                 :             :             }
    3500                 :             : 
    3501                 :         146 :           lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
    3502                 :         146 :                                     build_int_cst (type, 1), shift);
    3503                 :         146 :           ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
    3504                 :         146 :                                 rse.expr, build_int_cst (type, 0));
    3505                 :         146 :           cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
    3506                 :         146 :                                  build_int_cst (type, 0));
    3507                 :         146 :           num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
    3508                 :         146 :           cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
    3509                 :             :                                    rse.expr, num_bits);
    3510                 :         146 :           tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
    3511                 :         146 :                                   build_int_cst (type, 0), cond);
    3512                 :         146 :           if (v > 0)
    3513                 :             :             {
    3514                 :         104 :               se->expr = tmp1;
    3515                 :             :             }
    3516                 :             :           else
    3517                 :             :             {
    3518                 :             :               /* for v < 0, calculate v**n = |v|**n * (-1)**n */
    3519                 :          42 :               tree tmp2;
    3520                 :          42 :               tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
    3521                 :          42 :                                       rse.expr, build_int_cst (type, 1));
    3522                 :          42 :               tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
    3523                 :          42 :                                       tmp2, build_int_cst (type, 1));
    3524                 :          42 :               tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
    3525                 :          42 :                                       build_int_cst (type, 1), tmp2);
    3526                 :          42 :               se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
    3527                 :             :                                           tmp1, tmp2);
    3528                 :             :             }
    3529                 :         146 :           return;
    3530                 :             :         }
    3531                 :             :     }
    3532                 :             : 
    3533                 :        1704 :   gfc_int4_type_node = gfc_get_int_type (4);
    3534                 :             : 
    3535                 :             :   /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
    3536                 :             :      library routine.  But in the end, we have to convert the result back
    3537                 :             :      if this case applies -- with res_ikind_K, we keep track whether operand K
    3538                 :             :      falls into this case.  */
    3539                 :        1704 :   res_ikind_1 = -1;
    3540                 :        1704 :   res_ikind_2 = -1;
    3541                 :             : 
    3542                 :        1704 :   kind = expr->value.op.op1->ts.kind;
    3543                 :        1704 :   switch (expr->value.op.op2->ts.type)
    3544                 :             :     {
    3545                 :         840 :     case BT_INTEGER:
    3546                 :         840 :       ikind = expr->value.op.op2->ts.kind;
    3547                 :         840 :       switch (ikind)
    3548                 :             :         {
    3549                 :         144 :         case 1:
    3550                 :         144 :         case 2:
    3551                 :         144 :           rse.expr = convert (gfc_int4_type_node, rse.expr);
    3552                 :         144 :           res_ikind_2 = ikind;
    3553                 :             :           /* Fall through.  */
    3554                 :             : 
    3555                 :             :         case 4:
    3556                 :             :           ikind = 0;
    3557                 :             :           break;
    3558                 :             : 
    3559                 :             :         case 8:
    3560                 :             :           ikind = 1;
    3561                 :             :           break;
    3562                 :             : 
    3563                 :           6 :         case 16:
    3564                 :           6 :           ikind = 2;
    3565                 :           6 :           break;
    3566                 :             : 
    3567                 :           0 :         default:
    3568                 :           0 :           gcc_unreachable ();
    3569                 :             :         }
    3570                 :         840 :       switch (kind)
    3571                 :             :         {
    3572                 :           0 :         case 1:
    3573                 :           0 :         case 2:
    3574                 :           0 :           if (expr->value.op.op1->ts.type == BT_INTEGER)
    3575                 :             :             {
    3576                 :           0 :               lse.expr = convert (gfc_int4_type_node, lse.expr);
    3577                 :           0 :               res_ikind_1 = kind;
    3578                 :             :             }
    3579                 :             :           else
    3580                 :           0 :             gcc_unreachable ();
    3581                 :             :           /* Fall through.  */
    3582                 :             : 
    3583                 :             :         case 4:
    3584                 :             :           kind = 0;
    3585                 :             :           break;
    3586                 :             : 
    3587                 :             :         case 8:
    3588                 :             :           kind = 1;
    3589                 :             :           break;
    3590                 :             : 
    3591                 :           6 :         case 10:
    3592                 :           6 :           kind = 2;
    3593                 :           6 :           break;
    3594                 :             : 
    3595                 :          18 :         case 16:
    3596                 :          18 :           kind = 3;
    3597                 :          18 :           break;
    3598                 :             : 
    3599                 :           0 :         default:
    3600                 :           0 :           gcc_unreachable ();
    3601                 :             :         }
    3602                 :             : 
    3603                 :         840 :       switch (expr->value.op.op1->ts.type)
    3604                 :             :         {
    3605                 :          96 :         case BT_INTEGER:
    3606                 :          96 :           if (kind == 3) /* Case 16 was not handled properly above.  */
    3607                 :           6 :             kind = 2;
    3608                 :          96 :           fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
    3609                 :          96 :           break;
    3610                 :             : 
    3611                 :         557 :         case BT_REAL:
    3612                 :             :           /* Use builtins for real ** int4.  */
    3613                 :         557 :           if (ikind == 0)
    3614                 :             :             {
    3615                 :         500 :               switch (kind)
    3616                 :             :                 {
    3617                 :         327 :                 case 0:
    3618                 :         327 :                   fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
    3619                 :         327 :                   break;
    3620                 :             : 
    3621                 :         155 :                 case 1:
    3622                 :         155 :                   fndecl = builtin_decl_explicit (BUILT_IN_POWI);
    3623                 :         155 :                   break;
    3624                 :             : 
    3625                 :           6 :                 case 2:
    3626                 :           6 :                   fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
    3627                 :           6 :                   break;
    3628                 :             : 
    3629                 :          12 :                 case 3:
    3630                 :             :                   /* Use the __builtin_powil() only if real(kind=16) is
    3631                 :             :                      actually the C long double type.  */
    3632                 :          12 :                   if (!gfc_real16_is_float128)
    3633                 :           0 :                     fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
    3634                 :             :                   break;
    3635                 :             : 
    3636                 :             :                 default:
    3637                 :             :                   gcc_unreachable ();
    3638                 :             :                 }
    3639                 :             :             }
    3640                 :             : 
    3641                 :             :           /* If we don't have a good builtin for this, go for the
    3642                 :             :              library function.  */
    3643                 :         488 :           if (!fndecl)
    3644                 :          69 :             fndecl = gfor_fndecl_math_powi[kind][ikind].real;
    3645                 :             :           break;
    3646                 :             : 
    3647                 :         187 :         case BT_COMPLEX:
    3648                 :         187 :           fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
    3649                 :         187 :           break;
    3650                 :             : 
    3651                 :           0 :         default:
    3652                 :           0 :           gcc_unreachable ();
    3653                 :             :         }
    3654                 :             :       break;
    3655                 :             : 
    3656                 :         135 :     case BT_REAL:
    3657                 :         135 :       fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
    3658                 :         135 :       break;
    3659                 :             : 
    3660                 :         729 :     case BT_COMPLEX:
    3661                 :         729 :       fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
    3662                 :         729 :       break;
    3663                 :             : 
    3664                 :           0 :     default:
    3665                 :           0 :       gcc_unreachable ();
    3666                 :        1704 :       break;
    3667                 :             :     }
    3668                 :             : 
    3669                 :        1704 :   se->expr = build_call_expr_loc (input_location,
    3670                 :             :                               fndecl, 2, lse.expr, rse.expr);
    3671                 :             : 
    3672                 :             :   /* Convert the result back if it is of wrong integer kind.  */
    3673                 :        1704 :   if (res_ikind_1 != -1 && res_ikind_2 != -1)
    3674                 :             :     {
    3675                 :             :       /* We want the maximum of both operand kinds as result.  */
    3676                 :           0 :       if (res_ikind_1 < res_ikind_2)
    3677                 :           0 :         res_ikind_1 = res_ikind_2;
    3678                 :           0 :       se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
    3679                 :             :     }
    3680                 :             : }
    3681                 :             : 
    3682                 :             : 
    3683                 :             : /* Generate code to allocate a string temporary.  */
    3684                 :             : 
    3685                 :             : tree
    3686                 :        4408 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
    3687                 :             : {
    3688                 :        4408 :   tree var;
    3689                 :        4408 :   tree tmp;
    3690                 :             : 
    3691                 :        4408 :   if (gfc_can_put_var_on_stack (len))
    3692                 :             :     {
    3693                 :             :       /* Create a temporary variable to hold the result.  */
    3694                 :        3904 :       tmp = fold_build2_loc (input_location, MINUS_EXPR,
    3695                 :        1952 :                              TREE_TYPE (len), len,
    3696                 :        1952 :                              build_int_cst (TREE_TYPE (len), 1));
    3697                 :        1952 :       tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
    3698                 :             : 
    3699                 :        1952 :       if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
    3700                 :        1952 :         tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
    3701                 :             :       else
    3702                 :           0 :         tmp = build_array_type (TREE_TYPE (type), tmp);
    3703                 :             : 
    3704                 :        1952 :       var = gfc_create_var (tmp, "str");
    3705                 :        1952 :       var = gfc_build_addr_expr (type, var);
    3706                 :             :     }
    3707                 :             :   else
    3708                 :             :     {
    3709                 :             :       /* Allocate a temporary to hold the result.  */
    3710                 :        2456 :       var = gfc_create_var (type, "pstr");
    3711                 :        2456 :       gcc_assert (POINTER_TYPE_P (type));
    3712                 :        2456 :       tmp = TREE_TYPE (type);
    3713                 :        2456 :       if (TREE_CODE (tmp) == ARRAY_TYPE)
    3714                 :        2456 :         tmp = TREE_TYPE (tmp);
    3715                 :        2456 :       tmp = TYPE_SIZE_UNIT (tmp);
    3716                 :        2456 :       tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
    3717                 :             :                             fold_convert (size_type_node, len),
    3718                 :             :                             fold_convert (size_type_node, tmp));
    3719                 :        2456 :       tmp = gfc_call_malloc (&se->pre, type, tmp);
    3720                 :        2456 :       gfc_add_modify (&se->pre, var, tmp);
    3721                 :             : 
    3722                 :             :       /* Free the temporary afterwards.  */
    3723                 :        2456 :       tmp = gfc_call_free (var);
    3724                 :        2456 :       gfc_add_expr_to_block (&se->post, tmp);
    3725                 :             :     }
    3726                 :             : 
    3727                 :        4408 :   return var;
    3728                 :             : }
    3729                 :             : 
    3730                 :             : 
    3731                 :             : /* Handle a string concatenation operation.  A temporary will be allocated to
    3732                 :             :    hold the result.  */
    3733                 :             : 
    3734                 :             : static void
    3735                 :        1162 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
    3736                 :             : {
    3737                 :        1162 :   gfc_se lse, rse;
    3738                 :        1162 :   tree len, type, var, tmp, fndecl;
    3739                 :             : 
    3740                 :        1162 :   gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
    3741                 :             :               && expr->value.op.op2->ts.type == BT_CHARACTER);
    3742                 :        1162 :   gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
    3743                 :             : 
    3744                 :        1162 :   gfc_init_se (&lse, se);
    3745                 :        1162 :   gfc_conv_expr (&lse, expr->value.op.op1);
    3746                 :        1162 :   gfc_conv_string_parameter (&lse);
    3747                 :        1162 :   gfc_init_se (&rse, se);
    3748                 :        1162 :   gfc_conv_expr (&rse, expr->value.op.op2);
    3749                 :        1162 :   gfc_conv_string_parameter (&rse);
    3750                 :             : 
    3751                 :        1162 :   gfc_add_block_to_block (&se->pre, &lse.pre);
    3752                 :        1162 :   gfc_add_block_to_block (&se->pre, &rse.pre);
    3753                 :             : 
    3754                 :        1162 :   type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
    3755                 :        1162 :   len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
    3756                 :        1162 :   if (len == NULL_TREE)
    3757                 :             :     {
    3758                 :        1031 :       len = fold_build2_loc (input_location, PLUS_EXPR,
    3759                 :             :                              gfc_charlen_type_node,
    3760                 :             :                              fold_convert (gfc_charlen_type_node,
    3761                 :             :                                            lse.string_length),
    3762                 :             :                              fold_convert (gfc_charlen_type_node,
    3763                 :             :                                            rse.string_length));
    3764                 :             :     }
    3765                 :             : 
    3766                 :        1162 :   type = build_pointer_type (type);
    3767                 :             : 
    3768                 :        1162 :   var = gfc_conv_string_tmp (se, type, len);
    3769                 :             : 
    3770                 :             :   /* Do the actual concatenation.  */
    3771                 :        1162 :   if (expr->ts.kind == 1)
    3772                 :        1098 :     fndecl = gfor_fndecl_concat_string;
    3773                 :          64 :   else if (expr->ts.kind == 4)
    3774                 :          64 :     fndecl = gfor_fndecl_concat_string_char4;
    3775                 :             :   else
    3776                 :           0 :     gcc_unreachable ();
    3777                 :             : 
    3778                 :        1162 :   tmp = build_call_expr_loc (input_location,
    3779                 :             :                          fndecl, 6, len, var, lse.string_length, lse.expr,
    3780                 :             :                          rse.string_length, rse.expr);
    3781                 :        1162 :   gfc_add_expr_to_block (&se->pre, tmp);
    3782                 :             : 
    3783                 :             :   /* Add the cleanup for the operands.  */
    3784                 :        1162 :   gfc_add_block_to_block (&se->pre, &rse.post);
    3785                 :        1162 :   gfc_add_block_to_block (&se->pre, &lse.post);
    3786                 :             : 
    3787                 :        1162 :   se->expr = var;
    3788                 :        1162 :   se->string_length = len;
    3789                 :        1162 : }
    3790                 :             : 
    3791                 :             : /* Translates an op expression. Common (binary) cases are handled by this
    3792                 :             :    function, others are passed on. Recursion is used in either case.
    3793                 :             :    We use the fact that (op1.ts == op2.ts) (except for the power
    3794                 :             :    operator **).
    3795                 :             :    Operators need no special handling for scalarized expressions as long as
    3796                 :             :    they call gfc_conv_simple_val to get their operands.
    3797                 :             :    Character strings get special handling.  */
    3798                 :             : 
    3799                 :             : static void
    3800                 :      341053 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
    3801                 :             : {
    3802                 :      341053 :   enum tree_code code;
    3803                 :      341053 :   gfc_se lse;
    3804                 :      341053 :   gfc_se rse;
    3805                 :      341053 :   tree tmp, type;
    3806                 :      341053 :   int lop;
    3807                 :      341053 :   int checkstring;
    3808                 :             : 
    3809                 :      341053 :   checkstring = 0;
    3810                 :      341053 :   lop = 0;
    3811                 :      341053 :   switch (expr->value.op.op)
    3812                 :             :     {
    3813                 :       14478 :     case INTRINSIC_PARENTHESES:
    3814                 :       14478 :       if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
    3815                 :        3541 :           && flag_protect_parens)
    3816                 :             :         {
    3817                 :        3398 :           gfc_conv_unary_op (PAREN_EXPR, se, expr);
    3818                 :        3398 :           gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
    3819                 :       41867 :           return;
    3820                 :             :         }
    3821                 :             : 
    3822                 :             :       /* Fallthrough.  */
    3823                 :       11086 :     case INTRINSIC_UPLUS:
    3824                 :       11086 :       gfc_conv_expr (se, expr->value.op.op1);
    3825                 :       11086 :       return;
    3826                 :             : 
    3827                 :        4821 :     case INTRINSIC_UMINUS:
    3828                 :        4821 :       gfc_conv_unary_op (NEGATE_EXPR, se, expr);
    3829                 :        4821 :       return;
    3830                 :             : 
    3831                 :       18220 :     case INTRINSIC_NOT:
    3832                 :       18220 :       gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
    3833                 :       18220 :       return;
    3834                 :             : 
    3835                 :             :     case INTRINSIC_PLUS:
    3836                 :             :       code = PLUS_EXPR;
    3837                 :             :       break;
    3838                 :             : 
    3839                 :       25909 :     case INTRINSIC_MINUS:
    3840                 :       25909 :       code = MINUS_EXPR;
    3841                 :       25909 :       break;
    3842                 :             : 
    3843                 :       29361 :     case INTRINSIC_TIMES:
    3844                 :       29361 :       code = MULT_EXPR;
    3845                 :       29361 :       break;
    3846                 :             : 
    3847                 :        5921 :     case INTRINSIC_DIVIDE:
    3848                 :             :       /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
    3849                 :             :          an integer, we must round towards zero, so we use a
    3850                 :             :          TRUNC_DIV_EXPR.  */
    3851                 :        5921 :       if (expr->ts.type == BT_INTEGER)
    3852                 :             :         code = TRUNC_DIV_EXPR;
    3853                 :             :       else
    3854                 :        2608 :         code = RDIV_EXPR;
    3855                 :             :       break;
    3856                 :             : 
    3857                 :        3180 :     case INTRINSIC_POWER:
    3858                 :        3180 :       gfc_conv_power_op (se, expr);
    3859                 :        3180 :       return;
    3860                 :             : 
    3861                 :        1162 :     case INTRINSIC_CONCAT:
    3862                 :        1162 :       gfc_conv_concat_op (se, expr);
    3863                 :        1162 :       return;
    3864                 :             : 
    3865                 :        4526 :     case INTRINSIC_AND:
    3866                 :        4526 :       code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
    3867                 :             :       lop = 1;
    3868                 :             :       break;
    3869                 :             : 
    3870                 :       23920 :     case INTRINSIC_OR:
    3871                 :       23920 :       code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
    3872                 :             :       lop = 1;
    3873                 :             :       break;
    3874                 :             : 
    3875                 :             :       /* EQV and NEQV only work on logicals, but since we represent them
    3876                 :             :          as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE.  */
    3877                 :       11784 :     case INTRINSIC_EQ:
    3878                 :       11784 :     case INTRINSIC_EQ_OS:
    3879                 :       11784 :     case INTRINSIC_EQV:
    3880                 :       11784 :       code = EQ_EXPR;
    3881                 :       11784 :       checkstring = 1;
    3882                 :       11784 :       lop = 1;
    3883                 :       11784 :       break;
    3884                 :             : 
    3885                 :      135486 :     case INTRINSIC_NE:
    3886                 :      135486 :     case INTRINSIC_NE_OS:
    3887                 :      135486 :     case INTRINSIC_NEQV:
    3888                 :      135486 :       code = NE_EXPR;
    3889                 :      135486 :       checkstring = 1;
    3890                 :      135486 :       lop = 1;
    3891                 :      135486 :       break;
    3892                 :             : 
    3893                 :       11340 :     case INTRINSIC_GT:
    3894                 :       11340 :     case INTRINSIC_GT_OS:
    3895                 :       11340 :       code = GT_EXPR;
    3896                 :       11340 :       checkstring = 1;
    3897                 :       11340 :       lop = 1;
    3898                 :       11340 :       break;
    3899                 :             : 
    3900                 :        1656 :     case INTRINSIC_GE:
    3901                 :        1656 :     case INTRINSIC_GE_OS:
    3902                 :        1656 :       code = GE_EXPR;
    3903                 :        1656 :       checkstring = 1;
    3904                 :        1656 :       lop = 1;
    3905                 :        1656 :       break;
    3906                 :             : 
    3907                 :        4065 :     case INTRINSIC_LT:
    3908                 :        4065 :     case INTRINSIC_LT_OS:
    3909                 :        4065 :       code = LT_EXPR;
    3910                 :        4065 :       checkstring = 1;
    3911                 :        4065 :       lop = 1;
    3912                 :        4065 :       break;
    3913                 :             : 
    3914                 :        2514 :     case INTRINSIC_LE:
    3915                 :        2514 :     case INTRINSIC_LE_OS:
    3916                 :        2514 :       code = LE_EXPR;
    3917                 :        2514 :       checkstring = 1;
    3918                 :        2514 :       lop = 1;
    3919                 :        2514 :       break;
    3920                 :             : 
    3921                 :           0 :     case INTRINSIC_USER:
    3922                 :           0 :     case INTRINSIC_ASSIGN:
    3923                 :             :       /* These should be converted into function calls by the frontend.  */
    3924                 :           0 :       gcc_unreachable ();
    3925                 :             : 
    3926                 :           0 :     default:
    3927                 :           0 :       fatal_error (input_location, "Unknown intrinsic op");
    3928                 :      299186 :       return;
    3929                 :             :     }
    3930                 :             : 
    3931                 :             :   /* The only exception to this is **, which is handled separately anyway.  */
    3932                 :      299186 :   gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
    3933                 :             : 
    3934                 :      299186 :   if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
    3935                 :      268382 :     checkstring = 0;
    3936                 :             : 
    3937                 :             :   /* lhs */
    3938                 :      299186 :   gfc_init_se (&lse, se);
    3939                 :      299186 :   gfc_conv_expr (&lse, expr->value.op.op1);
    3940                 :      299186 :   gfc_add_block_to_block (&se->pre, &lse.pre);
    3941                 :             : 
    3942                 :             :   /* rhs */
    3943                 :      299186 :   gfc_init_se (&rse, se);
    3944                 :      299186 :   gfc_conv_expr (&rse, expr->value.op.op2);
    3945                 :      299186 :   gfc_add_block_to_block (&se->pre, &rse.pre);
    3946                 :             : 
    3947                 :      299186 :   if (checkstring)
    3948                 :             :     {
    3949                 :       30804 :       gfc_conv_string_parameter (&lse);
    3950                 :       30804 :       gfc_conv_string_parameter (&rse);
    3951                 :             : 
    3952                 :       61608 :       lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
    3953                 :             :                                            rse.string_length, rse.expr,
    3954                 :       30804 :                                            expr->value.op.op1->ts.kind,
    3955                 :             :                                            code);
    3956                 :       30804 :       rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
    3957                 :       30804 :       gfc_add_block_to_block (&lse.post, &rse.post);
    3958                 :             :     }
    3959                 :             : 
    3960                 :      299186 :   type = gfc_typenode_for_spec (&expr->ts);
    3961                 :             : 
    3962                 :      299186 :   if (lop)
    3963                 :             :     {
    3964                 :             :       /* The result of logical ops is always logical_type_node.  */
    3965                 :      195291 :       tmp = fold_build2_loc (input_location, code, logical_type_node,
    3966                 :             :                              lse.expr, rse.expr);
    3967                 :      195291 :       se->expr = convert (type, tmp);
    3968                 :             :     }
    3969                 :             :   else
    3970                 :      103895 :     se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
    3971                 :             : 
    3972                 :             :   /* Add the post blocks.  */
    3973                 :      299186 :   gfc_add_block_to_block (&se->post, &rse.post);
    3974                 :      299186 :   gfc_add_block_to_block (&se->post, &lse.post);
    3975                 :             : }
    3976                 :             : 
    3977                 :             : /* If a string's length is one, we convert it to a single character.  */
    3978                 :             : 
    3979                 :             : tree
    3980                 :      125032 : gfc_string_to_single_character (tree len, tree str, int kind)
    3981                 :             : {
    3982                 :             : 
    3983                 :      125032 :   if (len == NULL
    3984                 :      125032 :       || !tree_fits_uhwi_p (len)
    3985                 :      230421 :       || !POINTER_TYPE_P (TREE_TYPE (str)))
    3986                 :             :     return NULL_TREE;
    3987                 :             : 
    3988                 :      105338 :   if (TREE_INT_CST_LOW (len) == 1)
    3989                 :             :     {
    3990                 :       20779 :       str = fold_convert (gfc_get_pchar_type (kind), str);
    3991                 :       20779 :       return build_fold_indirect_ref_loc (input_location, str);
    3992                 :             :     }
    3993                 :             : 
    3994                 :       84559 :   if (kind == 1
    3995                 :       69096 :       && TREE_CODE (str) == ADDR_EXPR
    3996                 :       59685 :       && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
    3997                 :       43034 :       && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
    3998                 :       26195 :       && array_ref_low_bound (TREE_OPERAND (str, 0))
    3999                 :       26195 :          == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
    4000                 :       26195 :       && TREE_INT_CST_LOW (len) > 1
    4001                 :      109024 :       && TREE_INT_CST_LOW (len)
    4002                 :             :          == (unsigned HOST_WIDE_INT)
    4003                 :       24465 :             TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
    4004                 :             :     {
    4005                 :       24465 :       tree ret = fold_convert (gfc_get_pchar_type (kind), str);
    4006                 :       24465 :       ret = build_fold_indirect_ref_loc (input_location, ret);
    4007                 :       24465 :       if (TREE_CODE (ret) == INTEGER_CST)
    4008                 :             :         {
    4009                 :       24465 :           tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
    4010                 :       24465 :           int i, length = TREE_STRING_LENGTH (string_cst);
    4011                 :       24465 :           const char *ptr = TREE_STRING_POINTER (string_cst);
    4012                 :             : 
    4013                 :       36048 :           for (i = 1; i < length; i++)
    4014                 :       35490 :             if (ptr[i] != ' ')
    4015                 :             :               return NULL_TREE;
    4016                 :             : 
    4017                 :             :           return ret;
    4018                 :             :         }
    4019                 :             :     }
    4020                 :             : 
    4021                 :             :   return NULL_TREE;
    4022                 :             : }
    4023                 :             : 
    4024                 :             : 
    4025                 :             : static void
    4026                 :         171 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
    4027                 :             : {
    4028                 :         171 :   gcc_assert (expr);
    4029                 :             : 
    4030                 :             :   /* We used to modify the tree here. Now it is done earlier in
    4031                 :             :      the front-end, so we only check it here to avoid regressions.  */
    4032                 :         171 :   if (sym->backend_decl)
    4033                 :             :     {
    4034                 :          66 :       gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
    4035                 :          66 :       gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
    4036                 :          66 :       gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
    4037                 :          66 :       gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
    4038                 :             :     }
    4039                 :             : 
    4040                 :             :   /* If we have a constant character expression, make it into an
    4041                 :             :       integer of type C char.  */
    4042                 :         171 :   if ((*expr)->expr_type == EXPR_CONSTANT)
    4043                 :             :     {
    4044                 :         165 :       gfc_typespec ts;
    4045                 :         165 :       gfc_clear_ts (&ts);
    4046                 :             : 
    4047                 :         330 :       gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
    4048                 :         165 :                                         (*expr)->value.character.string[0]);
    4049                 :         165 :       gfc_replace_expr (*expr, tmp);
    4050                 :             :     }
    4051                 :           6 :   else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
    4052                 :             :     {
    4053                 :           6 :       if ((*expr)->ref == NULL)
    4054                 :             :         {
    4055                 :          12 :           se->expr = gfc_string_to_single_character
    4056                 :           6 :             (build_int_cst (integer_type_node, 1),
    4057                 :           6 :               gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
    4058                 :             :                                   gfc_get_symbol_decl
    4059                 :           6 :                                   ((*expr)->symtree->n.sym)),
    4060                 :             :               (*expr)->ts.kind);
    4061                 :             :         }
    4062                 :             :       else
    4063                 :             :         {
    4064                 :           0 :           gfc_conv_variable (se, *expr);
    4065                 :           0 :           se->expr = gfc_string_to_single_character
    4066                 :           0 :             (build_int_cst (integer_type_node, 1),
    4067                 :             :               gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
    4068                 :             :                                   se->expr),
    4069                 :           0 :               (*expr)->ts.kind);
    4070                 :             :         }
    4071                 :             :     }
    4072                 :         171 : }
    4073                 :             : 
    4074                 :             : /* Helper function for gfc_build_compare_string.  Return LEN_TRIM value
    4075                 :             :    if STR is a string literal, otherwise return -1.  */
    4076                 :             : 
    4077                 :             : static int
    4078                 :       28756 : gfc_optimize_len_trim (tree len, tree str, int kind)
    4079                 :             : {
    4080                 :       28756 :   if (kind == 1
    4081                 :       24140 :       && TREE_CODE (str) == ADDR_EXPR
    4082                 :       20943 :       && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
    4083                 :       13570 :       && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
    4084                 :        8579 :       && array_ref_low_bound (TREE_OPERAND (str, 0))
    4085                 :        8579 :          == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
    4086                 :        8579 :       && tree_fits_uhwi_p (len)
    4087                 :        8579 :       && tree_to_uhwi (len) >= 1
    4088                 :       28756 :       && tree_to_uhwi (len)
    4089                 :        8535 :          == (unsigned HOST_WIDE_INT)
    4090                 :        8535 :             TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
    4091                 :             :     {
    4092                 :        8535 :       tree folded = fold_convert (gfc_get_pchar_type (kind), str);
    4093                 :        8535 :       folded = build_fold_indirect_ref_loc (input_location, folded);
    4094                 :        8535 :       if (TREE_CODE (folded) == INTEGER_CST)
    4095                 :             :         {
    4096                 :        8535 :           tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
    4097                 :        8535 :           int length = TREE_STRING_LENGTH (string_cst);
    4098                 :        8535 :           const char *ptr = TREE_STRING_POINTER (string_cst);
    4099                 :             : 
    4100                 :       11741 :           for (; length > 0; length--)
    4101                 :       11741 :             if (ptr[length - 1] != ' ')
    4102                 :             :               break;
    4103                 :             : 
    4104                 :        8535 :           return length;
    4105                 :             :         }
    4106                 :             :     }
    4107                 :             :   return -1;
    4108                 :             : }
    4109                 :             : 
    4110                 :             : /* Helper to build a call to memcmp.  */
    4111                 :             : 
    4112                 :             : static tree
    4113                 :       11546 : build_memcmp_call (tree s1, tree s2, tree n)
    4114                 :             : {
    4115                 :       11546 :   tree tmp;
    4116                 :             : 
    4117                 :       11546 :   if (!POINTER_TYPE_P (TREE_TYPE (s1)))
    4118                 :           0 :     s1 = gfc_build_addr_expr (pvoid_type_node, s1);
    4119                 :             :   else
    4120                 :       11546 :     s1 = fold_convert (pvoid_type_node, s1);
    4121                 :             : 
    4122                 :       11546 :   if (!POINTER_TYPE_P (TREE_TYPE (s2)))
    4123                 :           0 :     s2 = gfc_build_addr_expr (pvoid_type_node, s2);
    4124                 :             :   else
    4125                 :       11546 :     s2 = fold_convert (pvoid_type_node, s2);
    4126                 :             : 
    4127                 :       11546 :   n = fold_convert (size_type_node, n);
    4128                 :             : 
    4129                 :       11546 :   tmp = build_call_expr_loc (input_location,
    4130                 :             :                              builtin_decl_explicit (BUILT_IN_MEMCMP),
    4131                 :             :                              3, s1, s2, n);
    4132                 :             : 
    4133                 :       11546 :   return fold_convert (integer_type_node, tmp);
    4134                 :             : }
    4135                 :             : 
    4136                 :             : /* Compare two strings. If they are all single characters, the result is the
    4137                 :             :    subtraction of them. Otherwise, we build a library call.  */
    4138                 :             : 
    4139                 :             : tree
    4140                 :       30903 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
    4141                 :             :                           enum tree_code code)
    4142                 :             : {
    4143                 :       30903 :   tree sc1;
    4144                 :       30903 :   tree sc2;
    4145                 :       30903 :   tree fndecl;
    4146                 :             : 
    4147                 :       30903 :   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
    4148                 :       30903 :   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
    4149                 :             : 
    4150                 :       30903 :   sc1 = gfc_string_to_single_character (len1, str1, kind);
    4151                 :       30903 :   sc2 = gfc_string_to_single_character (len2, str2, kind);
    4152                 :             : 
    4153                 :       30903 :   if (sc1 != NULL_TREE && sc2 != NULL_TREE)
    4154                 :             :     {
    4155                 :             :       /* Deal with single character specially.  */
    4156                 :        4612 :       sc1 = fold_convert (integer_type_node, sc1);
    4157                 :        4612 :       sc2 = fold_convert (integer_type_node, sc2);
    4158                 :        4612 :       return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
    4159                 :        4612 :                               sc1, sc2);
    4160                 :             :     }
    4161                 :             : 
    4162                 :       26291 :   if ((code == EQ_EXPR || code == NE_EXPR)
    4163                 :       25725 :       && optimize
    4164                 :       21599 :       && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
    4165                 :             :     {
    4166                 :             :       /* If one string is a string literal with LEN_TRIM longer
    4167                 :             :          than the length of the second string, the strings
    4168                 :             :          compare unequal.  */
    4169                 :       14378 :       int len = gfc_optimize_len_trim (len1, str1, kind);
    4170                 :       14378 :       if (len > 0 && compare_tree_int (len2, len) < 0)
    4171                 :           0 :         return integer_one_node;
    4172                 :       14378 :       len = gfc_optimize_len_trim (len2, str2, kind);
    4173                 :       14378 :       if (len > 0 && compare_tree_int (len1, len) < 0)
    4174                 :           0 :         return integer_one_node;
    4175                 :             :     }
    4176                 :             : 
    4177                 :             :   /* We can compare via memcpy if the strings are known to be equal
    4178                 :             :      in length and they are
    4179                 :             :      - kind=1
    4180                 :             :      - kind=4 and the comparison is for (in)equality.  */
    4181                 :             : 
    4182                 :       17480 :   if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
    4183                 :       17147 :       && tree_int_cst_equal (len1, len2)
    4184                 :       37897 :       && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
    4185                 :             :     {
    4186                 :       11546 :       tree tmp;
    4187                 :       11546 :       tree chartype;
    4188                 :             : 
    4189                 :       11546 :       chartype = gfc_get_char_type (kind);
    4190                 :       11546 :       tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
    4191                 :       11546 :                              fold_convert (TREE_TYPE(len1),
    4192                 :             :                                            TYPE_SIZE_UNIT(chartype)),
    4193                 :             :                              len1);
    4194                 :       11546 :       return build_memcmp_call (str1, str2, tmp);
    4195                 :             :     }
    4196                 :             : 
    4197                 :             :   /* Build a call for the comparison.  */
    4198                 :       14745 :   if (kind == 1)
    4199                 :       11998 :     fndecl = gfor_fndecl_compare_string;
    4200                 :        2747 :   else if (kind == 4)
    4201                 :        2747 :     fndecl = gfor_fndecl_compare_string_char4;
    4202                 :             :   else
    4203                 :           0 :     gcc_unreachable ();
    4204                 :             : 
    4205                 :       14745 :   return build_call_expr_loc (input_location, fndecl, 4,
    4206                 :       14745 :                               len1, str1, len2, str2);
    4207                 :             : }
    4208                 :             : 
    4209                 :             : 
    4210                 :             : /* Return the backend_decl for a procedure pointer component.  */
    4211                 :             : 
    4212                 :             : static tree
    4213                 :        1570 : get_proc_ptr_comp (gfc_expr *e)
    4214                 :             : {
    4215                 :        1570 :   gfc_se comp_se;
    4216                 :        1570 :   gfc_expr *e2;
    4217                 :        1570 :   expr_t old_type;
    4218                 :             : 
    4219                 :        1570 :   gfc_init_se (&comp_se, NULL);
    4220                 :        1570 :   e2 = gfc_copy_expr (e);
    4221                 :             :   /* We have to restore the expr type later so that gfc_free_expr frees
    4222                 :             :      the exact same thing that was allocated.
    4223                 :             :      TODO: This is ugly.  */
    4224                 :        1570 :   old_type = e2->expr_type;
    4225                 :        1570 :   e2->expr_type = EXPR_VARIABLE;
    4226                 :        1570 :   gfc_conv_expr (&comp_se, e2);
    4227                 :        1570 :   e2->expr_type = old_type;
    4228                 :        1570 :   gfc_free_expr (e2);
    4229                 :        1570 :   return build_fold_addr_expr_loc (input_location, comp_se.expr);
    4230                 :             : }
    4231                 :             : 
    4232                 :             : 
    4233                 :             : /* Convert a typebound function reference from a class object.  */
    4234                 :             : static void
    4235                 :          80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
    4236                 :             : {
    4237                 :          80 :   gfc_ref *ref;
    4238                 :          80 :   tree var;
    4239                 :             : 
    4240                 :          80 :   if (!VAR_P (base_object))
    4241                 :             :     {
    4242                 :           0 :       var = gfc_create_var (TREE_TYPE (base_object), NULL);
    4243                 :           0 :       gfc_add_modify (&se->pre, var, base_object);
    4244                 :             :     }
    4245                 :          80 :   se->expr = gfc_class_vptr_get (base_object);
    4246                 :          80 :   se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
    4247                 :          80 :   ref = expr->ref;
    4248                 :         308 :   while (ref && ref->next)
    4249                 :             :     ref = ref->next;
    4250                 :          80 :   gcc_assert (ref && ref->type == REF_COMPONENT);
    4251                 :          80 :   if (ref->u.c.sym->attr.extension)
    4252                 :           0 :     conv_parent_component_references (se, ref);
    4253                 :          80 :   gfc_conv_component_ref (se, ref);
    4254                 :          80 :   se->expr = build_fold_addr_expr_loc (input_location, se->expr);
    4255                 :          80 : }
    4256                 :             : 
    4257                 :             : 
    4258                 :             : static void
    4259                 :      109025 : conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
    4260                 :             :                    gfc_actual_arglist *actual_args)
    4261                 :             : {
    4262                 :      109025 :   tree tmp;
    4263                 :             : 
    4264                 :      109025 :   if (gfc_is_proc_ptr_comp (expr))
    4265                 :        1570 :     tmp = get_proc_ptr_comp (expr);
    4266                 :      107455 :   else if (sym->attr.dummy)
    4267                 :             :     {
    4268                 :         763 :       tmp = gfc_get_symbol_decl (sym);
    4269                 :         763 :       if (sym->attr.proc_pointer)
    4270                 :          83 :         tmp = build_fold_indirect_ref_loc (input_location,
    4271                 :             :                                        tmp);
    4272                 :         763 :       gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
    4273                 :             :               && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
    4274                 :             :     }
    4275                 :             :   else
    4276                 :             :     {
    4277                 :      106692 :       if (!sym->backend_decl)
    4278                 :       27776 :         sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
    4279                 :             : 
    4280                 :      106692 :       TREE_USED (sym->backend_decl) = 1;
    4281                 :             : 
    4282                 :      106692 :       tmp = sym->backend_decl;
    4283                 :             : 
    4284                 :      106692 :       if (sym->attr.cray_pointee)
    4285                 :             :         {
    4286                 :             :           /* TODO - make the cray pointee a pointer to a procedure,
    4287                 :             :              assign the pointer to it and use it for the call.  This
    4288                 :             :              will do for now!  */
    4289                 :          19 :           tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
    4290                 :             :                          gfc_get_symbol_decl (sym->cp_pointer));
    4291                 :          19 :           tmp = gfc_evaluate_now (tmp, &se->pre);
    4292                 :             :         }
    4293                 :             : 
    4294                 :      106692 :       if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
    4295                 :             :         {
    4296                 :      106135 :           gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
    4297                 :      106135 :           tmp = gfc_build_addr_expr (NULL_TREE, tmp);
    4298                 :             :         }
    4299                 :             :     }
    4300                 :      109025 :   se->expr = tmp;
    4301                 :      109025 : }
    4302                 :             : 
    4303                 :             : 
    4304                 :             : /* Initialize MAPPING.  */
    4305                 :             : 
    4306                 :             : void
    4307                 :      109142 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
    4308                 :             : {
    4309                 :      109142 :   mapping->syms = NULL;
    4310                 :      109142 :   mapping->charlens = NULL;
    4311                 :      109142 : }
    4312                 :             : 
    4313                 :             : 
    4314                 :             : /* Free all memory held by MAPPING (but not MAPPING itself).  */
    4315                 :             : 
    4316                 :             : void
    4317                 :      109142 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
    4318                 :             : {
    4319                 :      109142 :   gfc_interface_sym_mapping *sym;
    4320                 :      109142 :   gfc_interface_sym_mapping *nextsym;
    4321                 :      109142 :   gfc_charlen *cl;
    4322                 :      109142 :   gfc_charlen *nextcl;
    4323                 :             : 
    4324                 :      137405 :   for (sym = mapping->syms; sym; sym = nextsym)
    4325                 :             :     {
    4326                 :       28263 :       nextsym = sym->next;
    4327                 :       28263 :       sym->new_sym->n.sym->formal = NULL;
    4328                 :       28263 :       gfc_free_symbol (sym->new_sym->n.sym);
    4329                 :       28263 :       gfc_free_expr (sym->expr);
    4330                 :       28263 :       free (sym->new_sym);
    4331                 :       28263 :       free (sym);
    4332                 :             :     }
    4333                 :      112982 :   for (cl = mapping->charlens; cl; cl = nextcl)
    4334                 :             :     {
    4335                 :        3840 :       nextcl = cl->next;
    4336                 :        3840 :       gfc_free_expr (cl->length);
    4337                 :        3840 :       free (cl);
    4338                 :             :     }
    4339                 :      109142 : }
    4340                 :             : 
    4341                 :             : 
    4342                 :             : /* Return a copy of gfc_charlen CL.  Add the returned structure to
    4343                 :             :    MAPPING so that it will be freed by gfc_free_interface_mapping.  */
    4344                 :             : 
    4345                 :             : static gfc_charlen *
    4346                 :        3840 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
    4347                 :             :                                    gfc_charlen * cl)
    4348                 :             : {
    4349                 :        3840 :   gfc_charlen *new_charlen;
    4350                 :             : 
    4351                 :        3840 :   new_charlen = gfc_get_charlen ();
    4352                 :        3840 :   new_charlen->next = mapping->charlens;
    4353                 :        3840 :   new_charlen->length = gfc_copy_expr (cl->length);
    4354                 :             : 
    4355                 :        3840 :   mapping->charlens = new_charlen;
    4356                 :        3840 :   return new_charlen;
    4357                 :             : }
    4358                 :             : 
    4359                 :             : 
    4360                 :             : /* A subroutine of gfc_add_interface_mapping.  Return a descriptorless
    4361                 :             :    array variable that can be used as the actual argument for dummy
    4362                 :             :    argument SYM.  Add any initialization code to BLOCK.  PACKED is as
    4363                 :             :    for gfc_get_nodesc_array_type and DATA points to the first element
    4364                 :             :    in the passed array.  */
    4365                 :             : 
    4366                 :             : static tree
    4367                 :        5883 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
    4368                 :             :                                  gfc_packed packed, tree data)
    4369                 :             : {
    4370                 :        5883 :   tree type;
    4371                 :        5883 :   tree var;
    4372                 :             : 
    4373                 :        5883 :   type = gfc_typenode_for_spec (&sym->ts);
    4374                 :       11766 :   type = gfc_get_nodesc_array_type (type, sym->as, packed,
    4375                 :             :                                     !sym->attr.target && !sym->attr.pointer
    4376                 :        5883 :                                     && !sym->attr.proc_pointer);
    4377                 :             : 
    4378                 :        5883 :   var = gfc_create_var (type, "ifm");
    4379                 :        5883 :   gfc_add_modify (block, var, fold_convert (type, data));
    4380                 :             : 
    4381                 :        5883 :   return var;
    4382                 :             : }
    4383                 :             : 
    4384                 :             : 
    4385                 :             : /* A subroutine of gfc_add_interface_mapping.  Set the stride, upper bounds
    4386                 :             :    and offset of descriptorless array type TYPE given that it has the same
    4387                 :             :    size as DESC.  Add any set-up code to BLOCK.  */
    4388                 :             : 
    4389                 :             : static void
    4390                 :        5613 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
    4391                 :             : {
    4392                 :        5613 :   int n;
    4393                 :        5613 :   tree dim;
    4394                 :        5613 :   tree offset;
    4395                 :        5613 :   tree tmp;
    4396                 :             : 
    4397                 :        5613 :   offset = gfc_index_zero_node;
    4398                 :        6652 :   for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
    4399                 :             :     {
    4400                 :        1039 :       dim = gfc_rank_cst[n];
    4401                 :        1039 :       GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
    4402                 :        1039 :       if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
    4403                 :             :         {
    4404                 :           1 :           GFC_TYPE_ARRAY_LBOUND (type, n)
    4405                 :           1 :                 = gfc_conv_descriptor_lbound_get (desc, dim);
    4406                 :           1 :           GFC_TYPE_ARRAY_UBOUND (type, n)
    4407                 :           2 :                 = gfc_conv_descriptor_ubound_get (desc, dim);
    4408                 :             :         }
    4409                 :        1038 :       else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
    4410                 :             :         {
    4411                 :        1038 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
    4412                 :             :                                  gfc_array_index_type,
    4413                 :             :                                  gfc_conv_descriptor_ubound_get (desc, dim),
    4414                 :             :                                  gfc_conv_descriptor_lbound_get (desc, dim));
    4415                 :        3114 :           tmp = fold_build2_loc (input_location, PLUS_EXPR,
    4416                 :             :                                  gfc_array_index_type,
    4417                 :        1038 :                                  GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
    4418                 :        1038 :           tmp = gfc_evaluate_now (tmp, block);
    4419                 :        1038 :           GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
    4420                 :             :         }
    4421                 :        4156 :       tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    4422                 :        1039 :                              GFC_TYPE_ARRAY_LBOUND (type, n),
    4423                 :        1039 :                              GFC_TYPE_ARRAY_STRIDE (type, n));
    4424                 :        1039 :       offset = fold_build2_loc (input_location, MINUS_EXPR,
    4425                 :             :                                 gfc_array_index_type, offset, tmp);
    4426                 :             :     }
    4427                 :        5613 :   offset = gfc_evaluate_now (offset, block);
    4428                 :        5613 :   GFC_TYPE_ARRAY_OFFSET (type) = offset;
    4429                 :        5613 : }
    4430                 :             : 
    4431                 :             : 
    4432                 :             : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
    4433                 :             :    in SE.  The caller may still use se->expr and se->string_length after
    4434                 :             :    calling this function.  */
    4435                 :             : 
    4436                 :             : void
    4437                 :       28263 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
    4438                 :             :                            gfc_symbol * sym, gfc_se * se,
    4439                 :             :                            gfc_expr *expr)
    4440                 :             : {
    4441                 :       28263 :   gfc_interface_sym_mapping *sm;
    4442                 :       28263 :   tree desc;
    4443                 :       28263 :   tree tmp;
    4444                 :       28263 :   tree value;
    4445                 :       28263 :   gfc_symbol *new_sym;
    4446                 :       28263 :   gfc_symtree *root;
    4447                 :       28263 :   gfc_symtree *new_symtree;
    4448                 :             : 
    4449                 :             :   /* Create a new symbol to represent the actual argument.  */
    4450                 :       28263 :   new_sym = gfc_new_symbol (sym->name, NULL);
    4451                 :       28263 :   new_sym->ts = sym->ts;
    4452                 :       28263 :   new_sym->as = gfc_copy_array_spec (sym->as);
    4453                 :       28263 :   new_sym->attr.referenced = 1;
    4454                 :       28263 :   new_sym->attr.dimension = sym->attr.dimension;
    4455                 :       28263 :   new_sym->attr.contiguous = sym->attr.contiguous;
    4456                 :       28263 :   new_sym->attr.codimension = sym->attr.codimension;
    4457                 :       28263 :   new_sym->attr.pointer = sym->attr.pointer;
    4458                 :       28263 :   new_sym->attr.allocatable = sym->attr.allocatable;
    4459                 :       28263 :   new_sym->attr.flavor = sym->attr.flavor;
    4460                 :       28263 :   new_sym->attr.function = sym->attr.function;
    4461                 :             : 
    4462                 :             :   /* Ensure that the interface is available and that
    4463                 :             :      descriptors are passed for array actual arguments.  */
    4464                 :       28263 :   if (sym->attr.flavor == FL_PROCEDURE)
    4465                 :             :     {
    4466                 :          36 :       new_sym->formal = expr->symtree->n.sym->formal;
    4467                 :          36 :       new_sym->attr.always_explicit
    4468                 :          36 :             = expr->symtree->n.sym->attr.always_explicit;
    4469                 :             :     }
    4470                 :             : 
    4471                 :             :   /* Create a fake symtree for it.  */
    4472                 :       28263 :   root = NULL;
    4473                 :       28263 :   new_symtree = gfc_new_symtree (&root, sym->name);
    4474                 :       28263 :   new_symtree->n.sym = new_sym;
    4475                 :       28263 :   gcc_assert (new_symtree == root);
    4476                 :             : 
    4477                 :             :   /* Create a dummy->actual mapping.  */
    4478                 :       28263 :   sm = XCNEW (gfc_interface_sym_mapping);
    4479                 :       28263 :   sm->next = mapping->syms;
    4480                 :       28263 :   sm->old = sym;
    4481                 :       28263 :   sm->new_sym = new_symtree;
    4482                 :       28263 :   sm->expr = gfc_copy_expr (expr);
    4483                 :       28263 :   mapping->syms = sm;
    4484                 :             : 
    4485                 :             :   /* Stabilize the argument's value.  */
    4486                 :       28263 :   if (!sym->attr.function && se)
    4487                 :       28165 :     se->expr = gfc_evaluate_now (se->expr, &se->pre);
    4488                 :             : 
    4489                 :       28263 :   if (sym->ts.type == BT_CHARACTER)
    4490                 :             :     {
    4491                 :             :       /* Create a copy of the dummy argument's length.  */
    4492                 :        1969 :       new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
    4493                 :        1969 :       sm->expr->ts.u.cl = new_sym->ts.u.cl;
    4494                 :             : 
    4495                 :             :       /* If the length is specified as "*", record the length that
    4496                 :             :          the caller is passing.  We should use the callee's length
    4497                 :             :          in all other cases.  */
    4498                 :        1969 :       if (!new_sym->ts.u.cl->length && se)
    4499                 :             :         {
    4500                 :        1765 :           se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
    4501                 :        1765 :           new_sym->ts.u.cl->backend_decl = se->string_length;
    4502                 :             :         }
    4503                 :             :     }
    4504                 :             : 
    4505                 :       28249 :   if (!se)
    4506                 :          62 :     return;
    4507                 :             : 
    4508                 :             :   /* Use the passed value as-is if the argument is a function.  */
    4509                 :       28201 :   if (sym->attr.flavor == FL_PROCEDURE)
    4510                 :          36 :     value = se->expr;
    4511                 :             : 
    4512                 :             :   /* If the argument is a pass-by-value scalar, use the value as is.  */
    4513                 :       28165 :   else if (!sym->attr.dimension && sym->attr.value)
    4514                 :          39 :     value = se->expr;
    4515                 :             : 
    4516                 :             :   /* If the argument is either a string or a pointer to a string,
    4517                 :             :      convert it to a boundless character type.  */
    4518                 :       28126 :   else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
    4519                 :             :     {
    4520                 :        1120 :       tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
    4521                 :        1120 :       tmp = build_pointer_type (tmp);
    4522                 :        1120 :       if (sym->attr.pointer)
    4523                 :         126 :         value = build_fold_indirect_ref_loc (input_location,
    4524                 :             :                                          se->expr);
    4525                 :             :       else
    4526                 :         994 :         value = se->expr;
    4527                 :        1120 :       value = fold_convert (tmp, value);
    4528                 :             :     }
    4529                 :             : 
    4530                 :             :   /* If the argument is a scalar, a pointer to an array or an allocatable,
    4531                 :             :      dereference it.  */
    4532                 :       27006 :   else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
    4533                 :       20322 :     value = build_fold_indirect_ref_loc (input_location,
    4534                 :             :                                      se->expr);
    4535                 :             : 
    4536                 :             :   /* For character(*), use the actual argument's descriptor.  */
    4537                 :        6684 :   else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
    4538                 :         801 :     value = build_fold_indirect_ref_loc (input_location,
    4539                 :             :                                      se->expr);
    4540                 :             : 
    4541                 :             :   /* If the argument is an array descriptor, use it to determine
    4542                 :             :      information about the actual argument's shape.  */
    4543                 :        5883 :   else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
    4544                 :        5883 :            && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
    4545                 :             :     {
    4546                 :             :       /* Get the actual argument's descriptor.  */
    4547                 :        5613 :       desc = build_fold_indirect_ref_loc (input_location,
    4548                 :             :                                       se->expr);
    4549                 :             : 
    4550                 :             :       /* Create the replacement variable.  */
    4551                 :        5613 :       tmp = gfc_conv_descriptor_data_get (desc);
    4552                 :        5613 :       value = gfc_get_interface_mapping_array (&se->pre, sym,
    4553                 :             :                                                PACKED_NO, tmp);
    4554                 :             : 
    4555                 :             :       /* Use DESC to work out the upper bounds, strides and offset.  */
    4556                 :        5613 :       gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
    4557                 :             :     }
    4558                 :             :   else
    4559                 :             :     /* Otherwise we have a packed array.  */
    4560                 :         270 :     value = gfc_get_interface_mapping_array (&se->pre, sym,
    4561                 :             :                                              PACKED_FULL, se->expr);
    4562                 :             : 
    4563                 :       28201 :   new_sym->backend_decl = value;
    4564                 :             : }
    4565                 :             : 
    4566                 :             : 
    4567                 :             : /* Called once all dummy argument mappings have been added to MAPPING,
    4568                 :             :    but before the mapping is used to evaluate expressions.  Pre-evaluate
    4569                 :             :    the length of each argument, adding any initialization code to PRE and
    4570                 :             :    any finalization code to POST.  */
    4571                 :             : 
    4572                 :             : static void
    4573                 :      109105 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
    4574                 :             :                               stmtblock_t * pre, stmtblock_t * post)
    4575                 :             : {
    4576                 :      109105 :   gfc_interface_sym_mapping *sym;
    4577                 :      109105 :   gfc_expr *expr;
    4578                 :      109105 :   gfc_se se;
    4579                 :             : 
    4580                 :      137306 :   for (sym = mapping->syms; sym; sym = sym->next)
    4581                 :       28201 :     if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
    4582                 :        1955 :         && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
    4583                 :             :       {
    4584                 :         190 :         expr = sym->new_sym->n.sym->ts.u.cl->length;
    4585                 :         190 :         gfc_apply_interface_mapping_to_expr (mapping, expr);
    4586                 :         190 :         gfc_init_se (&se, NULL);
    4587                 :         190 :         gfc_conv_expr (&se, expr);
    4588                 :         190 :         se.expr = fold_convert (gfc_charlen_type_node, se.expr);
    4589                 :         190 :         se.expr = gfc_evaluate_now (se.expr, &se.pre);
    4590                 :         190 :         gfc_add_block_to_block (pre, &se.pre);
    4591                 :         190 :         gfc_add_block_to_block (post, &se.post);
    4592                 :             : 
    4593                 :         190 :         sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
    4594                 :             :       }
    4595                 :      109105 : }
    4596                 :             : 
    4597                 :             : 
    4598                 :             : /* Like gfc_apply_interface_mapping_to_expr, but applied to
    4599                 :             :    constructor C.  */
    4600                 :             : 
    4601                 :             : static void
    4602                 :          47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
    4603                 :             :                                      gfc_constructor_base base)
    4604                 :             : {
    4605                 :          47 :   gfc_constructor *c;
    4606                 :         428 :   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
    4607                 :             :     {
    4608                 :         381 :       gfc_apply_interface_mapping_to_expr (mapping, c->expr);
    4609                 :         381 :       if (c->iterator)
    4610                 :             :         {
    4611                 :           6 :           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
    4612                 :           6 :           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
    4613                 :           6 :           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
    4614                 :             :         }
    4615                 :             :     }
    4616                 :          47 : }
    4617                 :             : 
    4618                 :             : 
    4619                 :             : /* Like gfc_apply_interface_mapping_to_expr, but applied to
    4620                 :             :    reference REF.  */
    4621                 :             : 
    4622                 :             : static void
    4623                 :       13266 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
    4624                 :             :                                     gfc_ref * ref)
    4625                 :             : {
    4626                 :       13266 :   int n;
    4627                 :             : 
    4628                 :       14666 :   for (; ref; ref = ref->next)
    4629                 :        1400 :     switch (ref->type)
    4630                 :             :       {
    4631                 :             :       case REF_ARRAY:
    4632                 :        2821 :         for (n = 0; n < ref->u.ar.dimen; n++)
    4633                 :             :           {
    4634                 :        1599 :             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
    4635                 :        1599 :             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
    4636                 :        1599 :             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
    4637                 :             :           }
    4638                 :             :         break;
    4639                 :             : 
    4640                 :             :       case REF_COMPONENT:
    4641                 :             :       case REF_INQUIRY:
    4642                 :             :         break;
    4643                 :             : 
    4644                 :          43 :       case REF_SUBSTRING:
    4645                 :          43 :         gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
    4646                 :          43 :         gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
    4647                 :          43 :         break;
    4648                 :             :       }
    4649                 :       13266 : }
    4650                 :             : 
    4651                 :             : 
    4652                 :             : /* Convert intrinsic function calls into result expressions.  */
    4653                 :             : 
    4654                 :             : static bool
    4655                 :        2190 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
    4656                 :             : {
    4657                 :        2190 :   gfc_symbol *sym;
    4658                 :        2190 :   gfc_expr *new_expr;
    4659                 :        2190 :   gfc_expr *arg1;
    4660                 :        2190 :   gfc_expr *arg2;
    4661                 :        2190 :   int d, dup;
    4662                 :             : 
    4663                 :        2190 :   arg1 = expr->value.function.actual->expr;
    4664                 :        2190 :   if (expr->value.function.actual->next)
    4665                 :        2069 :     arg2 = expr->value.function.actual->next->expr;
    4666                 :             :   else
    4667                 :             :     arg2 = NULL;
    4668                 :             : 
    4669                 :        2190 :   sym = arg1->symtree->n.sym;
    4670                 :             : 
    4671                 :        2190 :   if (sym->attr.dummy)
    4672                 :             :     return false;
    4673                 :             : 
    4674                 :        2123 :   new_expr = NULL;
    4675                 :             : 
    4676                 :        2123 :   switch (expr->value.function.isym->id)
    4677                 :             :     {
    4678                 :         875 :     case GFC_ISYM_LEN:
    4679                 :             :       /* TODO figure out why this condition is necessary.  */
    4680                 :         875 :       if (sym->attr.function
    4681                 :          43 :           && (arg1->ts.u.cl->length == NULL
    4682                 :          42 :               || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
    4683                 :          42 :                   && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
    4684                 :             :         return false;
    4685                 :             : 
    4686                 :         832 :       new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
    4687                 :         832 :       break;
    4688                 :             : 
    4689                 :         277 :     case GFC_ISYM_LEN_TRIM:
    4690                 :         277 :       new_expr = gfc_copy_expr (arg1);
    4691                 :         277 :       gfc_apply_interface_mapping_to_expr (mapping, new_expr);
    4692                 :             : 
    4693                 :         277 :       if (!new_expr)
    4694                 :             :         return false;
    4695                 :             : 
    4696                 :         277 :       gfc_replace_expr (arg1, new_expr);
    4697                 :         277 :       return true;
    4698                 :             : 
    4699                 :         556 :     case GFC_ISYM_SIZE:
    4700                 :         556 :       if (!sym->as || sym->as->rank == 0)
    4701                 :             :         return false;
    4702                 :             : 
    4703                 :         498 :       if (arg2 && arg2->expr_type == EXPR_CONSTANT)
    4704                 :             :         {
    4705                 :         328 :           dup = mpz_get_si (arg2->value.integer);
    4706                 :         328 :           d = dup - 1;
    4707                 :             :         }
    4708                 :             :       else
    4709                 :             :         {
    4710                 :         498 :           dup = sym->as->rank;
    4711                 :         498 :           d = 0;
    4712                 :             :         }
    4713                 :             : 
    4714                 :         510 :       for (; d < dup; d++)
    4715                 :             :         {
    4716                 :         498 :           gfc_expr *tmp;
    4717                 :             : 
    4718                 :         498 :           if (!sym->as->upper[d] || !sym->as->lower[d])
    4719                 :             :             {
    4720                 :         486 :               gfc_free_expr (new_expr);
    4721                 :         486 :               return false;
    4722                 :             :             }
    4723                 :             : 
    4724                 :          12 :           tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
    4725                 :             :                                         gfc_get_int_expr (gfc_default_integer_kind,
    4726                 :             :                                                           NULL, 1));
    4727                 :          12 :           tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
    4728                 :          12 :           if (new_expr)
    4729                 :           0 :             new_expr = gfc_multiply (new_expr, tmp);
    4730                 :             :           else
    4731                 :             :             new_expr = tmp;
    4732                 :             :         }
    4733                 :             :       break;
    4734                 :             : 
    4735                 :          44 :     case GFC_ISYM_LBOUND:
    4736                 :          44 :     case GFC_ISYM_UBOUND:
    4737                 :             :         /* TODO These implementations of lbound and ubound do not limit if
    4738                 :             :            the size < 0, according to F95's 13.14.53 and 13.14.113.  */
    4739                 :             : 
    4740                 :          44 :       if (!sym->as || sym->as->rank == 0)
    4741                 :             :         return false;
    4742                 :             : 
    4743                 :          44 :       if (arg2 && arg2->expr_type == EXPR_CONSTANT)
    4744                 :          38 :         d = mpz_get_si (arg2->value.integer) - 1;
    4745                 :             :       else
    4746                 :             :         return false;
    4747                 :             : 
    4748                 :          38 :       if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
    4749                 :             :         {
    4750                 :          23 :           if (sym->as->lower[d])
    4751                 :          23 :             new_expr = gfc_copy_expr (sym->as->lower[d]);
    4752                 :             :         }
    4753                 :             :       else
    4754                 :             :         {
    4755                 :          15 :           if (sym->as->upper[d])
    4756                 :           9 :             new_expr = gfc_copy_expr (sym->as->upper[d]);
    4757                 :             :         }
    4758                 :             :       break;
    4759                 :             : 
    4760                 :             :     default:
    4761                 :             :       break;
    4762                 :             :     }
    4763                 :             : 
    4764                 :        1253 :   gfc_apply_interface_mapping_to_expr (mapping, new_expr);
    4765                 :        1253 :   if (!new_expr)
    4766                 :             :     return false;
    4767                 :             : 
    4768                 :         113 :   gfc_replace_expr (expr, new_expr);
    4769                 :         113 :   return true;
    4770                 :             : }
    4771                 :             : 
    4772                 :             : 
    4773                 :             : static void
    4774                 :          24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
    4775                 :             :                               gfc_interface_mapping * mapping)
    4776                 :             : {
    4777                 :          24 :   gfc_formal_arglist *f;
    4778                 :          24 :   gfc_actual_arglist *actual;
    4779                 :             : 
    4780                 :          24 :   actual = expr->value.function.actual;
    4781                 :          24 :   f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
    4782                 :             : 
    4783                 :          72 :   for (; f && actual; f = f->next, actual = actual->next)
    4784                 :             :     {
    4785                 :          24 :       if (!actual->expr)
    4786                 :           0 :         continue;
    4787                 :             : 
    4788                 :          24 :       gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
    4789                 :             :     }
    4790                 :             : 
    4791                 :          24 :   if (map_expr->symtree->n.sym->attr.dimension)
    4792                 :             :     {
    4793                 :           6 :       int d;
    4794                 :           6 :       gfc_array_spec *as;
    4795                 :             : 
    4796                 :           6 :       as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
    4797                 :             : 
    4798                 :          18 :       for (d = 0; d < as->rank; d++)
    4799                 :             :         {
    4800                 :           6 :           gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
    4801                 :           6 :           gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
    4802                 :             :         }
    4803                 :             : 
    4804                 :           6 :       expr->value.function.esym->as = as;
    4805                 :             :     }
    4806                 :             : 
    4807                 :          24 :   if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
    4808                 :             :     {
    4809                 :           0 :       expr->value.function.esym->ts.u.cl->length
    4810                 :           0 :         = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
    4811                 :             : 
    4812                 :           0 :       gfc_apply_interface_mapping_to_expr (mapping,
    4813                 :           0 :                         expr->value.function.esym->ts.u.cl->length);
    4814                 :             :     }
    4815                 :          24 : }
    4816                 :             : 
    4817                 :             : 
    4818                 :             : /* EXPR is a copy of an expression that appeared in the interface
    4819                 :             :    associated with MAPPING.  Walk it recursively looking for references to
    4820                 :             :    dummy arguments that MAPPING maps to actual arguments.  Replace each such
    4821                 :             :    reference with a reference to the associated actual argument.  */
    4822                 :             : 
    4823                 :             : static void
    4824                 :       21551 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
    4825                 :             :                                      gfc_expr * expr)
    4826                 :             : {
    4827                 :       23080 :   gfc_interface_sym_mapping *sym;
    4828                 :       23080 :   gfc_actual_arglist *actual;
    4829                 :             : 
    4830                 :       23080 :   if (!expr)
    4831                 :             :     return;
    4832                 :             : 
    4833                 :             :   /* Copying an expression does not copy its length, so do that here.  */
    4834                 :       13266 :   if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
    4835                 :             :     {
    4836                 :        1871 :       expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
    4837                 :        1871 :       gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
    4838                 :             :     }
    4839                 :             : 
    4840                 :             :   /* Apply the mapping to any references.  */
    4841                 :       13266 :   gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
    4842                 :             : 
    4843                 :             :   /* ...and to the expression's symbol, if it has one.  */
    4844                 :             :   /* TODO Find out why the condition on expr->symtree had to be moved into
    4845                 :             :      the loop rather than being outside it, as originally.  */
    4846                 :       32687 :   for (sym = mapping->syms; sym; sym = sym->next)
    4847                 :       19421 :     if (expr->symtree && sym->old == expr->symtree->n.sym)
    4848                 :             :       {
    4849                 :        2819 :         if (sym->new_sym->n.sym->backend_decl)
    4850                 :        2775 :           expr->symtree = sym->new_sym;
    4851                 :          44 :         else if (sym->expr)
    4852                 :          44 :           gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
    4853                 :             :       }
    4854                 :             : 
    4855                 :             :       /* ...and to subexpressions in expr->value.  */
    4856                 :       13266 :   switch (expr->expr_type)
    4857                 :             :     {
    4858                 :             :     case EXPR_VARIABLE:
    4859                 :             :     case EXPR_CONSTANT:
    4860                 :             :     case EXPR_NULL:
    4861                 :             :     case EXPR_SUBSTRING:
    4862                 :             :       break;
    4863                 :             : 
    4864                 :        1529 :     case EXPR_OP:
    4865                 :        1529 :       gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
    4866                 :        1529 :       gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
    4867                 :        1529 :       break;
    4868                 :             : 
    4869                 :        2919 :     case EXPR_FUNCTION:
    4870                 :        9346 :       for (actual = expr->value.function.actual; actual; actual = actual->next)
    4871                 :        6427 :         gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
    4872                 :             : 
    4873                 :        2919 :       if (expr->value.function.esym == NULL
    4874                 :        2608 :             && expr->value.function.isym != NULL
    4875                 :        2608 :             && expr->value.function.actual
    4876                 :        2607 :             && expr->value.function.actual->expr
    4877                 :        2607 :             && expr->value.function.actual->expr->symtree
    4878                 :        5109 :             && gfc_map_intrinsic_function (expr, mapping))
    4879                 :             :         break;
    4880                 :             : 
    4881                 :        5945 :       for (sym = mapping->syms; sym; sym = sym->next)
    4882                 :        3416 :         if (sym->old == expr->value.function.esym)
    4883                 :             :           {
    4884                 :          24 :             expr->value.function.esym = sym->new_sym->n.sym;
    4885                 :          24 :             gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
    4886                 :          24 :             expr->value.function.esym->result = sym->new_sym->n.sym;
    4887                 :             :           }
    4888                 :             :       break;
    4889                 :             : 
    4890                 :          47 :     case EXPR_ARRAY:
    4891                 :          47 :     case EXPR_STRUCTURE:
    4892                 :          47 :       gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
    4893                 :          47 :       break;
    4894                 :             : 
    4895                 :           0 :     case EXPR_COMPCALL:
    4896                 :           0 :     case EXPR_PPC:
    4897                 :           0 :     case EXPR_UNKNOWN:
    4898                 :           0 :       gcc_unreachable ();
    4899                 :             :       break;
    4900                 :             :     }
    4901                 :             : 
    4902                 :             :   return;
    4903                 :             : }
    4904                 :             : 
    4905                 :             : 
    4906                 :             : /* Evaluate interface expression EXPR using MAPPING.  Store the result
    4907                 :             :    in SE.  */
    4908                 :             : 
    4909                 :             : void
    4910                 :        4710 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
    4911                 :             :                              gfc_se * se, gfc_expr * expr)
    4912                 :             : {
    4913                 :        4710 :   expr = gfc_copy_expr (expr);
    4914                 :        4710 :   gfc_apply_interface_mapping_to_expr (mapping, expr);
    4915                 :        4710 :   gfc_conv_expr (se, expr);
    4916                 :        4710 :   se->expr = gfc_evaluate_now (se->expr, &se->pre);
    4917                 :        4710 :   gfc_free_expr (expr);
    4918                 :        4710 : }
    4919                 :             : 
    4920                 :             : 
    4921                 :             : /* Returns a reference to a temporary array into which a component of
    4922                 :             :    an actual argument derived type array is copied and then returned
    4923                 :             :    after the function call.  */
    4924                 :             : void
    4925                 :        2139 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
    4926                 :             :                            sym_intent intent, bool formal_ptr,
    4927                 :             :                            const gfc_symbol *fsym, const char *proc_name,
    4928                 :             :                            gfc_symbol *sym, bool check_contiguous)
    4929                 :             : {
    4930                 :        2139 :   gfc_se lse;
    4931                 :        2139 :   gfc_se rse;
    4932                 :        2139 :   gfc_ss *lss;
    4933                 :        2139 :   gfc_ss *rss;
    4934                 :        2139 :   gfc_loopinfo loop;
    4935                 :        2139 :   gfc_loopinfo loop2;
    4936                 :        2139 :   gfc_array_info *info;
    4937                 :        2139 :   tree offset;
    4938                 :        2139 :   tree tmp_index;
    4939                 :        2139 :   tree tmp;
    4940                 :        2139 :   tree base_type;
    4941                 :        2139 :   tree size;
    4942                 :        2139 :   stmtblock_t body;
    4943                 :        2139 :   int n;
    4944                 :        2139 :   int dimen;
    4945                 :        2139 :   gfc_se work_se;
    4946                 :        2139 :   gfc_se *parmse;
    4947                 :        2139 :   bool pass_optional;
    4948                 :             : 
    4949                 :        2139 :   pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
    4950                 :             : 
    4951                 :        2139 :   if (pass_optional || check_contiguous)
    4952                 :             :     {
    4953                 :        1326 :       gfc_init_se (&work_se, NULL);
    4954                 :        1326 :       parmse = &work_se;
    4955                 :             :     }
    4956                 :             :   else
    4957                 :             :     parmse = se;
    4958                 :             : 
    4959                 :        2139 :   if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
    4960                 :             :     {
    4961                 :             :       /* We will create a temporary array, so let us warn.  */
    4962                 :         868 :       char * msg;
    4963                 :             : 
    4964                 :         868 :       if (fsym && proc_name)
    4965                 :         868 :         msg = xasprintf ("An array temporary was created for argument "
    4966                 :         868 :                          "'%s' of procedure '%s'", fsym->name, proc_name);
    4967                 :             :       else
    4968                 :           0 :         msg = xasprintf ("An array temporary was created");
    4969                 :             : 
    4970                 :         868 :       tmp = build_int_cst (logical_type_node, 1);
    4971                 :         868 :       gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
    4972                 :             :                                &expr->where, msg);
    4973                 :         868 :       free (msg);
    4974                 :             :     }
    4975                 :             : 
    4976                 :        2139 :   gfc_init_se (&lse, NULL);
    4977                 :        2139 :   gfc_init_se (&rse, NULL);
    4978                 :             : 
    4979                 :             :   /* Walk the argument expression.  */
    4980                 :        2139 :   rss = gfc_walk_expr (expr);
    4981                 :             : 
    4982                 :        2139 :   gcc_assert (rss != gfc_ss_terminator);
    4983                 :             : 
    4984                 :             :   /* Initialize the scalarizer.  */
    4985                 :        2139 :   gfc_init_loopinfo (&loop);
    4986                 :        2139 :   gfc_add_ss_to_loop (&loop, rss);
    4987                 :             : 
    4988                 :             :   /* Calculate the bounds of the scalarization.  */
    4989                 :        2139 :   gfc_conv_ss_startstride (&loop);
    4990                 :             : 
    4991                 :             :   /* Build an ss for the temporary.  */
    4992                 :        2139 :   if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
    4993                 :         150 :     gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
    4994                 :             : 
    4995                 :        2139 :   base_type = gfc_typenode_for_spec (&expr->ts);
    4996                 :        2139 :   if (GFC_ARRAY_TYPE_P (base_type)
    4997                 :        2139 :                 || GFC_DESCRIPTOR_TYPE_P (base_type))
    4998                 :           0 :     base_type = gfc_get_element_type (base_type);
    4999                 :             : 
    5000                 :        2139 :   if (expr->ts.type == BT_CLASS)
    5001                 :         121 :     base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
    5002                 :             : 
    5003                 :        3223 :   loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
    5004                 :        1084 :                                               ? expr->ts.u.cl->backend_decl
    5005                 :             :                                               : NULL),
    5006                 :             :                                   loop.dimen);
    5007                 :             : 
    5008                 :        2139 :   parmse->string_length = loop.temp_ss->info->string_length;
    5009                 :             : 
    5010                 :             :   /* Associate the SS with the loop.  */
    5011                 :        2139 :   gfc_add_ss_to_loop (&loop, loop.temp_ss);
    5012                 :             : 
    5013                 :             :   /* Setup the scalarizing loops.  */
    5014                 :        2139 :   gfc_conv_loop_setup (&loop, &expr->where);
    5015                 :             : 
    5016                 :             :   /* Pass the temporary descriptor back to the caller.  */
    5017                 :        2139 :   info = &loop.temp_ss->info->data.array;
    5018                 :        2139 :   parmse->expr = info->descriptor;
    5019                 :             : 
    5020                 :             :   /* Setup the gfc_se structures.  */
    5021                 :        2139 :   gfc_copy_loopinfo_to_se (&lse, &loop);
    5022                 :        2139 :   gfc_copy_loopinfo_to_se (&rse, &loop);
    5023                 :             : 
    5024                 :        2139 :   rse.ss = rss;
    5025                 :        2139 :   lse.ss = loop.temp_ss;
    5026                 :        2139 :   gfc_mark_ss_chain_used (rss, 1);
    5027                 :        2139 :   gfc_mark_ss_chain_used (loop.temp_ss, 1);
    5028                 :             : 
    5029                 :             :   /* Start the scalarized loop body.  */
    5030                 :        2139 :   gfc_start_scalarized_body (&loop, &body);
    5031                 :             : 
    5032                 :             :   /* Translate the expression.  */
    5033                 :        2139 :   gfc_conv_expr (&rse, expr);
    5034                 :             : 
    5035                 :             :   /* Reset the offset for the function call since the loop
    5036                 :             :      is zero based on the data pointer.  Note that the temp
    5037                 :             :      comes first in the loop chain since it is added second.  */
    5038                 :        2139 :   if (gfc_is_class_array_function (expr))
    5039                 :             :     {
    5040                 :          13 :       tmp = loop.ss->loop_chain->info->data.array.descriptor;
    5041                 :          13 :       gfc_conv_descriptor_offset_set (&loop.pre, tmp,
    5042                 :             :                                       gfc_index_zero_node);
    5043                 :             :     }
    5044                 :             : 
    5045                 :        2139 :   gfc_conv_tmp_array_ref (&lse);
    5046                 :             : 
    5047                 :        2139 :   if (intent != INTENT_OUT)
    5048                 :             :     {
    5049                 :        2096 :       tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
    5050                 :        2096 :       gfc_add_expr_to_block (&body, tmp);
    5051                 :        2096 :       gcc_assert (rse.ss == gfc_ss_terminator);
    5052                 :        2096 :       gfc_trans_scalarizing_loops (&loop, &body);
    5053                 :             :     }
    5054                 :             :   else
    5055                 :             :     {
    5056                 :             :       /* Make sure that the temporary declaration survives by merging
    5057                 :             :        all the loop declarations into the current context.  */
    5058                 :         100 :       for (n = 0; n < loop.dimen; n++)
    5059                 :             :         {
    5060                 :          57 :           gfc_merge_block_scope (&body);
    5061                 :          57 :           body = loop.code[loop.order[n]];
    5062                 :             :         }
    5063                 :          43 :       gfc_merge_block_scope (&body);
    5064                 :             :     }
    5065                 :             : 
    5066                 :             :   /* Add the post block after the second loop, so that any
    5067                 :             :      freeing of allocated memory is done at the right time.  */
    5068                 :        2139 :   gfc_add_block_to_block (&parmse->pre, &loop.pre);
    5069                 :             : 
    5070                 :             :   /**********Copy the temporary back again.*********/
    5071                 :             : 
    5072                 :        2139 :   gfc_init_se (&lse, NULL);
    5073                 :        2139 :   gfc_init_se (&rse, NULL);
    5074                 :             : 
    5075                 :             :   /* Walk the argument expression.  */
    5076                 :        2139 :   lss = gfc_walk_expr (expr);
    5077                 :        2139 :   rse.ss = loop.temp_ss;
    5078                 :        2139 :   lse.ss = lss;
    5079                 :             : 
    5080                 :             :   /* Initialize the scalarizer.  */
    5081                 :        2139 :   gfc_init_loopinfo (&loop2);
    5082                 :        2139 :   gfc_add_ss_to_loop (&loop2, lss);
    5083                 :             : 
    5084                 :        2139 :   dimen = rse.ss->dimen;
    5085                 :             : 
    5086                 :             :   /* Skip the write-out loop for this case.  */
    5087                 :        2139 :   if (gfc_is_class_array_function (expr))
    5088                 :          13 :     goto class_array_fcn;
    5089                 :             : 
    5090                 :             :   /* Calculate the bounds of the scalarization.  */
    5091                 :        2126 :   gfc_conv_ss_startstride (&loop2);
    5092                 :             : 
    5093                 :             :   /* Setup the scalarizing loops.  */
    5094                 :        2126 :   gfc_conv_loop_setup (&loop2, &expr->where);
    5095                 :             : 
    5096                 :        2126 :   gfc_copy_loopinfo_to_se (&lse, &loop2);
    5097                 :        2126 :   gfc_copy_loopinfo_to_se (&rse, &loop2);
    5098                 :             : 
    5099                 :        2126 :   gfc_mark_ss_chain_used (lss, 1);
    5100                 :        2126 :   gfc_mark_ss_chain_used (loop.temp_ss, 1);
    5101                 :             : 
    5102                 :             :   /* Declare the variable to hold the temporary offset and start the
    5103                 :             :      scalarized loop body.  */
    5104                 :        2126 :   offset = gfc_create_var (gfc_array_index_type, NULL);
    5105                 :        2126 :   gfc_start_scalarized_body (&loop2, &body);
    5106                 :             : 
    5107                 :             :   /* Build the offsets for the temporary from the loop variables.  The
    5108                 :             :      temporary array has lbounds of zero and strides of one in all
    5109                 :             :      dimensions, so this is very simple.  The offset is only computed
    5110                 :             :      outside the innermost loop, so the overall transfer could be
    5111                 :             :      optimized further.  */
    5112                 :        2126 :   info = &rse.ss->info->data.array;
    5113                 :             : 
    5114                 :        2126 :   tmp_index = gfc_index_zero_node;
    5115                 :        3412 :   for (n = dimen - 1; n > 0; n--)
    5116                 :             :     {
    5117                 :        1286 :       tree tmp_str;
    5118                 :        1286 :       tmp = rse.loop->loopvar[n];
    5119                 :        1286 :       tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    5120                 :             :                              tmp, rse.loop->from[n]);
    5121                 :        1286 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
    5122                 :             :                              tmp, tmp_index);
    5123                 :             : 
    5124                 :        2572 :       tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
    5125                 :             :                                  gfc_array_index_type,
    5126                 :        1286 :                                  rse.loop->to[n-1], rse.loop->from[n-1]);
    5127                 :        1286 :       tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
    5128                 :             :                                  gfc_array_index_type,
    5129                 :             :                                  tmp_str, gfc_index_one_node);
    5130                 :             : 
    5131                 :        1286 :       tmp_index = fold_build2_loc (input_location, MULT_EXPR,
    5132                 :             :                                    gfc_array_index_type, tmp, tmp_str);
    5133                 :             :     }
    5134                 :             : 
    5135                 :        4252 :   tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
    5136                 :             :                                gfc_array_index_type,
    5137                 :        2126 :                                tmp_index, rse.loop->from[0]);
    5138                 :        2126 :   gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
    5139                 :             : 
    5140                 :        4252 :   tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
    5141                 :             :                                gfc_array_index_type,
    5142                 :        2126 :                                rse.loop->loopvar[0], offset);
    5143                 :             : 
    5144                 :             :   /* Now use the offset for the reference.  */
    5145                 :        2126 :   tmp = build_fold_indirect_ref_loc (input_location,
    5146                 :             :                                  info->data);
    5147                 :        2126 :   rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
    5148                 :             : 
    5149                 :        2126 :   if (expr->ts.type == BT_CHARACTER)
    5150                 :        1084 :     rse.string_length = expr->ts.u.cl->backend_decl;
    5151                 :             : 
    5152                 :        2126 :   gfc_conv_expr (&lse, expr);
    5153                 :             : 
    5154                 :        2126 :   gcc_assert (lse.ss == gfc_ss_terminator);
    5155                 :             : 
    5156                 :        2126 :   tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
    5157                 :        2126 :   gfc_add_expr_to_block (&body, tmp);
    5158                 :             : 
    5159                 :             :   /* Generate the copying loops.  */
    5160                 :        2126 :   gfc_trans_scalarizing_loops (&loop2, &body);
    5161                 :             : 
    5162                 :             :   /* Wrap the whole thing up by adding the second loop to the post-block
    5163                 :             :      and following it by the post-block of the first loop.  In this way,
    5164                 :             :      if the temporary needs freeing, it is done after use!  */
    5165                 :        2126 :   if (intent != INTENT_IN)
    5166                 :             :     {
    5167                 :        1154 :       gfc_add_block_to_block (&parmse->post, &loop2.pre);
    5168                 :        1154 :       gfc_add_block_to_block (&parmse->post, &loop2.post);
    5169                 :             :     }
    5170                 :             : 
    5171                 :         972 : class_array_fcn:
    5172                 :             : 
    5173                 :        2139 :   gfc_add_block_to_block (&parmse->post, &loop.post);
    5174                 :             : 
    5175                 :        2139 :   gfc_cleanup_loop (&loop);
    5176                 :        2139 :   gfc_cleanup_loop (&loop2);
    5177                 :             : 
    5178                 :             :   /* Pass the string length to the argument expression.  */
    5179                 :        2139 :   if (expr->ts.type == BT_CHARACTER)
    5180                 :        1084 :     parmse->string_length = expr->ts.u.cl->backend_decl;
    5181                 :             : 
    5182                 :             :   /* Determine the offset for pointer formal arguments and set the
    5183                 :             :      lbounds to one.  */
    5184                 :        2139 :   if (formal_ptr)
    5185                 :             :     {
    5186                 :           0 :       size = gfc_index_one_node;
    5187                 :           0 :       offset = gfc_index_zero_node;
    5188                 :           0 :       for (n = 0; n < dimen; n++)
    5189                 :             :         {
    5190                 :           0 :           tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
    5191                 :             :                                                 gfc_rank_cst[n]);
    5192                 :           0 :           tmp = fold_build2_loc (input_location, PLUS_EXPR,
    5193                 :             :                                  gfc_array_index_type, tmp,
    5194                 :             :                                  gfc_index_one_node);
    5195                 :           0 :           gfc_conv_descriptor_ubound_set (&parmse->pre,
    5196                 :             :                                           parmse->expr,
    5197                 :             :                                           gfc_rank_cst[n],
    5198                 :             :                                           tmp);
    5199                 :           0 :           gfc_conv_descriptor_lbound_set (&parmse->pre,
    5200                 :             :                                           parmse->expr,
    5201                 :             :                                           gfc_rank_cst[n],
    5202                 :             :                                           gfc_index_one_node);
    5203                 :           0 :           size = gfc_evaluate_now (size, &parmse->pre);
    5204                 :           0 :           offset = fold_build2_loc (input_location, MINUS_EXPR,
    5205                 :             :                                     gfc_array_index_type,
    5206                 :             :                                     offset, size);
    5207                 :           0 :           offset = gfc_evaluate_now (offset, &parmse->pre);
    5208                 :           0 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
    5209                 :             :                                  gfc_array_index_type,
    5210                 :           0 :                                  rse.loop->to[n], rse.loop->from[n]);
    5211                 :           0 :           tmp = fold_build2_loc (input_location, PLUS_EXPR,
    5212                 :             :                                  gfc_array_index_type,
    5213                 :             :                                  tmp, gfc_index_one_node);
    5214                 :           0 :           size = fold_build2_loc (input_location, MULT_EXPR,
    5215                 :             :                                   gfc_array_index_type, size, tmp);
    5216                 :             :         }
    5217                 :             : 
    5218                 :           0 :       gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
    5219                 :             :                                       offset);
    5220                 :             :     }
    5221                 :             : 
    5222                 :             :   /* We want either the address for the data or the address of the descriptor,
    5223                 :             :      depending on the mode of passing array arguments.  */
    5224                 :        2139 :   if (g77)
    5225                 :         368 :     parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
    5226                 :             :   else
    5227                 :        1771 :     parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
    5228                 :             : 
    5229                 :             :   /* Basically make this into
    5230                 :             : 
    5231                 :             :      if (present)
    5232                 :             :        {
    5233                 :             :          if (contiguous)
    5234                 :             :            {
    5235                 :             :              pointer = a;
    5236                 :             :            }
    5237                 :             :          else
    5238                 :             :            {
    5239                 :             :              parmse->pre();
    5240                 :             :              pointer = parmse->expr;
    5241                 :             :            }
    5242                 :             :        }
    5243                 :             :      else
    5244                 :             :        pointer = NULL;
    5245                 :             : 
    5246                 :             :      foo (pointer);
    5247                 :             :      if (present && !contiguous)
    5248                 :             :            se->post();
    5249                 :             : 
    5250                 :             :      */
    5251                 :             : 
    5252                 :        2139 :   if (pass_optional || check_contiguous)
    5253                 :             :     {
    5254                 :        1326 :       tree type;
    5255                 :        1326 :       stmtblock_t else_block;
    5256                 :        1326 :       tree pre_stmts, post_stmts;
    5257                 :        1326 :       tree pointer;
    5258                 :        1326 :       tree else_stmt;
    5259                 :        1326 :       tree present_var = NULL_TREE;
    5260                 :        1326 :       tree cont_var = NULL_TREE;
    5261                 :        1326 :       tree post_cond;
    5262                 :             : 
    5263                 :        1326 :       type = TREE_TYPE (parmse->expr);
    5264                 :        1326 :       if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
    5265                 :        1003 :         type = TREE_TYPE (type);
    5266                 :        1326 :       pointer = gfc_create_var (type, "arg_ptr");
    5267                 :             : 
    5268                 :        1326 :       if (check_contiguous)
    5269                 :             :         {
    5270                 :        1326 :           gfc_se cont_se, array_se;
    5271                 :        1326 :           stmtblock_t if_block, else_block;
    5272                 :        1326 :           tree if_stmt, else_stmt;
    5273                 :        1326 :           mpz_t size;
    5274                 :        1326 :           bool size_set;
    5275                 :             : 
    5276                 :        1326 :           cont_var = gfc_create_var (boolean_type_node, "contiguous");
    5277                 :             : 
    5278                 :             :           /* If the size is known to be one at compile-time, set
    5279                 :             :              cont_var to true unconditionally.  This may look
    5280                 :             :              inelegant, but we're only doing this during
    5281                 :             :              optimization, so the statements will be optimized away,
    5282                 :             :              and this saves complexity here.  */
    5283                 :             : 
    5284                 :        1326 :           size_set = gfc_array_size (expr, &size);
    5285                 :        1326 :           if (size_set && mpz_cmp_ui (size, 1) == 0)
    5286                 :             :             {
    5287                 :          36 :               gfc_add_modify (&se->pre, cont_var,
    5288                 :             :                               build_one_cst (boolean_type_node));
    5289                 :             :             }
    5290                 :             :           else
    5291                 :             :             {
    5292                 :             :               /* cont_var = is_contiguous (expr); .  */
    5293                 :        1290 :               gfc_init_se (&cont_se, parmse);
    5294                 :        1290 :               gfc_conv_is_contiguous_expr (&cont_se, expr);
    5295                 :        1290 :               gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
    5296                 :        1290 :               gfc_add_modify (&se->pre, cont_var, cont_se.expr);
    5297                 :        1290 :               gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
    5298                 :             :             }
    5299                 :             : 
    5300                 :        1326 :           if (size_set)
    5301                 :        1157 :             mpz_clear (size);
    5302                 :             : 
    5303                 :             :           /* arrayse->expr = descriptor of a.  */
    5304                 :        1326 :           gfc_init_se (&array_se, se);
    5305                 :        1326 :           gfc_conv_expr_descriptor (&array_se, expr);
    5306                 :        1326 :           gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
    5307                 :        1326 :           gfc_add_block_to_block (&se->pre, &(&array_se)->post);
    5308                 :             : 
    5309                 :             :           /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } .  */
    5310                 :        1326 :           gfc_init_block (&if_block);
    5311                 :        1326 :           if (GFC_DESCRIPTOR_TYPE_P (type))
    5312                 :        1003 :             gfc_add_modify (&if_block, pointer, array_se.expr);
    5313                 :             :           else
    5314                 :             :             {
    5315                 :         323 :               tmp = gfc_conv_array_data (array_se.expr);
    5316                 :         323 :               tmp = fold_convert (type, tmp);
    5317                 :         323 :               gfc_add_modify (&if_block, pointer, tmp);
    5318                 :             :             }
    5319                 :        1326 :           if_stmt = gfc_finish_block (&if_block);
    5320                 :             : 
    5321                 :             :           /* else_stmt = { parmse->pre(); pointer = parmse->expr; } .  */
    5322                 :        1326 :           gfc_init_block (&else_block);
    5323                 :        1326 :           gfc_add_block_to_block (&else_block, &parmse->pre);
    5324                 :        1326 :           tmp = (GFC_DESCRIPTOR_TYPE_P (type)
    5325                 :        1326 :                  ? build_fold_indirect_ref_loc (input_location, parmse->expr)
    5326                 :             :                  : parmse->expr);
    5327                 :        1326 :           gfc_add_modify (&else_block, pointer, tmp);
    5328                 :        1326 :           else_stmt = gfc_finish_block (&else_block);
    5329                 :             : 
    5330                 :             :           /* And put the above into an if statement.  */
    5331                 :        1326 :           pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
    5332                 :             :                                        gfc_likely (cont_var,
    5333                 :             :                                                    PRED_FORTRAN_CONTIGUOUS),
    5334                 :             :                                        if_stmt, else_stmt);
    5335                 :             :         }
    5336                 :             :       else
    5337                 :             :         {
    5338                 :             :           /* pointer = pramse->expr;  .  */
    5339                 :           0 :           gfc_add_modify (&parmse->pre, pointer, parmse->expr);
    5340                 :           0 :           pre_stmts = gfc_finish_block (&parmse->pre);
    5341                 :             :         }
    5342                 :             : 
    5343                 :        1326 :       if (pass_optional)
    5344                 :             :         {
    5345                 :          26 :           present_var = gfc_create_var (boolean_type_node, "present");
    5346                 :             : 
    5347                 :             :           /* present_var = present(sym); .  */
    5348                 :          26 :           tmp = gfc_conv_expr_present (sym);
    5349                 :          26 :           tmp = fold_convert (boolean_type_node, tmp);
    5350                 :          26 :           gfc_add_modify (&se->pre, present_var, tmp);
    5351                 :             : 
    5352                 :             :           /* else_stmt = { pointer = NULL; } .  */
    5353                 :          26 :           gfc_init_block (&else_block);
    5354                 :          26 :           if (GFC_DESCRIPTOR_TYPE_P (type))
    5355                 :           0 :             gfc_conv_descriptor_data_set (&else_block, pointer,
    5356                 :             :                                           null_pointer_node);
    5357                 :             :           else
    5358                 :          26 :             gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
    5359                 :          26 :           else_stmt = gfc_finish_block (&else_block);
    5360                 :             : 
    5361                 :          26 :           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
    5362                 :             :                                  gfc_likely (present_var,
    5363                 :             :                                              PRED_FORTRAN_ABSENT_DUMMY),
    5364                 :             :                                  pre_stmts, else_stmt);
    5365                 :          26 :           gfc_add_expr_to_block (&se->pre, tmp);
    5366                 :             :         }
    5367                 :             :       else
    5368                 :        1300 :         gfc_add_expr_to_block (&se->pre, pre_stmts);
    5369                 :             : 
    5370                 :        1326 :       post_stmts = gfc_finish_block (&parmse->post);
    5371                 :             : 
    5372                 :             :       /* Put together the post stuff, plus the optional
    5373                 :             :          deallocation.  */
    5374                 :        1326 :       if (check_contiguous)
    5375                 :             :         {
    5376                 :             :           /* !cont_var.  */
    5377                 :        1326 :           tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
    5378                 :             :                                  cont_var,
    5379                 :             :                                  build_zero_cst (boolean_type_node));
    5380                 :        1326 :           tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
    5381                 :             : 
    5382                 :        1326 :           if (pass_optional)
    5383                 :             :             {
    5384                 :          26 :               tree present_likely = gfc_likely (present_var,
    5385                 :             :                                                 PRED_FORTRAN_ABSENT_DUMMY);
    5386                 :          26 :               post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
    5387                 :             :                                            boolean_type_node, present_likely,
    5388                 :             :                                            tmp);
    5389                 :             :             }
    5390                 :             :           else
    5391                 :             :             post_cond = tmp;
    5392                 :             :         }
    5393                 :             :       else
    5394                 :             :         {
    5395                 :           0 :           gcc_assert (pass_optional);
    5396                 :             :           post_cond = present_var;
    5397                 :             :         }
    5398                 :             : 
    5399                 :        1326 :       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
    5400                 :             :                              post_stmts, build_empty_stmt (input_location));
    5401                 :        1326 :       gfc_add_expr_to_block (&se->post, tmp);
    5402                 :        1326 :       if (GFC_DESCRIPTOR_TYPE_P (type))
    5403                 :             :         {
    5404                 :        1003 :           type = TREE_TYPE (parmse->expr);
    5405                 :        1003 :           if (POINTER_TYPE_P (type))
    5406                 :             :             {
    5407                 :        1003 :               pointer = gfc_build_addr_expr (type, pointer);
    5408                 :        1003 :               if (pass_optional)
    5409                 :             :                 {
    5410                 :           0 :                   tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
    5411                 :           0 :                   pointer = fold_build3_loc (input_location, COND_EXPR, type,
    5412                 :             :                                              tmp, pointer,
    5413                 :             :                                              fold_convert (type,
    5414                 :             :                                                            null_pointer_node));
    5415                 :             :                 }
    5416                 :             :             }
    5417                 :             :           else
    5418                 :           0 :             gcc_assert (!pass_optional);
    5419                 :             :         }
    5420                 :        1326 :       se->expr = pointer;
    5421                 :             :     }
    5422                 :             : 
    5423                 :        2139 :   return;
    5424                 :             : }
    5425                 :             : 
    5426                 :             : 
    5427                 :             : /* Generate the code for argument list functions.  */
    5428                 :             : 
    5429                 :             : static void
    5430                 :        3517 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
    5431                 :             : {
    5432                 :             :   /* Pass by value for g77 %VAL(arg), pass the address
    5433                 :             :      indirectly for %LOC, else by reference.  Thus %REF
    5434                 :             :      is a "do-nothing" and %LOC is the same as an F95
    5435                 :             :      pointer.  */
    5436                 :        3517 :   if (strcmp (name, "%VAL") == 0)
    5437                 :        3445 :     gfc_conv_expr (se, expr);
    5438                 :          72 :   else if (strcmp (name, "%LOC") == 0)
    5439                 :             :     {
    5440                 :          36 :       gfc_conv_expr_reference (se, expr);
    5441                 :          36 :       se->expr = gfc_build_addr_expr (NULL, se->expr);
    5442                 :             :     }
    5443                 :          36 :   else if (strcmp (name, "%REF") == 0)
    5444                 :          36 :     gfc_conv_expr_reference (se, expr);
    5445                 :             :   else
    5446                 :           0 :     gfc_error ("Unknown argument list function at %L", &expr->where);
    5447                 :        3517 : }
    5448                 :             : 
    5449                 :             : 
    5450                 :             : /* This function tells whether the middle-end representation of the expression
    5451                 :             :    E given as input may point to data otherwise accessible through a variable
    5452                 :             :    (sub-)reference.
    5453                 :             :    It is assumed that the only expressions that may alias are variables,
    5454                 :             :    and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
    5455                 :             :    may alias.
    5456                 :             :    This function is used to decide whether freeing an expression's allocatable
    5457                 :             :    components is safe or should be avoided.
    5458                 :             : 
    5459                 :             :    If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
    5460                 :             :    its elements are copied from a variable.  This ARRAY_MAY_ALIAS trick
    5461                 :             :    is necessary because for array constructors, aliasing depends on how
    5462                 :             :    the array is used:
    5463                 :             :     - If E is an array constructor used as argument to an elemental procedure,
    5464                 :             :       the array, which is generated through shallow copy by the scalarizer,
    5465                 :             :       is used directly and can alias the expressions it was copied from.
    5466                 :             :     - If E is an array constructor used as argument to a non-elemental
    5467                 :             :       procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
    5468                 :             :       the array as in the previous case, but then that array is used
    5469                 :             :       to initialize a new descriptor through deep copy.  There is no alias
    5470                 :             :       possible in that case.
    5471                 :             :    Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
    5472                 :             :    above.  */
    5473                 :             : 
    5474                 :             : static bool
    5475                 :        6899 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
    5476                 :             : {
    5477                 :        6899 :   gfc_constructor *c;
    5478                 :             : 
    5479                 :        6899 :   if (e->expr_type == EXPR_VARIABLE)
    5480                 :             :     return true;
    5481                 :         336 :   else if (e->expr_type == EXPR_FUNCTION)
    5482                 :             :     {
    5483                 :         138 :       gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
    5484                 :             : 
    5485                 :         138 :       if (proc_ifc->result != NULL
    5486                 :         138 :           && ((proc_ifc->result->ts.type == BT_CLASS
    5487                 :          25 :                && proc_ifc->result->ts.u.derived->attr.is_class
    5488                 :          25 :                && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
    5489                 :         138 :               || proc_ifc->result->attr.pointer))
    5490                 :             :         return true;
    5491                 :             :       else
    5492                 :             :         return false;
    5493                 :             :     }
    5494                 :         198 :   else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
    5495                 :             :     return false;
    5496                 :             : 
    5497                 :          54 :   for (c = gfc_constructor_first (e->value.constructor);
    5498                 :          78 :        c; c = gfc_constructor_next (c))
    5499                 :          54 :     if (c->expr
    5500                 :          54 :         && expr_may_alias_variables (c->expr, array_may_alias))
    5501                 :             :       return true;
    5502                 :             : 
    5503                 :             :   return false;
    5504                 :             : }
    5505                 :             : 
    5506                 :             : 
    5507                 :             : /* A helper function to set the dtype for unallocated or unassociated
    5508                 :             :    entities.  */
    5509                 :             : 
    5510                 :             : static void
    5511                 :         711 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
    5512                 :             : {
    5513                 :         711 :   tree tmp;
    5514                 :         711 :   tree desc;
    5515                 :         711 :   tree cond;
    5516                 :         711 :   tree type;
    5517                 :         711 :   stmtblock_t block;
    5518                 :             : 
    5519                 :             :   /* TODO Figure out how to handle optional dummies.  */
    5520                 :         711 :   if (e && e->expr_type == EXPR_VARIABLE
    5521                 :         711 :       && e->symtree->n.sym->attr.optional)
    5522                 :          72 :     return;
    5523                 :             : 
    5524                 :         639 :   desc = parmse->expr;
    5525                 :         639 :   if (desc == NULL_TREE)
    5526                 :             :     return;
    5527                 :             : 
    5528                 :         639 :   if (POINTER_TYPE_P (TREE_TYPE (desc)))
    5529                 :         639 :     desc = build_fold_indirect_ref_loc (input_location, desc);
    5530                 :         639 :   if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
    5531                 :         192 :     desc = gfc_class_data_get (desc);
    5532                 :         639 :   if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
    5533                 :             :     return;
    5534                 :             : 
    5535                 :         639 :   gfc_init_block (&block);
    5536                 :         639 :   tmp = gfc_conv_descriptor_data_get (desc);
    5537                 :         639 :   cond = fold_build2_loc (input_location, EQ_EXPR,
    5538                 :             :                           logical_type_node, tmp,
    5539                 :         639 :                           build_int_cst (TREE_TYPE (tmp), 0));
    5540                 :         639 :   tmp = gfc_conv_descriptor_dtype (desc);
    5541                 :         639 :   type = gfc_get_element_type (TREE_TYPE (desc));
    5542                 :        1278 :   tmp = fold_build2_loc (input_location, MODIFY_EXPR,
    5543                 :         639 :                          TREE_TYPE (tmp), tmp,
    5544                 :             :                          gfc_get_dtype_rank_type (e->rank, type));
    5545                 :         639 :   gfc_add_expr_to_block (&block, tmp);
    5546                 :         639 :   cond = build3_v (COND_EXPR, cond,
    5547                 :             :                    gfc_finish_block (&block),
    5548                 :             :                    build_empty_stmt (input_location));
    5549                 :         639 :   gfc_add_expr_to_block (&parmse->pre, cond);
    5550                 :             : }
    5551                 :             : 
    5552                 :             : 
    5553                 :             : 
    5554                 :             : /* Provide an interface between gfortran array descriptors and the F2018:18.4
    5555                 :             :    ISO_Fortran_binding array descriptors. */
    5556                 :             : 
    5557                 :             : static void
    5558                 :        6338 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
    5559                 :             : {
    5560                 :        6338 :   stmtblock_t block, block2;
    5561                 :        6338 :   tree cfi, gfc, tmp, tmp2;
    5562                 :        6338 :   tree present = NULL;
    5563                 :        6338 :   tree gfc_strlen = NULL;
    5564                 :        6338 :   tree rank;
    5565                 :        6338 :   gfc_se se;
    5566                 :             : 
    5567                 :        6338 :   if (fsym->attr.optional
    5568                 :         932 :       && e->expr_type == EXPR_VARIABLE
    5569                 :         932 :       && e->symtree->n.sym->attr.optional)
    5570                 :           7 :     present = gfc_conv_expr_present (e->symtree->n.sym);
    5571                 :             : 
    5572                 :        6338 :   gfc_init_block (&block);
    5573                 :             : 
    5574                 :             :   /* Convert original argument to a tree. */
    5575                 :        6338 :   gfc_init_se (&se, NULL);
    5576                 :        6338 :   if (e->rank == 0)
    5577                 :             :     {
    5578                 :         602 :       se.want_pointer = 1;
    5579                 :         602 :       gfc_conv_expr (&se, e);
    5580                 :         602 :       gfc = se.expr;
    5581                 :             :       /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst.  */
    5582                 :         602 :       if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
    5583                 :          20 :         gfc = gfc_build_addr_expr (NULL, gfc);
    5584                 :             :     }
    5585                 :             :   else
    5586                 :             :     {
    5587                 :             :       /* If the actual argument can be noncontiguous, copy-in/out is required,
    5588                 :             :          if the dummy has either the CONTIGUOUS attribute or is an assumed-
    5589                 :             :          length assumed-length/assumed-size CHARACTER array.  This only
    5590                 :             :          applies if the actual argument is a "variable"; if it's some
    5591                 :             :          non-lvalue expression, we are going to evaluate it to a
    5592                 :             :          temporary below anyway.  */
    5593                 :        5736 :       se.force_no_tmp = 1;
    5594                 :        5736 :       if ((fsym->attr.contiguous
    5595                 :        4655 :            || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
    5596                 :        1297 :                && (fsym->as->type == AS_ASSUMED_SIZE
    5597                 :         865 :                    || fsym->as->type == AS_EXPLICIT)))
    5598                 :        1945 :           && !gfc_is_simply_contiguous (e, false, true)
    5599                 :        6745 :           && gfc_expr_is_variable (e))
    5600                 :             :         {
    5601                 :        1003 :           bool optional = fsym->attr.optional;
    5602                 :        1003 :           fsym->attr.optional = 0;
    5603                 :        1003 :           gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
    5604                 :        1003 :                                      fsym->attr.pointer, fsym,
    5605                 :        1003 :                                      fsym->ns->proc_name->name, NULL,
    5606                 :             :                                      /* check_contiguous= */ true);
    5607                 :        1003 :           fsym->attr.optional = optional;
    5608                 :             :         }
    5609                 :             :       else
    5610                 :        4733 :         gfc_conv_expr_descriptor (&se, e);
    5611                 :        5736 :       gfc = se.expr;
    5612                 :             :       /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
    5613                 :             :          elem_len = sizeof(dt) and base_addr = dt(lb) instead.
    5614                 :             :          gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
    5615                 :             :          While sm is fine as it uses span*stride and not elem_len.  */
    5616                 :        5736 :       if (POINTER_TYPE_P (TREE_TYPE (gfc)))
    5617                 :        1003 :         gfc = build_fold_indirect_ref_loc (input_location, gfc);
    5618                 :        4733 :       else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
    5619                 :          12 :          gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
    5620                 :             :     }
    5621                 :        6338 :   if (e->ts.type == BT_CHARACTER)
    5622                 :             :     {
    5623                 :        3259 :       if (se.string_length)
    5624                 :             :         gfc_strlen = se.string_length;
    5625                 :         865 :       else if (e->ts.u.cl->backend_decl)
    5626                 :             :         gfc_strlen = e->ts.u.cl->backend_decl;
    5627                 :             :       else
    5628                 :           0 :         gcc_unreachable ();
    5629                 :             :     }
    5630                 :        6338 :   gfc_add_block_to_block (&block, &se.pre);
    5631                 :             : 
    5632                 :             :   /* Create array descriptor and set version, rank, attribute, type. */
    5633                 :       12371 :   cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
    5634                 :             :                                           ? GFC_MAX_DIMENSIONS : e->rank,
    5635                 :             :                                           false), "cfi");
    5636                 :             :   /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
    5637                 :        6338 :   if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
    5638                 :             :     {
    5639                 :        2302 :       tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
    5640                 :        2302 :       tmp = build_pointer_type (tmp);
    5641                 :        2302 :       parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
    5642                 :        2302 :       cfi = build_fold_indirect_ref_loc (input_location, cfi);
    5643                 :             :     }
    5644                 :             :   else
    5645                 :        4036 :     parmse->expr = gfc_build_addr_expr (NULL, cfi);
    5646                 :             : 
    5647                 :        6338 :   tmp = gfc_get_cfi_desc_version (cfi);
    5648                 :        6338 :   gfc_add_modify (&block, tmp,
    5649                 :        6338 :                   build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
    5650                 :        6338 :   if (e->rank < 0)
    5651                 :         305 :     rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
    5652                 :             :   else
    5653                 :        6033 :     rank = build_int_cst (signed_char_type_node, e->rank);
    5654                 :        6338 :   tmp = gfc_get_cfi_desc_rank (cfi);
    5655                 :        6338 :   gfc_add_modify (&block, tmp, rank);
    5656                 :        6338 :   int itype = CFI_type_other;
    5657                 :        6338 :   if (e->ts.f90_type == BT_VOID)
    5658                 :          96 :     itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
    5659                 :          96 :              ? CFI_type_cfunptr : CFI_type_cptr);
    5660                 :             :   else
    5661                 :             :     {
    5662                 :        6242 :       if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
    5663                 :           1 :         e->ts = fsym->ts;
    5664                 :        6242 :       switch (e->ts.type)
    5665                 :             :         {
    5666                 :        2248 :         case BT_INTEGER:
    5667                 :        2248 :         case BT_LOGICAL:
    5668                 :        2248 :         case BT_REAL:
    5669                 :        2248 :         case BT_COMPLEX:
    5670                 :        2248 :           itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
    5671                 :        2248 :           break;
    5672                 :        3260 :         case BT_CHARACTER:
    5673                 :        3260 :           itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
    5674                 :        3260 :           break;
    5675                 :             :         case BT_DERIVED:
    5676                 :        6338 :           itype = CFI_type_struct;
    5677                 :             :           break;
    5678                 :           0 :         case BT_VOID:
    5679                 :           0 :           itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
    5680                 :           0 :                    ? CFI_type_cfunptr : CFI_type_cptr);
    5681                 :             :           break;
    5682                 :             :         case BT_ASSUMED:
    5683                 :             :           itype = CFI_type_other;  // FIXME: Or CFI_type_cptr ?
    5684                 :             :           break;
    5685                 :           1 :         case BT_CLASS:
    5686                 :           1 :           if (fsym->ts.type == BT_ASSUMED)
    5687                 :             :             {
    5688                 :             :               // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
    5689                 :             :               // type specifier is assumed-type and is an unlimited polymorphic
    5690                 :             :               //  entity." The actual argument _data component is passed.
    5691                 :             :               itype = CFI_type_other;  // FIXME: Or CFI_type_cptr ?
    5692                 :             :               break;
    5693                 :             :             }
    5694                 :             :           else
    5695                 :           0 :             gcc_unreachable ();
    5696                 :           0 :         case BT_PROCEDURE:
    5697                 :           0 :         case BT_HOLLERITH:
    5698                 :           0 :         case BT_UNION:
    5699                 :           0 :         case BT_BOZ:
    5700                 :           0 :         case BT_UNKNOWN:
    5701                 :             :           // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
    5702                 :           0 :           gcc_unreachable ();
    5703                 :             :         }
    5704                 :             :     }
    5705                 :             : 
    5706                 :        6338 :   tmp = gfc_get_cfi_desc_type (cfi);
    5707                 :        6338 :   gfc_add_modify (&block, tmp,
    5708                 :        6338 :                   build_int_cst (TREE_TYPE (tmp), itype));
    5709                 :             : 
    5710                 :        6338 :   int attr = CFI_attribute_other;
    5711                 :        6338 :   if (fsym->attr.pointer)
    5712                 :             :     attr = CFI_attribute_pointer;
    5713                 :        5576 :   else if (fsym->attr.allocatable)
    5714                 :         433 :     attr = CFI_attribute_allocatable;
    5715                 :        6338 :   tmp = gfc_get_cfi_desc_attribute (cfi);
    5716                 :        6338 :   gfc_add_modify (&block, tmp,
    5717                 :        6338 :                   build_int_cst (TREE_TYPE (tmp), attr));
    5718                 :             : 
    5719                 :             :   /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
    5720                 :             :      That is very sensible for undefined pointers, but the C code might assume
    5721                 :             :      that the pointer retains the value, in particular, if it was NULL.  */
    5722                 :        6338 :   if (e->rank == 0)
    5723                 :             :     {
    5724                 :         602 :       tmp = gfc_get_cfi_desc_base_addr (cfi);
    5725                 :         602 :       gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
    5726                 :             :     }
    5727                 :             :   else
    5728                 :             :     {
    5729                 :        5736 :       tmp = gfc_get_cfi_desc_base_addr (cfi);
    5730                 :        5736 :       tmp2 = gfc_conv_descriptor_data_get (gfc);
    5731                 :        5736 :       gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
    5732                 :             :     }
    5733                 :             : 
    5734                 :             :   /* Set elem_len if known - must be before the next if block.
    5735                 :             :      Note that allocatable implies 'len=:'.  */
    5736                 :        6338 :   if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
    5737                 :             :     {
    5738                 :             :       /* Length is known at compile time; use 'block' for it.  */
    5739                 :        3024 :       tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
    5740                 :        3024 :       tmp2 = gfc_get_cfi_desc_elem_len (cfi);
    5741                 :        3024 :       gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
    5742                 :             :     }
    5743                 :             : 
    5744                 :        6338 :   if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
    5745                 :          91 :     goto done;
    5746                 :             : 
    5747                 :             :   /* When allocatable + intent out, free the cfi descriptor.  */
    5748                 :        6247 :   if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
    5749                 :             :     {
    5750                 :          90 :       tmp = gfc_get_cfi_desc_base_addr (cfi);
    5751                 :          90 :       tree call = builtin_decl_explicit (BUILT_IN_FREE);
    5752                 :          90 :       call = build_call_expr_loc (input_location, call, 1, tmp);
    5753                 :          90 :       gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
    5754                 :          90 :       gfc_add_modify (&block, tmp,
    5755                 :          90 :                       fold_convert (TREE_TYPE (tmp), null_pointer_node));
    5756                 :          90 :       goto done;
    5757                 :             :     }
    5758                 :             : 
    5759                 :             :   /* If not unallocated/unassociated. */
    5760                 :        6157 :   gfc_init_block (&block2);
    5761                 :             : 
    5762                 :             :   /* Set elem_len, which may be only known at run time. */
    5763                 :        6157 :   if (e->ts.type == BT_CHARACTER
    5764                 :        3260 :       && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
    5765                 :             :     {
    5766                 :        3258 :       gcc_assert (gfc_strlen);
    5767                 :        3259 :       tmp = gfc_strlen;
    5768                 :        3259 :       if (e->ts.kind != 1)
    5769                 :        1117 :         tmp = fold_build2_loc (input_location, MULT_EXPR,
    5770                 :             :                                gfc_charlen_type_node, tmp,
    5771                 :             :                                build_int_cst (gfc_charlen_type_node,
    5772                 :        1117 :                                               e->ts.kind));
    5773                 :        3259 :       tmp2 = gfc_get_cfi_desc_elem_len (cfi);
    5774                 :        3259 :       gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
    5775                 :             :     }
    5776                 :        2898 :   else if (e->ts.type == BT_ASSUMED)
    5777                 :             :     {
    5778                 :          54 :       tmp = gfc_conv_descriptor_elem_len (gfc);
    5779                 :          54 :       tmp2 = gfc_get_cfi_desc_elem_len (cfi);
    5780                 :          54 :       gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
    5781                 :             :     }
    5782                 :             : 
    5783                 :        6157 :   if (e->ts.type == BT_ASSUMED)
    5784                 :             :     {
    5785                 :             :       /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
    5786                 :             :          an CFI descriptor.  Use the type in the descriptor as it provide
    5787                 :             :          mode information. (Quality of implementation feature.)  */
    5788                 :          54 :       tree cond;
    5789                 :          54 :       tree ctype = gfc_get_cfi_desc_type (cfi);
    5790                 :          54 :       tree type = fold_convert (TREE_TYPE (ctype),
    5791                 :             :                                 gfc_conv_descriptor_type (gfc));
    5792                 :          54 :       tree kind = fold_convert (TREE_TYPE (ctype),
    5793                 :             :                                 gfc_conv_descriptor_elem_len (gfc));
    5794                 :          54 :       kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
    5795                 :          54 :                               kind, build_int_cst (TREE_TYPE (type),
    5796                 :          54 :                                                    CFI_type_kind_shift));
    5797                 :             : 
    5798                 :             :       /* if (BT_VOID) CFI_type_cptr else CFI_type_other  */
    5799                 :             :       /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
    5800                 :          54 :       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
    5801                 :          54 :                               build_int_cst (TREE_TYPE (type), BT_VOID));
    5802                 :          54 :       tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
    5803                 :          54 :                              build_int_cst (TREE_TYPE (type), CFI_type_cptr));
    5804                 :          54 :       tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
    5805                 :             :                               ctype,
    5806                 :          54 :                               build_int_cst (TREE_TYPE (type), CFI_type_other));
    5807                 :          54 :       tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
    5808                 :             :                               tmp, tmp2);
    5809                 :             :       /* if (BT_DERIVED) CFI_type_struct else  < tmp2 >  */
    5810                 :          54 :       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
    5811                 :          54 :                               build_int_cst (TREE_TYPE (type), BT_DERIVED));
    5812                 :          54 :       tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
    5813                 :          54 :                              build_int_cst (TREE_TYPE (type), CFI_type_struct));
    5814                 :          54 :       tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
    5815                 :             :                               tmp, tmp2);
    5816                 :             :       /* if (BT_CHARACTER) CFI_type_Character + kind=1 else  < tmp2 >  */
    5817                 :             :       /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4.  */
    5818                 :          54 :       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
    5819                 :          54 :                               build_int_cst (TREE_TYPE (type), BT_CHARACTER));
    5820                 :          54 :       tmp = build_int_cst (TREE_TYPE (type),
    5821                 :          54 :                            CFI_type_from_type_kind (CFI_type_Character, 1));
    5822                 :          54 :       tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
    5823                 :             :                              ctype, tmp);
    5824                 :          54 :       tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
    5825                 :             :                               tmp, tmp2);
    5826                 :             :       /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else  < tmp2 >  */
    5827                 :          54 :       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
    5828                 :          54 :                               build_int_cst (TREE_TYPE (type), BT_COMPLEX));
    5829                 :          54 :       tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
    5830                 :          54 :                              kind, build_int_cst (TREE_TYPE (type), 2));
    5831                 :          54 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
    5832                 :          54 :                              build_int_cst (TREE_TYPE (type),
    5833                 :          54 :                                             CFI_type_Complex));
    5834                 :          54 :       tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
    5835                 :             :                              ctype, tmp);
    5836                 :          54 :       tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
    5837                 :             :                               tmp, tmp2);
    5838                 :             :       /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else  <tmp2>  */
    5839                 :          54 :       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
    5840                 :          54 :                               build_int_cst (TREE_TYPE (type), BT_INTEGER));
    5841                 :          54 :       tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
    5842                 :          54 :                               build_int_cst (TREE_TYPE (type), BT_LOGICAL));
    5843                 :          54 :       cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
    5844                 :             :                               cond, tmp);
    5845                 :          54 :       tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
    5846                 :          54 :                               build_int_cst (TREE_TYPE (type), BT_REAL));
    5847                 :          54 :       cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
    5848                 :             :                               cond, tmp);
    5849                 :          54 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
    5850                 :             :                              type, kind);
    5851                 :          54 :       tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
    5852                 :             :                              ctype, tmp);
    5853                 :          54 :       tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
    5854                 :             :                               tmp, tmp2);
    5855                 :          54 :       gfc_add_expr_to_block (&block2, tmp2);
    5856                 :             :     }
    5857                 :             : 
    5858                 :        6157 :   if (e->rank != 0)
    5859                 :             :     {
    5860                 :             :       /* Loop: for (i = 0; i < rank; ++i).  */
    5861                 :        5621 :       tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
    5862                 :             :       /* Loop body.  */
    5863                 :        5621 :       stmtblock_t loop_body;
    5864                 :        5621 :       gfc_init_block (&loop_body);
    5865                 :             :       /* cfi->dim[i].lower_bound = (allocatable/pointer)
    5866                 :             :                                    ? gfc->dim[i].lbound : 0 */
    5867                 :        5621 :       if (fsym->attr.pointer || fsym->attr.allocatable)
    5868                 :         648 :         tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
    5869                 :             :       else
    5870                 :        4973 :         tmp = gfc_index_zero_node;
    5871                 :        5621 :       gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
    5872                 :             :       /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1.  */
    5873                 :        5621 :       tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    5874                 :             :                              gfc_conv_descriptor_ubound_get (gfc, idx),
    5875                 :             :                              gfc_conv_descriptor_lbound_get (gfc, idx));
    5876                 :        5621 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
    5877                 :             :                              tmp, gfc_index_one_node);
    5878                 :        5621 :       gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
    5879                 :             :       /* d->dim[n].sm = gfc->dim[i].stride  * gfc->span); */
    5880                 :        5621 :       tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    5881                 :             :                              gfc_conv_descriptor_stride_get (gfc, idx),
    5882                 :             :                              gfc_conv_descriptor_span_get (gfc));
    5883                 :        5621 :       gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
    5884                 :             : 
    5885                 :             :       /* Generate loop.  */
    5886                 :        5621 :       gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
    5887                 :        5621 :                            rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
    5888                 :             :                            gfc_finish_block (&loop_body));
    5889                 :             : 
    5890                 :        5621 :       if (e->expr_type == EXPR_VARIABLE
    5891                 :        5459 :           && e->ref
    5892                 :        5459 :           && e->ref->u.ar.type == AR_FULL
    5893                 :        2624 :           && e->symtree->n.sym->attr.dummy
    5894                 :         904 :           && e->symtree->n.sym->as
    5895                 :         904 :           && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
    5896                 :             :         {
    5897                 :         138 :           tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
    5898                 :         138 :           gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
    5899                 :             :         }
    5900                 :             :     }
    5901                 :             : 
    5902                 :        6157 :   if (fsym->attr.allocatable || fsym->attr.pointer)
    5903                 :             :     {
    5904                 :        1014 :       tmp = gfc_get_cfi_desc_base_addr (cfi),
    5905                 :        1014 :       tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
    5906                 :             :                              tmp, null_pointer_node);
    5907                 :        1014 :       tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
    5908                 :             :                       build_empty_stmt (input_location));
    5909                 :        1014 :       gfc_add_expr_to_block (&block, tmp);
    5910                 :             :     }
    5911                 :             :   else
    5912                 :        5143 :     gfc_add_block_to_block (&block, &block2);
    5913                 :             : 
    5914                 :             : 
    5915                 :        6338 : done:
    5916                 :        6338 :   if (present)
    5917                 :             :     {
    5918                 :           7 :       parmse->expr = build3_loc (input_location, COND_EXPR,
    5919                 :           7 :                                  TREE_TYPE (parmse->expr),
    5920                 :             :                                  present, parmse->expr, null_pointer_node);
    5921                 :           7 :       tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
    5922                 :             :                       build_empty_stmt (input_location));
    5923                 :           7 :       gfc_add_expr_to_block (&parmse->pre, tmp);
    5924                 :             :     }
    5925                 :             :   else
    5926                 :        6331 :     gfc_add_block_to_block (&parmse->pre, &block);
    5927                 :             : 
    5928                 :        6338 :   gfc_init_block (&block);
    5929                 :             : 
    5930                 :        6338 :   if ((!fsym->attr.allocatable && !fsym->attr.pointer)
    5931                 :        1195 :       || fsym->attr.intent == INTENT_IN)
    5932                 :        5351 :     goto post_call;
    5933                 :             : 
    5934                 :         987 :   gfc_init_block (&block2);
    5935                 :         987 :   if (e->rank == 0)
    5936                 :             :     {
    5937                 :         428 :       tmp = gfc_get_cfi_desc_base_addr (cfi);
    5938                 :         428 :       gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
    5939                 :             :     }
    5940                 :             :   else
    5941                 :             :     {
    5942                 :         559 :       tmp = gfc_get_cfi_desc_base_addr (cfi);
    5943                 :         559 :       gfc_conv_descriptor_data_set (&block, gfc, tmp);
    5944                 :             : 
    5945                 :         559 :       if (fsym->attr.allocatable)
    5946                 :             :         {
    5947                 :             :           /* gfc->span = cfi->elem_len.  */
    5948                 :         252 :           tmp = fold_convert (gfc_array_index_type,
    5949                 :             :                               gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
    5950                 :             :         }
    5951                 :             :       else
    5952                 :             :         {
    5953                 :             :           /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
    5954                 :             :                           ? cfi->dim[0].sm : cfi->elem_len).  */
    5955                 :         307 :           tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
    5956                 :         307 :           tmp2 = fold_convert (gfc_array_index_type,
    5957                 :             :                                gfc_get_cfi_desc_elem_len (cfi));
    5958                 :         307 :           tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
    5959                 :             :                                  gfc_array_index_type, tmp, tmp2);
    5960                 :         307 :           tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
    5961                 :             :                              tmp, gfc_index_zero_node);
    5962                 :         307 :           tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
    5963                 :             :                             gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
    5964                 :             :         }
    5965                 :         559 :       gfc_conv_descriptor_span_set (&block2, gfc, tmp);
    5966                 :             : 
    5967                 :             :       /* Calculate offset + set lbound, ubound and stride.  */
    5968                 :         559 :       gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
    5969                 :             :       /* Loop: for (i = 0; i < rank; ++i).  */
    5970                 :         559 :       tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
    5971                 :             :       /* Loop body.  */
    5972                 :         559 :       stmtblock_t loop_body;
    5973                 :         559 :       gfc_init_block (&loop_body);
    5974                 :             :       /* gfc->dim[i].lbound = ... */
    5975                 :         559 :       tmp = gfc_get_cfi_dim_lbound (cfi, idx);
    5976                 :         559 :       gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
    5977                 :             : 
    5978                 :             :       /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
    5979                 :         559 :       tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    5980                 :             :                              gfc_conv_descriptor_lbound_get (gfc, idx),
    5981                 :             :                              gfc_index_one_node);
    5982                 :         559 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
    5983                 :             :                              gfc_get_cfi_dim_extent (cfi, idx), tmp);
    5984                 :         559 :       gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
    5985                 :             : 
    5986                 :             :       /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
    5987                 :         559 :       tmp = gfc_get_cfi_dim_sm (cfi, idx);
    5988                 :         559 :       tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
    5989                 :             :                              gfc_array_index_type, tmp,
    5990                 :             :                              fold_convert (gfc_array_index_type,
    5991                 :             :                                            gfc_get_cfi_desc_elem_len (cfi)));
    5992                 :         559 :       gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
    5993                 :             : 
    5994                 :             :       /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
    5995                 :         559 :       tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
    5996                 :             :                              gfc_conv_descriptor_stride_get (gfc, idx),
    5997                 :             :                              gfc_conv_descriptor_lbound_get (gfc, idx));
    5998                 :         559 :       tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    5999                 :             :                              gfc_conv_descriptor_offset_get (gfc), tmp);
    6000                 :         559 :       gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
    6001                 :             :       /* Generate loop.  */
    6002                 :         559 :       gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
    6003                 :         559 :                            rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
    6004                 :             :                            gfc_finish_block (&loop_body));
    6005                 :             :     }
    6006                 :             : 
    6007                 :         987 :   if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
    6008                 :             :     {
    6009                 :          60 :       tmp = fold_convert (gfc_charlen_type_node,
    6010                 :             :                           gfc_get_cfi_desc_elem_len (cfi));
    6011                 :          60 :       if (e->ts.kind != 1)
    6012                 :          24 :         tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
    6013                 :             :                                gfc_charlen_type_node, tmp,
    6014                 :             :                                build_int_cst (gfc_charlen_type_node,
    6015                 :          24 :                                               e->ts.kind));
    6016                 :          60 :       gfc_add_modify (&block2, gfc_strlen, tmp);
    6017                 :             :     }
    6018                 :             : 
    6019                 :         987 :   tmp = gfc_get_cfi_desc_base_addr (cfi),
    6020                 :         987 :   tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
    6021                 :             :                          tmp, null_pointer_node);
    6022                 :         987 :   tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
    6023                 :             :                   build_empty_stmt (input_location));
    6024                 :         987 :   gfc_add_expr_to_block (&block, tmp);
    6025                 :             : 
    6026                 :        6338 : post_call:
    6027                 :        6338 :   gfc_add_block_to_block (&block, &se.post);
    6028                 :        6338 :   if (present && block.head)
    6029                 :             :     {
    6030                 :           0 :       tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
    6031                 :             :                       build_empty_stmt (input_location));
    6032                 :           0 :       gfc_add_expr_to_block (&parmse->post, tmp);
    6033                 :             :     }
    6034                 :        6338 :   else if (block.head)
    6035                 :        1552 :     gfc_add_block_to_block (&parmse->post, &block);
    6036                 :        6338 : }
    6037                 :             : 
    6038                 :             : 
    6039                 :             : /* Generate code for a procedure call.  Note can return se->post != NULL.
    6040                 :             :    If se->direct_byref is set then se->expr contains the return parameter.
    6041                 :             :    Return nonzero, if the call has alternate specifiers.
    6042                 :             :    'expr' is only needed for procedure pointer components.  */
    6043                 :             : 
    6044                 :             : int
    6045                 :      115291 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
    6046                 :             :                          gfc_actual_arglist * args, gfc_expr * expr,
    6047                 :             :                          vec<tree, va_gc> *append_args)
    6048                 :             : {
    6049                 :      115291 :   gfc_interface_mapping mapping;
    6050                 :      115291 :   vec<tree, va_gc> *arglist;
    6051                 :      115291 :   vec<tree, va_gc> *retargs;
    6052                 :      115291 :   tree tmp;
    6053                 :      115291 :   tree fntype;
    6054                 :      115291 :   gfc_se parmse;
    6055                 :      115291 :   gfc_array_info *info;
    6056                 :      115291 :   int byref;
    6057                 :      115291 :   int parm_kind;
    6058                 :      115291 :   tree type;
    6059                 :      115291 :   tree var;
    6060                 :      115291 :   tree len;
    6061                 :      115291 :   tree base_object;
    6062                 :      115291 :   vec<tree, va_gc> *stringargs;
    6063                 :      115291 :   vec<tree, va_gc> *optionalargs;
    6064                 :      115291 :   tree result = NULL;
    6065                 :      115291 :   gfc_formal_arglist *formal;
    6066                 :      115291 :   gfc_actual_arglist *arg;
    6067                 :      115291 :   int has_alternate_specifier = 0;
    6068                 :      115291 :   bool need_interface_mapping;
    6069                 :      115291 :   bool callee_alloc;
    6070                 :      115291 :   bool ulim_copy;
    6071                 :      115291 :   gfc_typespec ts;
    6072                 :      115291 :   gfc_charlen cl;
    6073                 :      115291 :   gfc_expr *e;
    6074                 :      115291 :   gfc_symbol *fsym;
    6075                 :      115291 :   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
    6076                 :      115291 :   gfc_component *comp = NULL;
    6077                 :      115291 :   int arglen;
    6078                 :      115291 :   unsigned int argc;
    6079                 :             : 
    6080                 :      115291 :   arglist = NULL;
    6081                 :      115291 :   retargs = NULL;
    6082                 :      115291 :   stringargs = NULL;
    6083                 :      115291 :   optionalargs = NULL;
    6084                 :      115291 :   var = NULL_TREE;
    6085                 :      115291 :   len = NULL_TREE;
    6086                 :      115291 :   gfc_clear_ts (&ts);
    6087                 :             : 
    6088                 :      115291 :   comp = gfc_get_proc_ptr_comp (expr);
    6089                 :             : 
    6090                 :      230582 :   bool elemental_proc = (comp
    6091                 :        1696 :                          && comp->ts.interface
    6092                 :        1651 :                          && comp->ts.interface->attr.elemental)
    6093                 :        1510 :                         || (comp && comp->attr.elemental)
    6094                 :      116801 :                         || sym->attr.elemental;
    6095                 :             : 
    6096                 :      115291 :   if (se->ss != NULL)
    6097                 :             :     {
    6098                 :       19531 :       if (!elemental_proc)
    6099                 :             :         {
    6100                 :       17271 :           gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
    6101                 :       17271 :           if (se->ss->info->useflags)
    6102                 :             :             {
    6103                 :        6186 :               gcc_assert ((!comp && gfc_return_by_reference (sym)
    6104                 :             :                            && sym->result->attr.dimension)
    6105                 :             :                           || (comp && comp->attr.dimension)
    6106                 :             :                           || gfc_is_class_array_function (expr));
    6107                 :        6186 :               gcc_assert (se->loop != NULL);
    6108                 :             :               /* Access the previously obtained result.  */
    6109                 :        6186 :               gfc_conv_tmp_array_ref (se);
    6110                 :        6186 :               return 0;
    6111                 :             :             }
    6112                 :             :         }
    6113                 :       13345 :       info = &se->ss->info->data.array;
    6114                 :             :     }
    6115                 :             :   else
    6116                 :             :     info = NULL;
    6117                 :             : 
    6118                 :      109105 :   stmtblock_t post, clobbers, dealloc_blk;
    6119                 :      109105 :   gfc_init_block (&post);
    6120                 :      109105 :   gfc_init_block (&clobbers);
    6121                 :      109105 :   gfc_init_block (&dealloc_blk);
    6122                 :      109105 :   gfc_init_interface_mapping (&mapping);
    6123                 :      109105 :   if (!comp)
    6124                 :             :     {
    6125                 :      107455 :       formal = gfc_sym_get_dummy_args (sym);
    6126                 :      107455 :       need_interface_mapping = sym->attr.dimension ||
    6127                 :       96562 :                                (sym->ts.type == BT_CHARACTER
    6128                 :        2753 :                                 && sym->ts.u.cl->length
    6129                 :        2296 :                                 && sym->ts.u.cl->length->expr_type
    6130                 :             :                                    != EXPR_CONSTANT);
    6131                 :             :     }
    6132                 :             :   else
    6133                 :             :     {
    6134                 :        1650 :       formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
    6135                 :        1650 :       need_interface_mapping = comp->attr.dimension ||
    6136                 :        1593 :                                (comp->ts.type == BT_CHARACTER
    6137                 :          67 :                                 && comp->ts.u.cl->length
    6138                 :          58 :                                 && comp->ts.u.cl->length->expr_type
    6139                 :             :                                    != EXPR_CONSTANT);
    6140                 :             :     }
    6141                 :             : 
    6142                 :      109105 :   base_object = NULL_TREE;
    6143                 :             :   /* For _vprt->_copy () routines no formal symbol is present.  Nevertheless
    6144                 :             :      is the third and fourth argument to such a function call a value
    6145                 :             :      denoting the number of elements to copy (i.e., most of the time the
    6146                 :             :      length of a deferred length string).  */
    6147                 :      218210 :   ulim_copy = (formal == NULL)
    6148                 :       26214 :                && UNLIMITED_POLY (sym)
    6149                 :      109130 :                && comp && (strcmp ("_copy", comp->name) == 0);
    6150                 :             : 
    6151                 :             :   /* Scan for allocatable actual arguments passed to allocatable dummy
    6152                 :             :      arguments with INTENT(OUT).  As the corresponding actual arguments are
    6153                 :             :      deallocated before execution of the procedure, we evaluate actual
    6154                 :             :      argument expressions to avoid problems with possible dependencies.  */
    6155                 :      109105 :   bool force_eval_args = false;
    6156                 :      109105 :   gfc_formal_arglist *tmp_formal;
    6157                 :      340665 :   for (arg = args, tmp_formal = formal; arg != NULL;
    6158                 :      198452 :        arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
    6159                 :             :     {
    6160                 :      232033 :       e = arg->expr;
    6161                 :      232033 :       fsym = tmp_formal ? tmp_formal->sym : NULL;
    6162                 :      223789 :       if (e && fsym
    6163                 :      191790 :           && e->expr_type == EXPR_VARIABLE
    6164                 :       81407 :           && fsym->attr.intent == INTENT_OUT
    6165                 :        5341 :           && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
    6166                 :        5341 :               ? CLASS_DATA (fsym)->attr.allocatable
    6167                 :        4143 :               : fsym->attr.allocatable)
    6168                 :         473 :           && e->symtree
    6169                 :         473 :           && e->symtree->n.sym
    6170                 :      455822 :           && gfc_variable_attr (e, NULL).allocatable)
    6171                 :             :         {
    6172                 :             :           force_eval_args = true;
    6173                 :             :           break;
    6174                 :             :         }
    6175                 :             :     }
    6176                 :             : 
    6177                 :             :   /* Evaluate the arguments.  */
    6178                 :      341522 :   for (arg = args, argc = 0; arg != NULL;
    6179                 :      232417 :        arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
    6180                 :             :     {
    6181                 :      232417 :       bool finalized = false;
    6182                 :      232417 :       tree derived_array = NULL_TREE;
    6183                 :             : 
    6184                 :      232417 :       e = arg->expr;
    6185                 :      232417 :       fsym = formal ? formal->sym : NULL;
    6186                 :      431726 :       parm_kind = MISSING;
    6187                 :             : 
    6188                 :             :       /* If the procedure requires an explicit interface, the actual
    6189                 :             :          argument is passed according to the corresponding formal
    6190                 :             :          argument.  If the corresponding formal argument is a POINTER,
    6191                 :             :          ALLOCATABLE or assumed shape, we do not use g77's calling
    6192                 :             :          convention, and pass the address of the array descriptor
    6193                 :             :          instead.  Otherwise we use g77's calling convention, in other words
    6194                 :             :          pass the array data pointer without descriptor.  */
    6195                 :      431726 :       bool nodesc_arg = fsym != NULL
    6196                 :      199256 :                         && !(fsym->attr.pointer || fsym->attr.allocatable)
    6197                 :      192035 :                         && fsym->as
    6198                 :       32216 :                         && fsym->as->type != AS_ASSUMED_SHAPE
    6199                 :      219051 :                         && fsym->as->type != AS_ASSUMED_RANK;
    6200                 :      232417 :       if (comp)
    6201                 :        2530 :         nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
    6202                 :             :       else
    6203                 :      229887 :         nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
    6204                 :             : 
    6205                 :             :       /* Class array expressions are sometimes coming completely unadorned
    6206                 :             :          with either arrayspec or _data component.  Correct that here.
    6207                 :             :          OOP-TODO: Move this to the frontend.  */
    6208                 :      232417 :       if (e && e->expr_type == EXPR_VARIABLE
    6209                 :       95541 :             && !e->ref
    6210                 :       45642 :             && e->ts.type == BT_CLASS
    6211                 :        2390 :             && (CLASS_DATA (e)->attr.codimension
    6212                 :        2390 :                 || CLASS_DATA (e)->attr.dimension))
    6213                 :             :         {
    6214                 :           0 :           gfc_typespec temp_ts = e->ts;
    6215                 :           0 :           gfc_add_class_array_ref (e);
    6216                 :           0 :           e->ts = temp_ts;
    6217                 :             :         }
    6218                 :             : 
    6219                 :      232417 :       if (e == NULL)
    6220                 :             :         {
    6221                 :        8250 :           if (se->ignore_optional)
    6222                 :             :             {
    6223                 :             :               /* Some intrinsics have already been resolved to the correct
    6224                 :             :                  parameters.  */
    6225                 :         326 :               continue;
    6226                 :             :             }
    6227                 :        8148 :           else if (arg->label)
    6228                 :             :             {
    6229                 :         224 :               has_alternate_specifier = 1;
    6230                 :         224 :               continue;
    6231                 :             :             }
    6232                 :             :           else
    6233                 :             :             {
    6234                 :        7924 :               gfc_init_se (&parmse, NULL);
    6235                 :             : 
    6236                 :             :               /* For scalar arguments with VALUE attribute which are passed by
    6237                 :             :                  value, pass "0" and a hidden argument gives the optional
    6238                 :             :                  status.  */
    6239                 :        7924 :               if (fsym && fsym->attr.optional && fsym->attr.value
    6240                 :        7088 :                   && !fsym->attr.dimension && fsym->ts.type != BT_CLASS
    6241                 :         228 :                   && !gfc_bt_struct (sym->ts.type))
    6242                 :             :                 {
    6243                 :         228 :                   if (fsym->ts.type == BT_CHARACTER)
    6244                 :             :                     {
    6245                 :             :                       /* Pass a NULL pointer for an absent CHARACTER arg
    6246                 :             :                          and a length of zero.  */
    6247                 :          18 :                       parmse.expr = null_pointer_node;
    6248                 :          18 :                       parmse.string_length
    6249                 :          18 :                         = build_int_cst (gfc_charlen_type_node,
    6250                 :          18 :                                          0);
    6251                 :             :                     }
    6252                 :             :                   else
    6253                 :         210 :                     parmse.expr = fold_convert (gfc_sym_type (fsym),
    6254                 :             :                                                 integer_zero_node);
    6255                 :         228 :                   vec_safe_push (optionalargs, boolean_false_node);
    6256                 :             :                 }
    6257                 :             :               else
    6258                 :             :                 {
    6259                 :             :                   /* Pass a NULL pointer for an absent arg.  */
    6260                 :        7696 :                   parmse.expr = null_pointer_node;
    6261                 :        7696 :                   gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
    6262                 :        7696 :                   if (dummy_arg
    6263                 :        7696 :                       && gfc_dummy_arg_get_typespec (*dummy_arg).type
    6264                 :             :                          == BT_CHARACTER)
    6265                 :         815 :                     parmse.string_length = build_int_cst (gfc_charlen_type_node,
    6266                 :         815 :                                                           0);
    6267                 :             :                 }
    6268                 :             :             }
    6269                 :             :         }
    6270                 :      224167 :       else if (arg->expr->expr_type == EXPR_NULL
    6271                 :         175 :                && fsym && !fsym->attr.pointer
    6272                 :          86 :                && (fsym->ts.type != BT_CLASS
    6273                 :          12 :                    || !CLASS_DATA (fsym)->attr.class_pointer))
    6274                 :             :         {
    6275                 :             :           /* Pass a NULL pointer to denote an absent arg.  */
    6276                 :          80 :           gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
    6277                 :             :                       && (fsym->ts.type != BT_CLASS
    6278                 :             :                           || !CLASS_DATA (fsym)->attr.allocatable));
    6279                 :          80 :           gfc_init_se (&parmse, NULL);
    6280                 :          80 :           parmse.expr = null_pointer_node;
    6281                 :          80 :           if (arg->associated_dummy
    6282                 :          80 :               && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
    6283                 :             :                  == BT_CHARACTER)
    6284                 :           0 :             parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
    6285                 :             :         }
    6286                 :      224087 :       else if (fsym && fsym->ts.type == BT_CLASS
    6287                 :        9489 :                  && e->ts.type == BT_DERIVED)
    6288                 :             :         {
    6289                 :             :           /* The derived type needs to be converted to a temporary
    6290                 :             :              CLASS object.  */
    6291                 :        3781 :           gfc_init_se (&parmse, se);
    6292                 :        3781 :           gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
    6293                 :        3781 :                                      fsym->attr.optional
    6294                 :        1008 :                                      && e->expr_type == EXPR_VARIABLE
    6295                 :        1008 :                                      && e->symtree->n.sym->attr.optional,
    6296                 :        3781 :                                      CLASS_DATA (fsym)->attr.class_pointer
    6297                 :        3781 :                                      || CLASS_DATA (fsym)->attr.allocatable,
    6298                 :             :                                      &derived_array);
    6299                 :             :         }
    6300                 :      188307 :       else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
    6301                 :         709 :                && e->ts.type != BT_PROCEDURE
    6302                 :         697 :                && (gfc_expr_attr (e).flavor != FL_PROCEDURE
    6303                 :          12 :                    || gfc_expr_attr (e).proc != PROC_UNKNOWN))
    6304                 :             :         {
    6305                 :             :           /* The intrinsic type needs to be converted to a temporary
    6306                 :             :              CLASS object for the unlimited polymorphic formal.  */
    6307                 :         697 :           gfc_find_vtab (&e->ts);
    6308                 :         697 :           gfc_init_se (&parmse, se);
    6309                 :         697 :           gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
    6310                 :             : 
    6311                 :             :         }
    6312                 :      219609 :       else if (se->ss && se->ss->info->useflags)
    6313                 :             :         {
    6314                 :        3863 :           gfc_ss *ss;
    6315                 :             : 
    6316                 :        3863 :           ss = se->ss;
    6317                 :             : 
    6318                 :             :           /* An elemental function inside a scalarized loop.  */
    6319                 :        3863 :           gfc_init_se (&parmse, se);
    6320                 :        3863 :           parm_kind = ELEMENTAL;
    6321                 :             : 
    6322                 :             :           /* When no fsym is present, ulim_copy is set and this is a third or
    6323                 :             :              fourth argument, use call-by-value instead of by reference to
    6324                 :             :              hand the length properties to the copy routine (i.e., most of the
    6325                 :             :              time this will be a call to a __copy_character_* routine where the
    6326                 :             :              third and fourth arguments are the lengths of a deferred length
    6327                 :             :              char array).  */
    6328                 :        3863 :           if ((fsym && fsym->attr.value)
    6329                 :        3851 :               || (ulim_copy && (argc == 2 || argc == 3)))
    6330                 :          12 :             gfc_conv_expr (&parmse, e);
    6331                 :             :           else
    6332                 :        3851 :             gfc_conv_expr_reference (&parmse, e);
    6333                 :             : 
    6334                 :        3863 :           if (e->ts.type == BT_CHARACTER && !e->rank
    6335                 :          54 :               && e->expr_type == EXPR_FUNCTION)
    6336                 :          12 :             parmse.expr = build_fold_indirect_ref_loc (input_location,
    6337                 :             :                                                        parmse.expr);
    6338                 :             : 
    6339                 :        3825 :           if (fsym && fsym->ts.type == BT_DERIVED
    6340                 :        5076 :               && gfc_is_class_container_ref (e))
    6341                 :             :             {
    6342                 :          24 :               parmse.expr = gfc_class_data_get (parmse.expr);
    6343                 :             : 
    6344                 :          24 :               if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
    6345                 :          24 :                   && e->symtree->n.sym->attr.optional)
    6346                 :             :                 {
    6347                 :           0 :                   tree cond = gfc_conv_expr_present (e->symtree->n.sym);
    6348                 :           0 :                   parmse.expr = build3_loc (input_location, COND_EXPR,
    6349                 :           0 :                                         TREE_TYPE (parmse.expr),
    6350                 :             :                                         cond, parmse.expr,
    6351                 :           0 :                                         fold_convert (TREE_TYPE (parmse.expr),
    6352                 :             :                                                       null_pointer_node));
    6353                 :             :                 }
    6354                 :             :             }
    6355                 :             : 
    6356                 :             :           /* If we are passing an absent array as optional dummy to an
    6357                 :             :              elemental procedure, make sure that we pass NULL when the data
    6358                 :             :              pointer is NULL.  We need this extra conditional because of
    6359                 :             :              scalarization which passes arrays elements to the procedure,
    6360                 :             :              ignoring the fact that the array can be absent/unallocated/...  */
    6361                 :        3863 :           if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
    6362                 :             :             {
    6363                 :         137 :               tree descriptor_data;
    6364                 :             : 
    6365                 :         137 :               descriptor_data = ss->info->data.array.data;
    6366                 :         137 :               tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    6367                 :             :                                      descriptor_data,
    6368                 :         137 :                                      fold_convert (TREE_TYPE (descriptor_data),
    6369                 :             :                                                    null_pointer_node));
    6370                 :         137 :               parmse.expr
    6371                 :         274 :                 = fold_build3_loc (input_location, COND_EXPR,
    6372                 :         137 :                                    TREE_TYPE (parmse.expr),
    6373                 :             :                                    gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
    6374                 :         137 :                                    fold_convert (TREE_TYPE (parmse.expr),
    6375                 :             :                                                  null_pointer_node),
    6376                 :             :                                    parmse.expr);
    6377                 :             :             }
    6378                 :             : 
    6379                 :             :           /* The scalarizer does not repackage the reference to a class
    6380                 :             :              array - instead it returns a pointer to the data element.  */
    6381                 :        3863 :           if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
    6382                 :         156 :             gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
    6383                 :         156 :                                      fsym->attr.intent != INTENT_IN
    6384                 :         156 :                                      && (CLASS_DATA (fsym)->attr.class_pointer
    6385                 :             :                                          || CLASS_DATA (fsym)->attr.allocatable),
    6386                 :         156 :                                      fsym->attr.optional
    6387                 :           0 :                                      && e->expr_type == EXPR_VARIABLE
    6388                 :           0 :                                      && e->symtree->n.sym->attr.optional,
    6389                 :         156 :                                      CLASS_DATA (fsym)->attr.class_pointer
    6390                 :         156 :                                      || CLASS_DATA (fsym)->attr.allocatable);
    6391                 :             :         }
    6392                 :             :       else
    6393                 :             :         {
    6394                 :      215746 :           bool scalar;
    6395                 :      215746 :           gfc_ss *argss;
    6396                 :             : 
    6397                 :      215746 :           gfc_init_se (&parmse, NULL);
    6398                 :             : 
    6399                 :             :           /* Check whether the expression is a scalar or not; we cannot use
    6400                 :             :              e->rank as it can be nonzero for functions arguments.  */
    6401                 :      215746 :           argss = gfc_walk_expr (e);
    6402                 :      215746 :           scalar = argss == gfc_ss_terminator;
    6403                 :      215746 :           if (!scalar)
    6404                 :       47669 :             gfc_free_ss_chain (argss);
    6405                 :             : 
    6406                 :             :           /* Special handling for passing scalar polymorphic coarrays;
    6407                 :             :              otherwise one passes "class->_data.data" instead of "&class".  */
    6408                 :      215746 :           if (e->rank == 0 && e->ts.type == BT_CLASS
    6409                 :        3268 :               && fsym && fsym->ts.type == BT_CLASS
    6410                 :        2864 :               && CLASS_DATA (fsym)->attr.codimension
    6411                 :        2864 :               && !CLASS_DATA (fsym)->attr.dimension)
    6412                 :             :             {
    6413                 :          47 :               gfc_add_class_array_ref (e);
    6414                 :          47 :               parmse.want_coarray = 1;
    6415                 :          47 :               scalar = false;
    6416                 :             :             }
    6417                 :             : 
    6418                 :             :           /* A scalar or transformational function.  */
    6419                 :      215746 :           if (scalar)
    6420                 :             :             {
    6421                 :      168030 :               if (e->expr_type == EXPR_VARIABLE
    6422                 :       49373 :                     && e->symtree->n.sym->attr.cray_pointee
    6423                 :         378 :                     && fsym && fsym->attr.flavor == FL_PROCEDURE)
    6424                 :             :                 {
    6425                 :             :                     /* The Cray pointer needs to be converted to a pointer to
    6426                 :             :                        a type given by the expression.  */
    6427                 :           6 :                     gfc_conv_expr (&parmse, e);
    6428                 :           6 :                     type = build_pointer_type (TREE_TYPE (parmse.expr));
    6429                 :           6 :                     tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
    6430                 :           6 :                     parmse.expr = convert (type, tmp);
    6431                 :             :                 }
    6432                 :             : 
    6433                 :      168024 :               else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
    6434                 :             :                 /* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
    6435                 :         602 :                 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
    6436                 :             : 
    6437                 :      167422 :               else if (fsym && fsym->attr.value)
    6438                 :             :                 {
    6439                 :       20464 :                   if (fsym->ts.type == BT_CHARACTER
    6440                 :         441 :                       && fsym->ts.is_c_interop
    6441                 :         180 :                       && fsym->ns->proc_name != NULL
    6442                 :         180 :                       && fsym->ns->proc_name->attr.is_bind_c)
    6443                 :             :                     {
    6444                 :         171 :                       parmse.expr = NULL;
    6445                 :         171 :                       conv_scalar_char_value (fsym, &parmse, &e);
    6446                 :         171 :                       if (parmse.expr == NULL)
    6447                 :         165 :                         gfc_conv_expr (&parmse, e);
    6448                 :             :                     }
    6449                 :             :                   else
    6450                 :             :                     {
    6451                 :       20293 :                     gfc_conv_expr (&parmse, e);
    6452                 :             : 
    6453                 :             :                     /* ABI: actual arguments to CHARACTER(len=1),VALUE
    6454                 :             :                        dummy arguments are actually passed by value.
    6455                 :             :                        Strings are truncated to length 1.  */
    6456                 :       20293 :                     if (gfc_length_one_character_type_p (&fsym->ts))
    6457                 :             :                       {
    6458                 :         240 :                         if (e->expr_type == EXPR_CONSTANT
    6459                 :          42 :                             && e->value.character.length > 1)
    6460                 :             :                           {
    6461                 :          12 :                             e->value.character.length = 1;
    6462                 :          12 :                             gfc_conv_expr (&parmse, e);
    6463                 :             :                           }
    6464                 :             : 
    6465                 :         240 :                         tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
    6466                 :         240 :                         gfc_conv_string_parameter (&parmse);
    6467                 :         240 :                         parmse.expr
    6468                 :         240 :                             = gfc_string_to_single_character (slen1,
    6469                 :             :                                                               parmse.expr,
    6470                 :             :                                                               e->ts.kind);
    6471                 :             :                         /* Truncate resulting string to length 1.  */
    6472                 :         240 :                         parmse.string_length = slen1;
    6473                 :             :                       }
    6474                 :             : 
    6475                 :       20293 :                     if (fsym->attr.optional
    6476                 :         237 :                         && fsym->ts.type != BT_CLASS
    6477                 :         237 :                         && fsym->ts.type != BT_DERIVED)
    6478                 :             :                       {
    6479                 :         237 :                         if (e->expr_type != EXPR_VARIABLE
    6480                 :         153 :                             || !e->symtree->n.sym->attr.optional
    6481                 :          48 :                             || e->ref != NULL)
    6482                 :         189 :                           vec_safe_push (optionalargs, boolean_true_node);
    6483                 :             :                         else
    6484                 :             :                           {
    6485                 :          48 :                             tmp = gfc_conv_expr_present (e->symtree->n.sym);
    6486                 :          48 :                             if (!e->symtree->n.sym->attr.value)
    6487                 :          24 :                               parmse.expr
    6488                 :          48 :                                 = fold_build3_loc (input_location, COND_EXPR,
    6489                 :          24 :                                         TREE_TYPE (parmse.expr),
    6490                 :             :                                         tmp, parmse.expr,
    6491                 :          24 :                                         fold_convert (TREE_TYPE (parmse.expr),
    6492                 :             :                                                       integer_zero_node));
    6493                 :             : 
    6494                 :          96 :                             vec_safe_push (optionalargs,
    6495                 :          48 :                                            fold_convert (boolean_type_node,
    6496                 :             :                                                          tmp));
    6497                 :             :                           }
    6498                 :             :                       }
    6499                 :             :                     }
    6500                 :             :                 }
    6501                 :             : 
    6502                 :      146958 :               else if (arg->name && arg->name[0] == '%')
    6503                 :             :                 /* Argument list functions %VAL, %LOC and %REF are signalled
    6504                 :             :                    through arg->name.  */
    6505                 :        3517 :                 conv_arglist_function (&parmse, arg->expr, arg->name);
    6506                 :      143441 :               else if ((e->expr_type == EXPR_FUNCTION)
    6507                 :        7055 :                         && ((e->value.function.esym
    6508                 :        2025 :                              && e->value.function.esym->result->attr.pointer)
    6509                 :        6955 :                             || (!e->value.function.esym
    6510                 :        5030 :                                 && e->symtree->n.sym->attr.pointer))
    6511                 :         100 :                         && fsym && fsym->attr.target)
    6512                 :             :                 /* Make sure the function only gets called once.  */
    6513                 :           8 :                 gfc_conv_expr_reference (&parmse, e);
    6514                 :      143433 :               else if (e->expr_type == EXPR_FUNCTION
    6515                 :        7047 :                        && e->symtree->n.sym->result
    6516                 :        6020 :                        && e->symtree->n.sym->result != e->symtree->n.sym
    6517                 :         111 :                        && e->symtree->n.sym->result->attr.proc_pointer)
    6518                 :             :                 {
    6519                 :             :                   /* Functions returning procedure pointers.  */
    6520                 :          18 :                   gfc_conv_expr (&parmse, e);
    6521                 :          18 :                   if (fsym && fsym->attr.proc_pointer)
    6522                 :           6 :                     parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
    6523                 :             :                 }
    6524                 :             : 
    6525                 :             :               else
    6526                 :             :                 {
    6527                 :      143415 :                   bool defer_to_dealloc_blk = false;
    6528                 :      143415 :                   if (e->ts.type == BT_CLASS && fsym
    6529                 :        3209 :                       && fsym->ts.type == BT_CLASS
    6530                 :        2805 :                       && (!CLASS_DATA (fsym)->as
    6531                 :         350 :                           || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
    6532                 :        2455 :                       && CLASS_DATA (e)->attr.codimension)
    6533                 :             :                     {
    6534                 :          48 :                       gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
    6535                 :          48 :                       gcc_assert (!CLASS_DATA (fsym)->as);
    6536                 :          48 :                       gfc_add_class_array_ref (e);
    6537                 :          48 :                       parmse.want_coarray = 1;
    6538                 :          48 :                       gfc_conv_expr_reference (&parmse, e);
    6539                 :          48 :                       class_scalar_coarray_to_class (&parmse, e, fsym->ts,
    6540                 :          48 :                                      fsym->attr.optional
    6541                 :          48 :                                      && e->expr_type == EXPR_VARIABLE);
    6542                 :             :                     }
    6543                 :      143367 :                   else if (e->ts.type == BT_CLASS && fsym
    6544                 :        3161 :                            && fsym->ts.type == BT_CLASS
    6545                 :        2757 :                            && !CLASS_DATA (fsym)->as
    6546                 :        2407 :                            && !CLASS_DATA (e)->as
    6547                 :        2297 :                            && strcmp (fsym->ts.u.derived->name,
    6548                 :             :                                       e->ts.u.derived->name))
    6549                 :             :                     {
    6550                 :        1498 :                       type = gfc_typenode_for_spec (&fsym->ts);
    6551                 :        1498 :                       var = gfc_create_var (type, fsym->name);
    6552                 :        1498 :                       gfc_conv_expr (&parmse, e);
    6553                 :        1498 :                       if (fsym->attr.optional
    6554                 :         153 :                           && e->expr_type == EXPR_VARIABLE
    6555                 :         153 :                           && e->symtree->n.sym->attr.optional)
    6556                 :             :                         {
    6557                 :          66 :                           stmtblock_t block;
    6558                 :          66 :                           tree cond;
    6559                 :          66 :                           tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
    6560                 :          66 :                           cond = fold_build2_loc (input_location, NE_EXPR,
    6561                 :             :                                                   logical_type_node, tmp,
    6562                 :          66 :                                                   fold_convert (TREE_TYPE (tmp),
    6563                 :             :                                                             null_pointer_node));
    6564                 :          66 :                           gfc_start_block (&block);
    6565                 :          66 :                           gfc_add_modify (&block, var,
    6566                 :             :                                           fold_build1_loc (input_location,
    6567                 :             :                                                            VIEW_CONVERT_EXPR,
    6568                 :             :                                                            type, parmse.expr));
    6569                 :          66 :                           gfc_add_expr_to_block (&parmse.pre,
    6570                 :             :                                  fold_build3_loc (input_location,
    6571                 :             :                                          COND_EXPR, void_type_node,
    6572                 :             :                                          cond, gfc_finish_block (&block),
    6573                 :             :                                          build_empty_stmt (input_location)));
    6574                 :          66 :                           parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
    6575                 :         132 :                           parmse.expr = build3_loc (input_location, COND_EXPR,
    6576                 :          66 :                                          TREE_TYPE (parmse.expr),
    6577                 :             :                                          cond, parmse.expr,
    6578                 :          66 :                                          fold_convert (TREE_TYPE (parmse.expr),
    6579                 :             :                                                        null_pointer_node));
    6580                 :          66 :                         }
    6581                 :             :                       else
    6582                 :             :                         {
    6583                 :             :                           /* Since the internal representation of unlimited
    6584                 :             :                              polymorphic expressions includes an extra field
    6585                 :             :                              that other class objects do not, a cast to the
    6586                 :             :                              formal type does not work.  */
    6587                 :        1432 :                           if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
    6588                 :             :                             {
    6589                 :          65 :                               tree efield;
    6590                 :             : 
    6591                 :             :                               /* Set the _data field.  */
    6592                 :          65 :                               tmp = gfc_class_data_get (var);
    6593                 :          65 :                               efield = fold_convert (TREE_TYPE (tmp),
    6594                 :             :                                         gfc_class_data_get (parmse.expr));
    6595                 :          65 :                               gfc_add_modify (&parmse.pre, tmp, efield);
    6596                 :             : 
    6597                 :             :                               /* Set the _vptr field.  */
    6598                 :          65 :                               tmp = gfc_class_vptr_get (var);
    6599                 :          65 :                               efield = fold_convert (TREE_TYPE (tmp),
    6600                 :             :                                         gfc_class_vptr_get (parmse.expr));
    6601                 :          65 :                               gfc_add_modify (&parmse.pre, tmp, efield);
    6602                 :             : 
    6603                 :             :                               /* Set the _len field.  */
    6604                 :          65 :                               tmp = gfc_class_len_get (var);
    6605                 :          65 :                               gfc_add_modify (&parmse.pre, tmp,
    6606                 :          65 :                                               build_int_cst (TREE_TYPE (tmp), 0));
    6607                 :          65 :                             }
    6608                 :             :                           else
    6609                 :             :                             {
    6610                 :        1367 :                               tmp = fold_build1_loc (input_location,
    6611                 :             :                                                      VIEW_CONVERT_EXPR,
    6612                 :             :                                                      type, parmse.expr);
    6613                 :        1367 :                               gfc_add_modify (&parmse.pre, var, tmp);
    6614                 :        1432 :                                               ;
    6615                 :             :                             }
    6616                 :        1432 :                           parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
    6617                 :             :                         }
    6618                 :             :                     }
    6619                 :             :                   else
    6620                 :             :                     {
    6621                 :      141869 :                       gfc_conv_expr_reference (&parmse, e);
    6622                 :             : 
    6623                 :      141869 :                       gfc_symbol *dsym = fsym;
    6624                 :      141869 :                       gfc_dummy_arg *dummy;
    6625                 :             : 
    6626                 :             :                       /* Use associated dummy as fallback for formal
    6627                 :             :                          argument if there is no explicit interface.  */
    6628                 :      141869 :                       if (dsym == NULL
    6629                 :       27468 :                           && (dummy = arg->associated_dummy)
    6630                 :       25034 :                           && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
    6631                 :      165461 :                           && dummy->u.non_intrinsic->sym)
    6632                 :             :                         dsym = dummy->u.non_intrinsic->sym;
    6633                 :             : 
    6634                 :      141869 :                       if (dsym
    6635                 :      137993 :                           && dsym->attr.intent == INTENT_OUT
    6636                 :             :                           && !dsym->attr.allocatable
    6637                 :        3045 :                           && !dsym->attr.pointer
    6638                 :        2888 :                           && e->expr_type == EXPR_VARIABLE
    6639                 :        2882 :                           && e->ref == NULL
    6640                 :        2780 :                           && e->symtree
    6641                 :        2780 :                           && e->symtree->n.sym
    6642                 :        2780 :                           && !e->symtree->n.sym->attr.dimension
    6643                 :        2780 :                           && e->ts.type != BT_CHARACTER
    6644                 :        2683 :                           && e->ts.type != BT_CLASS
    6645                 :        2477 :                           && (e->ts.type != BT_DERIVED
    6646                 :         455 :                               || (dsym->ts.type == BT_DERIVED
    6647                 :         455 :                                   && e->ts.u.derived == dsym->ts.u.derived
    6648                 :             :                                   /* Types with allocatable components are
    6649                 :             :                                      excluded from clobbering because we need
    6650                 :             :                                      the unclobbered pointers to free the
    6651                 :             :                                      allocatable components in the callee.
    6652                 :             :                                      Same goes for finalizable types or types
    6653                 :             :                                      with finalizable components, we need to
    6654                 :             :                                      pass the unclobbered values to the
    6655                 :             :                                      finalization routines.
    6656                 :             :                                      For parameterized types, it's less clear
    6657                 :             :                                      but they may not have a constant size
    6658                 :             :                                      so better exclude them in any case.  */
    6659                 :             :                                   && !e->ts.u.derived->attr.alloc_comp
    6660                 :         440 :                                   && !e->ts.u.derived->attr.pdt_type
    6661                 :         315 :                                   && !gfc_is_finalizable (e->ts.u.derived, NULL)))
    6662                 :      144170 :                           && !sym->attr.elemental)
    6663                 :             :                         {
    6664                 :         968 :                           tree var;
    6665                 :         968 :                           var = build_fold_indirect_ref_loc (input_location,
    6666                 :             :                                                              parmse.expr);
    6667                 :         968 :                           tree clobber = build_clobber (TREE_TYPE (var));
    6668                 :         968 :                           gfc_add_modify (&clobbers, var, clobber);
    6669                 :             :                         }
    6670                 :             :                     }
    6671                 :             :                   /* Catch base objects that are not variables.  */
    6672                 :      143415 :                   if (e->ts.type == BT_CLASS
    6673                 :        3209 :                         && e->expr_type != EXPR_VARIABLE
    6674                 :         275 :                         && expr && e == expr->base_expr)
    6675                 :          80 :                     base_object = build_fold_indirect_ref_loc (input_location,
    6676                 :             :                                                                parmse.expr);
    6677                 :             : 
    6678                 :             :                   /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
    6679                 :             :                      allocated on entry, it must be deallocated.  */
    6680                 :      115947 :                   if (fsym && fsym->attr.intent == INTENT_OUT
    6681                 :        2948 :                       && (fsym->attr.allocatable
    6682                 :        2809 :                           || (fsym->ts.type == BT_CLASS
    6683                 :         229 :                               && CLASS_DATA (fsym)->attr.allocatable))
    6684                 :      143702 :                       && !is_CFI_desc (fsym, NULL))
    6685                 :             :                     {
    6686                 :         287 :                       stmtblock_t block;
    6687                 :         287 :                       tree ptr;
    6688                 :             : 
    6689                 :         287 :                       defer_to_dealloc_blk = true;
    6690                 :             : 
    6691                 :         287 :                       parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
    6692                 :             :                                                                &parmse.pre);
    6693                 :             : 
    6694                 :         287 :                       if (parmse.class_container != NULL_TREE)
    6695                 :         155 :                         parmse.class_container
    6696                 :         155 :                             = gfc_evaluate_data_ref_now (parmse.class_container,
    6697                 :             :                                                          &parmse.pre);
    6698                 :             : 
    6699                 :         287 :                       gfc_init_block  (&block);
    6700                 :         287 :                       ptr = parmse.expr;
    6701                 :         287 :                       if (e->ts.type == BT_CLASS)
    6702                 :         155 :                         ptr = gfc_class_data_get (ptr);
    6703                 :             : 
    6704                 :         287 :                       tree cls = parmse.class_container;
    6705                 :         287 :                       tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
    6706                 :             :                                                                NULL_TREE, true,
    6707                 :             :                                                                e, e->ts, cls);
    6708                 :         287 :                       gfc_add_expr_to_block (&block, tmp);
    6709                 :         287 :                       tmp = fold_build2_loc (input_location, MODIFY_EXPR,
    6710                 :             :                                              void_type_node, ptr,
    6711                 :             :                                              null_pointer_node);
    6712                 :         287 :                       gfc_add_expr_to_block (&block, tmp);
    6713                 :             : 
    6714                 :         287 :                       if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
    6715                 :             :                         {
    6716                 :          18 :                           gfc_add_modify (&block, ptr,
    6717                 :          18 :                                           fold_convert (TREE_TYPE (ptr),
    6718                 :             :                                                         null_pointer_node));
    6719                 :          18 :                           gfc_add_expr_to_block (&block, tmp);
    6720                 :             :                         }
    6721                 :         269 :                       else if (fsym->ts.type == BT_CLASS)
    6722                 :             :                         {
    6723                 :         130 :                           gfc_symbol *vtab;
    6724                 :         130 :                           vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
    6725                 :         130 :                           tmp = gfc_get_symbol_decl (vtab);
    6726                 :         130 :                           tmp = gfc_build_addr_expr (NULL_TREE, tmp);
    6727                 :         130 :                           ptr = gfc_class_vptr_get (parmse.expr);
    6728                 :         130 :                           gfc_add_modify (&block, ptr,
    6729                 :         130 :                                           fold_convert (TREE_TYPE (ptr), tmp));
    6730                 :         130 :                           gfc_add_expr_to_block (&block, tmp);
    6731                 :             :                         }
    6732                 :             : 
    6733                 :         287 :                       if (fsym->attr.optional
    6734                 :          42 :                           && e->expr_type == EXPR_VARIABLE
    6735                 :          42 :                           && e->symtree->n.sym->attr.optional)
    6736                 :             :                         {
    6737                 :          36 :                           tmp = fold_build3_loc (input_location, COND_EXPR,
    6738                 :             :                                      void_type_node,
    6739                 :          18 :                                      gfc_conv_expr_present (e->symtree->n.sym),
    6740                 :             :                                             gfc_finish_block (&block),
    6741                 :             :                                             build_empty_stmt (input_location));
    6742                 :             :                         }
    6743                 :             :                       else
    6744                 :         269 :                         tmp = gfc_finish_block (&block);
    6745                 :             : 
    6746                 :         287 :                       gfc_add_expr_to_block (&dealloc_blk, tmp);
    6747                 :             :                     }
    6748                 :             : 
    6749                 :             :                   /* A class array element needs converting back to be a
    6750                 :             :                      class object, if the formal argument is a class object.  */
    6751                 :      143415 :                   if (fsym && fsym->ts.type == BT_CLASS
    6752                 :        2823 :                         && e->ts.type == BT_CLASS
    6753                 :        2805 :                         && ((CLASS_DATA (fsym)->as
    6754                 :         350 :                              && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
    6755                 :        2455 :                             || CLASS_DATA (e)->attr.dimension))
    6756                 :             :                     {
    6757                 :         460 :                       gfc_se class_se = parmse;
    6758                 :         460 :                       gfc_init_block (&class_se.pre);
    6759                 :         460 :                       gfc_init_block (&class_se.post);
    6760                 :             : 
    6761                 :         460 :                       gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
    6762                 :         460 :                                      fsym->attr.intent != INTENT_IN
    6763                 :         460 :                                      && (CLASS_DATA (fsym)->attr.class_pointer
    6764                 :             :                                          || CLASS_DATA (fsym)->attr.allocatable),
    6765                 :         460 :                                      fsym->attr.optional
    6766                 :         198 :                                      && e->expr_type == EXPR_VARIABLE
    6767                 :         198 :                                      && e->symtree->n.sym->attr.optional,
    6768                 :         460 :                                      CLASS_DATA (fsym)->attr.class_pointer
    6769                 :         460 :                                      || CLASS_DATA (fsym)->attr.allocatable);
    6770                 :             : 
    6771                 :         460 :                       parmse.expr = class_se.expr;
    6772                 :         920 :                       stmtblock_t *class_pre_block = defer_to_dealloc_blk
    6773                 :         460 :                                                      ? &dealloc_blk
    6774                 :             :                                                      : &parmse.pre;
    6775                 :         460 :                       gfc_add_block_to_block (class_pre_block, &class_se.pre);
    6776                 :         460 :                       gfc_add_block_to_block (&parmse.post, &class_se.post);
    6777                 :             :                     }
    6778                 :             : 
    6779                 :      115947 :                   if (fsym && (fsym->ts.type == BT_DERIVED
    6780                 :      104856 :                                || fsym->ts.type == BT_ASSUMED)
    6781                 :       11942 :                       && e->ts.type == BT_CLASS
    6782                 :         404 :                       && !CLASS_DATA (e)->attr.dimension
    6783                 :         404 :                       && !CLASS_DATA (e)->attr.codimension)
    6784                 :             :                     {
    6785                 :         368 :                       parmse.expr = gfc_class_data_get (parmse.expr);
    6786                 :             :                       /* The result is a class temporary, whose _data component
    6787                 :             :                          must be freed to avoid a memory leak.  */
    6788                 :         368 :                       if (e->expr_type == EXPR_FUNCTION
    6789                 :          17 :                           && CLASS_DATA (e)->attr.allocatable)
    6790                 :             :                         {
    6791                 :          13 :                           tree zero;
    6792                 :             : 
    6793                 :             :                           /* Finalize the expression.  */
    6794                 :          13 :                           gfc_finalize_tree_expr (&parmse, NULL,
    6795                 :             :                                                   gfc_expr_attr (e), e->rank);
    6796                 :          13 :                           gfc_add_block_to_block (&parmse.post,
    6797                 :             :                                                   &parmse.finalblock);
    6798                 :             : 
    6799                 :             :                           /* Then free the class _data.  */
    6800                 :          13 :                           zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
    6801                 :          13 :                           tmp = fold_build2_loc (input_location, NE_EXPR,
    6802                 :             :                                                  logical_type_node,
    6803                 :             :                                                  parmse.expr, zero);
    6804                 :          13 :                           tmp = build3_v (COND_EXPR, tmp,
    6805                 :             :                                           gfc_call_free (parmse.expr),
    6806                 :             :                                           build_empty_stmt (input_location));
    6807                 :          13 :                           gfc_add_expr_to_block (&parmse.post, tmp);
    6808                 :          13 :                           gfc_add_modify (&parmse.post, parmse.expr, zero);
    6809                 :             :                         }
    6810                 :             :                     }
    6811                 :             : 
    6812                 :             :                   /* Wrap scalar variable in a descriptor. We need to convert
    6813                 :             :                      the address of a pointer back to the pointer itself before,
    6814                 :             :                      we can assign it to the data field.  */
    6815                 :             : 
    6816                 :      115947 :                   if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
    6817                 :        1143 :                       && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
    6818                 :             :                     {
    6819                 :        1107 :                       tmp = parmse.expr;
    6820                 :        1107 :                       if (TREE_CODE (tmp) == ADDR_EXPR)
    6821                 :         643 :                         tmp = TREE_OPERAND (tmp, 0);
    6822                 :        1107 :                       parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
    6823                 :             :                                                                    fsym->attr);
    6824                 :        1107 :                       parmse.expr = gfc_build_addr_expr (NULL_TREE,
    6825                 :             :                                                          parmse.expr);
    6826                 :             :                     }
    6827                 :      114840 :                   else if (fsym && e->expr_type != EXPR_NULL
    6828                 :      114747 :                       && ((fsym->attr.pointer
    6829                 :        1611 :                            && fsym->attr.flavor != FL_PROCEDURE)
    6830                 :      113142 :                           || (fsym->attr.proc_pointer
    6831                 :         154 :                               && !(e->expr_type == EXPR_VARIABLE
    6832                 :         154 :                                    && e->symtree->n.sym->attr.dummy))
    6833                 :      113000 :                           || (fsym->attr.proc_pointer
    6834                 :          12 :                               && e->expr_type == EXPR_VARIABLE
    6835                 :          12 :                               && gfc_is_proc_ptr_comp (e))
    6836                 :      112994 :                           || (fsym->attr.allocatable
    6837                 :         824 :                               && fsym->attr.flavor != FL_PROCEDURE)))
    6838                 :             :                     {
    6839                 :             :                       /* Scalar pointer dummy args require an extra level of
    6840                 :             :                          indirection. The null pointer already contains
    6841                 :             :                          this level of indirection.  */
    6842                 :        2571 :                       parm_kind = SCALAR_POINTER;
    6843                 :        2571 :                       parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
    6844                 :             :                     }
    6845                 :             :                 }
    6846                 :             :             }
    6847                 :       47716 :           else if (e->ts.type == BT_CLASS
    6848                 :        2282 :                     && fsym && fsym->ts.type == BT_CLASS
    6849                 :        2020 :                     && (CLASS_DATA (fsym)->attr.dimension
    6850                 :        2020 :                         || CLASS_DATA (fsym)->attr.codimension))
    6851                 :             :             {
    6852                 :             :               /* Pass a class array.  */
    6853                 :        2020 :               parmse.use_offset = 1;
    6854                 :        2020 :               gfc_conv_expr_descriptor (&parmse, e);
    6855                 :        2020 :               bool defer_to_dealloc_blk = false;
    6856                 :             : 
    6857                 :        2020 :               if (fsym->attr.optional
    6858                 :         774 :                   && e->expr_type == EXPR_VARIABLE
    6859                 :         774 :                   && e->symtree->n.sym->attr.optional)
    6860                 :             :                 {
    6861                 :         414 :                   stmtblock_t block;
    6862                 :             : 
    6863                 :         414 :                   gfc_init_block (&block);
    6864                 :         414 :                   gfc_add_block_to_block (&block, &parmse.pre);
    6865                 :             : 
    6866                 :         828 :                   tree t = fold_build3_loc (input_location, COND_EXPR,
    6867                 :             :                              void_type_node,
    6868                 :         414 :                              gfc_conv_expr_present (e->symtree->n.sym),
    6869                 :             :                                     gfc_finish_block (&block),
    6870                 :             :                                     build_empty_stmt (input_location));
    6871                 :             : 
    6872                 :         414 :                   gfc_add_expr_to_block (&parmse.pre, t);
    6873                 :             :                 }
    6874                 :             : 
    6875                 :             :               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
    6876                 :             :                  allocated on entry, it must be deallocated.  */
    6877                 :        2020 :               if (fsym->attr.intent == INTENT_OUT
    6878                 :         139 :                   && CLASS_DATA (fsym)->attr.allocatable)
    6879                 :             :                 {
    6880                 :         109 :                   stmtblock_t block;
    6881                 :         109 :                   tree ptr;
    6882                 :             : 
    6883                 :             :                   /* In case the data reference to deallocate is dependent on
    6884                 :             :                      its own content, save the resulting pointer to a variable
    6885                 :             :                      and only use that variable from now on, before the
    6886                 :             :                      expression becomes invalid.  */
    6887                 :         109 :                   parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
    6888                 :             :                                                            &parmse.pre);
    6889                 :             : 
    6890                 :         109 :                   if (parmse.class_container != NULL_TREE)
    6891                 :         109 :                     parmse.class_container
    6892                 :         109 :                         = gfc_evaluate_data_ref_now (parmse.class_container,
    6893                 :             :                                                      &parmse.pre);
    6894                 :             : 
    6895                 :         109 :                   gfc_init_block  (&block);
    6896                 :         109 :                   ptr = parmse.expr;
    6897                 :         109 :                   ptr = gfc_class_data_get (ptr);
    6898                 :             : 
    6899                 :         109 :                   tree cls = parmse.class_container;
    6900                 :         109 :                   tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
    6901                 :             :                                                     NULL_TREE, NULL_TREE,
    6902                 :             :                                                     NULL_TREE, true, e,
    6903                 :             :                                                     GFC_CAF_COARRAY_NOCOARRAY,
    6904                 :             :                                                     cls);
    6905                 :         109 :                   gfc_add_expr_to_block (&block, tmp);
    6906                 :         109 :                   tmp = fold_build2_loc (input_location, MODIFY_EXPR,
    6907                 :             :                                          void_type_node, ptr,
    6908                 :             :                                          null_pointer_node);
    6909                 :         109 :                   gfc_add_expr_to_block (&block, tmp);
    6910                 :         109 :                   gfc_reset_vptr (&block, e, parmse.class_container);
    6911                 :             : 
    6912                 :         109 :                   if (fsym->attr.optional
    6913                 :          30 :                       && e->expr_type == EXPR_VARIABLE
    6914                 :          30 :                       && (!e->ref
    6915                 :          30 :                           || (e->ref->type == REF_ARRAY
    6916                 :           0 :                               && e->ref->u.ar.type != AR_FULL))
    6917                 :           0 :                       && e->symtree->n.sym->attr.optional)
    6918                 :             :                     {
    6919                 :           0 :                       tmp = fold_build3_loc (input_location, COND_EXPR,
    6920                 :             :                                     void_type_node,
    6921                 :           0 :                                     gfc_conv_expr_present (e->symtree->n.sym),
    6922                 :             :                                     gfc_finish_block (&block),
    6923                 :             :                                     build_empty_stmt (input_location));
    6924                 :             :                     }
    6925                 :             :                   else
    6926                 :         109 :                     tmp = gfc_finish_block (&block);
    6927                 :             : 
    6928                 :         109 :                   gfc_add_expr_to_block (&dealloc_blk, tmp);
    6929                 :         109 :                   defer_to_dealloc_blk = true;
    6930                 :             :                 }
    6931                 :             : 
    6932                 :        2020 :               gfc_se class_se = parmse;
    6933                 :        2020 :               gfc_init_block (&class_se.pre);
    6934                 :        2020 :               gfc_init_block (&class_se.post);
    6935                 :             : 
    6936                 :             :               /* The conversion does not repackage the reference to a class
    6937                 :             :                  array - _data descriptor.  */
    6938                 :        2020 :               gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
    6939                 :        2020 :                                      fsym->attr.intent != INTENT_IN
    6940                 :        2020 :                                      && (CLASS_DATA (fsym)->attr.class_pointer
    6941                 :             :                                          || CLASS_DATA (fsym)->attr.allocatable),
    6942                 :        2020 :                                      fsym->attr.optional
    6943                 :         774 :                                      && e->expr_type == EXPR_VARIABLE
    6944                 :         774 :                                      && e->symtree->n.sym->attr.optional,
    6945                 :        2020 :                                      CLASS_DATA (fsym)->attr.class_pointer
    6946                 :        2020 :                                      || CLASS_DATA (fsym)->attr.allocatable);
    6947                 :             : 
    6948                 :        2020 :               parmse.expr = class_se.expr;
    6949                 :        4040 :               stmtblock_t *class_pre_block = defer_to_dealloc_blk
    6950                 :        2020 :                                              ? &dealloc_blk
    6951                 :             :                                              : &parmse.pre;
    6952                 :        2020 :               gfc_add_block_to_block (class_pre_block, &class_se.pre);
    6953                 :        2020 :               gfc_add_block_to_block (&parmse.post, &class_se.post);
    6954                 :        2020 :             }
    6955                 :             :           else
    6956                 :             :             {
    6957                 :             :               /* If the argument is a function call that may not create
    6958                 :             :                  a temporary for the result, we have to check that we
    6959                 :             :                  can do it, i.e. that there is no alias between this
    6960                 :             :                  argument and another one.  */
    6961                 :       45696 :               if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
    6962                 :             :                 {
    6963                 :         377 :                   gfc_expr *iarg;
    6964                 :         377 :                   sym_intent intent;
    6965                 :             : 
    6966                 :         377 :                   if (fsym != NULL)
    6967                 :         368 :                     intent = fsym->attr.intent;
    6968                 :             :                   else
    6969                 :             :                     intent = INTENT_UNKNOWN;
    6970                 :             : 
    6971                 :         377 :                   if (gfc_check_fncall_dependency (e, intent, sym, args,
    6972                 :             :                                                    NOT_ELEMENTAL))
    6973                 :          21 :                     parmse.force_tmp = 1;
    6974                 :             : 
    6975                 :         377 :                   iarg = e->value.function.actual->expr;
    6976                 :             : 
    6977                 :             :                   /* Temporary needed if aliasing due to host association.  */
    6978                 :         377 :                   if (sym->attr.contained
    6979                 :         114 :                         && !sym->attr.pure
    6980                 :         114 :                         && !sym->attr.implicit_pure
    6981                 :          36 :                         && !sym->attr.use_assoc
    6982                 :          36 :                         && iarg->expr_type == EXPR_VARIABLE
    6983                 :          36 :                         && sym->ns == iarg->symtree->n.sym->ns)
    6984                 :          36 :                     parmse.force_tmp = 1;
    6985                 :             : 
    6986                 :             :                   /* Ditto within module.  */
    6987                 :         377 :                   if (sym->attr.use_assoc
    6988                 :         377 :                         && !sym->attr.pure
    6989                 :           6 :                         && !sym->attr.implicit_pure
    6990                 :           0 :                         && iarg->expr_type == EXPR_VARIABLE
    6991                 :           0 :                         && sym->module == iarg->symtree->n.sym->module)
    6992                 :           0 :                     parmse.force_tmp = 1;
    6993                 :             :                 }
    6994                 :             : 
    6995                 :             :               /* Special case for assumed-rank arrays: when passing an
    6996                 :             :                  argument to a nonallocatable/nonpointer dummy, the bounds have
    6997                 :             :                  to be reset as otherwise a last-dim ubound of -1 is
    6998                 :             :                  indistinguishable from an assumed-size array in the callee.  */
    6999                 :       45696 :               if (!sym->attr.is_bind_c && e && fsym && fsym->as
    7000                 :       26461 :                   && fsym->as->type == AS_ASSUMED_RANK
    7001                 :        8077 :                   && e->rank != -1
    7002                 :        7800 :                   && e->expr_type == EXPR_VARIABLE
    7003                 :        7390 :                   && ((fsym->ts.type == BT_CLASS
    7004                 :           0 :                        && !CLASS_DATA (fsym)->attr.class_pointer
    7005                 :           0 :                        && !CLASS_DATA (fsym)->attr.allocatable)
    7006                 :        7390 :                       || (fsym->ts.type != BT_CLASS
    7007                 :        7390 :                           && !fsym->attr.pointer && !fsym->attr.allocatable)))
    7008                 :             :                 {
    7009                 :             :                   /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
    7010                 :        6943 :                   gfc_ref *ref;
    7011                 :        7189 :                   for (ref = e->ref; ref->next; ref = ref->next)
    7012                 :             :                     ;
    7013                 :        6943 :                   if (ref->u.ar.type == AR_FULL
    7014                 :        6127 :                       && ref->u.ar.as->type != AS_ASSUMED_SIZE)
    7015                 :        6019 :                     ref->u.ar.type = AR_SECTION;
    7016                 :             :                 }
    7017                 :             : 
    7018                 :       45696 :               if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
    7019                 :             :                 /* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
    7020                 :        5736 :                 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
    7021                 :             : 
    7022                 :       39960 :               else if (e->expr_type == EXPR_VARIABLE
    7023                 :       31640 :                     && is_subref_array (e)
    7024                 :       40476 :                     && !(fsym && fsym->attr.pointer))
    7025                 :             :                 /* The actual argument is a component reference to an
    7026                 :             :                    array of derived types.  In this case, the argument
    7027                 :             :                    is converted to a temporary, which is passed and then
    7028                 :             :                    written back after the procedure call.  */
    7029                 :         311 :                 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
    7030                 :         311 :                                 fsym ? fsym->attr.intent : INTENT_INOUT,
    7031                 :         311 :                                 fsym && fsym->attr.pointer);
    7032                 :             : 
    7033                 :       39649 :               else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
    7034                 :         261 :                        && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
    7035                 :          18 :                        && nodesc_arg && fsym->ts.type == BT_DERIVED)
    7036                 :             :                 /* An assumed size class actual argument being passed to
    7037                 :             :                    a 'no descriptor' formal argument just requires the
    7038                 :             :                    data pointer to be passed. For class dummy arguments
    7039                 :             :                    this is stored in the symbol backend decl..  */
    7040                 :           6 :                 parmse.expr = e->symtree->n.sym->backend_decl;
    7041                 :             : 
    7042                 :       39643 :               else if (gfc_is_class_array_ref (e, NULL)
    7043                 :       39643 :                        && fsym && fsym->ts.type == BT_DERIVED)
    7044                 :             :                 /* The actual argument is a component reference to an
    7045                 :             :                    array of derived types.  In this case, the argument
    7046                 :             :                    is converted to a temporary, which is passed and then
    7047                 :             :                    written back after the procedure call.
    7048                 :             :                    OOP-TODO: Insert code so that if the dynamic type is
    7049                 :             :                    the same as the declared type, copy-in/copy-out does
    7050                 :             :                    not occur.  */
    7051                 :         108 :                 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
    7052                 :         108 :                                            fsym->attr.intent,
    7053                 :         108 :                                            fsym->attr.pointer);
    7054                 :             : 
    7055                 :       39535 :               else if (gfc_is_class_array_function (e)
    7056                 :       39535 :                        && fsym && fsym->ts.type == BT_DERIVED)
    7057                 :             :                 /* See previous comment.  For function actual argument,
    7058                 :             :                    the write out is not needed so the intent is set as
    7059                 :             :                    intent in.  */
    7060                 :             :                 {
    7061                 :          13 :                   e->must_finalize = 1;
    7062                 :          13 :                   gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
    7063                 :          13 :                                              INTENT_IN, fsym->attr.pointer);
    7064                 :             :                 }
    7065                 :       35947 :               else if (fsym && fsym->attr.contiguous
    7066                 :        1590 :                        && !gfc_is_simply_contiguous (e, false, true)
    7067                 :       39831 :                        && gfc_expr_is_variable (e))
    7068                 :             :                 {
    7069                 :         297 :                   gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
    7070                 :         297 :                                              fsym->attr.intent,
    7071                 :         297 :                                              fsym->attr.pointer);
    7072                 :             :                 }
    7073                 :             :               else
    7074                 :             :                 /* This is where we introduce a temporary to store the
    7075                 :             :                    result of a non-lvalue array expression.  */
    7076                 :       39225 :                 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
    7077                 :             :                                           sym->name, NULL);
    7078                 :             : 
    7079                 :             :               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
    7080                 :             :                  allocated on entry, it must be deallocated.
    7081                 :             :                  CFI descriptors are handled elsewhere.  */
    7082                 :       42121 :               if (fsym && fsym->attr.allocatable
    7083                 :        1230 :                   && fsym->attr.intent == INTENT_OUT
    7084                 :       45451 :                   && !is_CFI_desc (fsym, NULL))
    7085                 :             :                 {
    7086                 :         131 :                   if (fsym->ts.type == BT_DERIVED
    7087                 :          44 :                       && fsym->ts.u.derived->attr.alloc_comp)
    7088                 :             :                   {
    7089                 :             :                     // deallocate the components first
    7090                 :           8 :                     tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
    7091                 :             :                                                      parmse.expr, e->rank);
    7092                 :             :                     /* But check whether dummy argument is optional.  */
    7093                 :           8 :                     if (tmp != NULL_TREE
    7094                 :           8 :                         && fsym->attr.optional
    7095                 :           6 :                         && e->expr_type == EXPR_VARIABLE
    7096                 :           6 :                         && e->symtree->n.sym->attr.optional)
    7097                 :             :                       {
    7098                 :           6 :                         tree present;
    7099                 :           6 :                         present = gfc_conv_expr_present (e->symtree->n.sym);
    7100                 :           6 :                         tmp = build3_v (COND_EXPR, present, tmp,
    7101                 :             :                                         build_empty_stmt (input_location));
    7102                 :             :                       }
    7103                 :           8 :                     if (tmp != NULL_TREE)
    7104                 :           8 :                       gfc_add_expr_to_block (&dealloc_blk, tmp);
    7105                 :             :                   }
    7106                 :             : 
    7107                 :         131 :                   tmp = parmse.expr;
    7108                 :             :                   /* With bind(C), the actual argument is replaced by a bind-C
    7109                 :             :                      descriptor; in this case, the data component arrives here,
    7110                 :             :                      which shall not be dereferenced, but still freed and
    7111                 :             :                      nullified.  */
    7112                 :         131 :                   if  (TREE_TYPE(tmp) != pvoid_type_node)
    7113                 :         131 :                     tmp = build_fold_indirect_ref_loc (input_location,
    7114                 :             :                                                        parmse.expr);
    7115                 :         131 :                   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
    7116                 :         131 :                     tmp = gfc_conv_descriptor_data_get (tmp);
    7117                 :         131 :                   tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
    7118                 :             :                                                     NULL_TREE, NULL_TREE, true,
    7119                 :             :                                                     e,
    7120                 :             :                                                     GFC_CAF_COARRAY_NOCOARRAY);
    7121                 :         131 :                   if (fsym->attr.optional
    7122                 :          36 :                       && e->expr_type == EXPR_VARIABLE
    7123                 :          36 :                       && e->symtree->n.sym->attr.optional)
    7124                 :          36 :                     tmp = fold_build3_loc (input_location, COND_EXPR,
    7125                 :             :                                      void_type_node,
    7126                 :          18 :                                      gfc_conv_expr_present (e->symtree->n.sym),
    7127                 :             :                                        tmp, build_empty_stmt (input_location));
    7128                 :         131 :                   gfc_add_expr_to_block (&dealloc_blk, tmp);
    7129                 :             :                 }
    7130                 :             :             }
    7131                 :             :         }
    7132                 :             :       /* Special case for an assumed-rank dummy argument. */
    7133                 :      232091 :       if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
    7134                 :       41901 :           && (fsym->ts.type == BT_CLASS
    7135                 :       41901 :               ? (CLASS_DATA (fsym)->as
    7136                 :        3673 :                  && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
    7137                 :       38228 :               : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
    7138                 :             :         {
    7139                 :        8799 :           if (fsym->ts.type == BT_CLASS
    7140                 :        8799 :               ? (CLASS_DATA (fsym)->attr.class_pointer
    7141                 :         999 :                  || CLASS_DATA (fsym)->attr.allocatable)
    7142                 :        7800 :               : (fsym->attr.pointer || fsym->attr.allocatable))
    7143                 :             :             {
    7144                 :             :               /* Unallocated allocatable arrays and unassociated pointer
    7145                 :             :                  arrays need their dtype setting if they are argument
    7146                 :             :                  associated with assumed rank dummies to set the rank.  */
    7147                 :         711 :               set_dtype_for_unallocated (&parmse, e);
    7148                 :             :             }
    7149                 :        8088 :           else if (e->expr_type == EXPR_VARIABLE
    7150                 :        7641 :                    && e->symtree->n.sym->attr.dummy
    7151                 :         560 :                    && (e->ts.type == BT_CLASS
    7152                 :         740 :                        ? (e->ref && e->ref->next
    7153                 :         180 :                           && e->ref->next->type == REF_ARRAY