]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/trans-io.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* ChangeLog: Fix my ChangeLog entry.
[thirdparty/gcc.git] / gcc / fortran / trans-io.c
CommitLineData
6de9cd9a 1/* IO Code translation/library interface
cbe34bb5 2 Copyright (C) 2002-2017 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
TB		 330 iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec (
331 get_identifier (PREFIX("transfer_integer")), ".wW",
332 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
333
6eb6875d
TK		 334 iocall[IOCALL_X_INTEGER_WRITE] = gfc_build_library_function_decl_with_spec (
335 get_identifier (PREFIX("transfer_integer_write")), ".wR",
336 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
337
3f34855a
TB		 338 iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec (
339 get_identifier (PREFIX("transfer_logical")), ".wW",
340 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
341
6eb6875d
TK		 342 iocall[IOCALL_X_LOGICAL_WRITE] = gfc_build_library_function_decl_with_spec (
343 get_identifier (PREFIX("transfer_logical_write")), ".wR",
344 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
345
3f34855a
TB		 346 iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec (
347 get_identifier (PREFIX("transfer_character")), ".wW",
c1e9bbcc 348 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
3f34855a 349
6eb6875d
TK		 350 iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec (
351 get_identifier (PREFIX("transfer_character_write")), ".wR",
c1e9bbcc 352 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
6eb6875d 353
3f34855a
TB		 354 iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec (
355 get_identifier (PREFIX("transfer_character_wide")), ".wW",
356 void_type_node, 4, dt_parm_type, pvoid_type_node,
357 gfc_charlen_type_node, gfc_int4_type_node);
358
6eb6875d
TK		 359 iocall[IOCALL_X_CHARACTER_WIDE_WRITE] =
360 gfc_build_library_function_decl_with_spec (
361 get_identifier (PREFIX("transfer_character_wide_write")), ".wR",
362 void_type_node, 4, dt_parm_type, pvoid_type_node,
363 gfc_charlen_type_node, gfc_int4_type_node);
364
3f34855a
TB		 365 iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec (
366 get_identifier (PREFIX("transfer_real")), ".wW",
367 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
368
6eb6875d
TK		 369 iocall[IOCALL_X_REAL_WRITE] = gfc_build_library_function_decl_with_spec (
370 get_identifier (PREFIX("transfer_real_write")), ".wR",
371 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
372
3f34855a
TB		 373 iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec (
374 get_identifier (PREFIX("transfer_complex")), ".wW",
375 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
376
6eb6875d
TK		 377 iocall[IOCALL_X_COMPLEX_WRITE] = gfc_build_library_function_decl_with_spec (
378 get_identifier (PREFIX("transfer_complex_write")), ".wR",
379 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
380
1ec601bf
FXC		 381 /* Version for __float128. */
382 iocall[IOCALL_X_REAL128] = gfc_build_library_function_decl_with_spec (
383 get_identifier (PREFIX("transfer_real128")), ".wW",
384 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
385
386 iocall[IOCALL_X_REAL128_WRITE] = gfc_build_library_function_decl_with_spec (
387 get_identifier (PREFIX("transfer_real128_write")), ".wR",
388 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
389
390 iocall[IOCALL_X_COMPLEX128] = gfc_build_library_function_decl_with_spec (
391 get_identifier (PREFIX("transfer_complex128")), ".wW",
392 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
393
394 iocall[IOCALL_X_COMPLEX128_WRITE] = gfc_build_library_function_decl_with_spec (
395 get_identifier (PREFIX("transfer_complex128_write")), ".wR",
396 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
397
3f34855a 398 iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec (
d4d9b0a6 399 get_identifier (PREFIX("transfer_array")), ".ww",
3f34855a
TB		 400 void_type_node, 4, dt_parm_type, pvoid_type_node,
401 integer_type_node, gfc_charlen_type_node);
18623fae 402
6eb6875d
TK		 403 iocall[IOCALL_X_ARRAY_WRITE] = gfc_build_library_function_decl_with_spec (
404 get_identifier (PREFIX("transfer_array_write")), ".wr",
405 void_type_node, 4, dt_parm_type, pvoid_type_node,
406 integer_type_node, gfc_charlen_type_node);
407
e73d3ca6
PT		 408 iocall[IOCALL_X_DERIVED] = gfc_build_library_function_decl_with_spec (
409 get_identifier (PREFIX("transfer_derived")), ".wrR",
410 void_type_node, 2, dt_parm_type, pvoid_type_node, pchar_type_node);
411
6de9cd9a
DN		 412 /* Library entry points */
413
3f34855a
TB		 414 iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
415 get_identifier (PREFIX("st_read")), ".w",
416 void_type_node, 1, dt_parm_type);
6de9cd9a 417
3f34855a
TB		 418 iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec (
419 get_identifier (PREFIX("st_write")), ".w",
420 void_type_node, 1, dt_parm_type);
5e805e44
JJ		 421
422 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
3f34855a
TB		 423 iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec (
424 get_identifier (PREFIX("st_open")), ".w",
425 void_type_node, 1, parm_type);
5e805e44
JJ		 426
427 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
3f34855a
TB		 428 iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec (
429 get_identifier (PREFIX("st_close")), ".w",
430 void_type_node, 1, parm_type);
6de9cd9a 431
5e805e44 432 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
3f34855a
TB		 433 iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec (
434 get_identifier (PREFIX("st_inquire")), ".w",
a19d2b95 435 void_type_node, 1, parm_type);
6de9cd9a 436
3f34855a
TB		 437 iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec(
438 get_identifier (PREFIX("st_iolength")), ".w",
439 void_type_node, 1, dt_parm_type);
8750f9cd 440
3f34855a 441 /* TODO: Change when asynchronous I/O is implemented. */
6f0f0b2e 442 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
3f34855a
TB		 443 iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
444 get_identifier (PREFIX("st_wait")), ".X",
a19d2b95 445 void_type_node, 1, parm_type);
6f0f0b2e 446
5e805e44 447 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
3f34855a
TB		 448 iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec (
449 get_identifier (PREFIX("st_rewind")), ".w",
a19d2b95 450 void_type_node, 1, parm_type);
6de9cd9a 451
3f34855a
TB		 452 iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec (
453 get_identifier (PREFIX("st_backspace")), ".w",
a19d2b95 454 void_type_node, 1, parm_type);
6de9cd9a 455
3f34855a
TB		 456 iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec (
457 get_identifier (PREFIX("st_endfile")), ".w",
a19d2b95 458 void_type_node, 1, parm_type);
6403ec5f 459
3f34855a
TB		 460 iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec (
461 get_identifier (PREFIX("st_flush")), ".w",
a19d2b95 462 void_type_node, 1, parm_type);
6403ec5f 463
6de9cd9a
DN		 464 /* Library helpers */
465
3f34855a
TB		 466 iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec (
467 get_identifier (PREFIX("st_read_done")), ".w",
a19d2b95 468 void_type_node, 1, dt_parm_type);
8750f9cd 469
3f34855a
TB		 470 iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec (
471 get_identifier (PREFIX("st_write_done")), ".w",
a19d2b95 472 void_type_node, 1, dt_parm_type);
8750f9cd 473
3f34855a
TB		 474 iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec (
475 get_identifier (PREFIX("st_iolength_done")), ".w",
a19d2b95 476 void_type_node, 1, dt_parm_type);
6de9cd9a 477
3f34855a
TB		 478 iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
479 get_identifier (PREFIX("st_set_nml_var")), ".w.R",
480 void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
0522a84e 481 gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node);
6de9cd9a 482
e73d3ca6
PT		 483 iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec (
484 get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R",
485 void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node,
486 gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node,
487 pvoid_type_node, pvoid_type_node);
488
3f34855a
TB		 489 iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
490 get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
491 void_type_node, 5, dt_parm_type, gfc_int4_type_node,
492 gfc_array_index_type, gfc_array_index_type, gfc_array_index_type);
6de9cd9a
DN		 493}
494
495
e73d3ca6
PT		 496static void
497set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value)
5e805e44
JJ		 498{
499 tree tmp;
500 gfc_st_parameter_field *p = &st_parameter_field[type];
501
502 if (p->param_type == IOPARM_ptype_common)
65a9ca82
TB		 503 var = fold_build3_loc (input_location, COMPONENT_REF,
504 st_parameter[IOPARM_ptype_common].type,
505 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
506 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
507 var, p->field, NULL_TREE);
e73d3ca6
PT		 508 gfc_add_modify (block, tmp, value);
509}
510
511
512/* Generate code to store an integer constant into the
513 st_parameter_XXX structure. */
514
515static unsigned int
516set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
517 unsigned int val)
518{
519 gfc_st_parameter_field *p = &st_parameter_field[type];
520
521 set_parameter_tree (block, var, type,
522 build_int_cst (TREE_TYPE (p->field), val));
5e805e44
JJ		 523 return p->mask;
524}
525
526
49de9e73 527/* Generate code to store a non-string I/O parameter into the
5e805e44 528 st_parameter_XXX structure. This is a pass by value. */
6de9cd9a 529
5e805e44 530static unsigned int
e344505c
JD		 531set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
532 gfc_expr *e)
533{
534 gfc_se se;
535 tree tmp;
536 gfc_st_parameter_field *p = &st_parameter_field[type];
537 tree dest_type = TREE_TYPE (p->field);
538
539 gfc_init_se (&se, NULL);
540 gfc_conv_expr_val (&se, e);
541
542 se.expr = convert (dest_type, se.expr);
543 gfc_add_block_to_block (block, &se.pre);
544
545 if (p->param_type == IOPARM_ptype_common)
546 var = fold_build3_loc (input_location, COMPONENT_REF,
547 st_parameter[IOPARM_ptype_common].type,
548 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
549
550 tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
551 p->field, NULL_TREE);
552 gfc_add_modify (block, tmp, se.expr);
553 return p->mask;
554}
555
556
557/* Similar to set_parameter_value except generate runtime
558 error checks. */
559
560static unsigned int
561set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var,
ed9c79e1 562 enum iofield type, gfc_expr *e)
6de9cd9a
DN		 563{
564 gfc_se se;
565 tree tmp;
5e805e44 566 gfc_st_parameter_field *p = &st_parameter_field[type];
f96d606f 567 tree dest_type = TREE_TYPE (p->field);
6de9cd9a
DN		 568
569 gfc_init_se (&se, NULL);
f96d606f
JD		 570 gfc_conv_expr_val (&se, e);
571
572 /* If we're storing a UNIT number, we need to check it first. */
9ad55c33 573 if (type == IOPARM_common_unit && e->ts.kind > 4)
f96d606f 574 {
9ad55c33 575 tree cond, val;
f96d606f
JD		 576 int i;
577
f96d606f
JD		 578 /* Don't evaluate the UNIT number multiple times. */
579 se.expr = gfc_evaluate_now (se.expr, &se.pre);
580
9ad55c33
JD		 581 /* UNIT numbers should be greater than the min. */
582 i = gfc_validate_kind (BT_INTEGER, 4, false);
583 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
65a9ca82
TB		 584 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
585 se.expr,
586 fold_convert (TREE_TYPE (se.expr), val));
ed9c79e1
JJ		 587 gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
588 "Unit number in I/O statement too small",
589 &se.pre);
8019105d 590
f96d606f 591 /* UNIT numbers should be less than the max. */
9ad55c33 592 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
65a9ca82
TB		 593 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
594 se.expr,
595 fold_convert (TREE_TYPE (se.expr), val));
ed9c79e1
JJ		 596 gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
597 "Unit number in I/O statement too large",
598 &se.pre);
f96d606f
JD		 599 }
600
601 se.expr = convert (dest_type, se.expr);
6de9cd9a
DN		 602 gfc_add_block_to_block (block, &se.pre);
603
5e805e44 604 if (p->param_type == IOPARM_ptype_common)
65a9ca82
TB		 605 var = fold_build3_loc (input_location, COMPONENT_REF,
606 st_parameter[IOPARM_ptype_common].type,
607 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
f96d606f 608
65a9ca82
TB		 609 tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
610 p->field, NULL_TREE);
726a989a 611 gfc_add_modify (block, tmp, se.expr);
5e805e44 612 return p->mask;
6de9cd9a
DN		 613}
614
615
e344505c
JD		 616/* Build code to check the unit range if KIND=8 is used. Similar to
617 set_parameter_value_chk but we do not generate error calls for
618 inquire statements. */
619
620static unsigned int
621set_parameter_value_inquire (stmtblock_t *block, tree var,
622 enum iofield type, gfc_expr *e)
623{
624 gfc_se se;
625 gfc_st_parameter_field *p = &st_parameter_field[type];
626 tree dest_type = TREE_TYPE (p->field);
627
628 gfc_init_se (&se, NULL);
629 gfc_conv_expr_val (&se, e);
630
631 /* If we're inquiring on a UNIT number, we need to check to make
632 sure it exists for larger than kind = 4. */
633 if (type == IOPARM_common_unit && e->ts.kind > 4)
634 {
635 stmtblock_t newblock;
636 tree cond1, cond2, cond3, val, body;
637 int i;
638
639 /* Don't evaluate the UNIT number multiple times. */
640 se.expr = gfc_evaluate_now (se.expr, &se.pre);
641
642 /* UNIT numbers should be greater than zero. */
643 i = gfc_validate_kind (BT_INTEGER, 4, false);
644 cond1 = build2_loc (input_location, LT_EXPR, boolean_type_node,
645 se.expr,
646 fold_convert (TREE_TYPE (se.expr),
647 integer_zero_node));
648 /* UNIT numbers should be less than the max. */
649 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
650 cond2 = build2_loc (input_location, GT_EXPR, boolean_type_node,
651 se.expr,
652 fold_convert (TREE_TYPE (se.expr), val));
653 cond3 = build2_loc (input_location, TRUTH_OR_EXPR,
654 boolean_type_node, cond1, cond2);
655
656 gfc_start_block (&newblock);
657
658 /* The unit number GFC_INVALID_UNIT is reserved. No units can
659 ever have this value. It is used here to signal to the
660 runtime library that the inquire unit number is outside the
661 allowable range and so cannot exist. It is needed when
662 -fdefault-integer-8 is used. */
663 set_parameter_const (&newblock, var, IOPARM_common_unit,
664 GFC_INVALID_UNIT);
665
666 body = gfc_finish_block (&newblock);
667
e73d3ca6 668 cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
e344505c
JD		 669 var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
670 gfc_add_expr_to_block (&se.pre, var);
671 }
672
673 se.expr = convert (dest_type, se.expr);
674 gfc_add_block_to_block (block, &se.pre);
675
676 return p->mask;
677}
678
679
49de9e73 680/* Generate code to store a non-string I/O parameter into the
5e805e44 681 st_parameter_XXX structure. This is pass by reference. */
6de9cd9a 682
5e805e44
JJ		 683static unsigned int
684set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
685 tree var, enum iofield type, gfc_expr *e)
6de9cd9a
DN		 686{
687 gfc_se se;
5e805e44
JJ		 688 tree tmp, addr;
689 gfc_st_parameter_field *p = &st_parameter_field[type];
6de9cd9a 690
5e805e44 691 gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
6de9cd9a 692 gfc_init_se (&se, NULL);
5e805e44 693 gfc_conv_expr_lhs (&se, e);
6de9cd9a 694
6de9cd9a
DN		 695 gfc_add_block_to_block (block, &se.pre);
696
5e805e44
JJ		 697 if (TYPE_MODE (TREE_TYPE (se.expr))
698 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
f96d606f 699 {
628c189e 700 addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
f96d606f
JD		 701
702 /* If this is for the iostat variable initialize the
d74b97cc 703 user variable to LIBERROR_OK which is zero. */
f96d606f 704 if (type == IOPARM_common_iostat)
726a989a 705 gfc_add_modify (block, se.expr,
d74b97cc 706 build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
f96d606f 707 }
5e805e44
JJ		 708 else
709 {
710 /* The type used by the library has different size
f96d606f
JD		 711 from the type of the variable supplied by the user.
712 Need to use a temporary. */
713 tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
714 st_parameter_field[type].name);
715
716 /* If this is for the iostat variable, initialize the
d74b97cc 717 user variable to LIBERROR_OK which is zero. */
f96d606f 718 if (type == IOPARM_common_iostat)
726a989a 719 gfc_add_modify (block, tmpvar,
d74b97cc 720 build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
f96d606f 721
628c189e 722 addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
f96d606f 723 /* After the I/O operation, we set the variable from the temporary. */
5e805e44 724 tmp = convert (TREE_TYPE (se.expr), tmpvar);
726a989a 725 gfc_add_modify (postblock, se.expr, tmp);
f96d606f 726 }
5e805e44 727
e73d3ca6 728 set_parameter_tree (block, var, type, addr);
5e805e44 729 return p->mask;
6de9cd9a
DN		 730}
731
d3642f89
FW		 732/* Given an array expr, find its address and length to get a string. If the
733 array is full, the string's address is the address of array's first element
7e279142 734 and the length is the size of the whole array. If it is an element, the
d3642f89 735 string's address is the element's address and the length is the rest size of
7e279142 736 the array. */
d3642f89
FW		 737
738static void
739gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
740{
d3642f89 741 tree size;
d3642f89 742
7e279142 743 if (e->rank == 0)
d3642f89 744 {
7e279142
JJ		 745 tree type, array, tmp;
746 gfc_symbol *sym;
747 int rank;
748
749 /* If it is an element, we need its address and size of the rest. */
750 gcc_assert (e->expr_type == EXPR_VARIABLE);
751 gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
752 sym = e->symtree->n.sym;
753 rank = sym->as->rank - 1;
d3642f89 754 gfc_conv_expr (se, e);
d3642f89 755
7e279142
JJ		 756 array = sym->backend_decl;
757 type = TREE_TYPE (array);
d3642f89 758
7e279142
JJ		 759 if (GFC_ARRAY_TYPE_P (type))
760 size = GFC_TYPE_ARRAY_SIZE (type);
761 else
762 {
763 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
764 size = gfc_conv_array_stride (array, rank);
65a9ca82
TB		 765 tmp = fold_build2_loc (input_location, MINUS_EXPR,
766 gfc_array_index_type,
767 gfc_conv_array_ubound (array, rank),
768 gfc_conv_array_lbound (array, rank));
769 tmp = fold_build2_loc (input_location, PLUS_EXPR,
770 gfc_array_index_type, tmp,
771 gfc_index_one_node);
772 size = fold_build2_loc (input_location, MULT_EXPR,
773 gfc_array_index_type, tmp, size);
7e279142
JJ		 774 }
775 gcc_assert (size);
d3642f89 776
65a9ca82
TB		 777 size = fold_build2_loc (input_location, MINUS_EXPR,
778 gfc_array_index_type, size,
779 TREE_OPERAND (se->expr, 1));
628c189e 780 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
7e279142 781 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
65a9ca82
TB		 782 size = fold_build2_loc (input_location, MULT_EXPR,
783 gfc_array_index_type, size,
784 fold_convert (gfc_array_index_type, tmp));
7e279142
JJ		 785 se->string_length = fold_convert (gfc_charlen_type_node, size);
786 return;
d3642f89
FW		 787 }
788
2960a368 789 gfc_conv_array_parameter (se, e, true, NULL, NULL, &size);
d3642f89
FW		 790 se->string_length = fold_convert (gfc_charlen_type_node, size);
791}
6de9cd9a 792
109b0ac2 793
6de9cd9a 794/* Generate code to store a string and its length into the
5e805e44 795 st_parameter_XXX structure. */
6de9cd9a 796
5e805e44 797static unsigned int
6de9cd9a 798set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
5e805e44 799 enum iofield type, gfc_expr * e)
6de9cd9a
DN		 800{
801 gfc_se se;
802 tree tmp;
6de9cd9a
DN		 803 tree io;
804 tree len;
5e805e44 805 gfc_st_parameter_field *p = &st_parameter_field[type];
6de9cd9a
DN		 806
807 gfc_init_se (&se, NULL);
6de9cd9a 808
5e805e44 809 if (p->param_type == IOPARM_ptype_common)
65a9ca82
TB		 810 var = fold_build3_loc (input_location, COMPONENT_REF,
811 st_parameter[IOPARM_ptype_common].type,
812 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
813 io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
44855d8c 814 var, p->field, NULL_TREE);
65a9ca82
TB		 815 len = fold_build3_loc (input_location, COMPONENT_REF,
816 TREE_TYPE (p->field_len),
817 var, p->field_len, NULL_TREE);
6de9cd9a 818
7ab92584 819 /* Integer variable assigned a format label. */
7e279142
JJ		 820 if (e->ts.type == BT_INTEGER
821 && e->rank == 0
822 && e->symtree->n.sym->attr.assign == 1)
6de9cd9a 823 {
dd18a33b 824 char * msg;
c8fe94c7 825 tree cond;
dd18a33b 826
ce2df7c6 827 gfc_conv_label_variable (&se, e);
6de9cd9a 828 tmp = GFC_DECL_STRING_LEN (se.expr);
65a9ca82
TB		 829 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
830 tmp, build_int_cst (TREE_TYPE (tmp), 0));
dd18a33b 831
1a33dc9e
UB		 832 msg = xasprintf ("Label assigned to variable '%s' (%%ld) is not a format "
833 "label", e->symtree->name);
0d52899f 834 gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
c8fe94c7 835 fold_convert (long_integer_type_node, tmp));
cede9502 836 free (msg);
dd18a33b 837
726a989a 838 gfc_add_modify (&se.pre, io,
b078dfbf 839 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
726a989a 840 gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
6de9cd9a
DN		 841 }
842 else
843 {
d3642f89
FW		 844 /* General character. */
845 if (e->ts.type == BT_CHARACTER && e->rank == 0)
846 gfc_conv_expr (&se, e);
847 /* Array assigned Hollerith constant or character array. */
7e279142 848 else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
d3642f89
FW		 849 gfc_convert_array_to_string (&se, e);
850 else
851 gcc_unreachable ();
852
6de9cd9a 853 gfc_conv_string_parameter (&se);
726a989a
RB		 854 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
855 gfc_add_modify (&se.pre, len, 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
0cd2402d
SB		 1005 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
1006 rc, tmp, NULL_TREE);
6de9cd9a
DN		 1007
1008 gfc_add_expr_to_block (block, tmp);
1009}
1010
1011
1012/* Store the current file and line number to variables so that if a
1013 library call goes awry, we can tell the user where the problem is. */
1014
1015static void
5e805e44 1016set_error_locus (stmtblock_t * block, tree var, locus * where)
6de9cd9a
DN		 1017{
1018 gfc_file *f;
5e805e44 1019 tree str, locus_file;
6de9cd9a 1020 int line;
5e805e44 1021 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
6de9cd9a 1022
65a9ca82
TB		 1023 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1024 st_parameter[IOPARM_ptype_common].type,
1025 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
1026 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1027 TREE_TYPE (p->field), locus_file,
1028 p->field, NULL_TREE);
d4fa05b9 1029 f = where->lb->file;
5e805e44 1030 str = gfc_build_cstring_const (f->filename);
6de9cd9a 1031
5e805e44 1032 str = gfc_build_addr_expr (pchar_type_node, str);
726a989a 1033 gfc_add_modify (block, locus_file, str);
6de9cd9a 1034
c8cc8542 1035 line = LOCATION_LINE (where->lb->location);
5e805e44 1036 set_parameter_const (block, var, IOPARM_common_line, line);
6de9cd9a
DN		 1037}
1038
1039
1040/* Translate an OPEN statement. */
1041
1042tree
1043gfc_trans_open (gfc_code * code)
1044{
1045 stmtblock_t block, post_block;
1046 gfc_open *p;
5e805e44
JJ		 1047 tree tmp, var;
1048 unsigned int mask = 0;
6de9cd9a 1049
5e805e44 1050 gfc_start_block (&block);
6de9cd9a
DN		 1051 gfc_init_block (&post_block);
1052
5e805e44
JJ		 1053 var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
1054
1055 set_error_locus (&block, var, &code->loc);
6de9cd9a
DN		 1056 p = code->ext.open;
1057
f96d606f
JD		 1058 if (p->iomsg)
1059 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1060 p->iomsg);
1061
1062 if (p->iostat)
1063 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1064 p->iostat);
1065
1066 if (p->err)
1067 mask |= IOPARM_common_err;
6de9cd9a
DN		 1068
1069 if (p->file)
5e805e44 1070 mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
6de9cd9a
DN		 1071
1072 if (p->status)
5e805e44
JJ		 1073 mask |= set_string (&block, &post_block, var, IOPARM_open_status,
1074 p->status);
6de9cd9a
DN		 1075
1076 if (p->access)
5e805e44
JJ		 1077 mask |= set_string (&block, &post_block, var, IOPARM_open_access,
1078 p->access);
6de9cd9a
DN		 1079
1080 if (p->form)
5e805e44 1081 mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
6de9cd9a
DN		 1082
1083 if (p->recl)
e344505c 1084 mask |= set_parameter_value (&block, var, IOPARM_open_recl_in,
ed9c79e1 1085 p->recl);
6de9cd9a
DN		 1086
1087 if (p->blank)
5e805e44
JJ		 1088 mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
1089 p->blank);
6de9cd9a
DN		 1090
1091 if (p->position)
5e805e44
JJ		 1092 mask |= set_string (&block, &post_block, var, IOPARM_open_position,
1093 p->position);
6de9cd9a
DN		 1094
1095 if (p->action)
5e805e44
JJ		 1096 mask |= set_string (&block, &post_block, var, IOPARM_open_action,
1097 p->action);
6de9cd9a
DN		 1098
1099 if (p->delim)
5e805e44
JJ		 1100 mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
1101 p->delim);
6de9cd9a
DN		 1102
1103 if (p->pad)
5e805e44 1104 mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
6de9cd9a 1105
6f0f0b2e
JD		 1106 if (p->decimal)
1107 mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
1108 p->decimal);
1109
1110 if (p->encoding)
1111 mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
1112 p->encoding);
1113
1114 if (p->round)
1115 mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
1116
1117 if (p->sign)
1118 mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
1119
1120 if (p->asynchronous)
1121 mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
1122 p->asynchronous);
1123
181c9f4a
TK		 1124 if (p->convert)
1125 mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
1126 p->convert);
8019105d 1127
9ad55c33
JD		 1128 if (p->newunit)
1129 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
1130 p->newunit);
181c9f4a 1131
0ef33d44
FR		 1132 if (p->cc)
1133 mask |= set_string (&block, &post_block, var, IOPARM_open_cc, p->cc);
1134
1135 if (p->share)
1136 mask |= set_string (&block, &post_block, var, IOPARM_open_share, p->share);
1137
1138 mask |= set_parameter_const (&block, var, IOPARM_open_readonly, p->readonly);
1139
5e805e44
JJ		 1140 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1141
f96d606f 1142 if (p->unit)
e344505c 1143 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
f96d606f
JD		 1144 else
1145 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1146
628c189e 1147 tmp = gfc_build_addr_expr (NULL_TREE, var);
db3927fb
AH		 1148 tmp = build_call_expr_loc (input_location,
1149 iocall[IOCALL_OPEN], 1, tmp);
6de9cd9a
DN		 1150 gfc_add_expr_to_block (&block, tmp);
1151
1152 gfc_add_block_to_block (&block, &post_block);
1153
5e805e44 1154 io_result (&block, var, p->err, NULL, NULL);
6de9cd9a
DN		 1155
1156 return gfc_finish_block (&block);
1157}
1158
1159
1160/* Translate a CLOSE statement. */
1161
1162tree
1163gfc_trans_close (gfc_code * code)
1164{
1165 stmtblock_t block, post_block;
1166 gfc_close *p;
5e805e44
JJ		 1167 tree tmp, var;
1168 unsigned int mask = 0;
6de9cd9a 1169
5e805e44 1170 gfc_start_block (&block);
6de9cd9a
DN		 1171 gfc_init_block (&post_block);
1172
5e805e44
JJ		 1173 var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
1174
1175 set_error_locus (&block, var, &code->loc);
6de9cd9a
DN		 1176 p = code->ext.close;
1177
7aba8abe 1178 if (p->iomsg)
5e805e44
JJ		 1179 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1180 p->iomsg);
7aba8abe 1181
6de9cd9a 1182 if (p->iostat)
5e805e44
JJ		 1183 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1184 p->iostat);
6de9cd9a
DN		 1185
1186 if (p->err)
5e805e44
JJ		 1187 mask |= IOPARM_common_err;
1188
f96d606f
JD		 1189 if (p->status)
1190 mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1191 p->status);
1192
5e805e44 1193 set_parameter_const (&block, var, IOPARM_common_flags, mask);
6de9cd9a 1194
f96d606f 1195 if (p->unit)
e344505c 1196 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
f96d606f
JD		 1197 else
1198 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1199
628c189e 1200 tmp = gfc_build_addr_expr (NULL_TREE, var);
db3927fb
AH		 1201 tmp = build_call_expr_loc (input_location,
1202 iocall[IOCALL_CLOSE], 1, tmp);
6de9cd9a
DN		 1203 gfc_add_expr_to_block (&block, tmp);
1204
1205 gfc_add_block_to_block (&block, &post_block);
1206
5e805e44 1207 io_result (&block, var, p->err, NULL, NULL);
6de9cd9a
DN		 1208
1209 return gfc_finish_block (&block);
1210}
1211
1212
1213/* Common subroutine for building a file positioning statement. */
1214
1215static tree
1216build_filepos (tree function, gfc_code * code)
1217{
7aba8abe 1218 stmtblock_t block, post_block;
6de9cd9a 1219 gfc_filepos *p;
5e805e44
JJ		 1220 tree tmp, var;
1221 unsigned int mask = 0;
6de9cd9a
DN		 1222
1223 p = code->ext.filepos;
1224
5e805e44 1225 gfc_start_block (&block);
7aba8abe 1226 gfc_init_block (&post_block);
6de9cd9a 1227
5e805e44
JJ		 1228 var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1229 "filepos_parm");
1230
1231 set_error_locus (&block, var, &code->loc);
6de9cd9a 1232
7aba8abe 1233 if (p->iomsg)
5e805e44
JJ		 1234 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1235 p->iomsg);
7aba8abe 1236
6de9cd9a 1237 if (p->iostat)
e344505c
JD		 1238 mask |= set_parameter_ref (&block, &post_block, var,
1239 IOPARM_common_iostat, p->iostat);
6de9cd9a
DN		 1240
1241 if (p->err)
5e805e44
JJ		 1242 mask |= IOPARM_common_err;
1243
1244 set_parameter_const (&block, var, IOPARM_common_flags, mask);
6de9cd9a 1245
f96d606f 1246 if (p->unit)
e344505c
JD		 1247 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit,
1248 p->unit);
f96d606f
JD		 1249 else
1250 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1251
628c189e 1252 tmp = gfc_build_addr_expr (NULL_TREE, var);
db3927fb
AH		 1253 tmp = build_call_expr_loc (input_location,
1254 function, 1, tmp);
6de9cd9a
DN		 1255 gfc_add_expr_to_block (&block, tmp);
1256
7aba8abe
TK		 1257 gfc_add_block_to_block (&block, &post_block);
1258
5e805e44 1259 io_result (&block, var, p->err, NULL, NULL);
6de9cd9a
DN		 1260
1261 return gfc_finish_block (&block);
1262}
1263
1264
1265/* Translate a BACKSPACE statement. */
1266
1267tree
1268gfc_trans_backspace (gfc_code * code)
1269{
5e805e44 1270 return build_filepos (iocall[IOCALL_BACKSPACE], code);
6de9cd9a
DN		 1271}
1272
1273
1274/* Translate an ENDFILE statement. */
1275
1276tree
1277gfc_trans_endfile (gfc_code * code)
1278{
5e805e44 1279 return build_filepos (iocall[IOCALL_ENDFILE], code);
6de9cd9a
DN		 1280}
1281
1282
1283/* Translate a REWIND statement. */
1284
1285tree
1286gfc_trans_rewind (gfc_code * code)
1287{
5e805e44 1288 return build_filepos (iocall[IOCALL_REWIND], code);
6de9cd9a
DN		 1289}
1290
1291
6403ec5f
JB		 1292/* Translate a FLUSH statement. */
1293
1294tree
1295gfc_trans_flush (gfc_code * code)
1296{
5e805e44 1297 return build_filepos (iocall[IOCALL_FLUSH], code);
6403ec5f
JB		 1298}
1299
1300
6de9cd9a
DN		 1301/* Translate the non-IOLENGTH form of an INQUIRE statement. */
1302
1303tree
1304gfc_trans_inquire (gfc_code * code)
1305{
1306 stmtblock_t block, post_block;
1307 gfc_inquire *p;
5e805e44 1308 tree tmp, var;
6f0f0b2e 1309 unsigned int mask = 0, mask2 = 0;
6de9cd9a 1310
5e805e44 1311 gfc_start_block (&block);
6de9cd9a
DN		 1312 gfc_init_block (&post_block);
1313
5e805e44
JJ		 1314 var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1315 "inquire_parm");
1316
1317 set_error_locus (&block, var, &code->loc);
6de9cd9a
DN		 1318 p = code->ext.inquire;
1319
7aba8abe 1320 if (p->iomsg)
5e805e44
JJ		 1321 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1322 p->iomsg);
7aba8abe 1323
6de9cd9a 1324 if (p->iostat)
5e805e44
JJ		 1325 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1326 p->iostat);
6de9cd9a 1327
f96d606f
JD		 1328 if (p->err)
1329 mask |= IOPARM_common_err;
1330
1331 /* Sanity check. */
1332 if (p->unit && p->file)
1333 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1334
1335 if (p->file)
1336 mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1337 p->file);
1338
6de9cd9a 1339 if (p->exist)
e344505c 1340 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
c16dd6a8 1341 p->exist);
6de9cd9a
DN		 1342
1343 if (p->opened)
5e805e44
JJ		 1344 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1345 p->opened);
6de9cd9a
DN		 1346
1347 if (p->number)
5e805e44
JJ		 1348 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1349 p->number);
6de9cd9a
DN		 1350
1351 if (p->named)
5e805e44
JJ		 1352 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1353 p->named);
6de9cd9a
DN		 1354
1355 if (p->name)
5e805e44
JJ		 1356 mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1357 p->name);
6de9cd9a
DN		 1358
1359 if (p->access)
5e805e44
JJ		 1360 mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1361 p->access);
6de9cd9a
DN		 1362
1363 if (p->sequential)
5e805e44
JJ		 1364 mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1365 p->sequential);
6de9cd9a
DN		 1366
1367 if (p->direct)
5e805e44
JJ		 1368 mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1369 p->direct);
6de9cd9a
DN		 1370
1371 if (p->form)
5e805e44
JJ		 1372 mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1373 p->form);
6de9cd9a
DN		 1374
1375 if (p->formatted)
5e805e44
JJ		 1376 mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1377 p->formatted);
6de9cd9a
DN		 1378
1379 if (p->unformatted)
5e805e44
JJ		 1380 mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1381 p->unformatted);
6de9cd9a
DN		 1382
1383 if (p->recl)
5e805e44
JJ		 1384 mask |= set_parameter_ref (&block, &post_block, var,
1385 IOPARM_inquire_recl_out, p->recl);
6de9cd9a
DN		 1386
1387 if (p->nextrec)
5e805e44
JJ		 1388 mask |= set_parameter_ref (&block, &post_block, var,
1389 IOPARM_inquire_nextrec, p->nextrec);
6de9cd9a
DN		 1390
1391 if (p->blank)
5e805e44
JJ		 1392 mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1393 p->blank);
6de9cd9a 1394
d06b3496
JD		 1395 if (p->delim)
1396 mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1397 p->delim);
1398
6de9cd9a 1399 if (p->position)
5e805e44
JJ		 1400 mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1401 p->position);
6de9cd9a
DN		 1402
1403 if (p->action)
5e805e44
JJ		 1404 mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1405 p->action);
6de9cd9a
DN		 1406
1407 if (p->read)
5e805e44
JJ		 1408 mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1409 p->read);
6de9cd9a
DN		 1410
1411 if (p->write)
5e805e44
JJ		 1412 mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1413 p->write);
6de9cd9a
DN		 1414
1415 if (p->readwrite)
5e805e44
JJ		 1416 mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1417 p->readwrite);
6de9cd9a 1418
dae24534 1419 if (p->pad)
5e805e44
JJ		 1420 mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1421 p->pad);
8019105d 1422
181c9f4a
TK		 1423 if (p->convert)
1424 mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1425 p->convert);
1426
014ec6ee
JD		 1427 if (p->strm_pos)
1428 mask |= set_parameter_ref (&block, &post_block, var,
1429 IOPARM_inquire_strm_pos_out, p->strm_pos);
1430
6f0f0b2e
JD		 1431 /* The second series of flags. */
1432 if (p->asynchronous)
1433 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1434 p->asynchronous);
1435
1436 if (p->decimal)
1437 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1438 p->decimal);
1439
1440 if (p->encoding)
1441 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1442 p->encoding);
1443
1444 if (p->round)
1445 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1446 p->round);
1447
1448 if (p->sign)
1449 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1450 p->sign);
1451
1452 if (p->pending)
1453 mask2 |= set_parameter_ref (&block, &post_block, var,
1454 IOPARM_inquire_pending, p->pending);
1455
1456 if (p->size)
1457 mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1458 p->size);
1459
1460 if (p->id)
d06b3496
JD		 1461 mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1462 p->id);
93e8af19
JD		 1463 if (p->iqstream)
1464 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream,
1465 p->iqstream);
6f0f0b2e 1466
0ef33d44
FR		 1467 if (p->share)
1468 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_share,
1469 p->share);
1470
1471 if (p->cc)
1472 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_cc, p->cc);
1473
6f0f0b2e 1474 if (mask2)
e1456843 1475 mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
6f0f0b2e 1476
5e805e44 1477 set_parameter_const (&block, var, IOPARM_common_flags, mask);
6de9cd9a 1478
f96d606f 1479 if (p->unit)
e344505c
JD		 1480 {
1481 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1482 set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit);
1483 }
f96d606f
JD		 1484 else
1485 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1486
628c189e 1487 tmp = gfc_build_addr_expr (NULL_TREE, var);
db3927fb
AH		 1488 tmp = build_call_expr_loc (input_location,
1489 iocall[IOCALL_INQUIRE], 1, tmp);
6de9cd9a
DN		 1490 gfc_add_expr_to_block (&block, tmp);
1491
1492 gfc_add_block_to_block (&block, &post_block);
1493
5e805e44 1494 io_result (&block, var, p->err, NULL, NULL);
6de9cd9a
DN		 1495
1496 return gfc_finish_block (&block);
1497}
1498
6f0f0b2e
JD		 1499
1500tree
1501gfc_trans_wait (gfc_code * code)
1502{
1503 stmtblock_t block, post_block;
1504 gfc_wait *p;
1505 tree tmp, var;
1506 unsigned int mask = 0;
1507
1508 gfc_start_block (&block);
1509 gfc_init_block (&post_block);
1510
1511 var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1512 "wait_parm");
1513
1514 set_error_locus (&block, var, &code->loc);
1515 p = code->ext.wait;
1516
1517 /* Set parameters here. */
1518 if (p->iomsg)
1519 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1520 p->iomsg);
1521
1522 if (p->iostat)
1523 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1524 p->iostat);
1525
1526 if (p->err)
1527 mask |= IOPARM_common_err;
1528
1529 if (p->id)
e344505c 1530 mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
6f0f0b2e
JD		 1531
1532 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1533
1534 if (p->unit)
e344505c 1535 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
6f0f0b2e 1536
628c189e 1537 tmp = gfc_build_addr_expr (NULL_TREE, var);
db3927fb
AH		 1538 tmp = build_call_expr_loc (input_location,
1539 iocall[IOCALL_WAIT], 1, tmp);
6f0f0b2e
JD		 1540 gfc_add_expr_to_block (&block, tmp);
1541
1542 gfc_add_block_to_block (&block, &post_block);
1543
1544 io_result (&block, var, p->err, NULL, NULL);
1545
1546 return gfc_finish_block (&block);
1547
1548}
1549
6de9cd9a 1550
29dc5138 1551/* nml_full_name builds up the fully qualified name of a
3b111bd7 1552 derived type component. '+' is used to denote a type extension. */
29dc5138
PT		 1553
1554static char*
3b111bd7 1555nml_full_name (const char* var_name, const char* cmp_name, bool parent)
6de9cd9a 1556{
29dc5138
PT		 1557 int full_name_length;
1558 char * full_name;
1559
1560 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
93acb62c 1561 full_name = XCNEWVEC (char, full_name_length + 1);
29dc5138 1562 strcpy (full_name, var_name);
3b111bd7 1563 full_name = strcat (full_name, parent ? "+" : "%");
29dc5138
PT		 1564 full_name = strcat (full_name, cmp_name);
1565 return full_name;
6de9cd9a
DN		 1566}
1567
19d36107 1568
29dc5138
PT		 1569/* nml_get_addr_expr builds an address expression from the
1570 gfc_symbol or gfc_component backend_decl's. An offset is
1571 provided so that the address of an element of an array of
1572 derived types is returned. This is used in the runtime to
66e4ab31 1573 determine that span of the derived type. */
29dc5138
PT		 1574
1575static tree
1576nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1577 tree base_addr)
1578{
1579 tree decl = NULL_TREE;
1580 tree tmp;
29dc5138
PT		 1581
1582 if (sym)
1583 {
1584 sym->attr.referenced = 1;
1585 decl = gfc_get_symbol_decl (sym);
847b053d
PT		 1586
1587 /* If this is the enclosing function declaration, use
1588 the fake result instead. */
1589 if (decl == current_function_decl)
1590 decl = gfc_get_fake_result_decl (sym, 0);
1591 else if (decl == DECL_CONTEXT (current_function_decl))
1592 decl = gfc_get_fake_result_decl (sym, 1);
29dc5138
PT		 1593 }
1594 else
1595 decl = c->backend_decl;
1596
d168c883
JJ		 1597 gcc_assert (decl && (TREE_CODE (decl) == FIELD_DECL
1598 || VAR_P (decl)
1599 || TREE_CODE (decl) == PARM_DECL
1600 || TREE_CODE (decl) == COMPONENT_REF));
29dc5138
PT		 1601
1602 tmp = decl;
1603
1604 /* Build indirect reference, if dummy argument. */
1605
19d36107
TB		 1606 if (POINTER_TYPE_P (TREE_TYPE(tmp)))
1607 tmp = build_fold_indirect_ref_loc (input_location, tmp);
29dc5138
PT		 1608
1609 /* Treat the component of a derived type, using base_addr for
1610 the derived type. */
1611
1612 if (TREE_CODE (decl) == FIELD_DECL)
65a9ca82
TB		 1613 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
1614 base_addr, tmp, NULL_TREE);
29dc5138 1615
19d36107
TB		 1616 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1617 tmp = gfc_conv_array_data (tmp);
1618 else
1619 {
1620 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1621 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
29dc5138 1622
19d36107
TB		 1623 if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1624 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
29dc5138 1625
19d36107
TB		 1626 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1627 tmp = build_fold_indirect_ref_loc (input_location,
db3927fb 1628 tmp);
19d36107 1629 }
29dc5138
PT		 1630
1631 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1632
1633 return tmp;
1634}
3bc268e6 1635
19d36107 1636
29dc5138 1637/* For an object VAR_NAME whose base address is BASE_ADDR, generate a
5e805e44
JJ		 1638 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1639 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
3bc268e6 1640
29dc5138 1641#define IARG(i) build_int_cst (gfc_array_index_type, i)
3bc268e6
VL		 1642
1643static void
29dc5138
PT		 1644transfer_namelist_element (stmtblock_t * block, const char * var_name,
1645 gfc_symbol * sym, gfc_component * c,
1646 tree base_addr)
3bc268e6 1647{
29dc5138
PT		 1648 gfc_typespec * ts = NULL;
1649 gfc_array_spec * as = NULL;
1650 tree addr_expr = NULL;
1651 tree dt = NULL;
1652 tree string;
1653 tree tmp;
29dc5138 1654 tree dtype;
5e805e44 1655 tree dt_parm_addr;
19d36107 1656 tree decl = NULL_TREE;
0522a84e 1657 tree gfc_int4_type_node = gfc_get_int_type (4);
e73d3ca6
PT		 1658 tree dtio_proc = null_pointer_node;
1659 tree vtable = null_pointer_node;
8019105d 1660 int n_dim;
29dc5138
PT		 1661 int itype;
1662 int rank = 0;
3bc268e6 1663
29dc5138 1664 gcc_assert (sym || c);
3bc268e6 1665
29dc5138
PT		 1666 /* Build the namelist object name. */
1667
1668 string = gfc_build_cstring_const (var_name);
1669 string = gfc_build_addr_expr (pchar_type_node, string);
1670
1671 /* Build ts, as and data address using symbol or component. */
1672
1673 ts = (sym) ? &sym->ts : &c->ts;
1674 as = (sym) ? sym->as : c->as;
1675
1676 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1677
1678 if (as)
1679 rank = as->rank;
1680
1681 if (rank)
3bc268e6 1682 {
19d36107
TB		 1683 decl = (sym) ? sym->backend_decl : c->backend_decl;
1684 if (sym && sym->attr.dummy)
1685 decl = build_fold_indirect_ref_loc (input_location, decl);
1686 dt = TREE_TYPE (decl);
29dc5138 1687 dtype = gfc_get_dtype (dt);
3bc268e6 1688 }
29dc5138
PT		 1689 else
1690 {
a11930ba 1691 itype = ts->type;
29dc5138 1692 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
3bc268e6
VL		 1693 }
1694
29dc5138
PT		 1695 /* Build up the arguments for the transfer call.
1696 The call for the scalar part transfers:
1697 (address, name, type, kind or string_length, dtype) */
1698
628c189e 1699 dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
29dc5138 1700
e73d3ca6
PT		 1701 /* Check if the derived type has a specific DTIO for the mode.
1702 Note that although namelist io is forbidden to have a format
1703 list, the specific subroutine is of the formatted kind. */
1704 if (ts->type == BT_DERIVED)
1705 {
1706 gfc_symbol *dtio_sub = NULL;
1707 gfc_symbol *vtab;
1708 dtio_sub = gfc_find_specific_dtio_proc (ts->u.derived,
1709 last_dt == WRITE,
1710 true);
1711 if (dtio_sub != NULL)
1712 {
1713 dtio_proc = gfc_get_symbol_decl (dtio_sub);
1714 dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
1715 vtab = gfc_find_derived_vtab (ts->u.derived);
1716 vtable = vtab->backend_decl;
1717 if (vtable == NULL_TREE)
1718 vtable = gfc_get_symbol_decl (vtab);
1719 vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
1720 }
1721 }
1722
29dc5138 1723 if (ts->type == BT_CHARACTER)
bc21d315 1724 tmp = ts->u.cl->backend_decl;
29dc5138 1725 else
5039610b 1726 tmp = build_int_cst (gfc_charlen_type_node, 0);
e73d3ca6
PT		 1727
1728 if (dtio_proc == NULL_TREE)
1729 tmp = build_call_expr_loc (input_location,
1730 iocall[IOCALL_SET_NML_VAL], 6,
1731 dt_parm_addr, addr_expr, string,
1732 build_int_cst (gfc_int4_type_node, ts->kind),
1733 tmp, dtype);
1734 else
1735 tmp = build_call_expr_loc (input_location,
1736 iocall[IOCALL_SET_NML_DTIO_VAL], 8,
1737 dt_parm_addr, addr_expr, string,
1738 build_int_cst (gfc_int4_type_node, ts->kind),
1739 tmp, dtype, dtio_proc, vtable);
3bc268e6 1740 gfc_add_expr_to_block (block, tmp);
29dc5138
PT		 1741
1742 /* If the object is an array, transfer rank times:
1743 (null pointer, name, stride, lbound, ubound) */
1744
1745 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1746 {
db3927fb
AH		 1747 tmp = build_call_expr_loc (input_location,
1748 iocall[IOCALL_SET_NML_VAL_DIM], 5,
5039610b 1749 dt_parm_addr,
0522a84e 1750 build_int_cst (gfc_int4_type_node, n_dim),
19d36107
TB		 1751 gfc_conv_array_stride (decl, n_dim),
1752 gfc_conv_array_lbound (decl, n_dim),
1753 gfc_conv_array_ubound (decl, n_dim));
29dc5138
PT		 1754 gfc_add_expr_to_block (block, tmp);
1755 }
1756
e73d3ca6
PT		 1757 if (gfc_bt_struct (ts->type) && ts->u.derived->components
1758 && dtio_proc == null_pointer_node)
29dc5138
PT		 1759 {
1760 gfc_component *cmp;
1761
1762 /* Provide the RECORD_TYPE to build component references. */
1763
db3927fb
AH		 1764 tree expr = build_fold_indirect_ref_loc (input_location,
1765 addr_expr);
29dc5138 1766
bc21d315 1767 for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
29dc5138 1768 {
3b111bd7
JD		 1769 char *full_name = nml_full_name (var_name, cmp->name,
1770 ts->u.derived->attr.extension);
29dc5138
PT		 1771 transfer_namelist_element (block,
1772 full_name,
1773 NULL, cmp, expr);
cede9502 1774 free (full_name);
29dc5138
PT		 1775 }
1776 }
3bc268e6 1777}
6de9cd9a 1778
29dc5138 1779#undef IARG
29dc5138 1780
6de9cd9a
DN		 1781/* Create a data transfer statement. Not all of the fields are valid
1782 for both reading and writing, but improper use has been filtered
1783 out by now. */
1784
1785static tree
5e805e44 1786build_dt (tree function, gfc_code * code)
6de9cd9a 1787{
d4feb3d3 1788 stmtblock_t block, post_block, post_end_block, post_iu_block;
6de9cd9a 1789 gfc_dt *dt;
5e805e44 1790 tree tmp, var;
29dc5138 1791 gfc_expr *nmlname;
3bc268e6 1792 gfc_namelist *nml;
5e1bdeb7 1793 unsigned int mask = 0;
6de9cd9a 1794
5e805e44 1795 gfc_start_block (&block);
6de9cd9a 1796 gfc_init_block (&post_block);
5e805e44 1797 gfc_init_block (&post_end_block);
d4feb3d3 1798 gfc_init_block (&post_iu_block);
5e805e44
JJ		 1799
1800 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1801
1802 set_error_locus (&block, var, &code->loc);
6de9cd9a 1803
5e805e44
JJ		 1804 if (last_dt == IOLENGTH)
1805 {
1806 gfc_inquire *inq;
1807
1808 inq = code->ext.inquire;
6de9cd9a 1809
5e805e44
JJ		 1810 /* First check that preconditions are met. */
1811 gcc_assert (inq != NULL);
1812 gcc_assert (inq->iolength != NULL);
1813
1814 /* Connect to the iolength variable. */
1815 mask |= set_parameter_ref (&block, &post_end_block, var,
1816 IOPARM_dt_iolength, inq->iolength);
1817 dt = NULL;
1818 }
1819 else
1820 {
1821 dt = code->ext.dt;
1822 gcc_assert (dt != NULL);
1823 }
8750f9cd 1824
5e805e44 1825 if (dt && dt->io_unit)
6de9cd9a
DN		 1826 {
1827 if (dt->io_unit->ts.type == BT_CHARACTER)
1828 {
d4feb3d3
PT		 1829 mask |= set_internal_unit (&block, &post_iu_block,
1830 var, dt->io_unit);
c8dce2cf 1831 set_parameter_const (&block, var, IOPARM_common_unit,
4a8d4422
JD		 1832 dt->io_unit->ts.kind == 1 ?
1833 GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4);
6de9cd9a 1834 }
6de9cd9a 1835 }
5e805e44
JJ		 1836 else
1837 set_parameter_const (&block, var, IOPARM_common_unit, 0);
6de9cd9a 1838
5e805e44
JJ		 1839 if (dt)
1840 {
f96d606f
JD		 1841 if (dt->iomsg)
1842 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1843 dt->iomsg);
1844
1845 if (dt->iostat)
1846 mask |= set_parameter_ref (&block, &post_end_block, var,
1847 IOPARM_common_iostat, dt->iostat);
1848
1849 if (dt->err)
1850 mask |= IOPARM_common_err;
1851
1852 if (dt->eor)
1853 mask |= IOPARM_common_eor;
1854
1855 if (dt->end)
1856 mask |= IOPARM_common_end;
1857
6f0f0b2e
JD		 1858 if (dt->id)
1859 mask |= set_parameter_ref (&block, &post_end_block, var,
1860 IOPARM_dt_id, dt->id);
1861
1862 if (dt->pos)
e344505c 1863 mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
6f0f0b2e
JD		 1864
1865 if (dt->asynchronous)
e344505c
JD		 1866 mask |= set_string (&block, &post_block, var,
1867 IOPARM_dt_asynchronous, dt->asynchronous);
6f0f0b2e
JD		 1868
1869 if (dt->blank)
1870 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1871 dt->blank);
1872
1873 if (dt->decimal)
1874 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1875 dt->decimal);
1876
1877 if (dt->delim)
1878 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1879 dt->delim);
1880
1881 if (dt->pad)
1882 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1883 dt->pad);
1884
1885 if (dt->round)
1886 mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1887 dt->round);
1888
1889 if (dt->sign)
1890 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1891 dt->sign);
1892
5e805e44 1893 if (dt->rec)
e344505c 1894 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
6de9cd9a 1895
5e805e44
JJ		 1896 if (dt->advance)
1897 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1898 dt->advance);
6de9cd9a 1899
5e805e44 1900 if (dt->format_expr)
9341698a 1901 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
5e805e44 1902 dt->format_expr);
6de9cd9a 1903
5e805e44
JJ		 1904 if (dt->format_label)
1905 {
1906 if (dt->format_label == &format_asterisk)
1907 mask |= IOPARM_dt_list_format;
1908 else
1909 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1910 dt->format_label->format);
1911 }
6de9cd9a 1912
5e805e44
JJ		 1913 if (dt->size)
1914 mask |= set_parameter_ref (&block, &post_end_block, var,
1915 IOPARM_dt_size, dt->size);
6de9cd9a 1916
4a8d4422
JD		 1917 if (dt->udtio)
1918 mask |= IOPARM_dt_dtio;
1919
6869e9c6
FR		 1920 if (dt->default_exp)
1921 mask |= IOPARM_dt_default_exp;
1922
5e805e44
JJ		 1923 if (dt->namelist)
1924 {
1925 if (dt->format_expr || dt->format_label)
1926 gfc_internal_error ("build_dt: format with namelist");
1927
b7e75771
JD		 1928 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1929 dt->namelist->name,
1930 strlen (dt->namelist->name));
29dc5138 1931
5e805e44
JJ		 1932 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1933 nmlname);
29dc5138 1934
76c1a7ec
TB		 1935 gfc_free_expr (nmlname);
1936
5e805e44
JJ		 1937 if (last_dt == READ)
1938 mask |= IOPARM_dt_namelist_read_mode;
29dc5138 1939
5e805e44 1940 set_parameter_const (&block, var, IOPARM_common_flags, mask);
29dc5138 1941
5e805e44
JJ		 1942 dt_parm = var;
1943
1944 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1945 transfer_namelist_element (&block, nml->sym->name, nml->sym,
71ff73f3 1946 NULL, NULL_TREE);
5e805e44
JJ		 1947 }
1948 else
1949 set_parameter_const (&block, var, IOPARM_common_flags, mask);
f96d606f
JD		 1950
1951 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
e344505c
JD		 1952 set_parameter_value_chk (&block, dt->iostat, var,
1953 IOPARM_common_unit, dt->io_unit);
6de9cd9a 1954 }
5e805e44
JJ		 1955 else
1956 set_parameter_const (&block, var, IOPARM_common_flags, mask);
6de9cd9a 1957
628c189e 1958 tmp = gfc_build_addr_expr (NULL_TREE, var);
033e7d21 1959 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
db3927fb 1960 function, 1, tmp);
6de9cd9a
DN		 1961 gfc_add_expr_to_block (&block, tmp);
1962
1963 gfc_add_block_to_block (&block, &post_block);
1964
5e805e44
JJ		 1965 dt_parm = var;
1966 dt_post_end_block = &post_end_block;
1967
bc51e726
JD		 1968 /* Set implied do loop exit condition. */
1969 if (last_dt == READ || last_dt == WRITE)
1970 {
1971 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
1972
65a9ca82
TB		 1973 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1974 st_parameter[IOPARM_ptype_common].type,
1975 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
1976 NULL_TREE);
1977 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1978 TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
1979 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
1980 tmp, build_int_cst (TREE_TYPE (tmp),
1981 IOPARM_common_libreturn_mask));
bc51e726
JD		 1982 }
1983 else /* IOLENGTH */
1984 tmp = NULL_TREE;
1985
1986 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
5e805e44 1987
d4feb3d3
PT		 1988 gfc_add_block_to_block (&block, &post_iu_block);
1989
5e805e44
JJ		 1990 dt_parm = NULL;
1991 dt_post_end_block = NULL;
1992
6de9cd9a
DN		 1993 return gfc_finish_block (&block);
1994}
1995
1996
8750f9cd
JB		 1997/* Translate the IOLENGTH form of an INQUIRE statement. We treat
1998 this as a third sort of data transfer statement, except that
e7dc5b4f 1999 lengths are summed instead of actually transferring any data. */
8750f9cd
JB		 2000
2001tree
2002gfc_trans_iolength (gfc_code * code)
2003{
8750f9cd 2004 last_dt = IOLENGTH;
5e805e44 2005 return build_dt (iocall[IOCALL_IOLENGTH], code);
8750f9cd
JB		 2006}
2007
2008
6de9cd9a
DN		 2009/* Translate a READ statement. */
2010
2011tree
2012gfc_trans_read (gfc_code * code)
2013{
6de9cd9a 2014 last_dt = READ;
5e805e44 2015 return build_dt (iocall[IOCALL_READ], code);
6de9cd9a
DN		 2016}
2017
2018
2019/* Translate a WRITE statement */
2020
2021tree
2022gfc_trans_write (gfc_code * code)
2023{
6de9cd9a 2024 last_dt = WRITE;
5e805e44 2025 return build_dt (iocall[IOCALL_WRITE], code);
6de9cd9a
DN		 2026}
2027
2028
2029/* Finish a data transfer statement. */
2030
2031tree
2032gfc_trans_dt_end (gfc_code * code)
2033{
2034 tree function, tmp;
2035 stmtblock_t block;
2036
2037 gfc_init_block (&block);
2038
8750f9cd
JB		 2039 switch (last_dt)
2040 {
2041 case READ:
5e805e44 2042 function = iocall[IOCALL_READ_DONE];
8750f9cd
JB		 2043 break;
2044
2045 case WRITE:
5e805e44 2046 function = iocall[IOCALL_WRITE_DONE];
8750f9cd
JB		 2047 break;
2048
2049 case IOLENGTH:
5e805e44 2050 function = iocall[IOCALL_IOLENGTH_DONE];
8750f9cd
JB		 2051 break;
2052
2053 default:
6e45f57b 2054 gcc_unreachable ();
8750f9cd 2055 }
6de9cd9a 2056
628c189e 2057 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
db3927fb
AH		 2058 tmp = build_call_expr_loc (input_location,
2059 function, 1, tmp);
6de9cd9a 2060 gfc_add_expr_to_block (&block, tmp);
5e805e44
JJ		 2061 gfc_add_block_to_block (&block, dt_post_end_block);
2062 gfc_init_block (dt_post_end_block);
6de9cd9a 2063
8750f9cd
JB		 2064 if (last_dt != IOLENGTH)
2065 {
6e45f57b 2066 gcc_assert (code->ext.dt != NULL);
5e805e44 2067 io_result (&block, dt_parm, code->ext.dt->err,
8750f9cd
JB		 2068 code->ext.dt->end, code->ext.dt->eor);
2069 }
6de9cd9a
DN		 2070
2071 return gfc_finish_block (&block);
2072}
2073
d2ccf6aa 2074static void
e73d3ca6
PT		 2075transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2076 gfc_code * code, tree vptr);
d2ccf6aa
VL		 2077
2078/* Given an array field in a derived type variable, generate the code
2079 for the loop that iterates over array elements, and the code that
2080 accesses those array elements. Use transfer_expr to generate code
2081 for transferring that element. Because elements may also be
2082 derived types, transfer_expr and transfer_array_component are mutually
2083 recursive. */
2084
2085static tree
bdfd2ff0 2086transfer_array_component (tree expr, gfc_component * cm, locus * where)
d2ccf6aa
VL		 2087{
2088 tree tmp;
2089 stmtblock_t body;
2090 stmtblock_t block;
2091 gfc_loopinfo loop;
2092 int n;
2093 gfc_ss *ss;
2094 gfc_se se;
08dcec61 2095 gfc_array_info *ss_array;
d2ccf6aa
VL		 2096
2097 gfc_start_block (&block);
2098 gfc_init_se (&se, NULL);
2099
2100 /* Create and initialize Scalarization Status. Unlike in
2101 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2102 care of this task, because we don't have a gfc_expr at hand.
2103 Build one manually, as in gfc_trans_subarray_assign. */
2104
66877276
MM		 2105 ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
2106 GFC_SS_COMPONENT);
1838afec 2107 ss_array = &ss->info->data.array;
08dcec61
MM		 2108 ss_array->shape = gfc_get_shape (cm->as->rank);
2109 ss_array->descriptor = expr;
2110 ss_array->data = gfc_conv_array_data (expr);
2111 ss_array->offset = gfc_conv_array_offset (expr);
d2ccf6aa
VL		 2112 for (n = 0; n < cm->as->rank; n++)
2113 {
08dcec61
MM		 2114 ss_array->start[n] = gfc_conv_array_lbound (expr, n);
2115 ss_array->stride[n] = gfc_index_one_node;
d2ccf6aa 2116
08dcec61
MM		 2117 mpz_init (ss_array->shape[n]);
2118 mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
d2ccf6aa 2119 cm->as->lower[n]->value.integer);
08dcec61 2120 mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
d2ccf6aa
VL		 2121 }
2122
f7b529fa 2123 /* Once we got ss, we use scalarizer to create the loop. */
d2ccf6aa
VL		 2124
2125 gfc_init_loopinfo (&loop);
2126 gfc_add_ss_to_loop (&loop, ss);
2127 gfc_conv_ss_startstride (&loop);
bdfd2ff0 2128 gfc_conv_loop_setup (&loop, where);
d2ccf6aa
VL		 2129 gfc_mark_ss_chain_used (ss, 1);
2130 gfc_start_scalarized_body (&loop, &body);
2131
2132 gfc_copy_loopinfo_to_se (&se, &loop);
2133 se.ss = ss;
2134
2135 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2136 se.expr = expr;
2137 gfc_conv_tmp_array_ref (&se);
2138
2139 /* Now se.expr contains an element of the array. Take the address and pass
2140 it to the IO routines. */
628c189e 2141 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
e73d3ca6 2142 transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
d2ccf6aa
VL		 2143
2144 /* We are done now with the loop body. Wrap up the scalarizer and
f7b529fa 2145 return. */
d2ccf6aa
VL		 2146
2147 gfc_add_block_to_block (&body, &se.pre);
2148 gfc_add_block_to_block (&body, &se.post);
2149
2150 gfc_trans_scalarizing_loops (&loop, &body);
2151
2152 gfc_add_block_to_block (&block, &loop.pre);
2153 gfc_add_block_to_block (&block, &loop.post);
2154
08dcec61
MM		 2155 gcc_assert (ss_array->shape != NULL);
2156 gfc_free_shape (&ss_array->shape, cm->as->rank);
96654664
PB		 2157 gfc_cleanup_loop (&loop);
2158
d2ccf6aa
VL		 2159 return gfc_finish_block (&block);
2160}
6de9cd9a 2161
e73d3ca6
PT		 2162
2163/* Helper function for transfer_expr that looks for the DTIO procedure
2164 either as a typebound binding or in a generic interface. If present,
2165 the address expression of the procedure is returned. It is assumed
2166 that the procedure interface has been checked during resolution. */
2167
2168static tree
2169get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
2170{
2171 gfc_symbol *derived;
2172 bool formatted = false;
2173 gfc_dt *dt = code->ext.dt;
2174
2175 if (dt && dt->format_expr)
2176 {
2177 char *fmt;
2178 fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
2179 -1);
2180 if (strtok (fmt, "DT") != NULL)
2181 formatted = true;
2182 }
2183 else if (dt && dt->format_label == &format_asterisk)
2184 {
2185 /* List directed io must call the formatted DTIO procedure. */
2186 formatted = true;
2187 }
2188
707024b2
JW		 2189 if (ts->type == BT_CLASS)
2190 derived = ts->u.derived->components->ts.u.derived;
2191 else
2192 derived = ts->u.derived;
2193
2194 gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
2195 last_dt == WRITE, formatted);
2196 if (ts->type == BT_CLASS && tb_io_st)
e4e659b9 2197 {
707024b2
JW		 2198 // polymorphic DTIO call (based on the dynamic type)
2199 gfc_se se;
2200 gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1);
2201 gfc_add_vptr_component (expr);
2202 gfc_add_component_ref (expr,
2203 tb_io_st->n.tb->u.generic->specific_st->name);
2204 *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym;
2205 gfc_init_se (&se, NULL);
2206 se.want_pointer = 1;
2207 gfc_conv_expr (&se, expr);
2208 gfc_free_expr (expr);
2209 return se.expr;
2210 }
2211 else
2212 {
2213 // non-polymorphic DTIO call (based on the declared type)
e4e659b9
JW		 2214 *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
2215 formatted);
2216
2217 if (*dtio_sub)
2218 return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
2219 }
e73d3ca6
PT		 2220
2221 return NULL_TREE;
e73d3ca6
PT		 2222}
2223
6de9cd9a
DN		 2224/* Generate the call for a scalar transfer node. */
2225
2226static void
e73d3ca6
PT		 2227transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2228 gfc_code * code, tree vptr)
6de9cd9a 2229{
8a221914 2230 tree tmp, function, arg2, arg3, field, expr;
6de9cd9a
DN		 2231 gfc_component *c;
2232 int kind;
2233
a8b3b0b6
CR		 2234 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2235 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2236 We need to translate the expression to a constant if it's either
aa5e22f0
CR		 2237 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2238 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2239 BT_DERIVED (could have been changed by gfc_conv_expr). */
bc21d315
JW		 2240 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2241 && ts->u.derived != NULL
2242 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
a8b3b0b6 2243 {
cadddfdd
TB		 2244 ts->type = BT_INTEGER;
2245 ts->kind = gfc_index_integer_kind;
a8b3b0b6 2246 }
8019105d 2247
6de9cd9a
DN		 2248 kind = ts->kind;
2249 function = NULL;
2250 arg2 = NULL;
8a221914 2251 arg3 = NULL;
6de9cd9a
DN		 2252
2253 switch (ts->type)
2254 {
2255 case BT_INTEGER:
df09d1d5 2256 arg2 = build_int_cst (integer_type_node, kind);
6eb6875d
TK		 2257 if (last_dt == READ)
2258 function = iocall[IOCALL_X_INTEGER];
2259 else
2260 function = iocall[IOCALL_X_INTEGER_WRITE];
2261
6de9cd9a
DN		 2262 break;
2263
2264 case BT_REAL:
df09d1d5 2265 arg2 = build_int_cst (integer_type_node, kind);
6eb6875d 2266 if (last_dt == READ)
1ec601bf
FXC		 2267 {
2268 if (gfc_real16_is_float128 && ts->kind == 16)
2269 function = iocall[IOCALL_X_REAL128];
2270 else
2271 function = iocall[IOCALL_X_REAL];
2272 }
6eb6875d 2273 else
1ec601bf
FXC		 2274 {
2275 if (gfc_real16_is_float128 && ts->kind == 16)
2276 function = iocall[IOCALL_X_REAL128_WRITE];
2277 else
2278 function = iocall[IOCALL_X_REAL_WRITE];
2279 }
6eb6875d 2280
6de9cd9a
DN		 2281 break;
2282
2283 case BT_COMPLEX:
df09d1d5 2284 arg2 = build_int_cst (integer_type_node, kind);
6eb6875d 2285 if (last_dt == READ)
1ec601bf
FXC		 2286 {
2287 if (gfc_real16_is_float128 && ts->kind == 16)
2288 function = iocall[IOCALL_X_COMPLEX128];
2289 else
2290 function = iocall[IOCALL_X_COMPLEX];
2291 }
6eb6875d 2292 else
1ec601bf
FXC		 2293 {
2294 if (gfc_real16_is_float128 && ts->kind == 16)
2295 function = iocall[IOCALL_X_COMPLEX128_WRITE];
2296 else
2297 function = iocall[IOCALL_X_COMPLEX_WRITE];
2298 }
6eb6875d 2299
6de9cd9a
DN		 2300 break;
2301
2302 case BT_LOGICAL:
df09d1d5 2303 arg2 = build_int_cst (integer_type_node, kind);
6eb6875d
TK		 2304 if (last_dt == READ)
2305 function = iocall[IOCALL_X_LOGICAL];
2306 else
2307 function = iocall[IOCALL_X_LOGICAL_WRITE];
2308
6de9cd9a
DN		 2309 break;
2310
2311 case BT_CHARACTER:
8a221914
JD		 2312 if (kind == 4)
2313 {
2314 if (se->string_length)
2315 arg2 = se->string_length;
2316 else
2317 {
db3927fb
AH		 2318 tmp = build_fold_indirect_ref_loc (input_location,
2319 addr_expr);
8a221914
JD		 2320 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2321 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2322 arg2 = fold_convert (gfc_charlen_type_node, arg2);
2323 }
df09d1d5 2324 arg3 = build_int_cst (integer_type_node, kind);
6eb6875d
TK		 2325 if (last_dt == READ)
2326 function = iocall[IOCALL_X_CHARACTER_WIDE];
2327 else
2328 function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
8019105d 2329
628c189e 2330 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
db3927fb
AH		 2331 tmp = build_call_expr_loc (input_location,
2332 function, 4, tmp, addr_expr, arg2, arg3);
8a221914
JD		 2333 gfc_add_expr_to_block (&se->pre, tmp);
2334 gfc_add_block_to_block (&se->pre, &se->post);
2335 return;
2336 }
1cc0e193 2337 /* Fall through. */
7b95e2a8 2338 case BT_HOLLERITH:
d2ccf6aa
VL		 2339 if (se->string_length)
2340 arg2 = se->string_length;
2341 else
2342 {
db3927fb
AH		 2343 tmp = build_fold_indirect_ref_loc (input_location,
2344 addr_expr);
d2ccf6aa
VL		 2345 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2346 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2347 }
6eb6875d
TK		 2348 if (last_dt == READ)
2349 function = iocall[IOCALL_X_CHARACTER];
2350 else
2351 function = iocall[IOCALL_X_CHARACTER_WRITE];
2352
6de9cd9a
DN		 2353 break;
2354
f6288c24 2355 case_bt_struct:
e73d3ca6 2356 case BT_CLASS:
fc2655fb
TB		 2357 if (ts->u.derived->components == NULL)
2358 return;
e73d3ca6
PT		 2359 if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
2360 {
2361 gfc_symbol *derived;
2362 gfc_symbol *dtio_sub = NULL;
2363 /* Test for a specific DTIO subroutine. */
2364 if (ts->type == BT_DERIVED)
2365 derived = ts->u.derived;
2366 else
2367 derived = ts->u.derived->components->ts.u.derived;
fc2655fb 2368
e73d3ca6
PT		 2369 if (derived->attr.has_dtio_procs)
2370 arg2 = get_dtio_proc (ts, code, &dtio_sub);
6de9cd9a 2371
6c0347f6 2372 if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
e73d3ca6
PT		 2373 {
2374 tree decl;
2375 decl = build_fold_indirect_ref_loc (input_location,
2376 se->expr);
2377 /* Remember that the first dummy of the DTIO subroutines
2378 is CLASS(derived) for extensible derived types, so the
2379 conversion must be done here for derived type and for
2380 scalarized CLASS array element io-list objects. */
2381 if ((ts->type == BT_DERIVED
2382 && !(ts->u.derived->attr.sequence
2383 || ts->u.derived->attr.is_bind_c))
2384 || (ts->type == BT_CLASS
2385 && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
2386 gfc_conv_derived_to_class (se, code->expr1,
2387 dtio_sub->formal->sym->ts,
2388 vptr, false, false);
2389 addr_expr = se->expr;
2390 function = iocall[IOCALL_X_DERIVED];
2391 break;
2392 }
2393 else if (ts->type == BT_DERIVED)
2394 {
2395 /* Recurse into the elements of the derived type. */
2396 expr = gfc_evaluate_now (addr_expr, &se->pre);
2397 expr = build_fold_indirect_ref_loc (input_location,
2398 expr);
8019105d 2399
e73d3ca6
PT		 2400 /* Make sure that the derived type has been built. An external
2401 function, if only referenced in an io statement, requires this
2402 check (see PR58771). */
2403 if (ts->u.derived->backend_decl == NULL_TREE)
2404 (void) gfc_typenode_for_spec (ts);
2405
2406 for (c = ts->u.derived->components; c; c = c->next)
2407 {
2408 field = c->backend_decl;
2409 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2410
2411 tmp = fold_build3_loc (UNKNOWN_LOCATION,
2412 COMPONENT_REF, TREE_TYPE (field),
2413 expr, field, NULL_TREE);
2414
2415 if (c->attr.dimension)
2416 {
2417 tmp = transfer_array_component (tmp, c, & code->loc);
2418 gfc_add_expr_to_block (&se->pre, tmp);
2419 }
2420 else
2421 {
2422 if (!c->attr.pointer)
2423 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2424 transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
2425 }
2426 }
2427 return;
2428 }
2429 /* If a CLASS object gets through to here, fall through and ICE. */
6de9cd9a 2430 }
81fea426 2431 gcc_fallthrough ();
6de9cd9a 2432 default:
17d5d49f 2433 gfc_internal_error ("Bad IO basetype (%d)", ts->type);
6de9cd9a
DN		 2434 }
2435
628c189e 2436 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
db3927fb
AH		 2437 tmp = build_call_expr_loc (input_location,
2438 function, 3, tmp, addr_expr, arg2);
6de9cd9a
DN		 2439 gfc_add_expr_to_block (&se->pre, tmp);
2440 gfc_add_block_to_block (&se->pre, &se->post);
8750f9cd 2441
6de9cd9a
DN		 2442}
2443
2444
18623fae
JB		 2445/* Generate a call to pass an array descriptor to the IO library. The
2446 array should be of one of the intrinsic types. */
2447
2448static void
2449transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2450{
6eb6875d 2451 tree tmp, charlen_arg, kind_arg, io_call;
18623fae
JB		 2452
2453 if (ts->type == BT_CHARACTER)
2454 charlen_arg = se->string_length;
2455 else
df09d1d5 2456 charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
18623fae 2457
df09d1d5 2458 kind_arg = build_int_cst (integer_type_node, ts->kind);
e5ef4b3b 2459
628c189e 2460 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
6eb6875d
TK		 2461 if (last_dt == READ)
2462 io_call = iocall[IOCALL_X_ARRAY];
2463 else
2464 io_call = iocall[IOCALL_X_ARRAY_WRITE];
2465
033e7d21 2466 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
6eb6875d 2467 io_call, 4,
5039610b 2468 tmp, addr_expr, kind_arg, charlen_arg);
18623fae
JB		 2469 gfc_add_expr_to_block (&se->pre, tmp);
2470 gfc_add_block_to_block (&se->pre, &se->post);
2471}
2472
2473
6de9cd9a
DN		 2474/* gfc_trans_transfer()-- Translate a TRANSFER code node */
2475
2476tree
2477gfc_trans_transfer (gfc_code * code)
2478{
2479 stmtblock_t block, body;
2480 gfc_loopinfo loop;
2481 gfc_expr *expr;
99c7ab42 2482 gfc_ref *ref;
6de9cd9a
DN		 2483 gfc_ss *ss;
2484 gfc_se se;
2485 tree tmp;
e73d3ca6 2486 tree vptr;
c63173dd 2487 int n;
6de9cd9a
DN		 2488
2489 gfc_start_block (&block);
18623fae 2490 gfc_init_block (&body);
6de9cd9a 2491
a513927a 2492 expr = code->expr1;
99c7ab42 2493 ref = NULL;
6de9cd9a
DN		 2494 gfc_init_se (&se, NULL);
2495
2960a368 2496 if (expr->rank == 0)
18623fae 2497 {
815d8045 2498 /* Transfer a scalar value. */
e73d3ca6
PT		 2499 if (expr->ts.type == BT_CLASS)
2500 {
2501 se.want_pointer = 1;
2502 gfc_conv_expr (&se, expr);
2503 vptr = gfc_get_vptr_from_expr (se.expr);
2504 }
2505 else
2506 {
2507 vptr = NULL_TREE;
2508 gfc_conv_expr_reference (&se, expr);
2509 }
2510 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
18623fae 2511 }
815d8045 2512 else
6de9cd9a 2513 {
99c7ab42
PT		 2514 /* Transfer an array. If it is an array of an intrinsic
2515 type, pass the descriptor to the library. Otherwise
2516 scalarize the transfer. */
2a573572 2517 if (expr->ref && !gfc_is_proc_ptr_comp (expr))
99c7ab42
PT		 2518 {
2519 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
fc2655fb
TB		 2520 ref = ref->next);
2521 gcc_assert (ref && ref->type == REF_ARRAY);
99c7ab42
PT		 2522 }
2523
e73d3ca6
PT		 2524 if (!(gfc_bt_struct (expr->ts.type)
2525 || expr->ts.type == BT_CLASS)
1d6b7f39
PT		 2526 && ref && ref->next == NULL
2527 && !is_subref_array (expr))
815d8045 2528 {
c63173dd
PT		 2529 bool seen_vector = false;
2530
2531 if (ref && ref->u.ar.type == AR_SECTION)
2532 {
2533 for (n = 0; n < ref->u.ar.dimen; n++)
2534 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
502af491
PCC		 2535 {
2536 seen_vector = true;
2537 break;
2538 }
c63173dd
PT		 2539 }
2540
2541 if (seen_vector && last_dt == READ)
2542 {
2543 /* Create a temp, read to that and copy it back. */
430f2d1f 2544 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
c63173dd
PT		 2545 tmp = se.expr;
2546 }
2547 else
2548 {
2549 /* Get the descriptor. */
2960a368 2550 gfc_conv_expr_descriptor (&se, expr);
628c189e 2551 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
c63173dd
PT		 2552 }
2553
99c7ab42
PT		 2554 transfer_array_desc (&se, &expr->ts, tmp);
2555 goto finish_block_label;
815d8045 2556 }
2960a368 2557
6de9cd9a 2558 /* Initialize the scalarizer. */
2960a368 2559 ss = gfc_walk_expr (expr);
6de9cd9a
DN		 2560 gfc_init_loopinfo (&loop);
2561 gfc_add_ss_to_loop (&loop, ss);
2562
2563 /* Initialize the loop. */
2564 gfc_conv_ss_startstride (&loop);
a513927a 2565 gfc_conv_loop_setup (&loop, &code->expr1->where);
6de9cd9a
DN		 2566
2567 /* The main loop body. */
2568 gfc_mark_ss_chain_used (ss, 1);
2569 gfc_start_scalarized_body (&loop, &body);
2570
2571 gfc_copy_loopinfo_to_se (&se, &loop);
2572 se.ss = ss;
18623fae 2573 gfc_conv_expr_reference (&se, expr);
e73d3ca6
PT		 2574 if (expr->ts.type == BT_CLASS)
2575 vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
2576 else
2577 vptr = NULL_TREE;
2578 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
18623fae 2579 }
815d8045
JB		 2580
2581 finish_block_label:
6de9cd9a
DN		 2582
2583 gfc_add_block_to_block (&body, &se.pre);
2584 gfc_add_block_to_block (&body, &se.post);
2585
2586 if (se.ss == NULL)
2587 tmp = gfc_finish_block (&body);
2588 else
2589 {
770caa74 2590 gcc_assert (expr->rank != 0);
6e45f57b 2591 gcc_assert (se.ss == gfc_ss_terminator);
6de9cd9a
DN		 2592 gfc_trans_scalarizing_loops (&loop, &body);
2593
2594 gfc_add_block_to_block (&loop.pre, &loop.post);
2595 tmp = gfc_finish_block (&loop.pre);
2596 gfc_cleanup_loop (&loop);
2597 }
2598
2599 gfc_add_expr_to_block (&block, tmp);
2600
d2ccf6aa 2601 return gfc_finish_block (&block);
6de9cd9a
DN		 2602}
2603
2604#include "gt-fortran-trans-io.h"
Mirror of https://gcc.gnu.org/git/gcc.git