]> 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
Rename .c files to .cc files.
[thirdparty/gcc.git] / gcc / fortran / trans-io.cc
CommitLineData
6de9cd9a 1/* IO Code translation/library interface
7adcbafe 2 Copyright (C) 2002-2022 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
236 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
237 Therefore, the code to set these flags must be generated before
238 this function is used. */
239
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 tree size;
d3642f89 741
7e279142 742 if (e->rank == 0)
d3642f89 743 {
7e279142
JJ		 744 tree type, array, tmp;
745 gfc_symbol *sym;
746 int rank;
747
748 /* If it is an element, we need its address and size of the rest. */
749 gcc_assert (e->expr_type == EXPR_VARIABLE);
750 gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
751 sym = e->symtree->n.sym;
752 rank = sym->as->rank - 1;
d3642f89 753 gfc_conv_expr (se, e);
d3642f89 754
7e279142
JJ		 755 array = sym->backend_decl;
756 type = TREE_TYPE (array);
d3642f89 757
7e279142
JJ		 758 if (GFC_ARRAY_TYPE_P (type))
759 size = GFC_TYPE_ARRAY_SIZE (type);
760 else
761 {
762 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
763 size = 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);
771 size = fold_build2_loc (input_location, MULT_EXPR,
772 gfc_array_index_type, tmp, size);
7e279142
JJ		 773 }
774 gcc_assert (size);
d3642f89 775
65a9ca82
TB		 776 size = fold_build2_loc (input_location, MINUS_EXPR,
777 gfc_array_index_type, size,
778 TREE_OPERAND (se->expr, 1));
628c189e 779 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
7e279142 780 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
65a9ca82
TB		 781 size = fold_build2_loc (input_location, MULT_EXPR,
782 gfc_array_index_type, size,
783 fold_convert (gfc_array_index_type, tmp));
7e279142
JJ		 784 se->string_length = fold_convert (gfc_charlen_type_node, size);
785 return;
d3642f89
FW		 786 }
787
2960a368 788 gfc_conv_array_parameter (se, e, true, NULL, NULL, &size);
d3642f89
FW		 789 se->string_length = fold_convert (gfc_charlen_type_node, size);
790}
6de9cd9a 791
109b0ac2 792
6de9cd9a 793/* Generate code to store a string and its length into the
5e805e44 794 st_parameter_XXX structure. */
6de9cd9a 795
5e805e44 796static unsigned int
6de9cd9a 797set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
5e805e44 798 enum iofield type, gfc_expr * e)
6de9cd9a
DN		 799{
800 gfc_se se;
801 tree tmp;
6de9cd9a
DN		 802 tree io;
803 tree len;
5e805e44 804 gfc_st_parameter_field *p = &st_parameter_field[type];
6de9cd9a
DN		 805
806 gfc_init_se (&se, NULL);
6de9cd9a 807
5e805e44 808 if (p->param_type == IOPARM_ptype_common)
65a9ca82
TB		 809 var = fold_build3_loc (input_location, COMPONENT_REF,
810 st_parameter[IOPARM_ptype_common].type,
811 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
812 io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
44855d8c 813 var, p->field, NULL_TREE);
65a9ca82
TB		 814 len = fold_build3_loc (input_location, COMPONENT_REF,
815 TREE_TYPE (p->field_len),
816 var, p->field_len, NULL_TREE);
6de9cd9a 817
7ab92584 818 /* Integer variable assigned a format label. */
7e279142
JJ		 819 if (e->ts.type == BT_INTEGER
820 && e->rank == 0
821 && e->symtree->n.sym->attr.assign == 1)
6de9cd9a 822 {
dd18a33b 823 char * msg;
c8fe94c7 824 tree cond;
dd18a33b 825
ce2df7c6 826 gfc_conv_label_variable (&se, e);
6de9cd9a 827 tmp = GFC_DECL_STRING_LEN (se.expr);
63ee5404 828 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
65a9ca82 829 tmp, build_int_cst (TREE_TYPE (tmp), 0));
dd18a33b 830
1a33dc9e
UB		 831 msg = xasprintf ("Label assigned to variable '%s' (%%ld) is not a format "
832 "label", e->symtree->name);
0d52899f 833 gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
c8fe94c7 834 fold_convert (long_integer_type_node, tmp));
cede9502 835 free (msg);
dd18a33b 836
726a989a 837 gfc_add_modify (&se.pre, io,
b078dfbf 838 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
726a989a 839 gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
6de9cd9a
DN		 840 }
841 else
842 {
d3642f89
FW		 843 /* General character. */
844 if (e->ts.type == BT_CHARACTER && e->rank == 0)
845 gfc_conv_expr (&se, e);
846 /* Array assigned Hollerith constant or character array. */
7e279142 847 else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
d3642f89
FW		 848 gfc_convert_array_to_string (&se, e);
849 else
850 gcc_unreachable ();
851
6de9cd9a 852 gfc_conv_string_parameter (&se);
726a989a 853 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
f622221a
JB		 854 gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len),
855 se.string_length));
6de9cd9a
DN		 856 }
857
858 gfc_add_block_to_block (block, &se.pre);
859 gfc_add_block_to_block (postblock, &se.post);
5e805e44 860 return p->mask;
6de9cd9a
DN		 861}
862
863
109b0ac2
PT		 864/* Generate code to store the character (array) and the character length
865 for an internal unit. */
866
5e805e44 867static unsigned int
d4feb3d3
PT		 868set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
869 tree var, gfc_expr * e)
109b0ac2
PT		 870{
871 gfc_se se;
872 tree io;
873 tree len;
874 tree desc;
875 tree tmp;
5e805e44
JJ		 876 gfc_st_parameter_field *p;
877 unsigned int mask;
109b0ac2
PT		 878
879 gfc_init_se (&se, NULL);
880
5e805e44
JJ		 881 p = &st_parameter_field[IOPARM_dt_internal_unit];
882 mask = p->mask;
65a9ca82
TB		 883 io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
884 var, p->field, NULL_TREE);
885 len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len),
886 var, p->field_len, NULL_TREE);
5e805e44 887 p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
65a9ca82
TB		 888 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
889 var, p->field, NULL_TREE);
109b0ac2
PT		 890
891 gcc_assert (e->ts.type == BT_CHARACTER);
892
893 /* Character scalars. */
894 if (e->rank == 0)
895 {
896 gfc_conv_expr (&se, e);
897 gfc_conv_string_parameter (&se);
898 tmp = se.expr;
c3238e32 899 se.expr = build_int_cst (pchar_type_node, 0);
109b0ac2
PT		 900 }
901
902 /* Character array. */
64db4d29 903 else if (e->rank > 0)
109b0ac2 904 {
1d6b7f39 905 if (is_subref_array (e))
d4feb3d3
PT		 906 {
907 /* Use a temporary for components of arrays of derived types
908 or substring array references. */
1d6b7f39 909 gfc_conv_subref_array_arg (&se, e, 0,
430f2d1f 910 last_dt == READ ? INTENT_IN : INTENT_OUT, false);
db3927fb
AH		 911 tmp = build_fold_indirect_ref_loc (input_location,
912 se.expr);
d4feb3d3
PT		 913 se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
914 tmp = gfc_conv_descriptor_data_get (tmp);
915 }
916 else
917 {
918 /* Return the data pointer and rank from the descriptor. */
2960a368 919 gfc_conv_expr_descriptor (&se, e);
d4feb3d3
PT		 920 tmp = gfc_conv_descriptor_data_get (se.expr);
921 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
922 }
109b0ac2
PT		 923 }
924 else
925 gcc_unreachable ();
926
927 /* The cast is needed for character substrings and the descriptor
928 data. */
726a989a
RB		 929 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
930 gfc_add_modify (&se.pre, len,
d4feb3d3 931 fold_convert (TREE_TYPE (len), se.string_length));
726a989a 932 gfc_add_modify (&se.pre, desc, se.expr);
109b0ac2
PT		 933
934 gfc_add_block_to_block (block, &se.pre);
d4feb3d3 935 gfc_add_block_to_block (post_block, &se.post);
5e805e44 936 return mask;
109b0ac2
PT		 937}
938
6de9cd9a
DN		 939/* Add a case to a IO-result switch. */
940
941static void
942add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
943{
944 tree tmp, value;
945
946 if (label == NULL)
947 return; /* No label, no case */
948
df09d1d5 949 value = build_int_cst (integer_type_node, label_value);
6de9cd9a
DN		 950
951 /* Make a backend label for this case. */
c006df4e 952 tmp = gfc_build_label_decl (NULL_TREE);
6de9cd9a
DN		 953
954 /* And the case itself. */
3d528853 955 tmp = build_case_label (value, NULL_TREE, tmp);
6de9cd9a
DN		 956 gfc_add_expr_to_block (body, tmp);
957
958 /* Jump to the label. */
959 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
960 gfc_add_expr_to_block (body, tmp);
961}
962
963
964/* Generate a switch statement that branches to the correct I/O
965 result label. The last statement of an I/O call stores the
966 result into a variable because there is often cleanup that
967 must be done before the switch, so a temporary would have to
968 be created anyway. */
969
970static void
5e805e44 971io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
6de9cd9a
DN		 972 gfc_st_label * end_label, gfc_st_label * eor_label)
973{
974 stmtblock_t body;
975 tree tmp, rc;
5e805e44 976 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
6de9cd9a
DN		 977
978 /* If no labels are specified, ignore the result instead
979 of building an empty switch. */
980 if (err_label == NULL
981 && end_label == NULL
982 && eor_label == NULL)
983 return;
984
985 /* Build a switch statement. */
986 gfc_start_block (&body);
987
988 /* The label values here must be the same as the values
989 in the library_return enum in the runtime library */
990 add_case (1, err_label, &body);
991 add_case (2, end_label, &body);
992 add_case (3, eor_label, &body);
993
994 tmp = gfc_finish_block (&body);
995
65a9ca82
TB		 996 var = fold_build3_loc (input_location, COMPONENT_REF,
997 st_parameter[IOPARM_ptype_common].type,
998 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
999 rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
1000 var, p->field, NULL_TREE);
1001 rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc),
1002 rc, build_int_cst (TREE_TYPE (rc),
1003 IOPARM_common_libreturn_mask));
6de9cd9a 1004
9e851845 1005 tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, rc, tmp);
6de9cd9a
DN		 1006
1007 gfc_add_expr_to_block (block, tmp);
1008}
1009
1010
1011/* Store the current file and line number to variables so that if a
1012 library call goes awry, we can tell the user where the problem is. */
1013
1014static void
5e805e44 1015set_error_locus (stmtblock_t * block, tree var, locus * where)
6de9cd9a
DN		 1016{
1017 gfc_file *f;
5e805e44 1018 tree str, locus_file;
6de9cd9a 1019 int line;
5e805e44 1020 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
6de9cd9a 1021
65a9ca82
TB		 1022 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1023 st_parameter[IOPARM_ptype_common].type,
1024 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
1025 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1026 TREE_TYPE (p->field), locus_file,
1027 p->field, NULL_TREE);
d4fa05b9 1028 f = where->lb->file;
5e805e44 1029 str = gfc_build_cstring_const (f->filename);
6de9cd9a 1030
5e805e44 1031 str = gfc_build_addr_expr (pchar_type_node, str);
726a989a 1032 gfc_add_modify (block, locus_file, str);
6de9cd9a 1033
c8cc8542 1034 line = LOCATION_LINE (where->lb->location);
5e805e44 1035 set_parameter_const (block, var, IOPARM_common_line, line);
6de9cd9a
DN		 1036}
1037
1038
1039/* Translate an OPEN statement. */
1040
1041tree
1042gfc_trans_open (gfc_code * code)
1043{
1044 stmtblock_t block, post_block;
1045 gfc_open *p;
5e805e44
JJ		 1046 tree tmp, var;
1047 unsigned int mask = 0;
6de9cd9a 1048
5e805e44 1049 gfc_start_block (&block);
6de9cd9a
DN		 1050 gfc_init_block (&post_block);
1051
5e805e44
JJ		 1052 var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
1053
1054 set_error_locus (&block, var, &code->loc);
6de9cd9a
DN		 1055 p = code->ext.open;
1056
f96d606f
JD		 1057 if (p->iomsg)
1058 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1059 p->iomsg);
1060
1061 if (p->iostat)
1062 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1063 p->iostat);
1064
1065 if (p->err)
1066 mask |= IOPARM_common_err;
6de9cd9a
DN		 1067
1068 if (p->file)
5e805e44 1069 mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
6de9cd9a
DN		 1070
1071 if (p->status)
5e805e44
JJ		 1072 mask |= set_string (&block, &post_block, var, IOPARM_open_status,
1073 p->status);
6de9cd9a
DN		 1074
1075 if (p->access)
5e805e44
JJ		 1076 mask |= set_string (&block, &post_block, var, IOPARM_open_access,
1077 p->access);
6de9cd9a
DN		 1078
1079 if (p->form)
5e805e44 1080 mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
6de9cd9a
DN		 1081
1082 if (p->recl)
e344505c 1083 mask |= set_parameter_value (&block, var, IOPARM_open_recl_in,
ed9c79e1 1084 p->recl);
6de9cd9a
DN		 1085
1086 if (p->blank)
5e805e44
JJ		 1087 mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
1088 p->blank);
6de9cd9a
DN		 1089
1090 if (p->position)
5e805e44
JJ		 1091 mask |= set_string (&block, &post_block, var, IOPARM_open_position,
1092 p->position);
6de9cd9a
DN		 1093
1094 if (p->action)
5e805e44
JJ		 1095 mask |= set_string (&block, &post_block, var, IOPARM_open_action,
1096 p->action);
6de9cd9a
DN		 1097
1098 if (p->delim)
5e805e44
JJ		 1099 mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
1100 p->delim);
6de9cd9a
DN		 1101
1102 if (p->pad)
5e805e44 1103 mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
6de9cd9a 1104
6f0f0b2e
JD		 1105 if (p->decimal)
1106 mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
1107 p->decimal);
1108
1109 if (p->encoding)
1110 mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
1111 p->encoding);
1112
1113 if (p->round)
1114 mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
1115
1116 if (p->sign)
1117 mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
1118
1119 if (p->asynchronous)
1120 mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
1121 p->asynchronous);
1122
181c9f4a
TK		 1123 if (p->convert)
1124 mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
1125 p->convert);
8019105d 1126
9ad55c33
JD		 1127 if (p->newunit)
1128 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
1129 p->newunit);
181c9f4a 1130
0ef33d44
FR		 1131 if (p->cc)
1132 mask |= set_string (&block, &post_block, var, IOPARM_open_cc, p->cc);
1133
1134 if (p->share)
1135 mask |= set_string (&block, &post_block, var, IOPARM_open_share, p->share);
1136
1137 mask |= set_parameter_const (&block, var, IOPARM_open_readonly, p->readonly);
1138
5e805e44
JJ		 1139 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1140
f96d606f 1141 if (p->unit)
e344505c 1142 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
f96d606f
JD		 1143 else
1144 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1145
628c189e 1146 tmp = gfc_build_addr_expr (NULL_TREE, var);
db3927fb
AH		 1147 tmp = build_call_expr_loc (input_location,
1148 iocall[IOCALL_OPEN], 1, tmp);
6de9cd9a
DN		 1149 gfc_add_expr_to_block (&block, tmp);
1150
1151 gfc_add_block_to_block (&block, &post_block);
1152
5e805e44 1153 io_result (&block, var, p->err, NULL, NULL);
6de9cd9a
DN		 1154
1155 return gfc_finish_block (&block);
1156}
1157
1158
1159/* Translate a CLOSE statement. */
1160
1161tree
1162gfc_trans_close (gfc_code * code)
1163{
1164 stmtblock_t block, post_block;
1165 gfc_close *p;
5e805e44
JJ		 1166 tree tmp, var;
1167 unsigned int mask = 0;
6de9cd9a 1168
5e805e44 1169 gfc_start_block (&block);
6de9cd9a
DN		 1170 gfc_init_block (&post_block);
1171
5e805e44
JJ		 1172 var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
1173
1174 set_error_locus (&block, var, &code->loc);
6de9cd9a
DN		 1175 p = code->ext.close;
1176
7aba8abe 1177 if (p->iomsg)
5e805e44
JJ		 1178 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1179 p->iomsg);
7aba8abe 1180
6de9cd9a 1181 if (p->iostat)
5e805e44
JJ		 1182 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1183 p->iostat);
6de9cd9a
DN		 1184
1185 if (p->err)
5e805e44
JJ		 1186 mask |= IOPARM_common_err;
1187
f96d606f
JD		 1188 if (p->status)
1189 mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1190 p->status);
1191
5e805e44 1192 set_parameter_const (&block, var, IOPARM_common_flags, mask);
6de9cd9a 1193
f96d606f 1194 if (p->unit)
e344505c 1195 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
f96d606f
JD		 1196 else
1197 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1198
628c189e 1199 tmp = gfc_build_addr_expr (NULL_TREE, var);
db3927fb
AH		 1200 tmp = build_call_expr_loc (input_location,
1201 iocall[IOCALL_CLOSE], 1, tmp);
6de9cd9a
DN		 1202 gfc_add_expr_to_block (&block, tmp);
1203
1204 gfc_add_block_to_block (&block, &post_block);
1205
5e805e44 1206 io_result (&block, var, p->err, NULL, NULL);
6de9cd9a
DN		 1207
1208 return gfc_finish_block (&block);
1209}
1210
1211
1212/* Common subroutine for building a file positioning statement. */
1213
1214static tree
1215build_filepos (tree function, gfc_code * code)
1216{
7aba8abe 1217 stmtblock_t block, post_block;
6de9cd9a 1218 gfc_filepos *p;
5e805e44
JJ		 1219 tree tmp, var;
1220 unsigned int mask = 0;
6de9cd9a
DN		 1221
1222 p = code->ext.filepos;
1223
5e805e44 1224 gfc_start_block (&block);
7aba8abe 1225 gfc_init_block (&post_block);
6de9cd9a 1226
5e805e44
JJ		 1227 var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1228 "filepos_parm");
1229
1230 set_error_locus (&block, var, &code->loc);
6de9cd9a 1231
7aba8abe 1232 if (p->iomsg)
5e805e44
JJ		 1233 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1234 p->iomsg);
7aba8abe 1235
6de9cd9a 1236 if (p->iostat)
e344505c
JD		 1237 mask |= set_parameter_ref (&block, &post_block, var,
1238 IOPARM_common_iostat, p->iostat);
6de9cd9a
DN		 1239
1240 if (p->err)
5e805e44
JJ		 1241 mask |= IOPARM_common_err;
1242
1243 set_parameter_const (&block, var, IOPARM_common_flags, mask);
6de9cd9a 1244
f96d606f 1245 if (p->unit)
e344505c
JD		 1246 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit,
1247 p->unit);
f96d606f
JD		 1248 else
1249 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1250
628c189e 1251 tmp = gfc_build_addr_expr (NULL_TREE, var);
db3927fb
AH		 1252 tmp = build_call_expr_loc (input_location,
1253 function, 1, tmp);
6de9cd9a
DN		 1254 gfc_add_expr_to_block (&block, tmp);
1255
7aba8abe
TK		 1256 gfc_add_block_to_block (&block, &post_block);
1257
5e805e44 1258 io_result (&block, var, p->err, NULL, NULL);
6de9cd9a
DN		 1259
1260 return gfc_finish_block (&block);
1261}
1262
1263
1264/* Translate a BACKSPACE statement. */
1265
1266tree
1267gfc_trans_backspace (gfc_code * code)
1268{
5e805e44 1269 return build_filepos (iocall[IOCALL_BACKSPACE], code);
6de9cd9a
DN		 1270}
1271
1272
1273/* Translate an ENDFILE statement. */
1274
1275tree
1276gfc_trans_endfile (gfc_code * code)
1277{
5e805e44 1278 return build_filepos (iocall[IOCALL_ENDFILE], code);
6de9cd9a
DN		 1279}
1280
1281
1282/* Translate a REWIND statement. */
1283
1284tree
1285gfc_trans_rewind (gfc_code * code)
1286{
5e805e44 1287 return build_filepos (iocall[IOCALL_REWIND], code);
6de9cd9a
DN		 1288}
1289
1290
6403ec5f
JB		 1291/* Translate a FLUSH statement. */
1292
1293tree
1294gfc_trans_flush (gfc_code * code)
1295{
5e805e44 1296 return build_filepos (iocall[IOCALL_FLUSH], code);
6403ec5f
JB		 1297}
1298
1299
6de9cd9a
DN		 1300/* Translate the non-IOLENGTH form of an INQUIRE statement. */
1301
1302tree
1303gfc_trans_inquire (gfc_code * code)
1304{
1305 stmtblock_t block, post_block;
1306 gfc_inquire *p;
5e805e44 1307 tree tmp, var;
6f0f0b2e 1308 unsigned int mask = 0, mask2 = 0;
6de9cd9a 1309
5e805e44 1310 gfc_start_block (&block);
6de9cd9a
DN		 1311 gfc_init_block (&post_block);
1312
5e805e44
JJ		 1313 var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1314 "inquire_parm");
1315
1316 set_error_locus (&block, var, &code->loc);
6de9cd9a
DN		 1317 p = code->ext.inquire;
1318
7aba8abe 1319 if (p->iomsg)
5e805e44
JJ		 1320 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1321 p->iomsg);
7aba8abe 1322
6de9cd9a 1323 if (p->iostat)
5e805e44
JJ		 1324 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1325 p->iostat);
6de9cd9a 1326
f96d606f
JD		 1327 if (p->err)
1328 mask |= IOPARM_common_err;
1329
1330 /* Sanity check. */
1331 if (p->unit && p->file)
1332 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1333
1334 if (p->file)
1335 mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1336 p->file);
1337
6de9cd9a 1338 if (p->exist)
e344505c 1339 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
c16dd6a8 1340 p->exist);
6de9cd9a
DN		 1341
1342 if (p->opened)
5e805e44
JJ		 1343 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1344 p->opened);
6de9cd9a
DN		 1345
1346 if (p->number)
5e805e44
JJ		 1347 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1348 p->number);
6de9cd9a
DN		 1349
1350 if (p->named)
5e805e44
JJ		 1351 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1352 p->named);
6de9cd9a
DN		 1353
1354 if (p->name)
5e805e44
JJ		 1355 mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1356 p->name);
6de9cd9a
DN		 1357
1358 if (p->access)
5e805e44
JJ		 1359 mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1360 p->access);
6de9cd9a
DN		 1361
1362 if (p->sequential)
5e805e44
JJ		 1363 mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1364 p->sequential);
6de9cd9a
DN		 1365
1366 if (p->direct)
5e805e44
JJ		 1367 mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1368 p->direct);
6de9cd9a
DN		 1369
1370 if (p->form)
5e805e44
JJ		 1371 mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1372 p->form);
6de9cd9a
DN		 1373
1374 if (p->formatted)
5e805e44
JJ		 1375 mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1376 p->formatted);
6de9cd9a
DN		 1377
1378 if (p->unformatted)
5e805e44
JJ		 1379 mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1380 p->unformatted);
6de9cd9a
DN		 1381
1382 if (p->recl)
5e805e44
JJ		 1383 mask |= set_parameter_ref (&block, &post_block, var,
1384 IOPARM_inquire_recl_out, p->recl);
6de9cd9a
DN		 1385
1386 if (p->nextrec)
5e805e44
JJ		 1387 mask |= set_parameter_ref (&block, &post_block, var,
1388 IOPARM_inquire_nextrec, p->nextrec);
6de9cd9a
DN		 1389
1390 if (p->blank)
5e805e44
JJ		 1391 mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1392 p->blank);
6de9cd9a 1393
d06b3496
JD		 1394 if (p->delim)
1395 mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1396 p->delim);
1397
6de9cd9a 1398 if (p->position)
5e805e44
JJ		 1399 mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1400 p->position);
6de9cd9a
DN		 1401
1402 if (p->action)
5e805e44
JJ		 1403 mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1404 p->action);
6de9cd9a
DN		 1405
1406 if (p->read)
5e805e44
JJ		 1407 mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1408 p->read);
6de9cd9a
DN		 1409
1410 if (p->write)
5e805e44
JJ		 1411 mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1412 p->write);
6de9cd9a
DN		 1413
1414 if (p->readwrite)
5e805e44
JJ		 1415 mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1416 p->readwrite);
6de9cd9a 1417
dae24534 1418 if (p->pad)
5e805e44
JJ		 1419 mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1420 p->pad);
8019105d 1421
181c9f4a
TK		 1422 if (p->convert)
1423 mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1424 p->convert);
1425
014ec6ee
JD		 1426 if (p->strm_pos)
1427 mask |= set_parameter_ref (&block, &post_block, var,
1428 IOPARM_inquire_strm_pos_out, p->strm_pos);
1429
6f0f0b2e
JD		 1430 /* The second series of flags. */
1431 if (p->asynchronous)
1432 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1433 p->asynchronous);
1434
1435 if (p->decimal)
1436 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1437 p->decimal);
1438
1439 if (p->encoding)
1440 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1441 p->encoding);
1442
1443 if (p->round)
1444 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1445 p->round);
1446
1447 if (p->sign)
1448 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1449 p->sign);
1450
1451 if (p->pending)
1452 mask2 |= set_parameter_ref (&block, &post_block, var,
1453 IOPARM_inquire_pending, p->pending);
1454
1455 if (p->size)
1456 mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1457 p->size);
1458
1459 if (p->id)
d06b3496
JD		 1460 mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1461 p->id);
93e8af19
JD		 1462 if (p->iqstream)
1463 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream,
1464 p->iqstream);
6f0f0b2e 1465
0ef33d44
FR		 1466 if (p->share)
1467 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_share,
1468 p->share);
1469
1470 if (p->cc)
1471 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_cc, p->cc);
1472
6f0f0b2e 1473 if (mask2)
e1456843 1474 mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
6f0f0b2e 1475
5e805e44 1476 set_parameter_const (&block, var, IOPARM_common_flags, mask);
6de9cd9a 1477
f96d606f 1478 if (p->unit)
e344505c
JD		 1479 {
1480 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1481 set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit);
1482 }
f96d606f
JD		 1483 else
1484 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1485
628c189e 1486 tmp = gfc_build_addr_expr (NULL_TREE, var);
db3927fb
AH		 1487 tmp = build_call_expr_loc (input_location,
1488 iocall[IOCALL_INQUIRE], 1, tmp);
6de9cd9a
DN		 1489 gfc_add_expr_to_block (&block, tmp);
1490
1491 gfc_add_block_to_block (&block, &post_block);
1492
5e805e44 1493 io_result (&block, var, p->err, NULL, NULL);
6de9cd9a
DN		 1494
1495 return gfc_finish_block (&block);
1496}
1497
6f0f0b2e
JD		 1498
1499tree
1500gfc_trans_wait (gfc_code * code)
1501{
1502 stmtblock_t block, post_block;
1503 gfc_wait *p;
1504 tree tmp, var;
1505 unsigned int mask = 0;
1506
1507 gfc_start_block (&block);
1508 gfc_init_block (&post_block);
1509
1510 var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1511 "wait_parm");
1512
1513 set_error_locus (&block, var, &code->loc);
1514 p = code->ext.wait;
1515
1516 /* Set parameters here. */
1517 if (p->iomsg)
1518 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1519 p->iomsg);
1520
1521 if (p->iostat)
1522 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1523 p->iostat);
1524
1525 if (p->err)
1526 mask |= IOPARM_common_err;
1527
1528 if (p->id)
2b4c9065 1529 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_wait_id, p->id);
6f0f0b2e
JD		 1530
1531 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1532
1533 if (p->unit)
e344505c 1534 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
6f0f0b2e 1535
628c189e 1536 tmp = gfc_build_addr_expr (NULL_TREE, var);
db3927fb
AH		 1537 tmp = build_call_expr_loc (input_location,
1538 iocall[IOCALL_WAIT], 1, tmp);
6f0f0b2e
JD		 1539 gfc_add_expr_to_block (&block, tmp);
1540
1541 gfc_add_block_to_block (&block, &post_block);
1542
1543 io_result (&block, var, p->err, NULL, NULL);
1544
1545 return gfc_finish_block (&block);
1546
1547}
1548
6de9cd9a 1549
29dc5138 1550/* nml_full_name builds up the fully qualified name of a
3b111bd7 1551 derived type component. '+' is used to denote a type extension. */
29dc5138
PT		 1552
1553static char*
3b111bd7 1554nml_full_name (const char* var_name, const char* cmp_name, bool parent)
6de9cd9a 1555{
29dc5138
PT		 1556 int full_name_length;
1557 char * full_name;
1558
1559 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
93acb62c 1560 full_name = XCNEWVEC (char, full_name_length + 1);
29dc5138 1561 strcpy (full_name, var_name);
3b111bd7 1562 full_name = strcat (full_name, parent ? "+" : "%");
29dc5138
PT		 1563 full_name = strcat (full_name, cmp_name);
1564 return full_name;
6de9cd9a
DN		 1565}
1566
19d36107 1567
29dc5138
PT		 1568/* nml_get_addr_expr builds an address expression from the
1569 gfc_symbol or gfc_component backend_decl's. An offset is
1570 provided so that the address of an element of an array of
1571 derived types is returned. This is used in the runtime to
66e4ab31 1572 determine that span of the derived type. */
29dc5138
PT		 1573
1574static tree
1575nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1576 tree base_addr)
1577{
1578 tree decl = NULL_TREE;
1579 tree tmp;
29dc5138
PT		 1580
1581 if (sym)
1582 {
1583 sym->attr.referenced = 1;
1584 decl = gfc_get_symbol_decl (sym);
847b053d
PT		 1585
1586 /* If this is the enclosing function declaration, use
1587 the fake result instead. */
1588 if (decl == current_function_decl)
1589 decl = gfc_get_fake_result_decl (sym, 0);
1590 else if (decl == DECL_CONTEXT (current_function_decl))
1591 decl = gfc_get_fake_result_decl (sym, 1);
29dc5138
PT		 1592 }
1593 else
1594 decl = c->backend_decl;
1595
d168c883
JJ		 1596 gcc_assert (decl && (TREE_CODE (decl) == FIELD_DECL
1597 || VAR_P (decl)
1598 || TREE_CODE (decl) == PARM_DECL
1599 || TREE_CODE (decl) == COMPONENT_REF));
29dc5138
PT		 1600
1601 tmp = decl;
1602
1603 /* Build indirect reference, if dummy argument. */
1604
19d36107
TB		 1605 if (POINTER_TYPE_P (TREE_TYPE(tmp)))
1606 tmp = build_fold_indirect_ref_loc (input_location, tmp);
29dc5138
PT		 1607
1608 /* Treat the component of a derived type, using base_addr for
1609 the derived type. */
1610
1611 if (TREE_CODE (decl) == FIELD_DECL)
65a9ca82
TB		 1612 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
1613 base_addr, tmp, NULL_TREE);
29dc5138 1614
51cd6b78
JD		 1615 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1616 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp))))
1617 tmp = gfc_class_data_get (tmp);
1618
19d36107
TB		 1619 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1620 tmp = gfc_conv_array_data (tmp);
1621 else
1622 {
1623 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1624 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
29dc5138 1625
19d36107
TB		 1626 if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1627 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
29dc5138 1628
19d36107
TB		 1629 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1630 tmp = build_fold_indirect_ref_loc (input_location,
db3927fb 1631 tmp);
19d36107 1632 }
29dc5138
PT		 1633
1634 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1635
1636 return tmp;
1637}
3bc268e6 1638
19d36107 1639
29dc5138 1640/* For an object VAR_NAME whose base address is BASE_ADDR, generate a
5e805e44
JJ		 1641 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1642 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
3bc268e6 1643
29dc5138 1644#define IARG(i) build_int_cst (gfc_array_index_type, i)
3bc268e6
VL		 1645
1646static void
29dc5138
PT		 1647transfer_namelist_element (stmtblock_t * block, const char * var_name,
1648 gfc_symbol * sym, gfc_component * c,
1649 tree base_addr)
3bc268e6 1650{
29dc5138
PT		 1651 gfc_typespec * ts = NULL;
1652 gfc_array_spec * as = NULL;
1653 tree addr_expr = NULL;
1654 tree dt = NULL;
1655 tree string;
1656 tree tmp;
29dc5138 1657 tree dtype;
5e805e44 1658 tree dt_parm_addr;
19d36107 1659 tree decl = NULL_TREE;
0522a84e 1660 tree gfc_int4_type_node = gfc_get_int_type (4);
e73d3ca6
PT		 1661 tree dtio_proc = null_pointer_node;
1662 tree vtable = null_pointer_node;
8019105d 1663 int n_dim;
29dc5138 1664 int rank = 0;
3bc268e6 1665
29dc5138 1666 gcc_assert (sym || c);
3bc268e6 1667
29dc5138
PT		 1668 /* Build the namelist object name. */
1669
1670 string = gfc_build_cstring_const (var_name);
1671 string = gfc_build_addr_expr (pchar_type_node, string);
1672
1673 /* Build ts, as and data address using symbol or component. */
1674
51cd6b78
JD		 1675 ts = sym ? &sym->ts : &c->ts;
1676
1677 if (ts->type != BT_CLASS)
1678 as = sym ? sym->as : c->as;
1679 else
1680 as = sym ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as;
29dc5138
PT		 1681
1682 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1683
1684 if (as)
1685 rank = as->rank;
1686
1687 if (rank)
3bc268e6 1688 {
51cd6b78 1689 decl = sym ? sym->backend_decl : c->backend_decl;
19d36107
TB		 1690 if (sym && sym->attr.dummy)
1691 decl = build_fold_indirect_ref_loc (input_location, decl);
51cd6b78
JD		 1692
1693 if (ts->type == BT_CLASS)
1694 decl = gfc_class_data_get (decl);
19d36107 1695 dt = TREE_TYPE (decl);
29dc5138 1696 dtype = gfc_get_dtype (dt);
3bc268e6 1697 }
29dc5138
PT		 1698 else
1699 {
7fb43006
PT		 1700 dt = gfc_typenode_for_spec (ts);
1701 dtype = gfc_get_dtype_rank_type (0, dt);
3bc268e6
VL		 1702 }
1703
29dc5138
PT		 1704 /* Build up the arguments for the transfer call.
1705 The call for the scalar part transfers:
1706 (address, name, type, kind or string_length, dtype) */
1707
628c189e 1708 dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
29dc5138 1709
e73d3ca6
PT		 1710 /* Check if the derived type has a specific DTIO for the mode.
1711 Note that although namelist io is forbidden to have a format
1712 list, the specific subroutine is of the formatted kind. */
cf474530 1713 if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
e73d3ca6 1714 {
cf474530
JW		 1715 gfc_symbol *derived;
1716 if (ts->type==BT_CLASS)
1717 derived = ts->u.derived->components->ts.u.derived;
1718 else
1719 derived = ts->u.derived;
1720
1721 gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
1722 last_dt == WRITE, true);
1723
1724 if (ts->type == BT_CLASS && tb_io_st)
1725 {
1726 // polymorphic DTIO call (based on the dynamic type)
1727 gfc_se se;
1728 gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1729 // build vtable expr
1730 gfc_expr *expr = gfc_get_variable_expr (st);
1731 gfc_add_vptr_component (expr);
1732 gfc_init_se (&se, NULL);
1733 se.want_pointer = 1;
1734 gfc_conv_expr (&se, expr);
1735 vtable = se.expr;
1736 // build dtio expr
1737 gfc_add_component_ref (expr,
1738 tb_io_st->n.tb->u.generic->specific_st->name);
1739 gfc_init_se (&se, NULL);
1740 se.want_pointer = 1;
1741 gfc_conv_expr (&se, expr);
1742 gfc_free_expr (expr);
1743 dtio_proc = se.expr;
1744 }
1745 else
e73d3ca6 1746 {
cf474530
JW		 1747 // non-polymorphic DTIO call (based on the declared type)
1748 gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived,
1749 last_dt == WRITE, true);
1750 if (dtio_sub != NULL)
1751 {
1752 dtio_proc = gfc_get_symbol_decl (dtio_sub);
1753 dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
1754 gfc_symbol *vtab = gfc_find_derived_vtab (derived);
1755 vtable = vtab->backend_decl;
1756 if (vtable == NULL_TREE)
1757 vtable = gfc_get_symbol_decl (vtab);
1758 vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
1759 }
e73d3ca6
PT		 1760 }
1761 }
1762
29dc5138 1763 if (ts->type == BT_CHARACTER)
bc21d315 1764 tmp = ts->u.cl->backend_decl;
29dc5138 1765 else
5039610b 1766 tmp = build_int_cst (gfc_charlen_type_node, 0);
e73d3ca6 1767
07c60b8e 1768 int abi_kind = gfc_type_abi_kind (ts);
7f72e402 1769 if (dtio_proc == null_pointer_node)
07c60b8e
JJ		 1770 tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_VAL], 6,
1771 dt_parm_addr, addr_expr, string,
1772 build_int_cst (gfc_int4_type_node, abi_kind),
1773 tmp, dtype);
e73d3ca6 1774 else
07c60b8e
JJ		 1775 tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_DTIO_VAL],
1776 8, dt_parm_addr, addr_expr, string,
1777 build_int_cst (gfc_int4_type_node, abi_kind),
1778 tmp, dtype, dtio_proc, vtable);
3bc268e6 1779 gfc_add_expr_to_block (block, tmp);
29dc5138
PT		 1780
1781 /* If the object is an array, transfer rank times:
1782 (null pointer, name, stride, lbound, ubound) */
1783
1784 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1785 {
db3927fb
AH		 1786 tmp = build_call_expr_loc (input_location,
1787 iocall[IOCALL_SET_NML_VAL_DIM], 5,
5039610b 1788 dt_parm_addr,
0522a84e 1789 build_int_cst (gfc_int4_type_node, n_dim),
19d36107
TB		 1790 gfc_conv_array_stride (decl, n_dim),
1791 gfc_conv_array_lbound (decl, n_dim),
1792 gfc_conv_array_ubound (decl, n_dim));
29dc5138
PT		 1793 gfc_add_expr_to_block (block, tmp);
1794 }
1795
e73d3ca6
PT		 1796 if (gfc_bt_struct (ts->type) && ts->u.derived->components
1797 && dtio_proc == null_pointer_node)
29dc5138
PT		 1798 {
1799 gfc_component *cmp;
1800
1801 /* Provide the RECORD_TYPE to build component references. */
1802
db3927fb
AH		 1803 tree expr = build_fold_indirect_ref_loc (input_location,
1804 addr_expr);
29dc5138 1805
bc21d315 1806 for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
29dc5138 1807 {
3b111bd7
JD		 1808 char *full_name = nml_full_name (var_name, cmp->name,
1809 ts->u.derived->attr.extension);
29dc5138
PT		 1810 transfer_namelist_element (block,
1811 full_name,
1812 NULL, cmp, expr);
cede9502 1813 free (full_name);
29dc5138
PT		 1814 }
1815 }
3bc268e6 1816}
6de9cd9a 1817
29dc5138 1818#undef IARG
29dc5138 1819
6de9cd9a
DN		 1820/* Create a data transfer statement. Not all of the fields are valid
1821 for both reading and writing, but improper use has been filtered
1822 out by now. */
1823
1824static tree
5e805e44 1825build_dt (tree function, gfc_code * code)
6de9cd9a 1826{
d4feb3d3 1827 stmtblock_t block, post_block, post_end_block, post_iu_block;
6de9cd9a 1828 gfc_dt *dt;
5e805e44 1829 tree tmp, var;
29dc5138 1830 gfc_expr *nmlname;
3bc268e6 1831 gfc_namelist *nml;
5e1bdeb7 1832 unsigned int mask = 0;
6de9cd9a 1833
5e805e44 1834 gfc_start_block (&block);
6de9cd9a 1835 gfc_init_block (&post_block);
5e805e44 1836 gfc_init_block (&post_end_block);
d4feb3d3 1837 gfc_init_block (&post_iu_block);
5e805e44
JJ		 1838
1839 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1840
1841 set_error_locus (&block, var, &code->loc);
6de9cd9a 1842
5e805e44
JJ		 1843 if (last_dt == IOLENGTH)
1844 {
1845 gfc_inquire *inq;
1846
1847 inq = code->ext.inquire;
6de9cd9a 1848
5e805e44
JJ		 1849 /* First check that preconditions are met. */
1850 gcc_assert (inq != NULL);
1851 gcc_assert (inq->iolength != NULL);
1852
1853 /* Connect to the iolength variable. */
1854 mask |= set_parameter_ref (&block, &post_end_block, var,
1855 IOPARM_dt_iolength, inq->iolength);
1856 dt = NULL;
1857 }
1858 else
1859 {
1860 dt = code->ext.dt;
1861 gcc_assert (dt != NULL);
1862 }
8750f9cd 1863
5e805e44 1864 if (dt && dt->io_unit)
6de9cd9a
DN		 1865 {
1866 if (dt->io_unit->ts.type == BT_CHARACTER)
1867 {
d4feb3d3
PT		 1868 mask |= set_internal_unit (&block, &post_iu_block,
1869 var, dt->io_unit);
c8dce2cf 1870 set_parameter_const (&block, var, IOPARM_common_unit,
4a8d4422
JD		 1871 dt->io_unit->ts.kind == 1 ?
1872 GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4);
6de9cd9a 1873 }
6de9cd9a 1874 }
5e805e44
JJ		 1875 else
1876 set_parameter_const (&block, var, IOPARM_common_unit, 0);
6de9cd9a 1877
5e805e44
JJ		 1878 if (dt)
1879 {
f96d606f
JD		 1880 if (dt->iomsg)
1881 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1882 dt->iomsg);
1883
1884 if (dt->iostat)
1885 mask |= set_parameter_ref (&block, &post_end_block, var,
1886 IOPARM_common_iostat, dt->iostat);
1887
1888 if (dt->err)
1889 mask |= IOPARM_common_err;
1890
1891 if (dt->eor)
1892 mask |= IOPARM_common_eor;
1893
1894 if (dt->end)
1895 mask |= IOPARM_common_end;
1896
6f0f0b2e
JD		 1897 if (dt->id)
1898 mask |= set_parameter_ref (&block, &post_end_block, var,
1899 IOPARM_dt_id, dt->id);
1900
1901 if (dt->pos)
e344505c 1902 mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
6f0f0b2e
JD		 1903
1904 if (dt->asynchronous)
e344505c
JD		 1905 mask |= set_string (&block, &post_block, var,
1906 IOPARM_dt_asynchronous, dt->asynchronous);
6f0f0b2e
JD		 1907
1908 if (dt->blank)
1909 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1910 dt->blank);
1911
1912 if (dt->decimal)
1913 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1914 dt->decimal);
1915
1916 if (dt->delim)
1917 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1918 dt->delim);
1919
1920 if (dt->pad)
1921 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1922 dt->pad);
1923
1924 if (dt->round)
1925 mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1926 dt->round);
1927
1928 if (dt->sign)
1929 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1930 dt->sign);
1931
5e805e44 1932 if (dt->rec)
e344505c 1933 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
6de9cd9a 1934
5e805e44
JJ		 1935 if (dt->advance)
1936 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1937 dt->advance);
6de9cd9a 1938
5e805e44 1939 if (dt->format_expr)
9341698a 1940 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
5e805e44 1941 dt->format_expr);
6de9cd9a 1942
5e805e44
JJ		 1943 if (dt->format_label)
1944 {
1945 if (dt->format_label == &format_asterisk)
1946 mask |= IOPARM_dt_list_format;
1947 else
1948 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1949 dt->format_label->format);
1950 }
6de9cd9a 1951
5e805e44
JJ		 1952 if (dt->size)
1953 mask |= set_parameter_ref (&block, &post_end_block, var,
1954 IOPARM_dt_size, dt->size);
6de9cd9a 1955
4a8d4422
JD		 1956 if (dt->udtio)
1957 mask |= IOPARM_dt_dtio;
1958
7ee4f6f3
JJ		 1959 if (dt->dec_ext)
1960 mask |= IOPARM_dt_dec_ext;
6869e9c6 1961
5e805e44
JJ		 1962 if (dt->namelist)
1963 {
1964 if (dt->format_expr || dt->format_label)
1965 gfc_internal_error ("build_dt: format with namelist");
1966
b7e75771
JD		 1967 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1968 dt->namelist->name,
1969 strlen (dt->namelist->name));
29dc5138 1970
5e805e44
JJ		 1971 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1972 nmlname);
29dc5138 1973
76c1a7ec
TB		 1974 gfc_free_expr (nmlname);
1975
5e805e44
JJ		 1976 if (last_dt == READ)
1977 mask |= IOPARM_dt_namelist_read_mode;
29dc5138 1978
5e805e44 1979 set_parameter_const (&block, var, IOPARM_common_flags, mask);
29dc5138 1980
5e805e44
JJ		 1981 dt_parm = var;
1982
1983 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1984 transfer_namelist_element (&block, nml->sym->name, nml->sym,
71ff73f3 1985 NULL, NULL_TREE);
5e805e44
JJ		 1986 }
1987 else
1988 set_parameter_const (&block, var, IOPARM_common_flags, mask);
f96d606f
JD		 1989
1990 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
e344505c
JD		 1991 set_parameter_value_chk (&block, dt->iostat, var,
1992 IOPARM_common_unit, dt->io_unit);
6de9cd9a 1993 }
5e805e44
JJ		 1994 else
1995 set_parameter_const (&block, var, IOPARM_common_flags, mask);
6de9cd9a 1996
628c189e 1997 tmp = gfc_build_addr_expr (NULL_TREE, var);
033e7d21 1998 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
db3927fb 1999 function, 1, tmp);
6de9cd9a
DN		 2000 gfc_add_expr_to_block (&block, tmp);
2001
2002 gfc_add_block_to_block (&block, &post_block);
2003
5e805e44
JJ		 2004 dt_parm = var;
2005 dt_post_end_block = &post_end_block;
2006
bc51e726
JD		 2007 /* Set implied do loop exit condition. */
2008 if (last_dt == READ || last_dt == WRITE)
2009 {
2010 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
2011
65a9ca82
TB		 2012 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2013 st_parameter[IOPARM_ptype_common].type,
2014 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
2015 NULL_TREE);
2016 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2017 TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
2018 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
2019 tmp, build_int_cst (TREE_TYPE (tmp),
2020 IOPARM_common_libreturn_mask));
bc51e726
JD		 2021 }
2022 else /* IOLENGTH */
2023 tmp = NULL_TREE;
2024
2025 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
5e805e44 2026
d4feb3d3
PT		 2027 gfc_add_block_to_block (&block, &post_iu_block);
2028
5e805e44
JJ		 2029 dt_parm = NULL;
2030 dt_post_end_block = NULL;
2031
6de9cd9a
DN		 2032 return gfc_finish_block (&block);
2033}
2034
2035
8750f9cd
JB		 2036/* Translate the IOLENGTH form of an INQUIRE statement. We treat
2037 this as a third sort of data transfer statement, except that
e7dc5b4f 2038 lengths are summed instead of actually transferring any data. */
8750f9cd
JB		 2039
2040tree
2041gfc_trans_iolength (gfc_code * code)
2042{
8750f9cd 2043 last_dt = IOLENGTH;
5e805e44 2044 return build_dt (iocall[IOCALL_IOLENGTH], code);
8750f9cd
JB		 2045}
2046
2047
6de9cd9a
DN		 2048/* Translate a READ statement. */
2049
2050tree
2051gfc_trans_read (gfc_code * code)
2052{
6de9cd9a 2053 last_dt = READ;
5e805e44 2054 return build_dt (iocall[IOCALL_READ], code);
6de9cd9a
DN		 2055}
2056
2057
2058/* Translate a WRITE statement */
2059
2060tree
2061gfc_trans_write (gfc_code * code)
2062{
6de9cd9a 2063 last_dt = WRITE;
5e805e44 2064 return build_dt (iocall[IOCALL_WRITE], code);
6de9cd9a
DN		 2065}
2066
2067
2068/* Finish a data transfer statement. */
2069
2070tree
2071gfc_trans_dt_end (gfc_code * code)
2072{
2073 tree function, tmp;
2074 stmtblock_t block;
2075
2076 gfc_init_block (&block);
2077
8750f9cd
JB		 2078 switch (last_dt)
2079 {
2080 case READ:
5e805e44 2081 function = iocall[IOCALL_READ_DONE];
8750f9cd
JB		 2082 break;
2083
2084 case WRITE:
5e805e44 2085 function = iocall[IOCALL_WRITE_DONE];
8750f9cd
JB		 2086 break;
2087
2088 case IOLENGTH:
5e805e44 2089 function = iocall[IOCALL_IOLENGTH_DONE];
8750f9cd
JB		 2090 break;
2091
2092 default:
6e45f57b 2093 gcc_unreachable ();
8750f9cd 2094 }
6de9cd9a 2095
628c189e 2096 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
db3927fb
AH		 2097 tmp = build_call_expr_loc (input_location,
2098 function, 1, tmp);
6de9cd9a 2099 gfc_add_expr_to_block (&block, tmp);
5e805e44
JJ		 2100 gfc_add_block_to_block (&block, dt_post_end_block);
2101 gfc_init_block (dt_post_end_block);
6de9cd9a 2102
8750f9cd
JB		 2103 if (last_dt != IOLENGTH)
2104 {
6e45f57b 2105 gcc_assert (code->ext.dt != NULL);
5e805e44 2106 io_result (&block, dt_parm, code->ext.dt->err,
8750f9cd
JB		 2107 code->ext.dt->end, code->ext.dt->eor);
2108 }
6de9cd9a
DN		 2109
2110 return gfc_finish_block (&block);
2111}
2112
d2ccf6aa 2113static void
e73d3ca6
PT		 2114transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2115 gfc_code * code, tree vptr);
d2ccf6aa
VL		 2116
2117/* Given an array field in a derived type variable, generate the code
2118 for the loop that iterates over array elements, and the code that
2119 accesses those array elements. Use transfer_expr to generate code
2120 for transferring that element. Because elements may also be
2121 derived types, transfer_expr and transfer_array_component are mutually
2122 recursive. */
2123
2124static tree
bdfd2ff0 2125transfer_array_component (tree expr, gfc_component * cm, locus * where)
d2ccf6aa
VL		 2126{
2127 tree tmp;
2128 stmtblock_t body;
2129 stmtblock_t block;
2130 gfc_loopinfo loop;
2131 int n;
2132 gfc_ss *ss;
2133 gfc_se se;
08dcec61 2134 gfc_array_info *ss_array;
d2ccf6aa
VL		 2135
2136 gfc_start_block (&block);
2137 gfc_init_se (&se, NULL);
2138
2139 /* Create and initialize Scalarization Status. Unlike in
2140 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2141 care of this task, because we don't have a gfc_expr at hand.
2142 Build one manually, as in gfc_trans_subarray_assign. */
2143
66877276
MM		 2144 ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
2145 GFC_SS_COMPONENT);
1838afec 2146 ss_array = &ss->info->data.array;
276515e6
PT		 2147
2148 if (cm->attr.pdt_array)
2149 ss_array->shape = NULL;
2150 else
2151 ss_array->shape = gfc_get_shape (cm->as->rank);
2152
08dcec61
MM		 2153 ss_array->descriptor = expr;
2154 ss_array->data = gfc_conv_array_data (expr);
2155 ss_array->offset = gfc_conv_array_offset (expr);
d2ccf6aa
VL		 2156 for (n = 0; n < cm->as->rank; n++)
2157 {
08dcec61
MM		 2158 ss_array->start[n] = gfc_conv_array_lbound (expr, n);
2159 ss_array->stride[n] = gfc_index_one_node;
d2ccf6aa 2160
276515e6
PT		 2161 if (cm->attr.pdt_array)
2162 ss_array->end[n] = gfc_conv_array_ubound (expr, n);
2163 else
2164 {
2165 mpz_init (ss_array->shape[n]);
2166 mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
2167 cm->as->lower[n]->value.integer);
2168 mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
2169 }
d2ccf6aa
VL		 2170 }
2171
f7b529fa 2172 /* Once we got ss, we use scalarizer to create the loop. */
d2ccf6aa
VL		 2173
2174 gfc_init_loopinfo (&loop);
2175 gfc_add_ss_to_loop (&loop, ss);
2176 gfc_conv_ss_startstride (&loop);
bdfd2ff0 2177 gfc_conv_loop_setup (&loop, where);
d2ccf6aa
VL		 2178 gfc_mark_ss_chain_used (ss, 1);
2179 gfc_start_scalarized_body (&loop, &body);
2180
2181 gfc_copy_loopinfo_to_se (&se, &loop);
2182 se.ss = ss;
2183
2184 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2185 se.expr = expr;
2186 gfc_conv_tmp_array_ref (&se);
2187
2188 /* Now se.expr contains an element of the array. Take the address and pass
2189 it to the IO routines. */
628c189e 2190 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
e73d3ca6 2191 transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
d2ccf6aa
VL		 2192
2193 /* We are done now with the loop body. Wrap up the scalarizer and
f7b529fa 2194 return. */
d2ccf6aa
VL		 2195
2196 gfc_add_block_to_block (&body, &se.pre);
2197 gfc_add_block_to_block (&body, &se.post);
2198
2199 gfc_trans_scalarizing_loops (&loop, &body);
2200
2201 gfc_add_block_to_block (&block, &loop.pre);
2202 gfc_add_block_to_block (&block, &loop.post);
2203
276515e6
PT		 2204 if (!cm->attr.pdt_array)
2205 {
2206 gcc_assert (ss_array->shape != NULL);
2207 gfc_free_shape (&ss_array->shape, cm->as->rank);
2208 }
96654664
PB		 2209 gfc_cleanup_loop (&loop);
2210
d2ccf6aa
VL		 2211 return gfc_finish_block (&block);
2212}
6de9cd9a 2213
e73d3ca6
PT		 2214
2215/* Helper function for transfer_expr that looks for the DTIO procedure
2216 either as a typebound binding or in a generic interface. If present,
2217 the address expression of the procedure is returned. It is assumed
2218 that the procedure interface has been checked during resolution. */
2219
2220static tree
2221get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
2222{
2223 gfc_symbol *derived;
2224 bool formatted = false;
2225 gfc_dt *dt = code->ext.dt;
2226
f208c5cc
JD		 2227 /* Determine when to use the formatted DTIO procedure. */
2228 if (dt && (dt->format_expr || dt->format_label))
2229 formatted = true;
e73d3ca6 2230
707024b2
JW		 2231 if (ts->type == BT_CLASS)
2232 derived = ts->u.derived->components->ts.u.derived;
2233 else
2234 derived = ts->u.derived;
2235
2236 gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
2237 last_dt == WRITE, formatted);
2238 if (ts->type == BT_CLASS && tb_io_st)
e4e659b9 2239 {
707024b2
JW		 2240 // polymorphic DTIO call (based on the dynamic type)
2241 gfc_se se;
2242 gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1);
2243 gfc_add_vptr_component (expr);
2244 gfc_add_component_ref (expr,
2245 tb_io_st->n.tb->u.generic->specific_st->name);
2246 *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym;
2247 gfc_init_se (&se, NULL);
2248 se.want_pointer = 1;
2249 gfc_conv_expr (&se, expr);
2250 gfc_free_expr (expr);
2251 return se.expr;
2252 }
2253 else
2254 {
2255 // non-polymorphic DTIO call (based on the declared type)
e4e659b9
JW		 2256 *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
2257 formatted);
2258
2259 if (*dtio_sub)
2260 return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
2261 }
e73d3ca6
PT		 2262
2263 return NULL_TREE;
e73d3ca6
PT		 2264}
2265
6de9cd9a
DN		 2266/* Generate the call for a scalar transfer node. */
2267
2268static void
e73d3ca6
PT		 2269transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2270 gfc_code * code, tree vptr)
6de9cd9a 2271{
8a221914 2272 tree tmp, function, arg2, arg3, field, expr;
6de9cd9a
DN		 2273 gfc_component *c;
2274 int kind;
2275
a8b3b0b6
CR		 2276 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2277 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2278 We need to translate the expression to a constant if it's either
aa5e22f0
CR		 2279 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2280 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2281 BT_DERIVED (could have been changed by gfc_conv_expr). */
bc21d315
JW		 2282 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2283 && ts->u.derived != NULL
2284 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
a8b3b0b6 2285 {
cadddfdd 2286 ts->type = BT_INTEGER;
a26f63a8
SK		 2287 ts->kind = gfc_index_integer_kind;
2288 }
2289
2290 /* gfortran reaches here for "print *, c_loc(xxx)". */
2291 if (ts->type == BT_VOID
2292 && code->expr1 && code->expr1->ts.type == BT_VOID
2293 && code->expr1->symtree
2294 && strcmp (code->expr1->symtree->name, "c_loc") == 0)
2295 {
2296 ts->type = BT_INTEGER;
cadddfdd 2297 ts->kind = gfc_index_integer_kind;
a8b3b0b6 2298 }
8019105d 2299
07c60b8e 2300 kind = gfc_type_abi_kind (ts);
6de9cd9a
DN		 2301 function = NULL;
2302 arg2 = NULL;
8a221914 2303 arg3 = NULL;
6de9cd9a
DN		 2304
2305 switch (ts->type)
2306 {
2307 case BT_INTEGER:
df09d1d5 2308 arg2 = build_int_cst (integer_type_node, kind);
6eb6875d
TK		 2309 if (last_dt == READ)
2310 function = iocall[IOCALL_X_INTEGER];
2311 else
2312 function = iocall[IOCALL_X_INTEGER_WRITE];
2313
6de9cd9a
DN		 2314 break;
2315
2316 case BT_REAL:
df09d1d5 2317 arg2 = build_int_cst (integer_type_node, kind);
6eb6875d 2318 if (last_dt == READ)
1ec601bf 2319 {
07c60b8e 2320 if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
1ec601bf
FXC		 2321 function = iocall[IOCALL_X_REAL128];
2322 else
2323 function = iocall[IOCALL_X_REAL];
2324 }
6eb6875d 2325 else
1ec601bf 2326 {
07c60b8e 2327 if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
1ec601bf
FXC		 2328 function = iocall[IOCALL_X_REAL128_WRITE];
2329 else
2330 function = iocall[IOCALL_X_REAL_WRITE];
2331 }
6eb6875d 2332
6de9cd9a
DN		 2333 break;
2334
2335 case BT_COMPLEX:
df09d1d5 2336 arg2 = build_int_cst (integer_type_node, kind);
6eb6875d 2337 if (last_dt == READ)
1ec601bf 2338 {
07c60b8e 2339 if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
1ec601bf
FXC		 2340 function = iocall[IOCALL_X_COMPLEX128];
2341 else
2342 function = iocall[IOCALL_X_COMPLEX];
2343 }
6eb6875d 2344 else
1ec601bf 2345 {
07c60b8e 2346 if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
1ec601bf
FXC		 2347 function = iocall[IOCALL_X_COMPLEX128_WRITE];
2348 else
2349 function = iocall[IOCALL_X_COMPLEX_WRITE];
2350 }
6eb6875d 2351
6de9cd9a
DN		 2352 break;
2353
2354 case BT_LOGICAL:
df09d1d5 2355 arg2 = build_int_cst (integer_type_node, kind);
6eb6875d
TK		 2356 if (last_dt == READ)
2357 function = iocall[IOCALL_X_LOGICAL];
2358 else
2359 function = iocall[IOCALL_X_LOGICAL_WRITE];
2360
6de9cd9a
DN		 2361 break;
2362
2363 case BT_CHARACTER:
8a221914
JD		 2364 if (kind == 4)
2365 {
2366 if (se->string_length)
2367 arg2 = se->string_length;
2368 else
2369 {
db3927fb
AH		 2370 tmp = build_fold_indirect_ref_loc (input_location,
2371 addr_expr);
8a221914
JD		 2372 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2373 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2374 arg2 = fold_convert (gfc_charlen_type_node, arg2);
2375 }
df09d1d5 2376 arg3 = build_int_cst (integer_type_node, kind);
6eb6875d
TK		 2377 if (last_dt == READ)
2378 function = iocall[IOCALL_X_CHARACTER_WIDE];
2379 else
2380 function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
8019105d 2381
628c189e 2382 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
db3927fb
AH		 2383 tmp = build_call_expr_loc (input_location,
2384 function, 4, tmp, addr_expr, arg2, arg3);
8a221914
JD		 2385 gfc_add_expr_to_block (&se->pre, tmp);
2386 gfc_add_block_to_block (&se->pre, &se->post);
2387 return;
2388 }
1cc0e193 2389 /* Fall through. */
7b95e2a8 2390 case BT_HOLLERITH:
d2ccf6aa
VL		 2391 if (se->string_length)
2392 arg2 = se->string_length;
2393 else
2394 {
db3927fb
AH		 2395 tmp = build_fold_indirect_ref_loc (input_location,
2396 addr_expr);
d2ccf6aa
VL		 2397 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2398 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2399 }
6eb6875d
TK		 2400 if (last_dt == READ)
2401 function = iocall[IOCALL_X_CHARACTER];
2402 else
2403 function = iocall[IOCALL_X_CHARACTER_WRITE];
2404
6de9cd9a
DN		 2405 break;
2406
f6288c24 2407 case_bt_struct:
e73d3ca6 2408 case BT_CLASS:
9b460e2e 2409 if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS)
e73d3ca6
PT		 2410 {
2411 gfc_symbol *derived;
2412 gfc_symbol *dtio_sub = NULL;
2413 /* Test for a specific DTIO subroutine. */
2414 if (ts->type == BT_DERIVED)
2415 derived = ts->u.derived;
2416 else
2417 derived = ts->u.derived->components->ts.u.derived;
fc2655fb 2418
e73d3ca6
PT		 2419 if (derived->attr.has_dtio_procs)
2420 arg2 = get_dtio_proc (ts, code, &dtio_sub);
6de9cd9a 2421
6c0347f6 2422 if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
e73d3ca6
PT		 2423 {
2424 tree decl;
2425 decl = build_fold_indirect_ref_loc (input_location,
2426 se->expr);
2427 /* Remember that the first dummy of the DTIO subroutines
2428 is CLASS(derived) for extensible derived types, so the
2429 conversion must be done here for derived type and for
2430 scalarized CLASS array element io-list objects. */
2431 if ((ts->type == BT_DERIVED
2432 && !(ts->u.derived->attr.sequence
2433 || ts->u.derived->attr.is_bind_c))
2434 || (ts->type == BT_CLASS
2435 && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
2436 gfc_conv_derived_to_class (se, code->expr1,
2437 dtio_sub->formal->sym->ts,
2438 vptr, false, false);
2439 addr_expr = se->expr;
2440 function = iocall[IOCALL_X_DERIVED];
2441 break;
2442 }
9b460e2e 2443 else if (gfc_bt_struct (ts->type))
e73d3ca6
PT		 2444 {
2445 /* Recurse into the elements of the derived type. */
2446 expr = gfc_evaluate_now (addr_expr, &se->pre);
f208c5cc 2447 expr = build_fold_indirect_ref_loc (input_location, expr);
8019105d 2448
e73d3ca6
PT		 2449 /* Make sure that the derived type has been built. An external
2450 function, if only referenced in an io statement, requires this
2451 check (see PR58771). */
2452 if (ts->u.derived->backend_decl == NULL_TREE)
2453 (void) gfc_typenode_for_spec (ts);
2454
2455 for (c = ts->u.derived->components; c; c = c->next)
2456 {
276515e6
PT		 2457 /* Ignore hidden string lengths. */
2458 if (c->name[0] == '_')
2459 continue;
2460
e73d3ca6
PT		 2461 field = c->backend_decl;
2462 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2463
2464 tmp = fold_build3_loc (UNKNOWN_LOCATION,
2465 COMPONENT_REF, TREE_TYPE (field),
2466 expr, field, NULL_TREE);
2467
2468 if (c->attr.dimension)
2469 {
2470 tmp = transfer_array_component (tmp, c, & code->loc);
2471 gfc_add_expr_to_block (&se->pre, tmp);
2472 }
2473 else
2474 {
276515e6
PT		 2475 tree strlen = NULL_TREE;
2476
2477 if (!c->attr.pointer && !c->attr.pdt_string)
e73d3ca6 2478 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
276515e6
PT		 2479
2480 /* Use the hidden string length for pdt strings. */
2481 if (c->attr.pdt_string
2482 && gfc_deferred_strlen (c, &strlen)
2483 && strlen != NULL_TREE)
2484 {
2485 strlen = fold_build3_loc (UNKNOWN_LOCATION,
2486 COMPONENT_REF,
2487 TREE_TYPE (strlen),
2488 expr, strlen, NULL_TREE);
2489 se->string_length = strlen;
2490 }
2491
e73d3ca6 2492 transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
276515e6
PT		 2493
2494 /* Reset so that the pdt string length does not propagate
2495 through to other strings. */
2496 if (c->attr.pdt_string && strlen)
2497 se->string_length = NULL_TREE;
e73d3ca6
PT		 2498 }
2499 }
2500 return;
2501 }
2502 /* If a CLASS object gets through to here, fall through and ICE. */
6de9cd9a 2503 }
81fea426 2504 gcc_fallthrough ();
6de9cd9a 2505 default:
17d5d49f 2506 gfc_internal_error ("Bad IO basetype (%d)", ts->type);
6de9cd9a
DN		 2507 }
2508
628c189e 2509 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
db3927fb
AH		 2510 tmp = build_call_expr_loc (input_location,
2511 function, 3, tmp, addr_expr, arg2);
6de9cd9a
DN		 2512 gfc_add_expr_to_block (&se->pre, tmp);
2513 gfc_add_block_to_block (&se->pre, &se->post);
8750f9cd 2514
6de9cd9a
DN		 2515}
2516
2517
18623fae
JB		 2518/* Generate a call to pass an array descriptor to the IO library. The
2519 array should be of one of the intrinsic types. */
2520
2521static void
2522transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2523{
6eb6875d 2524 tree tmp, charlen_arg, kind_arg, io_call;
18623fae
JB		 2525
2526 if (ts->type == BT_CHARACTER)
2527 charlen_arg = se->string_length;
2528 else
df09d1d5 2529 charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
18623fae 2530
06a74228 2531 kind_arg = build_int_cst (integer_type_node, gfc_type_abi_kind (ts));
e5ef4b3b 2532
628c189e 2533 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
6eb6875d
TK		 2534 if (last_dt == READ)
2535 io_call = iocall[IOCALL_X_ARRAY];
2536 else
2537 io_call = iocall[IOCALL_X_ARRAY_WRITE];
2538
033e7d21 2539 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
6eb6875d 2540 io_call, 4,
5039610b 2541 tmp, addr_expr, kind_arg, charlen_arg);
18623fae
JB		 2542 gfc_add_expr_to_block (&se->pre, tmp);
2543 gfc_add_block_to_block (&se->pre, &se->post);
2544}
2545
2546
6de9cd9a
DN		 2547/* gfc_trans_transfer()-- Translate a TRANSFER code node */
2548
2549tree
2550gfc_trans_transfer (gfc_code * code)
2551{
2552 stmtblock_t block, body;
2553 gfc_loopinfo loop;
2554 gfc_expr *expr;
99c7ab42 2555 gfc_ref *ref;
6de9cd9a
DN		 2556 gfc_ss *ss;
2557 gfc_se se;
2558 tree tmp;
e73d3ca6 2559 tree vptr;
c63173dd 2560 int n;
6de9cd9a
DN		 2561
2562 gfc_start_block (&block);
18623fae 2563 gfc_init_block (&body);
6de9cd9a 2564
a513927a 2565 expr = code->expr1;
99c7ab42 2566 ref = NULL;
6de9cd9a
DN		 2567 gfc_init_se (&se, NULL);
2568
2960a368 2569 if (expr->rank == 0)
18623fae 2570 {
815d8045 2571 /* Transfer a scalar value. */
e73d3ca6
PT		 2572 if (expr->ts.type == BT_CLASS)
2573 {
2574 se.want_pointer = 1;
2575 gfc_conv_expr (&se, expr);
2576 vptr = gfc_get_vptr_from_expr (se.expr);
2577 }
2578 else
2579 {
2580 vptr = NULL_TREE;
2581 gfc_conv_expr_reference (&se, expr);
2582 }
2583 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
18623fae 2584 }
815d8045 2585 else
6de9cd9a 2586 {
99c7ab42
PT		 2587 /* Transfer an array. If it is an array of an intrinsic
2588 type, pass the descriptor to the library. Otherwise
2589 scalarize the transfer. */
2a573572 2590 if (expr->ref && !gfc_is_proc_ptr_comp (expr))
99c7ab42
PT		 2591 {
2592 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
fc2655fb
TB		 2593 ref = ref->next);
2594 gcc_assert (ref && ref->type == REF_ARRAY);
99c7ab42
PT		 2595 }
2596
ff3598bc
PT		 2597 if (expr->ts.type != BT_CLASS
2598 && expr->expr_type == EXPR_VARIABLE
2599 && gfc_expr_attr (expr).pointer)
2600 goto scalarize;
2601
2602
e73d3ca6
PT		 2603 if (!(gfc_bt_struct (expr->ts.type)
2604 || expr->ts.type == BT_CLASS)
1d6b7f39
PT		 2605 && ref && ref->next == NULL
2606 && !is_subref_array (expr))
815d8045 2607 {
c63173dd
PT		 2608 bool seen_vector = false;
2609
2610 if (ref && ref->u.ar.type == AR_SECTION)
2611 {
2612 for (n = 0; n < ref->u.ar.dimen; n++)
2613 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
502af491
PCC		 2614 {
2615 seen_vector = true;
2616 break;
2617 }
c63173dd
PT		 2618 }
2619
2620 if (seen_vector && last_dt == READ)
2621 {
2622 /* Create a temp, read to that and copy it back. */
430f2d1f 2623 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
c63173dd
PT		 2624 tmp = se.expr;
2625 }
2626 else
2627 {
2628 /* Get the descriptor. */
2960a368 2629 gfc_conv_expr_descriptor (&se, expr);
628c189e 2630 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
c63173dd
PT		 2631 }
2632
99c7ab42
PT		 2633 transfer_array_desc (&se, &expr->ts, tmp);
2634 goto finish_block_label;
815d8045 2635 }
2960a368 2636
ff3598bc 2637scalarize:
6de9cd9a 2638 /* Initialize the scalarizer. */
2960a368 2639 ss = gfc_walk_expr (expr);
6de9cd9a
DN		 2640 gfc_init_loopinfo (&loop);
2641 gfc_add_ss_to_loop (&loop, ss);
2642
2643 /* Initialize the loop. */
2644 gfc_conv_ss_startstride (&loop);
a513927a 2645 gfc_conv_loop_setup (&loop, &code->expr1->where);
6de9cd9a
DN		 2646
2647 /* The main loop body. */
2648 gfc_mark_ss_chain_used (ss, 1);
2649 gfc_start_scalarized_body (&loop, &body);
2650
2651 gfc_copy_loopinfo_to_se (&se, &loop);
2652 se.ss = ss;
ff3598bc 2653
18623fae 2654 gfc_conv_expr_reference (&se, expr);
ff3598bc 2655
e73d3ca6
PT		 2656 if (expr->ts.type == BT_CLASS)
2657 vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
2658 else
2659 vptr = NULL_TREE;
2660 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
18623fae 2661 }
815d8045
JB		 2662
2663 finish_block_label:
6de9cd9a
DN		 2664
2665 gfc_add_block_to_block (&body, &se.pre);
2666 gfc_add_block_to_block (&body, &se.post);
2667
2668 if (se.ss == NULL)
2669 tmp = gfc_finish_block (&body);
2670 else
2671 {
770caa74 2672 gcc_assert (expr->rank != 0);
6e45f57b 2673 gcc_assert (se.ss == gfc_ss_terminator);
6de9cd9a
DN		 2674 gfc_trans_scalarizing_loops (&loop, &body);
2675
2676 gfc_add_block_to_block (&loop.pre, &loop.post);
2677 tmp = gfc_finish_block (&loop.pre);
2678 gfc_cleanup_loop (&loop);
2679 }
2680
2681 gfc_add_expr_to_block (&block, tmp);
2682
d2ccf6aa 2683 return gfc_finish_block (&block);
6de9cd9a
DN		 2684}
2685
2686#include "gt-fortran-trans-io.h"
Mirror of https://gcc.gnu.org/git/gcc.git