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