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