LCOV - code coverage report
Current view: top level - gcc/fortran - trans-io.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 1188 1216 97.7 %
Date: 2020-03-28 11:57:23 Functions: 37 37 100.0 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* IO Code translation/library interface
       2                 :            :    Copyright (C) 2002-2020 Free Software Foundation, Inc.
       3                 :            :    Contributed by Paul Brook
       4                 :            : 
       5                 :            : This file is part of GCC.
       6                 :            : 
       7                 :            : GCC is free software; you can redistribute it and/or modify it under
       8                 :            : the terms of the GNU General Public License as published by the Free
       9                 :            : Software Foundation; either version 3, or (at your option) any later
      10                 :            : version.
      11                 :            : 
      12                 :            : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      13                 :            : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      14                 :            : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      15                 :            : for more details.
      16                 :            : 
      17                 :            : You should have received a copy of the GNU General Public License
      18                 :            : along with GCC; see the file COPYING3.  If not see
      19                 :            : <http://www.gnu.org/licenses/>.  */
      20                 :            : 
      21                 :            : 
      22                 :            : #include "config.h"
      23                 :            : #include "system.h"
      24                 :            : #include "coretypes.h"
      25                 :            : #include "tree.h"
      26                 :            : #include "gfortran.h"
      27                 :            : #include "trans.h"
      28                 :            : #include "stringpool.h"
      29                 :            : #include "fold-const.h"
      30                 :            : #include "stor-layout.h"
      31                 :            : #include "trans-stmt.h"
      32                 :            : #include "trans-array.h"
      33                 :            : #include "trans-types.h"
      34                 :            : #include "trans-const.h"
      35                 :            : #include "options.h"
      36                 :            : 
      37                 :            : /* Members of the ioparm structure.  */
      38                 :            : 
      39                 :            : enum ioparam_type
      40                 :            : {
      41                 :            :   IOPARM_ptype_common,
      42                 :            :   IOPARM_ptype_open,
      43                 :            :   IOPARM_ptype_close,
      44                 :            :   IOPARM_ptype_filepos,
      45                 :            :   IOPARM_ptype_inquire,
      46                 :            :   IOPARM_ptype_dt,
      47                 :            :   IOPARM_ptype_wait,
      48                 :            :   IOPARM_ptype_num
      49                 :            : };
      50                 :            : 
      51                 :            : enum iofield_type
      52                 :            : {
      53                 :            :   IOPARM_type_int4,
      54                 :            :   IOPARM_type_intio,
      55                 :            :   IOPARM_type_pint4,
      56                 :            :   IOPARM_type_pintio,
      57                 :            :   IOPARM_type_pchar,
      58                 :            :   IOPARM_type_parray,
      59                 :            :   IOPARM_type_pad,
      60                 :            :   IOPARM_type_char1,
      61                 :            :   IOPARM_type_char2,
      62                 :            :   IOPARM_type_common,
      63                 :            :   IOPARM_type_num
      64                 :            : };
      65                 :            : 
      66                 :            : typedef struct GTY(()) gfc_st_parameter_field {
      67                 :            :   const char *name;
      68                 :            :   unsigned int mask;
      69                 :            :   enum ioparam_type param_type;
      70                 :            :   enum iofield_type type;
      71                 :            :   tree field;
      72                 :            :   tree field_len;
      73                 :            : }
      74                 :            : gfc_st_parameter_field;
      75                 :            : 
      76                 :            : typedef struct GTY(()) gfc_st_parameter {
      77                 :            :   const char *name;
      78                 :            :   tree type;
      79                 :            : }
      80                 :            : gfc_st_parameter;
      81                 :            : 
      82                 :            : enum iofield
      83                 :            : {
      84                 :            : #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
      85                 :            : #include "ioparm.def"
      86                 :            : #undef IOPARM
      87                 :            :   IOPARM_field_num
      88                 :            : };
      89                 :            : 
      90                 :            : static GTY(()) gfc_st_parameter st_parameter[] =
      91                 :            : {
      92                 :            :   { "common", NULL },
      93                 :            :   { "open", NULL },
      94                 :            :   { "close", NULL },
      95                 :            :   { "filepos", NULL },
      96                 :            :   { "inquire", NULL },
      97                 :            :   { "dt", NULL },
      98                 :            :   { "wait", NULL }
      99                 :            : };
     100                 :            : 
     101                 :            : static GTY(()) gfc_st_parameter_field st_parameter_field[] =
     102                 :            : {
     103                 :            : #define IOPARM(param_type, name, mask, type) \
     104                 :            :   { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
     105                 :            : #include "ioparm.def"
     106                 :            : #undef IOPARM
     107                 :            :   { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL }
     108                 :            : };
     109                 :            : 
     110                 :            : /* Library I/O subroutines */
     111                 :            : 
     112                 :            : enum iocall
     113                 :            : {
     114                 :            :   IOCALL_READ,
     115                 :            :   IOCALL_READ_DONE,
     116                 :            :   IOCALL_WRITE,
     117                 :            :   IOCALL_WRITE_DONE,
     118                 :            :   IOCALL_X_INTEGER,
     119                 :            :   IOCALL_X_INTEGER_WRITE,
     120                 :            :   IOCALL_X_LOGICAL,
     121                 :            :   IOCALL_X_LOGICAL_WRITE,
     122                 :            :   IOCALL_X_CHARACTER,
     123                 :            :   IOCALL_X_CHARACTER_WRITE,
     124                 :            :   IOCALL_X_CHARACTER_WIDE,
     125                 :            :   IOCALL_X_CHARACTER_WIDE_WRITE,
     126                 :            :   IOCALL_X_REAL,
     127                 :            :   IOCALL_X_REAL_WRITE,
     128                 :            :   IOCALL_X_COMPLEX,
     129                 :            :   IOCALL_X_COMPLEX_WRITE,
     130                 :            :   IOCALL_X_REAL128,
     131                 :            :   IOCALL_X_REAL128_WRITE,
     132                 :            :   IOCALL_X_COMPLEX128,
     133                 :            :   IOCALL_X_COMPLEX128_WRITE,
     134                 :            :   IOCALL_X_ARRAY,
     135                 :            :   IOCALL_X_ARRAY_WRITE,
     136                 :            :   IOCALL_X_DERIVED,
     137                 :            :   IOCALL_OPEN,
     138                 :            :   IOCALL_CLOSE,
     139                 :            :   IOCALL_INQUIRE,
     140                 :            :   IOCALL_IOLENGTH,
     141                 :            :   IOCALL_IOLENGTH_DONE,
     142                 :            :   IOCALL_REWIND,
     143                 :            :   IOCALL_BACKSPACE,
     144                 :            :   IOCALL_ENDFILE,
     145                 :            :   IOCALL_FLUSH,
     146                 :            :   IOCALL_SET_NML_VAL,
     147                 :            :   IOCALL_SET_NML_DTIO_VAL,
     148                 :            :   IOCALL_SET_NML_VAL_DIM,
     149                 :            :   IOCALL_WAIT,
     150                 :            :   IOCALL_NUM
     151                 :            : };
     152                 :            : 
     153                 :            : static GTY(()) tree iocall[IOCALL_NUM];
     154                 :            : 
     155                 :            : /* Variable for keeping track of what the last data transfer statement
     156                 :            :    was.  Used for deciding which subroutine to call when the data
     157                 :            :    transfer is complete.  */
     158                 :            : static enum { READ, WRITE, IOLENGTH } last_dt;
     159                 :            : 
     160                 :            : /* The data transfer parameter block that should be shared by all
     161                 :            :    data transfer calls belonging to the same read/write/iolength.  */
     162                 :            : static GTY(()) tree dt_parm;
     163                 :            : static stmtblock_t *dt_post_end_block;
     164                 :            : 
     165                 :            : static void
     166                 :     176246 : gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
     167                 :            : {
     168                 :     176246 :   unsigned int type;
     169                 :     176246 :   gfc_st_parameter_field *p;
     170                 :     176246 :   char name[64];
     171                 :     176246 :   size_t len;
     172                 :     176246 :   tree t = make_node (RECORD_TYPE);
     173                 :     176246 :   tree *chain = NULL;
     174                 :            : 
     175                 :     176246 :   len = strlen (st_parameter[ptype].name);
     176                 :     176246 :   gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
     177                 :     176246 :   memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
     178                 :     176246 :   memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
     179                 :            :           len + 1);
     180                 :     176246 :   TYPE_NAME (t) = get_identifier (name);
     181                 :            : 
     182                 :   15685900 :   for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
     183                 :   15509600 :     if (p->param_type == ptype)
     184                 :    2215660 :       switch (p->type)
     185                 :            :         {
     186                 :     679806 :         case IOPARM_type_int4:
     187                 :     679806 :         case IOPARM_type_intio:
     188                 :     679806 :         case IOPARM_type_pint4:
     189                 :     679806 :         case IOPARM_type_pintio:
     190                 :     679806 :         case IOPARM_type_parray:
     191                 :     679806 :         case IOPARM_type_pchar:
     192                 :     679806 :         case IOPARM_type_pad:
     193                 :     679806 :           p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
     194                 :     679806 :                                               types[p->type], &chain);
     195                 :     679806 :           break;
     196                 :     730162 :         case IOPARM_type_char1:
     197                 :     730162 :           p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
     198                 :            :                                               pchar_type_node, &chain);
     199                 :            :           /* FALLTHROUGH */
     200                 :    1384790 :         case IOPARM_type_char2:
     201                 :    1384790 :           len = strlen (p->name);
     202                 :    1384790 :           gcc_assert (len <= sizeof (name) - sizeof ("_len"));
     203                 :    1384790 :           memcpy (name, p->name, len);
     204                 :    1384790 :           memcpy (name + len, "_len", sizeof ("_len"));
     205                 :    1384790 :           p->field_len = gfc_add_field_to_struct (t, get_identifier (name),
     206                 :            :                                                   gfc_charlen_type_node,
     207                 :            :                                                   &chain);
     208                 :    1384790 :           if (p->type == IOPARM_type_char2)
     209                 :     654628 :             p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
     210                 :            :                                                 pchar_type_node, &chain);
     211                 :            :           break;
     212                 :     151068 :         case IOPARM_type_common:
     213                 :     151068 :           p->field
     214                 :     151068 :             = gfc_add_field_to_struct (t,
     215                 :            :                                        get_identifier (p->name),
     216                 :            :                                        st_parameter[IOPARM_ptype_common].type,
     217                 :            :                                        &chain);
     218                 :     151068 :           break;
     219                 :          0 :         case IOPARM_type_num:
     220                 :          0 :           gcc_unreachable ();
     221                 :            :         }
     222                 :            : 
     223                 :            :   /* -Wpadded warnings on these artificially created structures are not
     224                 :            :      helpful; suppress them. */
     225                 :     176246 :   int save_warn_padded = warn_padded;
     226                 :     176246 :   warn_padded = 0;
     227                 :     176246 :   gfc_finish_type (t);
     228                 :     176246 :   warn_padded = save_warn_padded;
     229                 :     176246 :   st_parameter[ptype].type = t;
     230                 :     176246 : }
     231                 :            : 
     232                 :            : 
     233                 :            : /* Build code to test an error condition and call generate_error if needed.
     234                 :            :    Note: This builds calls to generate_error in the runtime library function.
     235                 :            :    The function generate_error is dependent on certain parameters in the
     236                 :            :    st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
     237                 :            :    Therefore, the code to set these flags must be generated before
     238                 :            :    this function is used.  */
     239                 :            : 
     240                 :            : static void
     241                 :        232 : gfc_trans_io_runtime_check (bool has_iostat, tree cond, tree var,
     242                 :            :                             int error_code, const char * msgid,
     243                 :            :                             stmtblock_t * pblock)
     244                 :            : {
     245                 :        232 :   stmtblock_t block;
     246                 :        232 :   tree body;
     247                 :        232 :   tree tmp;
     248                 :        232 :   tree arg1, arg2, arg3;
     249                 :        232 :   char *message;
     250                 :            : 
     251                 :        232 :   if (integer_zerop (cond))
     252                 :        124 :     return;
     253                 :            : 
     254                 :            :   /* The code to generate the error.  */
     255                 :        108 :   gfc_start_block (&block);
     256                 :            : 
     257                 :        108 :   if (has_iostat)
     258                 :         36 :     gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_FAIL_IO,
     259                 :            :                                                        NOT_TAKEN));
     260                 :            :   else
     261                 :         72 :     gfc_add_expr_to_block (&block, build_predict_expr (PRED_NORETURN,
     262                 :            :                                                        NOT_TAKEN));
     263                 :            : 
     264                 :        108 :   arg1 = gfc_build_addr_expr (NULL_TREE, var);
     265                 :            : 
     266                 :        108 :   arg2 = build_int_cst (integer_type_node, error_code),
     267                 :            : 
     268                 :        108 :   message = xasprintf ("%s", _(msgid));
     269                 :        108 :   arg3 = gfc_build_addr_expr (pchar_type_node,
     270                 :            :                               gfc_build_localized_cstring_const (message));
     271                 :        108 :   free (message);
     272                 :            : 
     273                 :        108 :   tmp = build_call_expr_loc (input_location,
     274                 :            :                          gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
     275                 :            : 
     276                 :        108 :   gfc_add_expr_to_block (&block, tmp);
     277                 :            : 
     278                 :        108 :   body = gfc_finish_block (&block);
     279                 :            : 
     280                 :        108 :   if (integer_onep (cond))
     281                 :            :     {
     282                 :         18 :       gfc_add_expr_to_block (pblock, body);
     283                 :            :     }
     284                 :            :   else
     285                 :            :     {
     286                 :         90 :       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
     287                 :         90 :       gfc_add_expr_to_block (pblock, tmp);
     288                 :            :     }
     289                 :            : }
     290                 :            : 
     291                 :            : 
     292                 :            : /* Create function decls for IO library functions.  */
     293                 :            : 
     294                 :            : void
     295                 :      25178 : gfc_build_io_library_fndecls (void)
     296                 :            : {
     297                 :      25178 :   tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
     298                 :      25178 :   tree gfc_intio_type_node;
     299                 :      25178 :   tree parm_type, dt_parm_type;
     300                 :      25178 :   HOST_WIDE_INT pad_size;
     301                 :      25178 :   unsigned int ptype;
     302                 :            : 
     303                 :      25178 :   types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
     304                 :      50356 :   types[IOPARM_type_intio] = gfc_intio_type_node
     305                 :      25178 :                             = gfc_get_int_type (gfc_intio_kind);
     306                 :      25178 :   types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
     307                 :      25178 :   types[IOPARM_type_pintio]
     308                 :      25178 :                             = build_pointer_type (gfc_intio_type_node);
     309                 :      25178 :   types[IOPARM_type_parray] = pchar_type_node;
     310                 :      25178 :   types[IOPARM_type_pchar] = pchar_type_node;
     311                 :      25178 :   pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
     312                 :      25178 :   pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
     313                 :      25178 :   pad_idx = build_index_type (size_int (pad_size - 1));
     314                 :      25178 :   types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
     315                 :            : 
     316                 :            :   /* pad actually contains pointers and integers so it needs to have an
     317                 :            :      alignment that is at least as large as the needed alignment for those
     318                 :            :      types.  See the st_parameter_dt structure in libgfortran/io/io.h for
     319                 :            :      what really goes into this space.  */
     320                 :      25178 :   SET_TYPE_ALIGN (types[IOPARM_type_pad], MAX (TYPE_ALIGN (pchar_type_node),
     321                 :            :                      TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind))));
     322                 :            : 
     323                 :     201424 :   for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
     324                 :     176246 :     gfc_build_st_parameter ((enum ioparam_type) ptype, types);
     325                 :            : 
     326                 :            :   /* Define the transfer functions.  */
     327                 :            : 
     328                 :      25178 :   dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
     329                 :            : 
     330                 :      25178 :   iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec (
     331                 :            :         get_identifier (PREFIX("transfer_integer")), ".wW",
     332                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     333                 :            : 
     334                 :      25178 :   iocall[IOCALL_X_INTEGER_WRITE] = gfc_build_library_function_decl_with_spec (
     335                 :            :         get_identifier (PREFIX("transfer_integer_write")), ".wR",
     336                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     337                 :            : 
     338                 :      25178 :   iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec (
     339                 :            :         get_identifier (PREFIX("transfer_logical")), ".wW",
     340                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     341                 :            : 
     342                 :      25178 :   iocall[IOCALL_X_LOGICAL_WRITE] = gfc_build_library_function_decl_with_spec (
     343                 :            :         get_identifier (PREFIX("transfer_logical_write")), ".wR",
     344                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     345                 :            : 
     346                 :      25178 :   iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec (
     347                 :            :         get_identifier (PREFIX("transfer_character")), ".wW",
     348                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_type_node);
     349                 :            : 
     350                 :      25178 :   iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec (
     351                 :            :         get_identifier (PREFIX("transfer_character_write")), ".wR",
     352                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_type_node);
     353                 :            : 
     354                 :      25178 :   iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec (
     355                 :            :         get_identifier (PREFIX("transfer_character_wide")), ".wW",
     356                 :            :         void_type_node, 4, dt_parm_type, pvoid_type_node,
     357                 :            :         gfc_charlen_type_node, gfc_int4_type_node);
     358                 :            : 
     359                 :      50356 :   iocall[IOCALL_X_CHARACTER_WIDE_WRITE] =
     360                 :      25178 :     gfc_build_library_function_decl_with_spec (
     361                 :            :         get_identifier (PREFIX("transfer_character_wide_write")), ".wR",
     362                 :            :         void_type_node, 4, dt_parm_type, pvoid_type_node,
     363                 :            :         gfc_charlen_type_node, gfc_int4_type_node);
     364                 :            : 
     365                 :      25178 :   iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec (
     366                 :            :         get_identifier (PREFIX("transfer_real")), ".wW",
     367                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     368                 :            : 
     369                 :      25178 :   iocall[IOCALL_X_REAL_WRITE] = gfc_build_library_function_decl_with_spec (
     370                 :            :         get_identifier (PREFIX("transfer_real_write")), ".wR",
     371                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     372                 :            : 
     373                 :      25178 :   iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec (
     374                 :            :         get_identifier (PREFIX("transfer_complex")), ".wW",
     375                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     376                 :            : 
     377                 :      25178 :   iocall[IOCALL_X_COMPLEX_WRITE] = gfc_build_library_function_decl_with_spec (
     378                 :            :         get_identifier (PREFIX("transfer_complex_write")), ".wR",
     379                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     380                 :            : 
     381                 :            :   /* Version for __float128.  */
     382                 :      25178 :   iocall[IOCALL_X_REAL128] = gfc_build_library_function_decl_with_spec (
     383                 :            :         get_identifier (PREFIX("transfer_real128")), ".wW",
     384                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     385                 :            : 
     386                 :      25178 :   iocall[IOCALL_X_REAL128_WRITE] = gfc_build_library_function_decl_with_spec (
     387                 :            :         get_identifier (PREFIX("transfer_real128_write")), ".wR",
     388                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     389                 :            : 
     390                 :      25178 :   iocall[IOCALL_X_COMPLEX128] = gfc_build_library_function_decl_with_spec (
     391                 :            :         get_identifier (PREFIX("transfer_complex128")), ".wW",
     392                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     393                 :            : 
     394                 :      25178 :   iocall[IOCALL_X_COMPLEX128_WRITE] = gfc_build_library_function_decl_with_spec (
     395                 :            :         get_identifier (PREFIX("transfer_complex128_write")), ".wR",
     396                 :            :         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
     397                 :            : 
     398                 :      25178 :   iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec (
     399                 :            :         get_identifier (PREFIX("transfer_array")), ".ww",
     400                 :            :         void_type_node, 4, dt_parm_type, pvoid_type_node,
     401                 :            :         integer_type_node, gfc_charlen_type_node);
     402                 :            : 
     403                 :      25178 :   iocall[IOCALL_X_ARRAY_WRITE] = gfc_build_library_function_decl_with_spec (
     404                 :            :         get_identifier (PREFIX("transfer_array_write")), ".wr",
     405                 :            :         void_type_node, 4, dt_parm_type, pvoid_type_node,
     406                 :            :         integer_type_node, gfc_charlen_type_node);
     407                 :            : 
     408                 :      25178 :   iocall[IOCALL_X_DERIVED] = gfc_build_library_function_decl_with_spec (
     409                 :            :         get_identifier (PREFIX("transfer_derived")), ".wrR",
     410                 :            :         void_type_node, 2, dt_parm_type, pvoid_type_node, pchar_type_node);
     411                 :            : 
     412                 :            :   /* Library entry points */
     413                 :            : 
     414                 :      25178 :   iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
     415                 :            :         get_identifier (PREFIX("st_read")), ".w",
     416                 :            :         void_type_node, 1, dt_parm_type);
     417                 :            : 
     418                 :      25178 :   iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec (
     419                 :            :         get_identifier (PREFIX("st_write")), ".w",
     420                 :            :         void_type_node, 1, dt_parm_type);
     421                 :            : 
     422                 :      25178 :   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
     423                 :      25178 :   iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec (
     424                 :            :         get_identifier (PREFIX("st_open")), ".w",
     425                 :            :         void_type_node, 1, parm_type);
     426                 :            : 
     427                 :      25178 :   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
     428                 :      25178 :   iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec (
     429                 :            :         get_identifier (PREFIX("st_close")), ".w",
     430                 :            :         void_type_node, 1, parm_type);
     431                 :            : 
     432                 :      25178 :   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
     433                 :      25178 :   iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec (
     434                 :            :         get_identifier (PREFIX("st_inquire")), ".w",
     435                 :            :         void_type_node, 1, parm_type);
     436                 :            : 
     437                 :      25178 :   iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec(
     438                 :            :         get_identifier (PREFIX("st_iolength")), ".w",
     439                 :            :         void_type_node, 1, dt_parm_type);
     440                 :            : 
     441                 :      25178 :   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
     442                 :      25178 :   iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
     443                 :            :         get_identifier (PREFIX("st_wait_async")), ".w",
     444                 :            :         void_type_node, 1, parm_type);
     445                 :            : 
     446                 :      25178 :   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
     447                 :      25178 :   iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec (
     448                 :            :         get_identifier (PREFIX("st_rewind")), ".w",
     449                 :            :         void_type_node, 1, parm_type);
     450                 :            : 
     451                 :      25178 :   iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec (
     452                 :            :         get_identifier (PREFIX("st_backspace")), ".w",
     453                 :            :         void_type_node, 1, parm_type);
     454                 :            : 
     455                 :      25178 :   iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec (
     456                 :            :         get_identifier (PREFIX("st_endfile")), ".w",
     457                 :            :         void_type_node, 1, parm_type);
     458                 :            : 
     459                 :      25178 :   iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec (
     460                 :            :         get_identifier (PREFIX("st_flush")), ".w",
     461                 :            :         void_type_node, 1, parm_type);
     462                 :            : 
     463                 :            :   /* Library helpers */
     464                 :            : 
     465                 :      25178 :   iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec (
     466                 :            :         get_identifier (PREFIX("st_read_done")), ".w",
     467                 :            :         void_type_node, 1, dt_parm_type);
     468                 :            : 
     469                 :      25178 :   iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec (
     470                 :            :         get_identifier (PREFIX("st_write_done")), ".w",
     471                 :            :         void_type_node, 1, dt_parm_type);
     472                 :            : 
     473                 :      25178 :   iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec (
     474                 :            :         get_identifier (PREFIX("st_iolength_done")), ".w",
     475                 :            :         void_type_node, 1, dt_parm_type);
     476                 :            : 
     477                 :      25178 :   iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
     478                 :            :         get_identifier (PREFIX("st_set_nml_var")), ".w.R",
     479                 :            :         void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
     480                 :            :         gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node());
     481                 :            : 
     482                 :      25178 :   iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec (
     483                 :            :         get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R",
     484                 :            :         void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node,
     485                 :            :         gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node(),
     486                 :            :         pvoid_type_node, pvoid_type_node);
     487                 :            : 
     488                 :      25178 :   iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
     489                 :            :         get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
     490                 :            :         void_type_node, 5, dt_parm_type, gfc_int4_type_node,
     491                 :            :         gfc_array_index_type, gfc_array_index_type, gfc_array_index_type);
     492                 :      25178 : }
     493                 :            : 
     494                 :            : 
     495                 :            : static void
     496                 :      82755 : set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value)
     497                 :            : {
     498                 :      82755 :   tree tmp;
     499                 :      82755 :   gfc_st_parameter_field *p = &st_parameter_field[type];
     500                 :            : 
     501                 :      82755 :   if (p->param_type == IOPARM_ptype_common)
     502                 :      78401 :     var = fold_build3_loc (input_location, COMPONENT_REF,
     503                 :            :                            st_parameter[IOPARM_ptype_common].type,
     504                 :      78401 :                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
     505                 :      82755 :   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
     506                 :            :                          var, p->field, NULL_TREE);
     507                 :      82755 :   gfc_add_modify (block, tmp, value);
     508                 :      82755 : }
     509                 :            : 
     510                 :            : 
     511                 :            : /* Generate code to store an integer constant into the
     512                 :            :    st_parameter_XXX structure.  */
     513                 :            : 
     514                 :            : static unsigned int
     515                 :      80019 : set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
     516                 :            :                      unsigned int val)
     517                 :            : {
     518                 :      80019 :   gfc_st_parameter_field *p = &st_parameter_field[type];
     519                 :            : 
     520                 :     160038 :   set_parameter_tree (block, var, type,
     521                 :      80019 :                       build_int_cst (TREE_TYPE (p->field), val));
     522                 :      80019 :   return p->mask;
     523                 :            : }
     524                 :            : 
     525                 :            : 
     526                 :            : /* Generate code to store a non-string I/O parameter into the
     527                 :            :    st_parameter_XXX structure.  This is a pass by value.  */
     528                 :            : 
     529                 :            : static unsigned int
     530                 :       1464 : set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
     531                 :            :                      gfc_expr *e)
     532                 :            : {
     533                 :       1464 :   gfc_se se;
     534                 :       1464 :   tree tmp;
     535                 :       1464 :   gfc_st_parameter_field *p = &st_parameter_field[type];
     536                 :       1464 :   tree dest_type = TREE_TYPE (p->field);
     537                 :            : 
     538                 :       1464 :   gfc_init_se (&se, NULL);
     539                 :       1464 :   gfc_conv_expr_val (&se, e);
     540                 :            : 
     541                 :       1464 :   se.expr = convert (dest_type, se.expr);
     542                 :       1464 :   gfc_add_block_to_block (block, &se.pre);
     543                 :            : 
     544                 :       1464 :   if (p->param_type == IOPARM_ptype_common)
     545                 :        564 :     var = fold_build3_loc (input_location, COMPONENT_REF,
     546                 :            :                            st_parameter[IOPARM_ptype_common].type,
     547                 :        564 :                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
     548                 :            : 
     549                 :       1464 :   tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
     550                 :            :                          p->field, NULL_TREE);
     551                 :       1464 :   gfc_add_modify (block, tmp, se.expr);
     552                 :       1464 :   return p->mask;
     553                 :            : }
     554                 :            : 
     555                 :            : 
     556                 :            : /* Similar to set_parameter_value except generate runtime
     557                 :            :    error checks.  */
     558                 :            : 
     559                 :            : static unsigned int
     560                 :      25097 : set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var,
     561                 :            :                      enum iofield type, gfc_expr *e)
     562                 :            : {
     563                 :      25097 :   gfc_se se;
     564                 :      25097 :   tree tmp;
     565                 :      25097 :   gfc_st_parameter_field *p = &st_parameter_field[type];
     566                 :      25097 :   tree dest_type = TREE_TYPE (p->field);
     567                 :            : 
     568                 :      25097 :   gfc_init_se (&se, NULL);
     569                 :      25097 :   gfc_conv_expr_val (&se, e);
     570                 :            : 
     571                 :            :   /* If we're storing a UNIT number, we need to check it first.  */
     572                 :      25097 :   if (type == IOPARM_common_unit && e->ts.kind > 4)
     573                 :            :     {
     574                 :        116 :       tree cond, val;
     575                 :        116 :       int i;
     576                 :            : 
     577                 :            :       /* Don't evaluate the UNIT number multiple times.  */
     578                 :        116 :       se.expr = gfc_evaluate_now (se.expr, &se.pre);
     579                 :            : 
     580                 :            :       /* UNIT numbers should be greater than the min.  */
     581                 :        116 :       i = gfc_validate_kind (BT_INTEGER, 4, false);
     582                 :        116 :       val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
     583                 :        116 :       cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
     584                 :            :                               se.expr,
     585                 :        116 :                               fold_convert (TREE_TYPE (se.expr), val));
     586                 :        116 :       gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
     587                 :            :                                   "Unit number in I/O statement too small",
     588                 :            :                                   &se.pre);
     589                 :            : 
     590                 :            :       /* UNIT numbers should be less than the max.  */
     591                 :        116 :       val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
     592                 :        116 :       cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
     593                 :            :                               se.expr,
     594                 :        116 :                               fold_convert (TREE_TYPE (se.expr), val));
     595                 :        116 :       gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
     596                 :            :                                   "Unit number in I/O statement too large",
     597                 :            :                                   &se.pre);
     598                 :            :     }
     599                 :            : 
     600                 :      25097 :   se.expr = convert (dest_type, se.expr);
     601                 :      25097 :   gfc_add_block_to_block (block, &se.pre);
     602                 :            : 
     603                 :      25097 :   if (p->param_type == IOPARM_ptype_common)
     604                 :      25097 :     var = fold_build3_loc (input_location, COMPONENT_REF,
     605                 :            :                            st_parameter[IOPARM_ptype_common].type,
     606                 :      25097 :                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
     607                 :            : 
     608                 :      25097 :   tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
     609                 :            :                          p->field, NULL_TREE);
     610                 :      25097 :   gfc_add_modify (block, tmp, se.expr);
     611                 :      25097 :   return p->mask;
     612                 :            : }
     613                 :            : 
     614                 :            : 
     615                 :            : /* Build code to check the unit range if KIND=8 is used.  Similar to
     616                 :            :    set_parameter_value_chk but we do not generate error calls for
     617                 :            :    inquire statements.  */
     618                 :            : 
     619                 :            : static unsigned int
     620                 :        564 : set_parameter_value_inquire (stmtblock_t *block, tree var,
     621                 :            :                              enum iofield type, gfc_expr *e)
     622                 :            : {
     623                 :        564 :   gfc_se se;
     624                 :        564 :   gfc_st_parameter_field *p = &st_parameter_field[type];
     625                 :        564 :   tree dest_type = TREE_TYPE (p->field);
     626                 :            : 
     627                 :        564 :   gfc_init_se (&se, NULL);
     628                 :        564 :   gfc_conv_expr_val (&se, e);
     629                 :            : 
     630                 :            :   /* If we're inquiring on a UNIT number, we need to check to make
     631                 :            :      sure it exists for larger than kind = 4.  */
     632                 :        564 :   if (type == IOPARM_common_unit && e->ts.kind > 4)
     633                 :            :     {
     634                 :         24 :       stmtblock_t newblock;
     635                 :         24 :       tree cond1, cond2, cond3, val, body;
     636                 :         24 :       int i;
     637                 :            : 
     638                 :            :       /* Don't evaluate the UNIT number multiple times.  */
     639                 :         24 :       se.expr = gfc_evaluate_now (se.expr, &se.pre);
     640                 :            : 
     641                 :            :       /* UNIT numbers should be greater than the min.  */
     642                 :         24 :       i = gfc_validate_kind (BT_INTEGER, 4, false);
     643                 :         24 :       val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
     644                 :         24 :       cond1 = build2_loc (input_location, LT_EXPR, logical_type_node,
     645                 :            :                           se.expr,
     646                 :         24 :                           fold_convert (TREE_TYPE (se.expr), val));
     647                 :            :       /* UNIT numbers should be less than the max.  */
     648                 :         24 :       val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
     649                 :         24 :       cond2 = build2_loc (input_location, GT_EXPR, logical_type_node,
     650                 :            :                           se.expr,
     651                 :         24 :                           fold_convert (TREE_TYPE (se.expr), val));
     652                 :         24 :       cond3 = build2_loc (input_location, TRUTH_OR_EXPR,
     653                 :            :                           logical_type_node, cond1, cond2);
     654                 :            : 
     655                 :         24 :       gfc_start_block (&newblock);
     656                 :            : 
     657                 :            :       /* The unit number GFC_INVALID_UNIT is reserved.  No units can
     658                 :            :          ever have this value.  It is used here to signal to the
     659                 :            :          runtime library that the inquire unit number is outside the
     660                 :            :          allowable range and so cannot exist.  It is needed when
     661                 :            :          -fdefault-integer-8 is used.  */
     662                 :         24 :       set_parameter_const (&newblock, var, IOPARM_common_unit,
     663                 :            :                            GFC_INVALID_UNIT);
     664                 :            : 
     665                 :         24 :       body = gfc_finish_block (&newblock);
     666                 :            : 
     667                 :         24 :       cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
     668                 :         24 :       var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
     669                 :         24 :       gfc_add_expr_to_block (&se.pre, var);
     670                 :            :     }
     671                 :            : 
     672                 :        564 :   se.expr = convert (dest_type, se.expr);
     673                 :        564 :   gfc_add_block_to_block (block, &se.pre);
     674                 :            : 
     675                 :        564 :   return p->mask;
     676                 :            : }
     677                 :            : 
     678                 :            : 
     679                 :            : /* Generate code to store a non-string I/O parameter into the
     680                 :            :    st_parameter_XXX structure.  This is pass by reference.  */
     681                 :            : 
     682                 :            : static unsigned int
     683                 :       2736 : set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
     684                 :            :                    tree var, enum iofield type, gfc_expr *e)
     685                 :            : {
     686                 :       2736 :   gfc_se se;
     687                 :       2736 :   tree tmp, addr;
     688                 :       2736 :   gfc_st_parameter_field *p = &st_parameter_field[type];
     689                 :            : 
     690                 :       2736 :   gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
     691                 :       2736 :   gfc_init_se (&se, NULL);
     692                 :       2736 :   gfc_conv_expr_lhs (&se, e);
     693                 :            : 
     694                 :       2736 :   gfc_add_block_to_block (block, &se.pre);
     695                 :            : 
     696                 :       5472 :   if (TYPE_MODE (TREE_TYPE (se.expr))
     697                 :       2736 :       == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
     698                 :            :     {
     699                 :       2332 :       addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
     700                 :            : 
     701                 :            :       /* If this is for the iostat variable initialize the
     702                 :            :          user variable to LIBERROR_OK which is zero.  */
     703                 :       2332 :       if (type == IOPARM_common_iostat)
     704                 :       1790 :         gfc_add_modify (block, se.expr,
     705                 :       1790 :                              build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
     706                 :            :     }
     707                 :            :   else
     708                 :            :     {
     709                 :            :       /* The type used by the library has different size
     710                 :            :         from the type of the variable supplied by the user.
     711                 :            :         Need to use a temporary.  */
     712                 :        404 :       tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
     713                 :            :                                     st_parameter_field[type].name);
     714                 :            : 
     715                 :            :       /* If this is for the iostat variable, initialize the
     716                 :            :          user variable to LIBERROR_OK which is zero.  */
     717                 :        404 :       if (type == IOPARM_common_iostat)
     718                 :         26 :         gfc_add_modify (block, tmpvar,
     719                 :         26 :                              build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
     720                 :            : 
     721                 :        404 :       addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
     722                 :            :         /* After the I/O operation, we set the variable from the temporary.  */
     723                 :        404 :       tmp = convert (TREE_TYPE (se.expr), tmpvar);
     724                 :        404 :       gfc_add_modify (postblock, se.expr, tmp);
     725                 :            :      }
     726                 :            : 
     727                 :       2736 :   set_parameter_tree (block, var, type, addr);
     728                 :       2736 :   return p->mask;
     729                 :            : }
     730                 :            : 
     731                 :            : /* Given an array expr, find its address and length to get a string. If the
     732                 :            :    array is full, the string's address is the address of array's first element
     733                 :            :    and the length is the size of the whole array.  If it is an element, the
     734                 :            :    string's address is the element's address and the length is the rest size of
     735                 :            :    the array.  */
     736                 :            : 
     737                 :            : static void
     738                 :        107 : gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
     739                 :            : {
     740                 :        107 :   tree size;
     741                 :            : 
     742                 :        107 :   if (e->rank == 0)
     743                 :            :     {
     744                 :         25 :       tree type, array, tmp;
     745                 :         25 :       gfc_symbol *sym;
     746                 :         25 :       int rank;
     747                 :            : 
     748                 :            :       /* If it is an element, we need its address and size of the rest.  */
     749                 :         25 :       gcc_assert (e->expr_type == EXPR_VARIABLE);
     750                 :         25 :       gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
     751                 :         25 :       sym = e->symtree->n.sym;
     752                 :         25 :       rank = sym->as->rank - 1;
     753                 :         25 :       gfc_conv_expr (se, e);
     754                 :            : 
     755                 :         25 :       array = sym->backend_decl;
     756                 :         25 :       type = TREE_TYPE (array);
     757                 :            : 
     758                 :         25 :       if (GFC_ARRAY_TYPE_P (type))
     759                 :         19 :         size = GFC_TYPE_ARRAY_SIZE (type);
     760                 :            :       else
     761                 :            :         {
     762                 :          6 :           gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
     763                 :          6 :           size = gfc_conv_array_stride (array, rank);
     764                 :          6 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
     765                 :            :                                  gfc_array_index_type,
     766                 :            :                                  gfc_conv_array_ubound (array, rank),
     767                 :            :                                  gfc_conv_array_lbound (array, rank));
     768                 :          6 :           tmp = fold_build2_loc (input_location, PLUS_EXPR,
     769                 :            :                                  gfc_array_index_type, tmp,
     770                 :            :                                  gfc_index_one_node);
     771                 :          6 :           size = fold_build2_loc (input_location, MULT_EXPR,
     772                 :            :                                   gfc_array_index_type, tmp, size);
     773                 :            :         }
     774                 :         25 :       gcc_assert (size);
     775                 :            : 
     776                 :         25 :       size = fold_build2_loc (input_location, MINUS_EXPR,
     777                 :            :                               gfc_array_index_type, size,
     778                 :         25 :                               TREE_OPERAND (se->expr, 1));
     779                 :         25 :       se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
     780                 :         25 :       tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
     781                 :         25 :       size = fold_build2_loc (input_location, MULT_EXPR,
     782                 :            :                               gfc_array_index_type, size,
     783                 :            :                               fold_convert (gfc_array_index_type, tmp));
     784                 :         25 :       se->string_length = fold_convert (gfc_charlen_type_node, size);
     785                 :         25 :       return;
     786                 :            :     }
     787                 :            : 
     788                 :         82 :   gfc_conv_array_parameter (se, e, true, NULL, NULL, &size);
     789                 :         82 :   se->string_length = fold_convert (gfc_charlen_type_node, size);
     790                 :            : }
     791                 :            : 
     792                 :            : 
     793                 :            : /* Generate code to store a string and its length into the
     794                 :            :    st_parameter_XXX structure.  */
     795                 :            : 
     796                 :            : static unsigned int
     797                 :      21802 : set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
     798                 :            :             enum iofield type, gfc_expr * e)
     799                 :            : {
     800                 :      21802 :   gfc_se se;
     801                 :      21802 :   tree tmp;
     802                 :      21802 :   tree io;
     803                 :      21802 :   tree len;
     804                 :      21802 :   gfc_st_parameter_field *p = &st_parameter_field[type];
     805                 :            : 
     806                 :      21802 :   gfc_init_se (&se, NULL);
     807                 :            : 
     808                 :      21802 :   if (p->param_type == IOPARM_ptype_common)
     809                 :        453 :     var = fold_build3_loc (input_location, COMPONENT_REF,
     810                 :            :                            st_parameter[IOPARM_ptype_common].type,
     811                 :        453 :                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
     812                 :      21802 :   io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
     813                 :            :                     var, p->field, NULL_TREE);
     814                 :      65406 :   len = fold_build3_loc (input_location, COMPONENT_REF,
     815                 :      21802 :                          TREE_TYPE (p->field_len),
     816                 :            :                          var, p->field_len, NULL_TREE);
     817                 :            : 
     818                 :            :   /* Integer variable assigned a format label.  */
     819                 :      21802 :   if (e->ts.type == BT_INTEGER
     820                 :         25 :       && e->rank == 0
     821                 :         19 :       && e->symtree->n.sym->attr.assign == 1)
     822                 :            :     {
     823                 :          1 :       char * msg;
     824                 :          1 :       tree cond;
     825                 :            : 
     826                 :          1 :       gfc_conv_label_variable (&se, e);
     827                 :          1 :       tmp = GFC_DECL_STRING_LEN (se.expr);
     828                 :          1 :       cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
     829                 :          1 :                               tmp, build_int_cst (TREE_TYPE (tmp), 0));
     830                 :            : 
     831                 :          2 :       msg = xasprintf ("Label assigned to variable '%s' (%%ld) is not a format "
     832                 :          1 :                        "label", e->symtree->name);
     833                 :          1 :       gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
     834                 :            :                                fold_convert (long_integer_type_node, tmp));
     835                 :          1 :       free (msg);
     836                 :            : 
     837                 :          1 :       gfc_add_modify (&se.pre, io,
     838                 :          1 :                  fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
     839                 :          1 :       gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
     840                 :            :     }
     841                 :            :   else
     842                 :            :     {
     843                 :            :       /* General character.  */
     844                 :      21801 :       if (e->ts.type == BT_CHARACTER && e->rank == 0)
     845                 :      21694 :         gfc_conv_expr (&se, e);
     846                 :            :       /* Array assigned Hollerith constant or character array.  */
     847                 :        107 :       else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
     848                 :        107 :         gfc_convert_array_to_string (&se, e);
     849                 :            :       else
     850                 :          0 :         gcc_unreachable ();
     851                 :            : 
     852                 :      21801 :       gfc_conv_string_parameter (&se);
     853                 :      21801 :       gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
     854                 :      21801 :       gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len),
     855                 :            :                                                   se.string_length));
     856                 :            :     }
     857                 :            : 
     858                 :      21802 :   gfc_add_block_to_block (block, &se.pre);
     859                 :      21802 :   gfc_add_block_to_block (postblock, &se.post);
     860                 :      21802 :   return p->mask;
     861                 :            : }
     862                 :            : 
     863                 :            : 
     864                 :            : /* Generate code to store the character (array) and the character length
     865                 :            :    for an internal unit.  */
     866                 :            : 
     867                 :            : static unsigned int
     868                 :       8013 : set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
     869                 :            :                    tree var, gfc_expr * e)
     870                 :            : {
     871                 :       8013 :   gfc_se se;
     872                 :       8013 :   tree io;
     873                 :       8013 :   tree len;
     874                 :       8013 :   tree desc;
     875                 :       8013 :   tree tmp;
     876                 :       8013 :   gfc_st_parameter_field *p;
     877                 :       8013 :   unsigned int mask;
     878                 :            : 
     879                 :       8013 :   gfc_init_se (&se, NULL);
     880                 :            : 
     881                 :       8013 :   p = &st_parameter_field[IOPARM_dt_internal_unit];
     882                 :       8013 :   mask = p->mask;
     883                 :       8013 :   io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
     884                 :            :                         var, p->field, NULL_TREE);
     885                 :       8013 :   len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len),
     886                 :            :                          var, p->field_len,  NULL_TREE);
     887                 :       8013 :   p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
     888                 :       8013 :   desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
     889                 :            :                           var, p->field, NULL_TREE);
     890                 :            : 
     891                 :       8013 :   gcc_assert (e->ts.type == BT_CHARACTER);
     892                 :            : 
     893                 :            :   /* Character scalars.  */
     894                 :       8013 :   if (e->rank == 0)
     895                 :            :     {
     896                 :       7507 :       gfc_conv_expr (&se, e);
     897                 :       7507 :       gfc_conv_string_parameter (&se);
     898                 :       7507 :       tmp = se.expr;
     899                 :       7507 :       se.expr = build_int_cst (pchar_type_node, 0);
     900                 :            :     }
     901                 :            : 
     902                 :            :   /* Character array.  */
     903                 :        506 :   else if (e->rank > 0)
     904                 :            :     {
     905                 :        506 :       if (is_subref_array (e))
     906                 :            :         {
     907                 :            :           /* Use a temporary for components of arrays of derived types
     908                 :            :              or substring array references.  */
     909                 :         48 :           gfc_conv_subref_array_arg (&se, e, 0,
     910                 :         48 :                 last_dt == READ ? INTENT_IN : INTENT_OUT, false);
     911                 :         48 :           tmp = build_fold_indirect_ref_loc (input_location,
     912                 :            :                                          se.expr);
     913                 :         48 :           se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
     914                 :         48 :           tmp = gfc_conv_descriptor_data_get (tmp);
     915                 :            :         }
     916                 :            :       else
     917                 :            :         {
     918                 :            :           /* Return the data pointer and rank from the descriptor.  */
     919                 :        458 :           gfc_conv_expr_descriptor (&se, e);
     920                 :        458 :           tmp = gfc_conv_descriptor_data_get (se.expr);
     921                 :        458 :           se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
     922                 :            :         }
     923                 :            :     }
     924                 :            :   else
     925                 :          0 :     gcc_unreachable ();
     926                 :            : 
     927                 :            :   /* The cast is needed for character substrings and the descriptor
     928                 :            :      data.  */
     929                 :       8013 :   gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
     930                 :      16026 :   gfc_add_modify (&se.pre, len,
     931                 :       8013 :                        fold_convert (TREE_TYPE (len), se.string_length));
     932                 :       8013 :   gfc_add_modify (&se.pre, desc, se.expr);
     933                 :            : 
     934                 :       8013 :   gfc_add_block_to_block (block, &se.pre);
     935                 :       8013 :   gfc_add_block_to_block (post_block, &se.post);
     936                 :       8013 :   return mask;
     937                 :            : }
     938                 :            : 
     939                 :            : /* Add a case to a IO-result switch.  */
     940                 :            : 
     941                 :            : static void
     942                 :       2553 : add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
     943                 :            : {
     944                 :       2553 :   tree tmp, value;
     945                 :            : 
     946                 :       2553 :   if (label == NULL)
     947                 :            :     return;                     /* No label, no case */
     948                 :            : 
     949                 :        947 :   value = build_int_cst (integer_type_node, label_value);
     950                 :            : 
     951                 :            :   /* Make a backend label for this case.  */
     952                 :        947 :   tmp = gfc_build_label_decl (NULL_TREE);
     953                 :            : 
     954                 :            :   /* And the case itself.  */
     955                 :        947 :   tmp = build_case_label (value, NULL_TREE, tmp);
     956                 :        947 :   gfc_add_expr_to_block (body, tmp);
     957                 :            : 
     958                 :            :   /* Jump to the label.  */
     959                 :        947 :   tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
     960                 :        947 :   gfc_add_expr_to_block (body, tmp);
     961                 :            : }
     962                 :            : 
     963                 :            : 
     964                 :            : /* Generate a switch statement that branches to the correct I/O
     965                 :            :    result label.  The last statement of an I/O call stores the
     966                 :            :    result into a variable because there is often cleanup that
     967                 :            :    must be done before the switch, so a temporary would have to
     968                 :            :    be created anyway.  */
     969                 :            : 
     970                 :            : static void
     971                 :      33991 : io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
     972                 :            :            gfc_st_label * end_label, gfc_st_label * eor_label)
     973                 :            : {
     974                 :      33991 :   stmtblock_t body;
     975                 :      33991 :   tree tmp, rc;
     976                 :      33991 :   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
     977                 :            : 
     978                 :            :   /* If no labels are specified, ignore the result instead
     979                 :            :      of building an empty switch.  */
     980                 :      33991 :   if (err_label == NULL
     981                 :      33991 :       && end_label == NULL
     982                 :      33164 :       && eor_label == NULL)
     983                 :      33140 :     return;
     984                 :            : 
     985                 :            :   /* Build a switch statement.  */
     986                 :        851 :   gfc_start_block (&body);
     987                 :            : 
     988                 :            :   /* The label values here must be the same as the values
     989                 :            :      in the library_return enum in the runtime library */
     990                 :        851 :   add_case (1, err_label, &body);
     991                 :        851 :   add_case (2, end_label, &body);
     992                 :        851 :   add_case (3, eor_label, &body);
     993                 :            : 
     994                 :        851 :   tmp = gfc_finish_block (&body);
     995                 :            : 
     996                 :        851 :   var = fold_build3_loc (input_location, COMPONENT_REF,
     997                 :            :                          st_parameter[IOPARM_ptype_common].type,
     998                 :        851 :                          var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
     999                 :        851 :   rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
    1000                 :            :                         var, p->field, NULL_TREE);
    1001                 :        851 :   rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc),
    1002                 :        851 :                         rc, build_int_cst (TREE_TYPE (rc),
    1003                 :        851 :                                            IOPARM_common_libreturn_mask));
    1004                 :            : 
    1005                 :        851 :   tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, rc, tmp);
    1006                 :            : 
    1007                 :        851 :   gfc_add_expr_to_block (block, tmp);
    1008                 :            : }
    1009                 :            : 
    1010                 :            : 
    1011                 :            : /* Store the current file and line number to variables so that if a
    1012                 :            :    library call goes awry, we can tell the user where the problem is.  */
    1013                 :            : 
    1014                 :            : static void
    1015                 :      34074 : set_error_locus (stmtblock_t * block, tree var, locus * where)
    1016                 :            : {
    1017                 :      34074 :   gfc_file *f;
    1018                 :      34074 :   tree str, locus_file;
    1019                 :      34074 :   int line;
    1020                 :      34074 :   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
    1021                 :            : 
    1022                 :      34074 :   locus_file = fold_build3_loc (input_location, COMPONENT_REF,
    1023                 :            :                                 st_parameter[IOPARM_ptype_common].type,
    1024                 :      34074 :                                 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
    1025                 :     102222 :   locus_file = fold_build3_loc (input_location, COMPONENT_REF,
    1026                 :      34074 :                                 TREE_TYPE (p->field), locus_file,
    1027                 :            :                                 p->field, NULL_TREE);
    1028                 :      34074 :   f = where->lb->file;
    1029                 :      34074 :   str = gfc_build_cstring_const (f->filename);
    1030                 :            : 
    1031                 :      34074 :   str = gfc_build_addr_expr (pchar_type_node, str);
    1032                 :      34074 :   gfc_add_modify (block, locus_file, str);
    1033                 :            : 
    1034                 :      34074 :   line = LOCATION_LINE (where->lb->location);
    1035                 :      34074 :   set_parameter_const (block, var, IOPARM_common_line, line);
    1036                 :      34074 : }
    1037                 :            : 
    1038                 :            : 
    1039                 :            : /* Translate an OPEN statement.  */
    1040                 :            : 
    1041                 :            : tree
    1042                 :       3331 : gfc_trans_open (gfc_code * code)
    1043                 :            : {
    1044                 :       3331 :   stmtblock_t block, post_block;
    1045                 :       3331 :   gfc_open *p;
    1046                 :       3331 :   tree tmp, var;
    1047                 :       3331 :   unsigned int mask = 0;
    1048                 :            : 
    1049                 :       3331 :   gfc_start_block (&block);
    1050                 :       3331 :   gfc_init_block (&post_block);
    1051                 :            : 
    1052                 :       3331 :   var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
    1053                 :            : 
    1054                 :       3331 :   set_error_locus (&block, var, &code->loc);
    1055                 :       3331 :   p = code->ext.open;
    1056                 :            : 
    1057                 :       3331 :   if (p->iomsg)
    1058                 :         42 :     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
    1059                 :            :                         p->iomsg);
    1060                 :            : 
    1061                 :       3331 :   if (p->iostat)
    1062                 :        117 :     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
    1063                 :            :                                p->iostat);
    1064                 :            : 
    1065                 :       3331 :   if (p->err)
    1066                 :         74 :     mask |= IOPARM_common_err;
    1067                 :            : 
    1068                 :       3331 :   if (p->file)
    1069                 :       1351 :     mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
    1070                 :            : 
    1071                 :       3331 :   if (p->status)
    1072                 :       2015 :     mask |= set_string (&block, &post_block, var, IOPARM_open_status,
    1073                 :            :                         p->status);
    1074                 :            : 
    1075                 :       3331 :   if (p->access)
    1076                 :        724 :     mask |= set_string (&block, &post_block, var, IOPARM_open_access,
    1077                 :            :                         p->access);
    1078                 :            : 
    1079                 :       3331 :   if (p->form)
    1080                 :       1033 :     mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
    1081                 :            : 
    1082                 :       3331 :   if (p->recl)
    1083                 :        240 :     mask |= set_parameter_value (&block, var, IOPARM_open_recl_in,
    1084                 :            :                                  p->recl);
    1085                 :            : 
    1086                 :       3331 :   if (p->blank)
    1087                 :         12 :     mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
    1088                 :            :                         p->blank);
    1089                 :            : 
    1090                 :       3331 :   if (p->position)
    1091                 :        108 :     mask |= set_string (&block, &post_block, var, IOPARM_open_position,
    1092                 :            :                         p->position);
    1093                 :            : 
    1094                 :       3331 :   if (p->action)
    1095                 :        218 :     mask |= set_string (&block, &post_block, var, IOPARM_open_action,
    1096                 :            :                         p->action);
    1097                 :            : 
    1098                 :       3331 :   if (p->delim)
    1099                 :        114 :     mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
    1100                 :            :                         p->delim);
    1101                 :            : 
    1102                 :       3331 :   if (p->pad)
    1103                 :         30 :     mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
    1104                 :            : 
    1105                 :       3331 :   if (p->decimal)
    1106                 :         24 :     mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
    1107                 :            :                         p->decimal);
    1108                 :            : 
    1109                 :       3331 :   if (p->encoding)
    1110                 :         42 :     mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
    1111                 :            :                         p->encoding);
    1112                 :            : 
    1113                 :       3331 :   if (p->round)
    1114                 :          0 :     mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
    1115                 :            : 
    1116                 :       3331 :   if (p->sign)
    1117                 :         18 :     mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
    1118                 :            : 
    1119                 :       3331 :   if (p->asynchronous)
    1120                 :         68 :     mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
    1121                 :            :                         p->asynchronous);
    1122                 :            : 
    1123                 :       3331 :   if (p->convert)
    1124                 :         72 :     mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
    1125                 :            :                         p->convert);
    1126                 :            : 
    1127                 :       3331 :   if (p->newunit)
    1128                 :        128 :     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
    1129                 :            :                                p->newunit);
    1130                 :            : 
    1131                 :       3331 :   if (p->cc)
    1132                 :         24 :     mask |= set_string (&block, &post_block, var, IOPARM_open_cc, p->cc);
    1133                 :            : 
    1134                 :       3331 :   if (p->share)
    1135                 :         24 :     mask |= set_string (&block, &post_block, var, IOPARM_open_share, p->share);
    1136                 :            : 
    1137                 :       3331 :   mask |= set_parameter_const (&block, var, IOPARM_open_readonly, p->readonly);
    1138                 :            : 
    1139                 :       3331 :   set_parameter_const (&block, var, IOPARM_common_flags, mask);
    1140                 :            : 
    1141                 :       3331 :   if (p->unit)
    1142                 :       3203 :     set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
    1143                 :            :   else
    1144                 :        128 :     set_parameter_const (&block, var, IOPARM_common_unit, 0);
    1145                 :            : 
    1146                 :       3331 :   tmp = gfc_build_addr_expr (NULL_TREE, var);
    1147                 :       3331 :   tmp = build_call_expr_loc (input_location,
    1148                 :            :                          iocall[IOCALL_OPEN], 1, tmp);
    1149                 :       3331 :   gfc_add_expr_to_block (&block, tmp);
    1150                 :            : 
    1151                 :       3331 :   gfc_add_block_to_block (&block, &post_block);
    1152                 :            : 
    1153                 :       3331 :   io_result (&block, var, p->err, NULL, NULL);
    1154                 :            : 
    1155                 :       3331 :   return gfc_finish_block (&block);
    1156                 :            : }
    1157                 :            : 
    1158                 :            : 
    1159                 :            : /* Translate a CLOSE statement.  */
    1160                 :            : 
    1161                 :            : tree
    1162                 :       2862 : gfc_trans_close (gfc_code * code)
    1163                 :            : {
    1164                 :       2862 :   stmtblock_t block, post_block;
    1165                 :       2862 :   gfc_close *p;
    1166                 :       2862 :   tree tmp, var;
    1167                 :       2862 :   unsigned int mask = 0;
    1168                 :            : 
    1169                 :       2862 :   gfc_start_block (&block);
    1170                 :       2862 :   gfc_init_block (&post_block);
    1171                 :            : 
    1172                 :       2862 :   var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
    1173                 :            : 
    1174                 :       2862 :   set_error_locus (&block, var, &code->loc);
    1175                 :       2862 :   p = code->ext.close;
    1176                 :            : 
    1177                 :       2862 :   if (p->iomsg)
    1178                 :          6 :     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
    1179                 :            :                         p->iomsg);
    1180                 :            : 
    1181                 :       2862 :   if (p->iostat)
    1182                 :          7 :     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
    1183                 :            :                                p->iostat);
    1184                 :            : 
    1185                 :       2862 :   if (p->err)
    1186                 :          7 :     mask |= IOPARM_common_err;
    1187                 :            : 
    1188                 :       2862 :   if (p->status)
    1189                 :       1264 :     mask |= set_string (&block, &post_block, var, IOPARM_close_status,
    1190                 :            :                         p->status);
    1191                 :            : 
    1192                 :       2862 :   set_parameter_const (&block, var, IOPARM_common_flags, mask);
    1193                 :            : 
    1194                 :       2862 :   if (p->unit)
    1195                 :       2862 :     set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
    1196                 :            :   else
    1197                 :          0 :     set_parameter_const (&block, var, IOPARM_common_unit, 0);
    1198                 :            : 
    1199                 :       2862 :   tmp = gfc_build_addr_expr (NULL_TREE, var);
    1200                 :       2862 :   tmp = build_call_expr_loc (input_location,
    1201                 :            :                          iocall[IOCALL_CLOSE], 1, tmp);
    1202                 :       2862 :   gfc_add_expr_to_block (&block, tmp);
    1203                 :            : 
    1204                 :       2862 :   gfc_add_block_to_block (&block, &post_block);
    1205                 :            : 
    1206                 :       2862 :   io_result (&block, var, p->err, NULL, NULL);
    1207                 :            : 
    1208                 :       2862 :   return gfc_finish_block (&block);
    1209                 :            : }
    1210                 :            : 
    1211                 :            : 
    1212                 :            : /* Common subroutine for building a file positioning statement.  */
    1213                 :            : 
    1214                 :            : static tree
    1215                 :       2454 : build_filepos (tree function, gfc_code * code)
    1216                 :            : {
    1217                 :       2454 :   stmtblock_t block, post_block;
    1218                 :       2454 :   gfc_filepos *p;
    1219                 :       2454 :   tree tmp, var;
    1220                 :       2454 :   unsigned int mask = 0;
    1221                 :            : 
    1222                 :       2454 :   p = code->ext.filepos;
    1223                 :            : 
    1224                 :       2454 :   gfc_start_block (&block);
    1225                 :       2454 :   gfc_init_block (&post_block);
    1226                 :            : 
    1227                 :       2454 :   var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
    1228                 :            :                         "filepos_parm");
    1229                 :            : 
    1230                 :       2454 :   set_error_locus (&block, var, &code->loc);
    1231                 :            : 
    1232                 :       2454 :   if (p->iomsg)
    1233                 :         24 :     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
    1234                 :            :                         p->iomsg);
    1235                 :            : 
    1236                 :       2454 :   if (p->iostat)
    1237                 :         57 :     mask |= set_parameter_ref (&block, &post_block, var,
    1238                 :            :                                IOPARM_common_iostat, p->iostat);
    1239                 :            : 
    1240                 :       2454 :   if (p->err)
    1241                 :         16 :     mask |= IOPARM_common_err;
    1242                 :            : 
    1243                 :       2454 :   set_parameter_const (&block, var, IOPARM_common_flags, mask);
    1244                 :            : 
    1245                 :       2454 :   if (p->unit)
    1246                 :       2454 :     set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit,
    1247                 :            :                              p->unit);
    1248                 :            :   else
    1249                 :          0 :     set_parameter_const (&block, var, IOPARM_common_unit, 0);
    1250                 :            : 
    1251                 :       2454 :   tmp = gfc_build_addr_expr (NULL_TREE, var);
    1252                 :       2454 :   tmp = build_call_expr_loc (input_location,
    1253                 :            :                          function, 1, tmp);
    1254                 :       2454 :   gfc_add_expr_to_block (&block, tmp);
    1255                 :            : 
    1256                 :       2454 :   gfc_add_block_to_block (&block, &post_block);
    1257                 :            : 
    1258                 :       2454 :   io_result (&block, var, p->err, NULL, NULL);
    1259                 :            : 
    1260                 :       2454 :   return gfc_finish_block (&block);
    1261                 :            : }
    1262                 :            : 
    1263                 :            : 
    1264                 :            : /* Translate a BACKSPACE statement.  */
    1265                 :            : 
    1266                 :            : tree
    1267                 :        389 : gfc_trans_backspace (gfc_code * code)
    1268                 :            : {
    1269                 :        389 :   return build_filepos (iocall[IOCALL_BACKSPACE], code);
    1270                 :            : }
    1271                 :            : 
    1272                 :            : 
    1273                 :            : /* Translate an ENDFILE statement.  */
    1274                 :            : 
    1275                 :            : tree
    1276                 :         50 : gfc_trans_endfile (gfc_code * code)
    1277                 :            : {
    1278                 :         50 :   return build_filepos (iocall[IOCALL_ENDFILE], code);
    1279                 :            : }
    1280                 :            : 
    1281                 :            : 
    1282                 :            : /* Translate a REWIND statement.  */
    1283                 :            : 
    1284                 :            : tree
    1285                 :       1948 : gfc_trans_rewind (gfc_code * code)
    1286                 :            : {
    1287                 :       1948 :   return build_filepos (iocall[IOCALL_REWIND], code);
    1288                 :            : }
    1289                 :            : 
    1290                 :            : 
    1291                 :            : /* Translate a FLUSH statement.  */
    1292                 :            : 
    1293                 :            : tree
    1294                 :         67 : gfc_trans_flush (gfc_code * code)
    1295                 :            : {
    1296                 :         67 :   return build_filepos (iocall[IOCALL_FLUSH], code);
    1297                 :            : }
    1298                 :            : 
    1299                 :            : 
    1300                 :            : /* Translate the non-IOLENGTH form of an INQUIRE statement.  */
    1301                 :            : 
    1302                 :            : tree
    1303                 :        753 : gfc_trans_inquire (gfc_code * code)
    1304                 :            : {
    1305                 :        753 :   stmtblock_t block, post_block;
    1306                 :        753 :   gfc_inquire *p;
    1307                 :        753 :   tree tmp, var;
    1308                 :        753 :   unsigned int mask = 0, mask2 = 0;
    1309                 :            : 
    1310                 :        753 :   gfc_start_block (&block);
    1311                 :        753 :   gfc_init_block (&post_block);
    1312                 :            : 
    1313                 :        753 :   var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
    1314                 :            :                         "inquire_parm");
    1315                 :            : 
    1316                 :        753 :   set_error_locus (&block, var, &code->loc);
    1317                 :        753 :   p = code->ext.inquire;
    1318                 :            : 
    1319                 :        753 :   if (p->iomsg)
    1320                 :         12 :     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
    1321                 :            :                         p->iomsg);
    1322                 :            : 
    1323                 :        753 :   if (p->iostat)
    1324                 :         31 :     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
    1325                 :            :                                p->iostat);
    1326                 :            : 
    1327                 :        753 :   if (p->err)
    1328                 :          7 :     mask |= IOPARM_common_err;
    1329                 :            : 
    1330                 :            :   /* Sanity check.  */
    1331                 :        753 :   if (p->unit && p->file)
    1332                 :          0 :     gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
    1333                 :            : 
    1334                 :        753 :   if (p->file)
    1335                 :        189 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
    1336                 :            :                         p->file);
    1337                 :            : 
    1338                 :        753 :   if (p->exist)
    1339                 :        136 :     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
    1340                 :            :                                  p->exist);
    1341                 :            : 
    1342                 :        753 :   if (p->opened)
    1343                 :        139 :     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
    1344                 :            :                                p->opened);
    1345                 :            : 
    1346                 :        753 :   if (p->number)
    1347                 :         76 :     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
    1348                 :            :                                p->number);
    1349                 :            : 
    1350                 :        753 :   if (p->named)
    1351                 :         13 :     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
    1352                 :            :                                p->named);
    1353                 :            : 
    1354                 :        753 :   if (p->name)
    1355                 :         18 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
    1356                 :            :                         p->name);
    1357                 :            : 
    1358                 :        753 :   if (p->access)
    1359                 :        141 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
    1360                 :            :                         p->access);
    1361                 :            : 
    1362                 :        753 :   if (p->sequential)
    1363                 :         30 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
    1364                 :            :                         p->sequential);
    1365                 :            : 
    1366                 :        753 :   if (p->direct)
    1367                 :        102 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
    1368                 :            :                         p->direct);
    1369                 :            : 
    1370                 :        753 :   if (p->form)
    1371                 :          6 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
    1372                 :            :                         p->form);
    1373                 :            : 
    1374                 :        753 :   if (p->formatted)
    1375                 :         36 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
    1376                 :            :                         p->formatted);
    1377                 :            : 
    1378                 :        753 :   if (p->unformatted)
    1379                 :         30 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
    1380                 :            :                         p->unformatted);
    1381                 :            : 
    1382                 :        753 :   if (p->recl)
    1383                 :         49 :     mask |= set_parameter_ref (&block, &post_block, var,
    1384                 :            :                                IOPARM_inquire_recl_out, p->recl);
    1385                 :            : 
    1386                 :        753 :   if (p->nextrec)
    1387                 :         58 :     mask |= set_parameter_ref (&block, &post_block, var,
    1388                 :            :                                IOPARM_inquire_nextrec, p->nextrec);
    1389                 :            : 
    1390                 :        753 :   if (p->blank)
    1391                 :         15 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
    1392                 :            :                         p->blank);
    1393                 :            : 
    1394                 :        753 :   if (p->delim)
    1395                 :         30 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
    1396                 :            :                         p->delim);
    1397                 :            : 
    1398                 :        753 :   if (p->position)
    1399                 :         48 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
    1400                 :            :                         p->position);
    1401                 :            : 
    1402                 :        753 :   if (p->action)
    1403                 :         12 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
    1404                 :            :                         p->action);
    1405                 :            : 
    1406                 :        753 :   if (p->read)
    1407                 :         24 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
    1408                 :            :                         p->read);
    1409                 :            : 
    1410                 :        753 :   if (p->write)
    1411                 :         24 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
    1412                 :            :                         p->write);
    1413                 :            : 
    1414                 :        753 :   if (p->readwrite)
    1415                 :         24 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
    1416                 :            :                         p->readwrite);
    1417                 :            : 
    1418                 :        753 :   if (p->pad)
    1419                 :         30 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
    1420                 :            :                         p->pad);
    1421                 :            : 
    1422                 :        753 :   if (p->convert)
    1423                 :         12 :     mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
    1424                 :            :                         p->convert);
    1425                 :            : 
    1426                 :        753 :   if (p->strm_pos)
    1427                 :        102 :     mask |= set_parameter_ref (&block, &post_block, var,
    1428                 :            :                                IOPARM_inquire_strm_pos_out, p->strm_pos);
    1429                 :            : 
    1430                 :            :   /* The second series of flags.  */
    1431                 :        753 :   if (p->asynchronous)
    1432                 :         18 :     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
    1433                 :            :                          p->asynchronous);
    1434                 :            : 
    1435                 :        753 :   if (p->decimal)
    1436                 :         12 :     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
    1437                 :            :                          p->decimal);
    1438                 :            : 
    1439                 :        753 :   if (p->encoding)
    1440                 :         12 :     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
    1441                 :            :                          p->encoding);
    1442                 :            : 
    1443                 :        753 :   if (p->round)
    1444                 :         12 :     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
    1445                 :            :                          p->round);
    1446                 :            : 
    1447                 :        753 :   if (p->sign)
    1448                 :         12 :     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
    1449                 :            :                          p->sign);
    1450                 :            : 
    1451                 :        753 :   if (p->pending)
    1452                 :         13 :     mask2 |= set_parameter_ref (&block, &post_block, var,
    1453                 :            :                                 IOPARM_inquire_pending, p->pending);
    1454                 :            : 
    1455                 :        753 :   if (p->size)
    1456                 :         42 :     mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
    1457                 :            :                                 p->size);
    1458                 :            : 
    1459                 :        753 :   if (p->id)
    1460                 :          6 :     mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
    1461                 :            :                                 p->id);
    1462                 :        753 :   if (p->iqstream)
    1463                 :         36 :     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream,
    1464                 :            :                          p->iqstream);
    1465                 :            : 
    1466                 :        753 :   if (p->share)
    1467                 :          6 :     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_share,
    1468                 :            :                          p->share);
    1469                 :            : 
    1470                 :        753 :   if (p->cc)
    1471                 :          6 :     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_cc, p->cc);
    1472                 :            : 
    1473                 :        753 :   if (mask2)
    1474                 :        103 :     mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
    1475                 :            : 
    1476                 :        753 :   set_parameter_const (&block, var, IOPARM_common_flags, mask);
    1477                 :            : 
    1478                 :        753 :   if (p->unit)
    1479                 :            :     {
    1480                 :        564 :       set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
    1481                 :        564 :       set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit);
    1482                 :            :     }
    1483                 :            :   else
    1484                 :        189 :     set_parameter_const (&block, var, IOPARM_common_unit, 0);
    1485                 :            : 
    1486                 :        753 :   tmp = gfc_build_addr_expr (NULL_TREE, var);
    1487                 :        753 :   tmp = build_call_expr_loc (input_location,
    1488                 :            :                          iocall[IOCALL_INQUIRE], 1, tmp);
    1489                 :        753 :   gfc_add_expr_to_block (&block, tmp);
    1490                 :            : 
    1491                 :        753 :   gfc_add_block_to_block (&block, &post_block);
    1492                 :            : 
    1493                 :        753 :   io_result (&block, var, p->err, NULL, NULL);
    1494                 :            : 
    1495                 :        753 :   return gfc_finish_block (&block);
    1496                 :            : }
    1497                 :            : 
    1498                 :            : 
    1499                 :            : tree
    1500                 :         56 : gfc_trans_wait (gfc_code * code)
    1501                 :            : {
    1502                 :         56 :   stmtblock_t block, post_block;
    1503                 :         56 :   gfc_wait *p;
    1504                 :         56 :   tree tmp, var;
    1505                 :         56 :   unsigned int mask = 0;
    1506                 :            : 
    1507                 :         56 :   gfc_start_block (&block);
    1508                 :         56 :   gfc_init_block (&post_block);
    1509                 :            : 
    1510                 :         56 :   var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
    1511                 :            :                         "wait_parm");
    1512                 :            : 
    1513                 :         56 :   set_error_locus (&block, var, &code->loc);
    1514                 :         56 :   p = code->ext.wait;
    1515                 :            : 
    1516                 :            :   /* Set parameters here.  */
    1517                 :         56 :   if (p->iomsg)
    1518                 :          8 :     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
    1519                 :            :                         p->iomsg);
    1520                 :            : 
    1521                 :         56 :   if (p->iostat)
    1522                 :          8 :     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
    1523                 :            :                                p->iostat);
    1524                 :            : 
    1525                 :         56 :   if (p->err)
    1526                 :          7 :     mask |= IOPARM_common_err;
    1527                 :            : 
    1528                 :         56 :   if (p->id)
    1529                 :          7 :     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_wait_id, p->id);
    1530                 :            : 
    1531                 :         56 :   set_parameter_const (&block, var, IOPARM_common_flags, mask);
    1532                 :            : 
    1533                 :         56 :   if (p->unit)
    1534                 :         56 :     set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
    1535                 :            : 
    1536                 :         56 :   tmp = gfc_build_addr_expr (NULL_TREE, var);
    1537                 :         56 :   tmp = build_call_expr_loc (input_location,
    1538                 :            :                          iocall[IOCALL_WAIT], 1, tmp);
    1539                 :         56 :   gfc_add_expr_to_block (&block, tmp);
    1540                 :            : 
    1541                 :         56 :   gfc_add_block_to_block (&block, &post_block);
    1542                 :            : 
    1543                 :         56 :   io_result (&block, var, p->err, NULL, NULL);
    1544                 :            : 
    1545                 :         56 :   return gfc_finish_block (&block);
    1546                 :            : 
    1547                 :            : }
    1548                 :            : 
    1549                 :            : 
    1550                 :            : /* nml_full_name builds up the fully qualified name of a
    1551                 :            :    derived type component. '+' is used to denote a type extension.  */
    1552                 :            : 
    1553                 :            : static char*
    1554                 :       1838 : nml_full_name (const char* var_name, const char* cmp_name, bool parent)
    1555                 :            : {
    1556                 :       1838 :   int full_name_length;
    1557                 :       1838 :   char * full_name;
    1558                 :            : 
    1559                 :       1838 :   full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
    1560                 :       1838 :   full_name = XCNEWVEC (char, full_name_length + 1);
    1561                 :       1838 :   strcpy (full_name, var_name);
    1562                 :       1838 :   full_name = strcat (full_name, parent ? "+" : "%");
    1563                 :       1838 :   full_name = strcat (full_name, cmp_name);
    1564                 :       1838 :   return full_name;
    1565                 :            : }
    1566                 :            : 
    1567                 :            : 
    1568                 :            : /* nml_get_addr_expr builds an address expression from the
    1569                 :            :    gfc_symbol or gfc_component backend_decl's. An offset is
    1570                 :            :    provided so that the address of an element of an array of
    1571                 :            :    derived types is returned. This is used in the runtime to
    1572                 :            :    determine that span of the derived type.  */
    1573                 :            : 
    1574                 :            : static tree
    1575                 :       4641 : nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
    1576                 :            :                    tree base_addr)
    1577                 :            : {
    1578                 :       4641 :   tree decl = NULL_TREE;
    1579                 :       4641 :   tree tmp;
    1580                 :            : 
    1581                 :       4641 :   if (sym)
    1582                 :            :     {
    1583                 :       2803 :       sym->attr.referenced = 1;
    1584                 :       2803 :       decl = gfc_get_symbol_decl (sym);
    1585                 :            : 
    1586                 :            :       /* If this is the enclosing function declaration, use
    1587                 :            :          the fake result instead.  */
    1588                 :       2803 :       if (decl == current_function_decl)
    1589                 :         12 :         decl = gfc_get_fake_result_decl (sym, 0);
    1590                 :       2791 :       else if (decl == DECL_CONTEXT (current_function_decl))
    1591                 :          0 :         decl =  gfc_get_fake_result_decl (sym, 1);
    1592                 :            :     }
    1593                 :            :   else
    1594                 :       1838 :     decl = c->backend_decl;
    1595                 :            : 
    1596                 :       4641 :   gcc_assert (decl && (TREE_CODE (decl) == FIELD_DECL
    1597                 :            :                        || VAR_P (decl)
    1598                 :            :                        || TREE_CODE (decl) == PARM_DECL
    1599                 :            :                        || TREE_CODE (decl) == COMPONENT_REF));
    1600                 :            : 
    1601                 :       4641 :   tmp = decl;
    1602                 :            : 
    1603                 :            :   /* Build indirect reference, if dummy argument.  */
    1604                 :            : 
    1605                 :       4641 :   if (POINTER_TYPE_P (TREE_TYPE(tmp)))
    1606                 :        831 :     tmp = build_fold_indirect_ref_loc (input_location, tmp);
    1607                 :            : 
    1608                 :            :   /* Treat the component of a derived type, using base_addr for
    1609                 :            :      the derived type.  */
    1610                 :            : 
    1611                 :       4641 :   if (TREE_CODE (decl) == FIELD_DECL)
    1612                 :       1838 :     tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
    1613                 :            :                            base_addr, tmp, NULL_TREE);
    1614                 :            : 
    1615                 :       4641 :   if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
    1616                 :       4641 :       && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp))))
    1617                 :         12 :     tmp = gfc_class_data_get (tmp);
    1618                 :            : 
    1619                 :       4641 :   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
    1620                 :        300 :     tmp = gfc_conv_array_data (tmp);
    1621                 :            :   else
    1622                 :            :     {
    1623                 :       4341 :       if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
    1624                 :       4149 :         tmp = gfc_build_addr_expr (NULL_TREE, tmp);
    1625                 :            : 
    1626                 :       4341 :       if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
    1627                 :          0 :          tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
    1628                 :            : 
    1629                 :       4341 :       if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
    1630                 :          0 :         tmp = build_fold_indirect_ref_loc (input_location,
    1631                 :            :                                    tmp);
    1632                 :            :     }
    1633                 :            : 
    1634                 :       9282 :   gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
    1635                 :            : 
    1636                 :       4641 :   return tmp;
    1637                 :            : }
    1638                 :            : 
    1639                 :            : 
    1640                 :            : /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
    1641                 :            :    call to iocall[IOCALL_SET_NML_VAL].  For derived type variable, recursively
    1642                 :            :    generate calls to iocall[IOCALL_SET_NML_VAL] for each component.  */
    1643                 :            : 
    1644                 :            : #define IARG(i) build_int_cst (gfc_array_index_type, i)
    1645                 :            : 
    1646                 :            : static void
    1647                 :       4641 : transfer_namelist_element (stmtblock_t * block, const char * var_name,
    1648                 :            :                            gfc_symbol * sym, gfc_component * c,
    1649                 :            :                            tree base_addr)
    1650                 :            : {
    1651                 :       4641 :   gfc_typespec * ts = NULL;
    1652                 :       4641 :   gfc_array_spec * as = NULL;
    1653                 :       4641 :   tree addr_expr = NULL;
    1654                 :       4641 :   tree dt = NULL;
    1655                 :       4641 :   tree string;
    1656                 :       4641 :   tree tmp;
    1657                 :       4641 :   tree dtype;
    1658                 :       4641 :   tree dt_parm_addr;
    1659                 :       4641 :   tree decl = NULL_TREE;
    1660                 :       4641 :   tree gfc_int4_type_node = gfc_get_int_type (4);
    1661                 :       4641 :   tree dtio_proc = null_pointer_node;
    1662                 :       4641 :   tree vtable = null_pointer_node;
    1663                 :       4641 :   int n_dim;
    1664                 :       4641 :   int rank = 0;
    1665                 :            : 
    1666                 :       4641 :   gcc_assert (sym || c);
    1667                 :            : 
    1668                 :            :   /* Build the namelist object name.  */
    1669                 :            : 
    1670                 :       4641 :   string = gfc_build_cstring_const (var_name);
    1671                 :       4641 :   string = gfc_build_addr_expr (pchar_type_node, string);
    1672                 :            : 
    1673                 :            :   /* Build ts, as and data address using symbol or component.  */
    1674                 :            : 
    1675                 :       4641 :   ts = sym ? &sym->ts : &c->ts;
    1676                 :            : 
    1677                 :       4641 :   if (ts->type != BT_CLASS)
    1678                 :       4623 :     as = sym ? sym->as : c->as;
    1679                 :            :   else
    1680                 :         18 :     as = sym ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as;
    1681                 :            : 
    1682                 :       4641 :   addr_expr = nml_get_addr_expr (sym, c, base_addr);
    1683                 :            : 
    1684                 :       4641 :   if (as)
    1685                 :       1901 :     rank = as->rank;
    1686                 :            : 
    1687                 :       1901 :   if (rank)
    1688                 :            :     {
    1689                 :       1901 :       decl = sym ? sym->backend_decl : c->backend_decl;
    1690                 :       1901 :       if (sym && sym->attr.dummy)
    1691                 :        325 :         decl = build_fold_indirect_ref_loc (input_location, decl);
    1692                 :            : 
    1693                 :       1901 :       if (ts->type == BT_CLASS)
    1694                 :         12 :         decl = gfc_class_data_get (decl);
    1695                 :       1901 :       dt =  TREE_TYPE (decl);
    1696                 :       1901 :       dtype = gfc_get_dtype (dt);
    1697                 :            :     }
    1698                 :            :   else
    1699                 :            :     {
    1700                 :       2740 :       dt =  gfc_typenode_for_spec (ts);
    1701                 :       2740 :       dtype = gfc_get_dtype_rank_type (0, dt);
    1702                 :            :     }
    1703                 :            : 
    1704                 :            :   /* Build up the arguments for the transfer call.
    1705                 :            :      The call for the scalar part transfers:
    1706                 :            :      (address, name, type, kind or string_length, dtype)  */
    1707                 :            : 
    1708                 :       4641 :   dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
    1709                 :            : 
    1710                 :            :   /* Check if the derived type has a specific DTIO for the mode.
    1711                 :            :      Note that although namelist io is forbidden to have a format
    1712                 :            :      list, the specific subroutine is of the formatted kind.  */
    1713                 :       4641 :   if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
    1714                 :            :     {
    1715                 :        926 :       gfc_symbol *derived;
    1716                 :        926 :       if (ts->type==BT_CLASS)
    1717                 :         18 :         derived = ts->u.derived->components->ts.u.derived;
    1718                 :            :       else
    1719                 :        908 :         derived = ts->u.derived;
    1720                 :            : 
    1721                 :        926 :       gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
    1722                 :            :                                                         last_dt == WRITE, true);
    1723                 :            : 
    1724                 :        926 :       if (ts->type == BT_CLASS && tb_io_st)
    1725                 :            :         {
    1726                 :            :           // polymorphic DTIO call  (based on the dynamic type)
    1727                 :         18 :           gfc_se se;
    1728                 :         18 :           gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
    1729                 :            :           // build vtable expr
    1730                 :         18 :           gfc_expr *expr = gfc_get_variable_expr (st);
    1731                 :         18 :           gfc_add_vptr_component (expr);
    1732                 :         18 :           gfc_init_se (&se, NULL);
    1733                 :         18 :           se.want_pointer = 1;
    1734                 :         18 :           gfc_conv_expr (&se, expr);
    1735                 :         18 :           vtable = se.expr;
    1736                 :            :           // build dtio expr
    1737                 :         18 :           gfc_add_component_ref (expr,
    1738                 :         18 :                                 tb_io_st->n.tb->u.generic->specific_st->name);
    1739                 :         18 :           gfc_init_se (&se, NULL);
    1740                 :         18 :           se.want_pointer = 1;
    1741                 :         18 :           gfc_conv_expr (&se, expr);
    1742                 :         18 :           gfc_free_expr (expr);
    1743                 :         18 :           dtio_proc = se.expr;
    1744                 :            :         }
    1745                 :            :       else
    1746                 :            :         {
    1747                 :            :           // non-polymorphic DTIO call (based on the declared type)
    1748                 :        908 :           gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived,
    1749                 :            :                                                         last_dt == WRITE, true);
    1750                 :        908 :           if (dtio_sub != NULL)
    1751                 :            :             {
    1752                 :         54 :               dtio_proc = gfc_get_symbol_decl (dtio_sub);
    1753                 :         54 :               dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
    1754                 :         54 :               gfc_symbol *vtab = gfc_find_derived_vtab (derived);
    1755                 :         54 :               vtable = vtab->backend_decl;
    1756                 :         54 :               if (vtable == NULL_TREE)
    1757                 :          0 :                 vtable = gfc_get_symbol_decl (vtab);
    1758                 :         54 :               vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
    1759                 :            :             }
    1760                 :            :         }
    1761                 :            :     }
    1762                 :            : 
    1763                 :       4641 :   if (ts->type == BT_CHARACTER)
    1764                 :       1561 :     tmp = ts->u.cl->backend_decl;
    1765                 :            :   else
    1766                 :       3080 :     tmp = build_int_cst (gfc_charlen_type_node, 0);
    1767                 :            : 
    1768                 :       4641 :   if (dtio_proc == null_pointer_node)
    1769                 :       4569 :     tmp = build_call_expr_loc (input_location,
    1770                 :            :                            iocall[IOCALL_SET_NML_VAL], 6,
    1771                 :            :                            dt_parm_addr, addr_expr, string,
    1772                 :       4569 :                            build_int_cst (gfc_int4_type_node, ts->kind),
    1773                 :            :                            tmp, dtype);
    1774                 :            :   else
    1775                 :         72 :     tmp = build_call_expr_loc (input_location,
    1776                 :            :                            iocall[IOCALL_SET_NML_DTIO_VAL], 8,
    1777                 :            :                            dt_parm_addr, addr_expr, string,
    1778                 :         72 :                            build_int_cst (gfc_int4_type_node, ts->kind),
    1779                 :            :                            tmp, dtype, dtio_proc, vtable);
    1780                 :       4641 :   gfc_add_expr_to_block (block, tmp);
    1781                 :            : 
    1782                 :            :   /* If the object is an array, transfer rank times:
    1783                 :            :      (null pointer, name, stride, lbound, ubound)  */
    1784                 :            : 
    1785                 :       6590 :   for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
    1786                 :            :     {
    1787                 :       1949 :       tmp = build_call_expr_loc (input_location,
    1788                 :            :                              iocall[IOCALL_SET_NML_VAL_DIM], 5,
    1789                 :            :                              dt_parm_addr,
    1790                 :            :                              build_int_cst (gfc_int4_type_node, n_dim),
    1791                 :            :                              gfc_conv_array_stride (decl, n_dim),
    1792                 :            :                              gfc_conv_array_lbound (decl, n_dim),
    1793                 :            :                              gfc_conv_array_ubound (decl, n_dim));
    1794                 :       1949 :       gfc_add_expr_to_block (block, tmp);
    1795                 :            :     }
    1796                 :            : 
    1797                 :       4641 :   if (gfc_bt_struct (ts->type) && ts->u.derived->components
    1798                 :        908 :       && dtio_proc == null_pointer_node)
    1799                 :            :     {
    1800                 :        854 :       gfc_component *cmp;
    1801                 :            : 
    1802                 :            :       /* Provide the RECORD_TYPE to build component references.  */
    1803                 :            : 
    1804                 :        854 :       tree expr = build_fold_indirect_ref_loc (input_location,
    1805                 :            :                                            addr_expr);
    1806                 :            : 
    1807                 :       2692 :       for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
    1808                 :            :         {
    1809                 :       3676 :           char *full_name = nml_full_name (var_name, cmp->name,
    1810                 :       1838 :                                            ts->u.derived->attr.extension);
    1811                 :       1838 :           transfer_namelist_element (block,
    1812                 :            :                                      full_name,
    1813                 :            :                                      NULL, cmp, expr);
    1814                 :       1838 :           free (full_name);
    1815                 :            :         }
    1816                 :            :     }
    1817                 :       4641 : }
    1818                 :            : 
    1819                 :            : #undef IARG
    1820                 :            : 
    1821                 :            : /* Create a data transfer statement.  Not all of the fields are valid
    1822                 :            :    for both reading and writing, but improper use has been filtered
    1823                 :            :    out by now.  */
    1824                 :            : 
    1825                 :            : static tree
    1826                 :      24618 : build_dt (tree function, gfc_code * code)
    1827                 :            : {
    1828                 :      24618 :   stmtblock_t block, post_block, post_end_block, post_iu_block;
    1829                 :      24618 :   gfc_dt *dt;
    1830                 :      24618 :   tree tmp, var;
    1831                 :      24618 :   gfc_expr *nmlname;
    1832                 :      24618 :   gfc_namelist *nml;
    1833                 :      24618 :   unsigned int mask = 0;
    1834                 :            : 
    1835                 :      24618 :   gfc_start_block (&block);
    1836                 :      24618 :   gfc_init_block (&post_block);
    1837                 :      24618 :   gfc_init_block (&post_end_block);
    1838                 :      24618 :   gfc_init_block (&post_iu_block);
    1839                 :            : 
    1840                 :      24618 :   var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
    1841                 :            : 
    1842                 :      24618 :   set_error_locus (&block, var, &code->loc);
    1843                 :            : 
    1844                 :      24618 :   if (last_dt == IOLENGTH)
    1845                 :            :     {
    1846                 :         83 :       gfc_inquire *inq;
    1847                 :            : 
    1848                 :         83 :       inq = code->ext.inquire;
    1849                 :            : 
    1850                 :            :       /* First check that preconditions are met.  */
    1851                 :         83 :       gcc_assert (inq != NULL);
    1852                 :         83 :       gcc_assert (inq->iolength != NULL);
    1853                 :            : 
    1854                 :            :       /* Connect to the iolength variable.  */
    1855                 :         83 :       mask |= set_parameter_ref (&block, &post_end_block, var,
    1856                 :            :                                  IOPARM_dt_iolength, inq->iolength);
    1857                 :         83 :       dt = NULL;
    1858                 :            :     }
    1859                 :            :   else
    1860                 :            :     {
    1861                 :      24535 :       dt = code->ext.dt;
    1862                 :      24535 :       gcc_assert (dt != NULL);
    1863                 :            :     }
    1864                 :            : 
    1865                 :      24618 :   if (dt && dt->io_unit)
    1866                 :            :     {
    1867                 :      24535 :       if (dt->io_unit->ts.type == BT_CHARACTER)
    1868                 :            :         {
    1869                 :       8013 :           mask |= set_internal_unit (&block, &post_iu_block,
    1870                 :            :                                      var, dt->io_unit);
    1871                 :       8013 :           set_parameter_const (&block, var, IOPARM_common_unit,
    1872                 :       8013 :                                dt->io_unit->ts.kind == 1 ?
    1873                 :            :                                 GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4);
    1874                 :            :         }
    1875                 :            :     }
    1876                 :            :   else
    1877                 :         83 :     set_parameter_const (&block, var, IOPARM_common_unit, 0);
    1878                 :            : 
    1879                 :      24618 :   if (dt)
    1880                 :            :     {
    1881                 :      24535 :       if (dt->iomsg)
    1882                 :        361 :         mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
    1883                 :            :                             dt->iomsg);
    1884                 :            : 
    1885                 :      24535 :       if (dt->iostat)
    1886                 :       1596 :         mask |= set_parameter_ref (&block, &post_end_block, var,
    1887                 :            :                                    IOPARM_common_iostat, dt->iostat);
    1888                 :            : 
    1889                 :      24535 :       if (dt->err)
    1890                 :        246 :         mask |= IOPARM_common_err;
    1891                 :            : 
    1892                 :      24535 :       if (dt->eor)
    1893                 :         30 :         mask |= IOPARM_common_eor;
    1894                 :            : 
    1895                 :      24535 :       if (dt->end)
    1896                 :        560 :         mask |= IOPARM_common_end;
    1897                 :            : 
    1898                 :      24535 :       if (dt->id)
    1899                 :         13 :         mask |= set_parameter_ref (&block, &post_end_block, var,
    1900                 :            :                                    IOPARM_dt_id, dt->id);
    1901                 :            : 
    1902                 :      24535 :       if (dt->pos)
    1903                 :        168 :         mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
    1904                 :            : 
    1905                 :      24535 :       if (dt->asynchronous)
    1906                 :        153 :         mask |= set_string (&block, &post_block, var,
    1907                 :            :                             IOPARM_dt_asynchronous, dt->asynchronous);
    1908                 :            : 
    1909                 :      24535 :       if (dt->blank)
    1910                 :         13 :         mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
    1911                 :            :                             dt->blank);
    1912                 :            : 
    1913                 :      24535 :       if (dt->decimal)
    1914                 :         75 :         mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
    1915                 :            :                             dt->decimal);
    1916                 :            : 
    1917                 :      24535 :       if (dt->delim)
    1918                 :          2 :         mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
    1919                 :            :                             dt->delim);
    1920                 :            : 
    1921                 :      24535 :       if (dt->pad)
    1922                 :         79 :         mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
    1923                 :            :                             dt->pad);
    1924                 :            : 
    1925                 :      24535 :       if (dt->round)
    1926                 :         25 :         mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
    1927                 :            :                             dt->round);
    1928                 :            : 
    1929                 :      24535 :       if (dt->sign)
    1930                 :         13 :         mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
    1931                 :            :                             dt->sign);
    1932                 :            : 
    1933                 :      24535 :       if (dt->rec)
    1934                 :        492 :         mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
    1935                 :            : 
    1936                 :      24535 :       if (dt->advance)
    1937                 :        327 :         mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
    1938                 :            :                             dt->advance);
    1939                 :            : 
    1940                 :      24535 :       if (dt->format_expr)
    1941                 :       9838 :         mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
    1942                 :            :                             dt->format_expr);
    1943                 :            : 
    1944                 :      24535 :       if (dt->format_label)
    1945                 :            :         {
    1946                 :      11300 :           if (dt->format_label == &format_asterisk)
    1947                 :       9548 :             mask |= IOPARM_dt_list_format;
    1948                 :            :           else
    1949                 :       1752 :             mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
    1950                 :            :                                 dt->format_label->format);
    1951                 :            :         }
    1952                 :            : 
    1953                 :      24535 :       if (dt->size)
    1954                 :         55 :         mask |= set_parameter_ref (&block, &post_end_block, var,
    1955                 :            :                                    IOPARM_dt_size, dt->size);
    1956                 :            : 
    1957                 :      24535 :       if (dt->udtio)
    1958                 :        302 :         mask |= IOPARM_dt_dtio;
    1959                 :            : 
    1960                 :      24535 :       if (dt->dec_ext)
    1961                 :        480 :         mask |= IOPARM_dt_dec_ext;
    1962                 :            : 
    1963                 :      24535 :       if (dt->namelist)
    1964                 :            :         {
    1965                 :       1046 :           if (dt->format_expr || dt->format_label)
    1966                 :          0 :             gfc_internal_error ("build_dt: format with namelist");
    1967                 :            : 
    1968                 :       2092 :           nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
    1969                 :            :                                             dt->namelist->name,
    1970                 :       1046 :                                             strlen (dt->namelist->name));
    1971                 :            : 
    1972                 :       1046 :           mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
    1973                 :            :                               nmlname);
    1974                 :            : 
    1975                 :       1046 :           gfc_free_expr (nmlname);
    1976                 :            : 
    1977                 :       1046 :           if (last_dt == READ)
    1978                 :        753 :             mask |= IOPARM_dt_namelist_read_mode;
    1979                 :            : 
    1980                 :       1046 :           set_parameter_const (&block, var, IOPARM_common_flags, mask);
    1981                 :            : 
    1982                 :       1046 :           dt_parm = var;
    1983                 :            : 
    1984                 :       3849 :           for (nml = dt->namelist->namelist; nml; nml = nml->next)
    1985                 :       2803 :             transfer_namelist_element (&block, nml->sym->name, nml->sym,
    1986                 :            :                                        NULL, NULL_TREE);
    1987                 :            :         }
    1988                 :            :       else
    1989                 :      23489 :         set_parameter_const (&block, var, IOPARM_common_flags, mask);
    1990                 :            : 
    1991                 :      24535 :       if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
    1992                 :      16522 :         set_parameter_value_chk (&block, dt->iostat, var,
    1993                 :            :                                  IOPARM_common_unit, dt->io_unit);
    1994                 :            :     }
    1995                 :            :   else
    1996                 :         83 :     set_parameter_const (&block, var, IOPARM_common_flags, mask);
    1997                 :            : 
    1998                 :      24618 :   tmp = gfc_build_addr_expr (NULL_TREE, var);
    1999                 :      24618 :   tmp = build_call_expr_loc (UNKNOWN_LOCATION,
    2000                 :            :                          function, 1, tmp);
    2001                 :      24618 :   gfc_add_expr_to_block (&block, tmp);
    2002                 :            : 
    2003                 :      24618 :   gfc_add_block_to_block (&block, &post_block);
    2004                 :            : 
    2005                 :      24618 :   dt_parm = var;
    2006                 :      24618 :   dt_post_end_block = &post_end_block;
    2007                 :            : 
    2008                 :            :   /* Set implied do loop exit condition.  */
    2009                 :      24618 :   if (last_dt == READ || last_dt == WRITE)
    2010                 :            :     {
    2011                 :      24535 :       gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
    2012                 :            : 
    2013                 :      73605 :       tmp = fold_build3_loc (input_location, COMPONENT_REF,
    2014                 :            :                              st_parameter[IOPARM_ptype_common].type,
    2015                 :      24535 :                              dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
    2016                 :            :                              NULL_TREE);
    2017                 :      73605 :       tmp = fold_build3_loc (input_location, COMPONENT_REF,
    2018                 :      24535 :                              TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
    2019                 :      24535 :       tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
    2020                 :      24535 :                              tmp, build_int_cst (TREE_TYPE (tmp),
    2021                 :      24535 :                              IOPARM_common_libreturn_mask));
    2022                 :            :     }
    2023                 :            :   else /* IOLENGTH */
    2024                 :            :     tmp = NULL_TREE;
    2025                 :            : 
    2026                 :      24618 :   gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
    2027                 :            : 
    2028                 :      24618 :   gfc_add_block_to_block (&block, &post_iu_block);
    2029                 :            : 
    2030                 :      24618 :   dt_parm = NULL;
    2031                 :      24618 :   dt_post_end_block = NULL;
    2032                 :            : 
    2033                 :      24618 :   return gfc_finish_block (&block);
    2034                 :            : }
    2035                 :            : 
    2036                 :            : 
    2037                 :            : /* Translate the IOLENGTH form of an INQUIRE statement.  We treat
    2038                 :            :    this as a third sort of data transfer statement, except that
    2039                 :            :    lengths are summed instead of actually transferring any data.  */
    2040                 :            : 
    2041                 :            : tree
    2042                 :         83 : gfc_trans_iolength (gfc_code * code)
    2043                 :            : {
    2044                 :         83 :   last_dt = IOLENGTH;
    2045                 :         83 :   return build_dt (iocall[IOCALL_IOLENGTH], code);
    2046                 :            : }
    2047                 :            : 
    2048                 :            : 
    2049                 :            : /* Translate a READ statement.  */
    2050                 :            : 
    2051                 :            : tree
    2052                 :       5583 : gfc_trans_read (gfc_code * code)
    2053                 :            : {
    2054                 :       5583 :   last_dt = READ;
    2055                 :       5583 :   return build_dt (iocall[IOCALL_READ], code);
    2056                 :            : }
    2057                 :            : 
    2058                 :            : 
    2059                 :            : /* Translate a WRITE statement */
    2060                 :            : 
    2061                 :            : tree
    2062                 :      18952 : gfc_trans_write (gfc_code * code)
    2063                 :            : {
    2064                 :      18952 :   last_dt = WRITE;
    2065                 :      18952 :   return build_dt (iocall[IOCALL_WRITE], code);
    2066                 :            : }
    2067                 :            : 
    2068                 :            : 
    2069                 :            : /* Finish a data transfer statement.  */
    2070                 :            : 
    2071                 :            : tree
    2072                 :      24618 : gfc_trans_dt_end (gfc_code * code)
    2073                 :            : {
    2074                 :      24618 :   tree function, tmp;
    2075                 :      24618 :   stmtblock_t block;
    2076                 :            : 
    2077                 :      24618 :   gfc_init_block (&block);
    2078                 :            : 
    2079                 :      24618 :   switch (last_dt)
    2080                 :            :     {
    2081                 :       5583 :     case READ:
    2082                 :       5583 :       function = iocall[IOCALL_READ_DONE];
    2083                 :       5583 :       break;
    2084                 :            : 
    2085                 :      18952 :     case WRITE:
    2086                 :      18952 :       function = iocall[IOCALL_WRITE_DONE];
    2087                 :      18952 :       break;
    2088                 :            : 
    2089                 :         83 :     case IOLENGTH:
    2090                 :         83 :       function = iocall[IOCALL_IOLENGTH_DONE];
    2091                 :         83 :       break;
    2092                 :            : 
    2093                 :          0 :     default:
    2094                 :          0 :       gcc_unreachable ();
    2095                 :            :     }
    2096                 :            : 
    2097                 :      24618 :   tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
    2098                 :      24618 :   tmp = build_call_expr_loc (input_location,
    2099                 :            :                          function, 1, tmp);
    2100                 :      24618 :   gfc_add_expr_to_block (&block, tmp);
    2101                 :      24618 :   gfc_add_block_to_block (&block, dt_post_end_block);
    2102                 :      24618 :   gfc_init_block (dt_post_end_block);
    2103                 :            : 
    2104                 :      24618 :   if (last_dt != IOLENGTH)
    2105                 :            :     {
    2106                 :      24535 :       gcc_assert (code->ext.dt != NULL);
    2107                 :      24535 :       io_result (&block, dt_parm, code->ext.dt->err,
    2108                 :            :                  code->ext.dt->end, code->ext.dt->eor);
    2109                 :            :     }
    2110                 :            : 
    2111                 :      24618 :   return gfc_finish_block (&block);
    2112                 :            : }
    2113                 :            : 
    2114                 :            : static void
    2115                 :            : transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
    2116                 :            :                gfc_code * code, tree vptr);
    2117                 :            : 
    2118                 :            : /* Given an array field in a derived type variable, generate the code
    2119                 :            :    for the loop that iterates over array elements, and the code that
    2120                 :            :    accesses those array elements.  Use transfer_expr to generate code
    2121                 :            :    for transferring that element.  Because elements may also be
    2122                 :            :    derived types, transfer_expr and transfer_array_component are mutually
    2123                 :            :    recursive.  */
    2124                 :            : 
    2125                 :            : static tree
    2126                 :         72 : transfer_array_component (tree expr, gfc_component * cm, locus * where)
    2127                 :            : {
    2128                 :         72 :   tree tmp;
    2129                 :         72 :   stmtblock_t body;
    2130                 :         72 :   stmtblock_t block;
    2131                 :         72 :   gfc_loopinfo loop;
    2132                 :         72 :   int n;
    2133                 :         72 :   gfc_ss *ss;
    2134                 :         72 :   gfc_se se;
    2135                 :         72 :   gfc_array_info *ss_array;
    2136                 :            : 
    2137                 :         72 :   gfc_start_block (&block);
    2138                 :         72 :   gfc_init_se (&se, NULL);
    2139                 :            : 
    2140                 :            :   /* Create and initialize Scalarization Status.  Unlike in
    2141                 :            :      gfc_trans_transfer, we can't simply use gfc_walk_expr to take
    2142                 :            :      care of this task, because we don't have a gfc_expr at hand.
    2143                 :            :      Build one manually, as in gfc_trans_subarray_assign.  */
    2144                 :            : 
    2145                 :         72 :   ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
    2146                 :            :                          GFC_SS_COMPONENT);
    2147                 :         72 :   ss_array = &ss->info->data.array;
    2148                 :            : 
    2149                 :         72 :   if (cm->attr.pdt_array)
    2150                 :          6 :     ss_array->shape = NULL;
    2151                 :            :   else
    2152                 :         66 :     ss_array->shape = gfc_get_shape (cm->as->rank);
    2153                 :            : 
    2154                 :         72 :   ss_array->descriptor = expr;
    2155                 :         72 :   ss_array->data = gfc_conv_array_data (expr);
    2156                 :         72 :   ss_array->offset = gfc_conv_array_offset (expr);
    2157                 :        144 :   for (n = 0; n < cm->as->rank; n++)
    2158                 :            :     {
    2159                 :         72 :       ss_array->start[n] = gfc_conv_array_lbound (expr, n);
    2160                 :         72 :       ss_array->stride[n] = gfc_index_one_node;
    2161                 :            : 
    2162                 :         72 :       if (cm->attr.pdt_array)
    2163                 :          6 :         ss_array->end[n] = gfc_conv_array_ubound (expr, n);
    2164                 :            :       else
    2165                 :            :         {
    2166                 :         66 :           mpz_init (ss_array->shape[n]);
    2167                 :         66 :           mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
    2168                 :         66 :                    cm->as->lower[n]->value.integer);
    2169                 :         66 :           mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
    2170                 :            :         }
    2171                 :            :     }
    2172                 :            : 
    2173                 :            :   /* Once we got ss, we use scalarizer to create the loop.  */
    2174                 :            : 
    2175                 :         72 :   gfc_init_loopinfo (&loop);
    2176                 :         72 :   gfc_add_ss_to_loop (&loop, ss);
    2177                 :         72 :   gfc_conv_ss_startstride (&loop);
    2178                 :         72 :   gfc_conv_loop_setup (&loop, where);
    2179                 :         72 :   gfc_mark_ss_chain_used (ss, 1);
    2180                 :         72 :   gfc_start_scalarized_body (&loop, &body);
    2181                 :            : 
    2182                 :         72 :   gfc_copy_loopinfo_to_se (&se, &loop);
    2183                 :         72 :   se.ss = ss;
    2184                 :            : 
    2185                 :            :   /* gfc_conv_tmp_array_ref assumes that se.expr contains the array.  */
    2186                 :         72 :   se.expr = expr;
    2187                 :         72 :   gfc_conv_tmp_array_ref (&se);
    2188                 :            : 
    2189                 :            :   /* Now se.expr contains an element of the array.  Take the address and pass
    2190                 :            :      it to the IO routines.  */
    2191                 :         72 :   tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
    2192                 :         72 :   transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
    2193                 :            : 
    2194                 :            :   /* We are done now with the loop body.  Wrap up the scalarizer and
    2195                 :            :      return.  */
    2196                 :            : 
    2197                 :         72 :   gfc_add_block_to_block (&body, &se.pre);
    2198                 :         72 :   gfc_add_block_to_block (&body, &se.post);
    2199                 :            : 
    2200                 :         72 :   gfc_trans_scalarizing_loops (&loop, &body);
    2201                 :            : 
    2202                 :         72 :   gfc_add_block_to_block (&block, &loop.pre);
    2203                 :         72 :   gfc_add_block_to_block (&block, &loop.post);
    2204                 :            : 
    2205                 :         72 :   if (!cm->attr.pdt_array)
    2206                 :            :     {
    2207                 :         66 :       gcc_assert (ss_array->shape != NULL);
    2208                 :         66 :       gfc_free_shape (&ss_array->shape, cm->as->rank);
    2209                 :            :     }
    2210                 :         72 :   gfc_cleanup_loop (&loop);
    2211                 :            : 
    2212                 :         72 :   return gfc_finish_block (&block);
    2213                 :            : }
    2214                 :            : 
    2215                 :            : 
    2216                 :            : /* Helper function for transfer_expr that looks for the DTIO procedure
    2217                 :            :    either as a typebound binding or in a generic interface. If present,
    2218                 :            :    the address expression of the procedure is returned. It is assumed
    2219                 :            :    that the procedure interface has been checked during resolution.  */
    2220                 :            : 
    2221                 :            : static tree
    2222                 :        418 : get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
    2223                 :            : {
    2224                 :        418 :   gfc_symbol *derived;
    2225                 :        418 :   bool formatted = false;
    2226                 :        418 :   gfc_dt *dt = code->ext.dt;
    2227                 :            : 
    2228                 :            :   /* Determine when to use the formatted DTIO procedure.  */
    2229                 :        418 :   if (dt && (dt->format_expr || dt->format_label))
    2230                 :        340 :     formatted = true;
    2231                 :            : 
    2232                 :        418 :   if (ts->type == BT_CLASS)
    2233                 :         54 :     derived = ts->u.derived->components->ts.u.derived;
    2234                 :            :   else
    2235                 :        364 :     derived = ts->u.derived;
    2236                 :            : 
    2237                 :        418 :   gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
    2238                 :            :                                                   last_dt == WRITE, formatted);
    2239                 :        418 :   if (ts->type == BT_CLASS && tb_io_st)
    2240                 :            :     {
    2241                 :            :       // polymorphic DTIO call  (based on the dynamic type)
    2242                 :         48 :       gfc_se se;
    2243                 :         48 :       gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1);
    2244                 :         48 :       gfc_add_vptr_component (expr);
    2245                 :         48 :       gfc_add_component_ref (expr,
    2246                 :         48 :                              tb_io_st->n.tb->u.generic->specific_st->name);
    2247                 :         48 :       *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym;
    2248                 :         48 :       gfc_init_se (&se, NULL);
    2249                 :         48 :       se.want_pointer = 1;
    2250                 :         48 :       gfc_conv_expr (&se, expr);
    2251                 :         48 :       gfc_free_expr (expr);
    2252                 :         48 :       return se.expr;
    2253                 :            :     }
    2254                 :            :   else
    2255                 :            :     {
    2256                 :            :       // non-polymorphic DTIO call (based on the declared type)
    2257                 :        370 :       *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
    2258                 :            :                                               formatted);
    2259                 :            : 
    2260                 :        370 :       if (*dtio_sub)
    2261                 :        370 :         return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
    2262                 :            :     }
    2263                 :            : 
    2264                 :            :   return NULL_TREE;
    2265                 :            : }
    2266                 :            : 
    2267                 :            : /* Generate the call for a scalar transfer node.  */
    2268                 :            : 
    2269                 :            : static void
    2270                 :      31986 : transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
    2271                 :            :                gfc_code * code, tree vptr)
    2272                 :            : {
    2273                 :      31986 :   tree tmp, function, arg2, arg3, field, expr;
    2274                 :      31986 :   gfc_component *c;
    2275                 :      31986 :   int kind;
    2276                 :            : 
    2277                 :            :   /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
    2278                 :            :      the user says something like: print *, 'c_null_ptr: ', c_null_ptr
    2279                 :            :      We need to translate the expression to a constant if it's either
    2280                 :            :      C_NULL_PTR or C_NULL_FUNPTR.  We could also get a user variable of
    2281                 :            :      type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
    2282                 :            :      BT_DERIVED (could have been changed by gfc_conv_expr).  */
    2283                 :      31986 :   if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
    2284                 :      10358 :       && ts->u.derived != NULL
    2285                 :        618 :       && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
    2286                 :            :     {
    2287                 :         21 :       ts->type = BT_INTEGER;
    2288                 :         21 :       ts->kind = gfc_index_integer_kind;
    2289                 :            :     }
    2290                 :            : 
    2291                 :            :   /* gfortran reaches here for "print *, c_loc(xxx)".  */
    2292                 :      31986 :   if (ts->type == BT_VOID
    2293                 :          0 :       && code->expr1 && code->expr1->ts.type == BT_VOID
    2294                 :          0 :       && code->expr1->symtree
    2295                 :          0 :       && strcmp (code->expr1->symtree->name, "c_loc") == 0)
    2296                 :            :     {
    2297                 :          0 :       ts->type = BT_INTEGER;
    2298                 :          0 :       ts->kind = gfc_index_integer_kind;
    2299                 :            :     }
    2300                 :            : 
    2301                 :      31986 :   kind = ts->kind;
    2302                 :      31986 :   function = NULL;
    2303                 :      31986 :   arg2 = NULL;
    2304                 :      31986 :   arg3 = NULL;
    2305                 :            : 
    2306                 :      31986 :   switch (ts->type)
    2307                 :            :     {
    2308                 :       9761 :     case BT_INTEGER:
    2309                 :       9761 :       arg2 = build_int_cst (integer_type_node, kind);
    2310                 :       9761 :       if (last_dt == READ)
    2311                 :       2220 :         function = iocall[IOCALL_X_INTEGER];
    2312                 :            :       else
    2313                 :       7541 :         function = iocall[IOCALL_X_INTEGER_WRITE];
    2314                 :            : 
    2315                 :            :       break;
    2316                 :            : 
    2317                 :       6255 :     case BT_REAL:
    2318                 :       6255 :       arg2 = build_int_cst (integer_type_node, kind);
    2319                 :       6255 :       if (last_dt == READ)
    2320                 :            :         {
    2321                 :       1395 :           if (gfc_real16_is_float128 && ts->kind == 16)
    2322                 :         66 :             function = iocall[IOCALL_X_REAL128];
    2323                 :            :           else
    2324                 :       1329 :             function = iocall[IOCALL_X_REAL];
    2325                 :            :         }
    2326                 :            :       else
    2327                 :            :         {
    2328                 :       4860 :           if (gfc_real16_is_float128 && ts->kind == 16)
    2329                 :        203 :             function = iocall[IOCALL_X_REAL128_WRITE];
    2330                 :            :           else
    2331                 :       4657 :             function = iocall[IOCALL_X_REAL_WRITE];
    2332                 :            :         }
    2333                 :            : 
    2334                 :            :       break;
    2335                 :            : 
    2336                 :        690 :     case BT_COMPLEX:
    2337                 :        690 :       arg2 = build_int_cst (integer_type_node, kind);
    2338                 :        690 :       if (last_dt == READ)
    2339                 :            :         {
    2340                 :        331 :           if (gfc_real16_is_float128 && ts->kind == 16)
    2341                 :          0 :             function = iocall[IOCALL_X_COMPLEX128];
    2342                 :            :           else
    2343                 :        331 :             function = iocall[IOCALL_X_COMPLEX];
    2344                 :            :         }
    2345                 :            :       else
    2346                 :            :         {
    2347                 :        359 :           if (gfc_real16_is_float128 && ts->kind == 16)
    2348                 :          3 :             function = iocall[IOCALL_X_COMPLEX128_WRITE];
    2349                 :            :           else
    2350                 :        356 :             function = iocall[IOCALL_X_COMPLEX_WRITE];
    2351                 :            :         }
    2352                 :            : 
    2353                 :            :       break;
    2354                 :            : 
    2355                 :        866 :     case BT_LOGICAL:
    2356                 :        866 :       arg2 = build_int_cst (integer_type_node, kind);
    2357                 :        866 :       if (last_dt == READ)
    2358                 :        120 :         function = iocall[IOCALL_X_LOGICAL];
    2359                 :            :       else
    2360                 :        746 :         function = iocall[IOCALL_X_LOGICAL_WRITE];
    2361                 :            : 
    2362                 :            :       break;
    2363                 :            : 
    2364                 :      13745 :     case BT_CHARACTER:
    2365                 :      13745 :       if (kind == 4)
    2366                 :            :         {
    2367                 :        214 :           if (se->string_length)
    2368                 :            :             arg2 = se->string_length;
    2369                 :            :           else
    2370                 :            :             {
    2371                 :          0 :               tmp = build_fold_indirect_ref_loc (input_location,
    2372                 :            :                                              addr_expr);
    2373                 :          0 :               gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
    2374                 :          0 :               arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
    2375                 :          0 :               arg2 = fold_convert (gfc_charlen_type_node, arg2);
    2376                 :            :             }
    2377                 :        214 :           arg3 = build_int_cst (integer_type_node, kind);
    2378                 :        214 :           if (last_dt == READ)
    2379                 :         84 :             function = iocall[IOCALL_X_CHARACTER_WIDE];
    2380                 :            :           else
    2381                 :        130 :             function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
    2382                 :            : 
    2383                 :        214 :           tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
    2384                 :        214 :           tmp = build_call_expr_loc (input_location,
    2385                 :            :                                  function, 4, tmp, addr_expr, arg2, arg3);
    2386                 :        214 :           gfc_add_expr_to_block (&se->pre, tmp);
    2387                 :        214 :           gfc_add_block_to_block (&se->pre, &se->post);
    2388                 :        214 :           return;
    2389                 :            :         }
    2390                 :            :       /* Fall through.  */
    2391                 :      13543 :     case BT_HOLLERITH:
    2392                 :      13543 :       if (se->string_length)
    2393                 :            :         arg2 = se->string_length;
    2394                 :            :       else
    2395                 :            :         {
    2396                 :        119 :           tmp = build_fold_indirect_ref_loc (input_location,
    2397                 :            :                                          addr_expr);
    2398                 :        119 :           gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
    2399                 :        119 :           arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
    2400                 :            :         }
    2401                 :      13543 :       if (last_dt == READ)
    2402                 :       1497 :         function = iocall[IOCALL_X_CHARACTER];
    2403                 :            :       else
    2404                 :      12046 :         function = iocall[IOCALL_X_CHARACTER_WRITE];
    2405                 :            : 
    2406                 :            :       break;
    2407                 :            : 
    2408                 :        657 :     case_bt_struct:
    2409                 :        657 :     case BT_CLASS:
    2410                 :        657 :       if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS)
    2411                 :            :         {
    2412                 :        657 :           gfc_symbol *derived;
    2413                 :        657 :           gfc_symbol *dtio_sub = NULL;
    2414                 :            :           /* Test for a specific DTIO subroutine.  */
    2415                 :        657 :           if (ts->type == BT_DERIVED)
    2416                 :        597 :             derived = ts->u.derived;
    2417                 :            :           else
    2418                 :         60 :             derived = ts->u.derived->components->ts.u.derived;
    2419                 :            : 
    2420                 :        657 :           if (derived->attr.has_dtio_procs)
    2421                 :        418 :             arg2 = get_dtio_proc (ts, code, &dtio_sub);
    2422                 :            : 
    2423                 :        657 :           if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
    2424                 :            :             {
    2425                 :        406 :               tree decl;
    2426                 :        406 :               decl = build_fold_indirect_ref_loc (input_location,
    2427                 :            :                                                   se->expr);
    2428                 :            :               /* Remember that the first dummy of the DTIO subroutines
    2429                 :            :                  is CLASS(derived) for extensible derived types, so the
    2430                 :            :                  conversion must be done here for derived type and for
    2431                 :            :                  scalarized CLASS array element io-list objects.  */
    2432                 :        406 :               if ((ts->type == BT_DERIVED
    2433                 :        352 :                    && !(ts->u.derived->attr.sequence
    2434                 :            :                         || ts->u.derived->attr.is_bind_c))
    2435                 :        430 :                   || (ts->type == BT_CLASS
    2436                 :         54 :                       && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
    2437                 :        364 :                 gfc_conv_derived_to_class (se, code->expr1,
    2438                 :        364 :                                            dtio_sub->formal->sym->ts,
    2439                 :            :                                            vptr, false, false);
    2440                 :        406 :               addr_expr = se->expr;
    2441                 :        406 :               function = iocall[IOCALL_X_DERIVED];
    2442                 :        406 :               break;
    2443                 :            :             }
    2444                 :        251 :           else if (gfc_bt_struct (ts->type))
    2445                 :            :             {
    2446                 :            :               /* Recurse into the elements of the derived type.  */
    2447                 :        251 :               expr = gfc_evaluate_now (addr_expr, &se->pre);
    2448                 :        251 :               expr = build_fold_indirect_ref_loc (input_location, expr);
    2449                 :            : 
    2450                 :            :               /* Make sure that the derived type has been built.  An external
    2451                 :            :                  function, if only referenced in an io statement, requires this
    2452                 :            :                  check (see PR58771).  */
    2453                 :        251 :               if (ts->u.derived->backend_decl == NULL_TREE)
    2454                 :          6 :                 (void) gfc_typenode_for_spec (ts);
    2455                 :            : 
    2456                 :        750 :               for (c = ts->u.derived->components; c; c = c->next)
    2457                 :            :                 {
    2458                 :            :                   /* Ignore hidden string lengths.  */
    2459                 :        499 :                   if (c->name[0] == '_')
    2460                 :         12 :                     continue;
    2461                 :            : 
    2462                 :        487 :                   field = c->backend_decl;
    2463                 :        487 :                   gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
    2464                 :            : 
    2465                 :        487 :                   tmp = fold_build3_loc (UNKNOWN_LOCATION,
    2466                 :        487 :                                          COMPONENT_REF, TREE_TYPE (field),
    2467                 :            :                                          expr, field, NULL_TREE);
    2468                 :            : 
    2469                 :        487 :                   if (c->attr.dimension)
    2470                 :            :                     {
    2471                 :         72 :                       tmp = transfer_array_component (tmp, c, & code->loc);
    2472                 :         72 :                       gfc_add_expr_to_block (&se->pre, tmp);
    2473                 :            :                     }
    2474                 :            :                   else
    2475                 :            :                     {
    2476                 :        415 :                       tree strlen = NULL_TREE;
    2477                 :            : 
    2478                 :        415 :                       if (!c->attr.pointer && !c->attr.pdt_string)
    2479                 :        403 :                         tmp = gfc_build_addr_expr (NULL_TREE, tmp);
    2480                 :            : 
    2481                 :            :                       /* Use the hidden string length for pdt strings.  */
    2482                 :        415 :                       if (c->attr.pdt_string
    2483                 :         12 :                           && gfc_deferred_strlen (c, &strlen)
    2484                 :        427 :                           && strlen != NULL_TREE)
    2485                 :            :                         {
    2486                 :         36 :                           strlen = fold_build3_loc (UNKNOWN_LOCATION,
    2487                 :            :                                                     COMPONENT_REF,
    2488                 :         12 :                                                     TREE_TYPE (strlen),
    2489                 :            :                                                     expr, strlen, NULL_TREE);
    2490                 :         12 :                           se->string_length = strlen;
    2491                 :            :                         }
    2492                 :            : 
    2493                 :        415 :                       transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
    2494                 :            : 
    2495                 :            :                       /* Reset so that the pdt string length does not propagate
    2496                 :            :                          through to other strings.  */
    2497                 :        415 :                       if (c->attr.pdt_string && strlen)
    2498                 :         12 :                         se->string_length = NULL_TREE;
    2499                 :            :                    }
    2500                 :            :                 }
    2501                 :        251 :               return;
    2502                 :            :             }
    2503                 :            :           /* If a CLASS object gets through to here, fall through and ICE.  */
    2504                 :            :         }
    2505                 :          0 :       gcc_fallthrough ();
    2506                 :          0 :     default:
    2507                 :          0 :       gfc_internal_error ("Bad IO basetype (%d)", ts->type);
    2508                 :            :     }
    2509                 :            : 
    2510                 :      31521 :   tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
    2511                 :      31521 :   tmp = build_call_expr_loc (input_location,
    2512                 :            :                          function, 3, tmp, addr_expr, arg2);
    2513                 :      31521 :   gfc_add_expr_to_block (&se->pre, tmp);
    2514                 :      31521 :   gfc_add_block_to_block (&se->pre, &se->post);
    2515                 :            : 
    2516                 :            : }
    2517                 :            : 
    2518                 :            : 
    2519                 :            : /* Generate a call to pass an array descriptor to the IO library. The
    2520                 :            :    array should be of one of the intrinsic types.  */
    2521                 :            : 
    2522                 :            : static void
    2523                 :       2911 : transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
    2524                 :            : {
    2525                 :       2911 :   tree tmp, charlen_arg, kind_arg, io_call;
    2526                 :            : 
    2527                 :       2911 :   if (ts->type == BT_CHARACTER)
    2528                 :        328 :     charlen_arg = se->string_length;
    2529                 :            :   else
    2530                 :       2583 :     charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
    2531                 :            : 
    2532                 :       2911 :   kind_arg = build_int_cst (integer_type_node, ts->kind);
    2533                 :            : 
    2534                 :       2911 :   tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
    2535                 :       2911 :   if (last_dt == READ)
    2536                 :        884 :     io_call = iocall[IOCALL_X_ARRAY];
    2537                 :            :   else
    2538                 :       2027 :     io_call = iocall[IOCALL_X_ARRAY_WRITE];
    2539                 :            : 
    2540                 :       2911 :   tmp = build_call_expr_loc (UNKNOWN_LOCATION,
    2541                 :            :                          io_call, 4,
    2542                 :            :                          tmp, addr_expr, kind_arg, charlen_arg);
    2543                 :       2911 :   gfc_add_expr_to_block (&se->pre, tmp);
    2544                 :       2911 :   gfc_add_block_to_block (&se->pre, &se->post);
    2545                 :       2911 : }
    2546                 :            : 
    2547                 :            : 
    2548                 :            : /* gfc_trans_transfer()-- Translate a TRANSFER code node */
    2549                 :            : 
    2550                 :            : tree
    2551                 :      34410 : gfc_trans_transfer (gfc_code * code)
    2552                 :            : {
    2553                 :      34410 :   stmtblock_t block, body;
    2554                 :      34410 :   gfc_loopinfo loop;
    2555                 :      34410 :   gfc_expr *expr;
    2556                 :      34410 :   gfc_ref *ref;
    2557                 :      34410 :   gfc_ss *ss;
    2558                 :      34410 :   gfc_se se;
    2559                 :      34410 :   tree tmp;
    2560                 :      34410 :   tree vptr;
    2561                 :      34410 :   int n;
    2562                 :            : 
    2563                 :      34410 :   gfc_start_block (&block);
    2564                 :      34410 :   gfc_init_block (&body);
    2565                 :            : 
    2566                 :      34410 :   expr = code->expr1;
    2567                 :      34410 :   ref = NULL;
    2568                 :      34410 :   gfc_init_se (&se, NULL);
    2569                 :            : 
    2570                 :      34410 :   if (expr->rank == 0)
    2571                 :            :     {
    2572                 :            :       /* Transfer a scalar value.  */
    2573                 :      29269 :       if (expr->ts.type == BT_CLASS)
    2574                 :            :         {
    2575                 :         30 :           se.want_pointer = 1;
    2576                 :         30 :           gfc_conv_expr (&se, expr);
    2577                 :         30 :           vptr = gfc_get_vptr_from_expr (se.expr);
    2578                 :            :         }
    2579                 :            :       else
    2580                 :            :         {
    2581                 :      29239 :           vptr = NULL_TREE;
    2582                 :      29239 :           gfc_conv_expr_reference (&se, expr);
    2583                 :            :         }
    2584                 :      29269 :       transfer_expr (&se, &expr->ts, se.expr, code, vptr);
    2585                 :            :     }
    2586                 :            :   else
    2587                 :            :     {
    2588                 :            :       /* Transfer an array. If it is an array of an intrinsic
    2589                 :            :          type, pass the descriptor to the library.  Otherwise
    2590                 :            :          scalarize the transfer.  */
    2591                 :       5141 :       if (expr->ref && !gfc_is_proc_ptr_comp (expr))
    2592                 :            :         {
    2593                 :       3274 :           for (ref = expr->ref; ref && ref->type != REF_ARRAY;
    2594                 :        137 :             ref = ref->next);
    2595                 :       3137 :           gcc_assert (ref && ref->type == REF_ARRAY);
    2596                 :            :         }
    2597                 :            : 
    2598                 :       5141 :       if (expr->ts.type != BT_CLASS
    2599                 :       5117 :          && expr->expr_type == EXPR_VARIABLE
    2600                 :       8254 :          && gfc_expr_attr (expr).pointer)
    2601                 :         56 :         goto scalarize;
    2602                 :            : 
    2603                 :            : 
    2604                 :       5024 :       if (!(gfc_bt_struct (expr->ts.type)
    2605                 :            :               || expr->ts.type == BT_CLASS)
    2606                 :       5000 :             && ref && ref->next == NULL
    2607                 :       7996 :             && !is_subref_array (expr))
    2608                 :            :         {
    2609                 :       2911 :           bool seen_vector = false;
    2610                 :            : 
    2611                 :       2911 :           if (ref && ref->u.ar.type == AR_SECTION)
    2612                 :            :             {
    2613                 :       1732 :               for (n = 0; n < ref->u.ar.dimen; n++)
    2614                 :        995 :                 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
    2615                 :            :                   {
    2616                 :            :                     seen_vector = true;
    2617                 :            :                     break;
    2618                 :            :                   }
    2619                 :            :             }
    2620                 :            : 
    2621                 :        747 :           if (seen_vector && last_dt == READ)
    2622                 :            :             {
    2623                 :            :               /* Create a temp, read to that and copy it back.  */
    2624                 :          6 :               gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
    2625                 :          6 :               tmp =  se.expr;
    2626                 :            :             }
    2627                 :            :           else
    2628                 :            :             {
    2629                 :            :               /* Get the descriptor.  */
    2630                 :       2905 :               gfc_conv_expr_descriptor (&se, expr);
    2631                 :       2905 :               tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
    2632                 :            :             }
    2633                 :            : 
    2634                 :       2911 :           transfer_array_desc (&se, &expr->ts, tmp);
    2635                 :       2911 :           goto finish_block_label;
    2636                 :            :         }
    2637                 :            : 
    2638                 :       2230 : scalarize:
    2639                 :            :       /* Initialize the scalarizer.  */
    2640                 :       2230 :       ss = gfc_walk_expr (expr);
    2641                 :       2230 :       gfc_init_loopinfo (&loop);
    2642                 :       2230 :       gfc_add_ss_to_loop (&loop, ss);
    2643                 :            : 
    2644                 :            :       /* Initialize the loop.  */
    2645                 :       2230 :       gfc_conv_ss_startstride (&loop);
    2646                 :       2230 :       gfc_conv_loop_setup (&loop, &code->expr1->where);
    2647                 :            : 
    2648                 :            :       /* The main loop body.  */
    2649                 :       2230 :       gfc_mark_ss_chain_used (ss, 1);
    2650                 :       2230 :       gfc_start_scalarized_body (&loop, &body);
    2651                 :            : 
    2652                 :       2230 :       gfc_copy_loopinfo_to_se (&se, &loop);
    2653                 :       2230 :       se.ss = ss;
    2654                 :            : 
    2655                 :       2230 :       gfc_conv_expr_reference (&se, expr);
    2656                 :            : 
    2657                 :       2230 :       if (expr->ts.type == BT_CLASS)
    2658                 :         24 :         vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
    2659                 :            :       else
    2660                 :            :         vptr = NULL_TREE;
    2661                 :       2230 :       transfer_expr (&se, &expr->ts, se.expr, code, vptr);
    2662                 :            :     }
    2663                 :            : 
    2664                 :      34410 :  finish_block_label:
    2665                 :            : 
    2666                 :      34410 :   gfc_add_block_to_block (&body, &se.pre);
    2667                 :      34410 :   gfc_add_block_to_block (&body, &se.post);
    2668                 :            : 
    2669                 :      34410 :   if (se.ss == NULL)
    2670                 :      32180 :     tmp = gfc_finish_block (&body);
    2671                 :            :   else
    2672                 :            :     {
    2673                 :       2230 :       gcc_assert (expr->rank != 0);
    2674                 :       2230 :       gcc_assert (se.ss == gfc_ss_terminator);
    2675                 :       2230 :       gfc_trans_scalarizing_loops (&loop, &body);
    2676                 :            : 
    2677                 :       2230 :       gfc_add_block_to_block (&loop.pre, &loop.post);
    2678                 :       2230 :       tmp = gfc_finish_block (&loop.pre);
    2679                 :       2230 :       gfc_cleanup_loop (&loop);
    2680                 :            :     }
    2681                 :            : 
    2682                 :      34410 :   gfc_add_expr_to_block (&block, tmp);
    2683                 :            : 
    2684                 :      34410 :   return gfc_finish_block (&block);
    2685                 :            : }
    2686                 :            : 
    2687                 :            : #include "gt-fortran-trans-io.h"

Generated by: LCOV version 1.0

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