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