1 /* IO Code translation/library interface
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
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
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
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/>. */
24 #include "coretypes.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"
37 /* Members of the ioparm structure. */
66 typedef struct GTY(()) gfc_st_parameter_field
{
69 enum ioparam_type param_type
;
70 enum iofield_type type
;
74 gfc_st_parameter_field
;
76 typedef struct GTY(()) gfc_st_parameter
{
84 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
90 static GTY(()) gfc_st_parameter st_parameter
[] =
101 static GTY(()) gfc_st_parameter_field st_parameter_field
[] =
103 #define IOPARM(param_type, name, mask, type) \
104 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
105 #include "ioparm.def"
107 { NULL
, 0, (enum ioparam_type
) 0, (enum iofield_type
) 0, NULL
, NULL
}
110 /* Library I/O subroutines */
119 IOCALL_X_INTEGER_WRITE
,
121 IOCALL_X_LOGICAL_WRITE
,
123 IOCALL_X_CHARACTER_WRITE
,
124 IOCALL_X_CHARACTER_WIDE
,
125 IOCALL_X_CHARACTER_WIDE_WRITE
,
129 IOCALL_X_COMPLEX_WRITE
,
131 IOCALL_X_REAL128_WRITE
,
133 IOCALL_X_COMPLEX128_WRITE
,
135 IOCALL_X_ARRAY_WRITE
,
141 IOCALL_IOLENGTH_DONE
,
147 IOCALL_SET_NML_DTIO_VAL
,
148 IOCALL_SET_NML_VAL_DIM
,
153 static GTY(()) tree iocall
[IOCALL_NUM
];
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
;
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
;
166 gfc_build_st_parameter (enum ioparam_type ptype
, tree
*types
)
169 gfc_st_parameter_field
*p
;
172 tree t
= make_node (RECORD_TYPE
);
175 len
= strlen (st_parameter
[ptype
].name
);
176 gcc_assert (len
<= sizeof (name
) - sizeof ("__st_parameter_"));
177 memcpy (name
, "__st_parameter_", sizeof ("__st_parameter_"));
178 memcpy (name
+ sizeof ("__st_parameter_") - 1, st_parameter
[ptype
].name
,
180 TYPE_NAME (t
) = get_identifier (name
);
182 for (type
= 0, p
= st_parameter_field
; type
< IOPARM_field_num
; type
++, p
++)
183 if (p
->param_type
== ptype
)
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
);
196 case IOPARM_type_char1
:
197 p
->field
= gfc_add_field_to_struct (t
, get_identifier (p
->name
),
198 pchar_type_node
, &chain
);
200 case IOPARM_type_char2
:
201 len
= strlen (p
->name
);
202 gcc_assert (len
<= sizeof (name
) - sizeof ("_len"));
203 memcpy (name
, p
->name
, len
);
204 memcpy (name
+ len
, "_len", sizeof ("_len"));
205 p
->field_len
= gfc_add_field_to_struct (t
, get_identifier (name
),
206 gfc_charlen_type_node
,
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
);
212 case IOPARM_type_common
:
214 = gfc_add_field_to_struct (t
,
215 get_identifier (p
->name
),
216 st_parameter
[IOPARM_ptype_common
].type
,
219 case IOPARM_type_num
:
223 /* -Wpadded warnings on these artificially created structures are not
224 helpful; suppress them. */
225 int save_warn_padded
= warn_padded
;
228 warn_padded
= save_warn_padded
;
229 st_parameter
[ptype
].type
= t
;
233 /* Build code to test an error condition and call generate_error if needed.
234 Note: This builds calls to generate_error in the runtime library function.
235 The function generate_error is dependent on certain parameters in the
236 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
237 Therefore, the code to set these flags must be generated before
238 this function is used. */
241 gfc_trans_io_runtime_check (bool has_iostat
, tree cond
, tree var
,
242 int error_code
, const char * msgid
,
243 stmtblock_t
* pblock
)
248 tree arg1
, arg2
, arg3
;
251 if (integer_zerop (cond
))
254 /* The code to generate the error. */
255 gfc_start_block (&block
);
258 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_FORTRAN_FAIL_IO
,
261 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_NORETURN
,
264 arg1
= gfc_build_addr_expr (NULL_TREE
, var
);
266 arg2
= build_int_cst (integer_type_node
, error_code
),
268 message
= xasprintf ("%s", _(msgid
));
269 arg3
= gfc_build_addr_expr (pchar_type_node
,
270 gfc_build_localized_cstring_const (message
));
273 tmp
= build_call_expr_loc (input_location
,
274 gfor_fndecl_generate_error
, 3, arg1
, arg2
, arg3
);
276 gfc_add_expr_to_block (&block
, tmp
);
278 body
= gfc_finish_block (&block
);
280 if (integer_onep (cond
))
282 gfc_add_expr_to_block (pblock
, body
);
286 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt (input_location
));
287 gfc_add_expr_to_block (pblock
, tmp
);
292 /* Create function decls for IO library functions. */
295 gfc_build_io_library_fndecls (void)
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
;
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
);
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
))));
323 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
324 gfc_build_st_parameter ((enum ioparam_type
) ptype
, types
);
326 /* Define the transfer functions. */
328 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
330 iocall
[IOCALL_X_INTEGER
] = gfc_build_library_function_decl_with_spec (
331 get_identifier (PREFIX("transfer_integer")), ".wW",
332 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
334 iocall
[IOCALL_X_INTEGER_WRITE
] = gfc_build_library_function_decl_with_spec (
335 get_identifier (PREFIX("transfer_integer_write")), ".wR",
336 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
338 iocall
[IOCALL_X_LOGICAL
] = gfc_build_library_function_decl_with_spec (
339 get_identifier (PREFIX("transfer_logical")), ".wW",
340 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
342 iocall
[IOCALL_X_LOGICAL_WRITE
] = gfc_build_library_function_decl_with_spec (
343 get_identifier (PREFIX("transfer_logical_write")), ".wR",
344 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
346 iocall
[IOCALL_X_CHARACTER
] = gfc_build_library_function_decl_with_spec (
347 get_identifier (PREFIX("transfer_character")), ".wW",
348 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
350 iocall
[IOCALL_X_CHARACTER_WRITE
] = gfc_build_library_function_decl_with_spec (
351 get_identifier (PREFIX("transfer_character_write")), ".wR",
352 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
354 iocall
[IOCALL_X_CHARACTER_WIDE
] = gfc_build_library_function_decl_with_spec (
355 get_identifier (PREFIX("transfer_character_wide")), ".wW",
356 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
357 gfc_charlen_type_node
, gfc_int4_type_node
);
359 iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
] =
360 gfc_build_library_function_decl_with_spec (
361 get_identifier (PREFIX("transfer_character_wide_write")), ".wR",
362 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
363 gfc_charlen_type_node
, gfc_int4_type_node
);
365 iocall
[IOCALL_X_REAL
] = gfc_build_library_function_decl_with_spec (
366 get_identifier (PREFIX("transfer_real")), ".wW",
367 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
369 iocall
[IOCALL_X_REAL_WRITE
] = gfc_build_library_function_decl_with_spec (
370 get_identifier (PREFIX("transfer_real_write")), ".wR",
371 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
373 iocall
[IOCALL_X_COMPLEX
] = gfc_build_library_function_decl_with_spec (
374 get_identifier (PREFIX("transfer_complex")), ".wW",
375 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
377 iocall
[IOCALL_X_COMPLEX_WRITE
] = gfc_build_library_function_decl_with_spec (
378 get_identifier (PREFIX("transfer_complex_write")), ".wR",
379 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
381 /* Version for __float128. */
382 iocall
[IOCALL_X_REAL128
] = gfc_build_library_function_decl_with_spec (
383 get_identifier (PREFIX("transfer_real128")), ".wW",
384 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
386 iocall
[IOCALL_X_REAL128_WRITE
] = gfc_build_library_function_decl_with_spec (
387 get_identifier (PREFIX("transfer_real128_write")), ".wR",
388 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
390 iocall
[IOCALL_X_COMPLEX128
] = gfc_build_library_function_decl_with_spec (
391 get_identifier (PREFIX("transfer_complex128")), ".wW",
392 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
394 iocall
[IOCALL_X_COMPLEX128_WRITE
] = gfc_build_library_function_decl_with_spec (
395 get_identifier (PREFIX("transfer_complex128_write")), ".wR",
396 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
398 iocall
[IOCALL_X_ARRAY
] = gfc_build_library_function_decl_with_spec (
399 get_identifier (PREFIX("transfer_array")), ".ww",
400 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
401 integer_type_node
, gfc_charlen_type_node
);
403 iocall
[IOCALL_X_ARRAY_WRITE
] = gfc_build_library_function_decl_with_spec (
404 get_identifier (PREFIX("transfer_array_write")), ".wr",
405 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
406 integer_type_node
, gfc_charlen_type_node
);
408 iocall
[IOCALL_X_DERIVED
] = gfc_build_library_function_decl_with_spec (
409 get_identifier (PREFIX("transfer_derived")), ".wrR",
410 void_type_node
, 2, dt_parm_type
, pvoid_type_node
, pchar_type_node
);
412 /* Library entry points */
414 iocall
[IOCALL_READ
] = gfc_build_library_function_decl_with_spec (
415 get_identifier (PREFIX("st_read")), ".w",
416 void_type_node
, 1, dt_parm_type
);
418 iocall
[IOCALL_WRITE
] = gfc_build_library_function_decl_with_spec (
419 get_identifier (PREFIX("st_write")), ".w",
420 void_type_node
, 1, dt_parm_type
);
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")), ".w",
425 void_type_node
, 1, parm_type
);
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")), ".w",
430 void_type_node
, 1, parm_type
);
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")), ".w",
435 void_type_node
, 1, parm_type
);
437 iocall
[IOCALL_IOLENGTH
] = gfc_build_library_function_decl_with_spec(
438 get_identifier (PREFIX("st_iolength")), ".w",
439 void_type_node
, 1, dt_parm_type
);
441 /* TODO: Change when asynchronous I/O is implemented. */
442 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_wait
].type
);
443 iocall
[IOCALL_WAIT
] = gfc_build_library_function_decl_with_spec (
444 get_identifier (PREFIX("st_wait")), ".X",
445 void_type_node
, 1, parm_type
);
447 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
448 iocall
[IOCALL_REWIND
] = gfc_build_library_function_decl_with_spec (
449 get_identifier (PREFIX("st_rewind")), ".w",
450 void_type_node
, 1, parm_type
);
452 iocall
[IOCALL_BACKSPACE
] = gfc_build_library_function_decl_with_spec (
453 get_identifier (PREFIX("st_backspace")), ".w",
454 void_type_node
, 1, parm_type
);
456 iocall
[IOCALL_ENDFILE
] = gfc_build_library_function_decl_with_spec (
457 get_identifier (PREFIX("st_endfile")), ".w",
458 void_type_node
, 1, parm_type
);
460 iocall
[IOCALL_FLUSH
] = gfc_build_library_function_decl_with_spec (
461 get_identifier (PREFIX("st_flush")), ".w",
462 void_type_node
, 1, parm_type
);
464 /* Library helpers */
466 iocall
[IOCALL_READ_DONE
] = gfc_build_library_function_decl_with_spec (
467 get_identifier (PREFIX("st_read_done")), ".w",
468 void_type_node
, 1, dt_parm_type
);
470 iocall
[IOCALL_WRITE_DONE
] = gfc_build_library_function_decl_with_spec (
471 get_identifier (PREFIX("st_write_done")), ".w",
472 void_type_node
, 1, dt_parm_type
);
474 iocall
[IOCALL_IOLENGTH_DONE
] = gfc_build_library_function_decl_with_spec (
475 get_identifier (PREFIX("st_iolength_done")), ".w",
476 void_type_node
, 1, dt_parm_type
);
478 iocall
[IOCALL_SET_NML_VAL
] = gfc_build_library_function_decl_with_spec (
479 get_identifier (PREFIX("st_set_nml_var")), ".w.R",
480 void_type_node
, 6, dt_parm_type
, pvoid_type_node
, pvoid_type_node
,
481 gfc_int4_type_node
, gfc_charlen_type_node
, gfc_int4_type_node
);
483 iocall
[IOCALL_SET_NML_DTIO_VAL
] = gfc_build_library_function_decl_with_spec (
484 get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R",
485 void_type_node
, 8, dt_parm_type
, pvoid_type_node
, pvoid_type_node
,
486 gfc_int4_type_node
, gfc_charlen_type_node
, gfc_int4_type_node
,
487 pvoid_type_node
, pvoid_type_node
);
489 iocall
[IOCALL_SET_NML_VAL_DIM
] = gfc_build_library_function_decl_with_spec (
490 get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
491 void_type_node
, 5, dt_parm_type
, gfc_int4_type_node
,
492 gfc_array_index_type
, gfc_array_index_type
, gfc_array_index_type
);
497 set_parameter_tree (stmtblock_t
*block
, tree var
, enum iofield type
, tree value
)
500 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
502 if (p
->param_type
== IOPARM_ptype_common
)
503 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
504 st_parameter
[IOPARM_ptype_common
].type
,
505 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
506 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
507 var
, p
->field
, NULL_TREE
);
508 gfc_add_modify (block
, tmp
, value
);
512 /* Generate code to store an integer constant into the
513 st_parameter_XXX structure. */
516 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
519 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
521 set_parameter_tree (block
, var
, type
,
522 build_int_cst (TREE_TYPE (p
->field
), val
));
527 /* Generate code to store a non-string I/O parameter into the
528 st_parameter_XXX structure. This is a pass by value. */
531 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
536 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
537 tree dest_type
= TREE_TYPE (p
->field
);
539 gfc_init_se (&se
, NULL
);
540 gfc_conv_expr_val (&se
, e
);
542 se
.expr
= convert (dest_type
, se
.expr
);
543 gfc_add_block_to_block (block
, &se
.pre
);
545 if (p
->param_type
== IOPARM_ptype_common
)
546 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
547 st_parameter
[IOPARM_ptype_common
].type
,
548 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
550 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, dest_type
, var
,
551 p
->field
, NULL_TREE
);
552 gfc_add_modify (block
, tmp
, se
.expr
);
557 /* Similar to set_parameter_value except generate runtime
561 set_parameter_value_chk (stmtblock_t
*block
, bool has_iostat
, tree var
,
562 enum iofield type
, gfc_expr
*e
)
566 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
567 tree dest_type
= TREE_TYPE (p
->field
);
569 gfc_init_se (&se
, NULL
);
570 gfc_conv_expr_val (&se
, e
);
572 /* If we're storing a UNIT number, we need to check it first. */
573 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
578 /* Don't evaluate the UNIT number multiple times. */
579 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
581 /* UNIT numbers should be greater than the min. */
582 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
583 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].pedantic_min_int
, 4);
584 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
586 fold_convert (TREE_TYPE (se
.expr
), val
));
587 gfc_trans_io_runtime_check (has_iostat
, cond
, var
, LIBERROR_BAD_UNIT
,
588 "Unit number in I/O statement too small",
591 /* UNIT numbers should be less than the max. */
592 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
593 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
595 fold_convert (TREE_TYPE (se
.expr
), val
));
596 gfc_trans_io_runtime_check (has_iostat
, cond
, var
, LIBERROR_BAD_UNIT
,
597 "Unit number in I/O statement too large",
601 se
.expr
= convert (dest_type
, se
.expr
);
602 gfc_add_block_to_block (block
, &se
.pre
);
604 if (p
->param_type
== IOPARM_ptype_common
)
605 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
606 st_parameter
[IOPARM_ptype_common
].type
,
607 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
609 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, dest_type
, var
,
610 p
->field
, NULL_TREE
);
611 gfc_add_modify (block
, tmp
, se
.expr
);
616 /* Build code to check the unit range if KIND=8 is used. Similar to
617 set_parameter_value_chk but we do not generate error calls for
618 inquire statements. */
621 set_parameter_value_inquire (stmtblock_t
*block
, tree var
,
622 enum iofield type
, gfc_expr
*e
)
625 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
626 tree dest_type
= TREE_TYPE (p
->field
);
628 gfc_init_se (&se
, NULL
);
629 gfc_conv_expr_val (&se
, e
);
631 /* If we're inquiring on a UNIT number, we need to check to make
632 sure it exists for larger than kind = 4. */
633 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
635 stmtblock_t newblock
;
636 tree cond1
, cond2
, cond3
, val
, body
;
639 /* Don't evaluate the UNIT number multiple times. */
640 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
642 /* UNIT numbers should be greater than zero. */
643 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
644 cond1
= build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
646 fold_convert (TREE_TYPE (se
.expr
),
648 /* UNIT numbers should be less than the max. */
649 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
650 cond2
= build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
652 fold_convert (TREE_TYPE (se
.expr
), val
));
653 cond3
= build2_loc (input_location
, TRUTH_OR_EXPR
,
654 boolean_type_node
, cond1
, cond2
);
656 gfc_start_block (&newblock
);
658 /* The unit number GFC_INVALID_UNIT is reserved. No units can
659 ever have this value. It is used here to signal to the
660 runtime library that the inquire unit number is outside the
661 allowable range and so cannot exist. It is needed when
662 -fdefault-integer-8 is used. */
663 set_parameter_const (&newblock
, var
, IOPARM_common_unit
,
666 body
= gfc_finish_block (&newblock
);
668 cond3
= gfc_unlikely (cond3
, PRED_FORTRAN_FAIL_IO
);
669 var
= build3_v (COND_EXPR
, cond3
, body
, build_empty_stmt (input_location
));
670 gfc_add_expr_to_block (&se
.pre
, var
);
673 se
.expr
= convert (dest_type
, se
.expr
);
674 gfc_add_block_to_block (block
, &se
.pre
);
680 /* Generate code to store a non-string I/O parameter into the
681 st_parameter_XXX structure. This is pass by reference. */
684 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
685 tree var
, enum iofield type
, gfc_expr
*e
)
689 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
691 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
692 gfc_init_se (&se
, NULL
);
693 gfc_conv_expr_lhs (&se
, e
);
695 gfc_add_block_to_block (block
, &se
.pre
);
697 if (TYPE_MODE (TREE_TYPE (se
.expr
))
698 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
700 addr
= convert (TREE_TYPE (p
->field
), gfc_build_addr_expr (NULL_TREE
, se
.expr
));
702 /* If this is for the iostat variable initialize the
703 user variable to LIBERROR_OK which is zero. */
704 if (type
== IOPARM_common_iostat
)
705 gfc_add_modify (block
, se
.expr
,
706 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
710 /* The type used by the library has different size
711 from the type of the variable supplied by the user.
712 Need to use a temporary. */
713 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
714 st_parameter_field
[type
].name
);
716 /* If this is for the iostat variable, initialize the
717 user variable to LIBERROR_OK which is zero. */
718 if (type
== IOPARM_common_iostat
)
719 gfc_add_modify (block
, tmpvar
,
720 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
722 addr
= gfc_build_addr_expr (NULL_TREE
, tmpvar
);
723 /* After the I/O operation, we set the variable from the temporary. */
724 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
725 gfc_add_modify (postblock
, se
.expr
, tmp
);
728 set_parameter_tree (block
, var
, type
, addr
);
732 /* Given an array expr, find its address and length to get a string. If the
733 array is full, the string's address is the address of array's first element
734 and the length is the size of the whole array. If it is an element, the
735 string's address is the element's address and the length is the rest size of
739 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
745 tree type
, array
, tmp
;
749 /* If it is an element, we need its address and size of the rest. */
750 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
751 gcc_assert (e
->ref
->u
.ar
.type
== AR_ELEMENT
);
752 sym
= e
->symtree
->n
.sym
;
753 rank
= sym
->as
->rank
- 1;
754 gfc_conv_expr (se
, e
);
756 array
= sym
->backend_decl
;
757 type
= TREE_TYPE (array
);
759 if (GFC_ARRAY_TYPE_P (type
))
760 size
= GFC_TYPE_ARRAY_SIZE (type
);
763 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
764 size
= gfc_conv_array_stride (array
, rank
);
765 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
766 gfc_array_index_type
,
767 gfc_conv_array_ubound (array
, rank
),
768 gfc_conv_array_lbound (array
, rank
));
769 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
770 gfc_array_index_type
, tmp
,
772 size
= fold_build2_loc (input_location
, MULT_EXPR
,
773 gfc_array_index_type
, tmp
, size
);
777 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
778 gfc_array_index_type
, size
,
779 TREE_OPERAND (se
->expr
, 1));
780 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
781 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
782 size
= fold_build2_loc (input_location
, MULT_EXPR
,
783 gfc_array_index_type
, size
,
784 fold_convert (gfc_array_index_type
, tmp
));
785 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
789 gfc_conv_array_parameter (se
, e
, true, NULL
, NULL
, &size
);
790 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
794 /* Generate code to store a string and its length into the
795 st_parameter_XXX structure. */
798 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
799 enum iofield type
, gfc_expr
* e
)
805 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
807 gfc_init_se (&se
, NULL
);
809 if (p
->param_type
== IOPARM_ptype_common
)
810 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
811 st_parameter
[IOPARM_ptype_common
].type
,
812 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
813 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
814 var
, p
->field
, NULL_TREE
);
815 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
816 TREE_TYPE (p
->field_len
),
817 var
, p
->field_len
, NULL_TREE
);
819 /* Integer variable assigned a format label. */
820 if (e
->ts
.type
== BT_INTEGER
822 && e
->symtree
->n
.sym
->attr
.assign
== 1)
827 gfc_conv_label_variable (&se
, e
);
828 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
829 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
830 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
832 msg
= xasprintf ("Label assigned to variable '%s' (%%ld) is not a format "
833 "label", e
->symtree
->name
);
834 gfc_trans_runtime_check (true, false, cond
, &se
.pre
, &e
->where
, msg
,
835 fold_convert (long_integer_type_node
, tmp
));
838 gfc_add_modify (&se
.pre
, io
,
839 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
840 gfc_add_modify (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
844 /* General character. */
845 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
846 gfc_conv_expr (&se
, e
);
847 /* Array assigned Hollerith constant or character array. */
848 else if (e
->rank
> 0 || (e
->symtree
&& e
->symtree
->n
.sym
->as
->rank
> 0))
849 gfc_convert_array_to_string (&se
, e
);
853 gfc_conv_string_parameter (&se
);
854 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
855 gfc_add_modify (&se
.pre
, len
, se
.string_length
);
858 gfc_add_block_to_block (block
, &se
.pre
);
859 gfc_add_block_to_block (postblock
, &se
.post
);
864 /* Generate code to store the character (array) and the character length
865 for an internal unit. */
868 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
869 tree var
, gfc_expr
* e
)
876 gfc_st_parameter_field
*p
;
879 gfc_init_se (&se
, NULL
);
881 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
883 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
884 var
, p
->field
, NULL_TREE
);
885 len
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field_len
),
886 var
, p
->field_len
, NULL_TREE
);
887 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
888 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
889 var
, p
->field
, NULL_TREE
);
891 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
893 /* Character scalars. */
896 gfc_conv_expr (&se
, e
);
897 gfc_conv_string_parameter (&se
);
899 se
.expr
= build_int_cst (pchar_type_node
, 0);
902 /* Character array. */
903 else if (e
->rank
> 0)
905 if (is_subref_array (e
))
907 /* Use a temporary for components of arrays of derived types
908 or substring array references. */
909 gfc_conv_subref_array_arg (&se
, e
, 0,
910 last_dt
== READ
? INTENT_IN
: INTENT_OUT
, false);
911 tmp
= build_fold_indirect_ref_loc (input_location
,
913 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
914 tmp
= gfc_conv_descriptor_data_get (tmp
);
918 /* Return the data pointer and rank from the descriptor. */
919 gfc_conv_expr_descriptor (&se
, e
);
920 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
921 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
927 /* The cast is needed for character substrings and the descriptor
929 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
930 gfc_add_modify (&se
.pre
, len
,
931 fold_convert (TREE_TYPE (len
), se
.string_length
));
932 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
934 gfc_add_block_to_block (block
, &se
.pre
);
935 gfc_add_block_to_block (post_block
, &se
.post
);
939 /* Add a case to a IO-result switch. */
942 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
947 return; /* No label, no case */
949 value
= build_int_cst (integer_type_node
, label_value
);
951 /* Make a backend label for this case. */
952 tmp
= gfc_build_label_decl (NULL_TREE
);
954 /* And the case itself. */
955 tmp
= build_case_label (value
, NULL_TREE
, tmp
);
956 gfc_add_expr_to_block (body
, tmp
);
958 /* Jump to the label. */
959 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
960 gfc_add_expr_to_block (body
, tmp
);
964 /* Generate a switch statement that branches to the correct I/O
965 result label. The last statement of an I/O call stores the
966 result into a variable because there is often cleanup that
967 must be done before the switch, so a temporary would have to
968 be created anyway. */
971 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
972 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
976 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
978 /* If no labels are specified, ignore the result instead
979 of building an empty switch. */
980 if (err_label
== NULL
982 && eor_label
== NULL
)
985 /* Build a switch statement. */
986 gfc_start_block (&body
);
988 /* The label values here must be the same as the values
989 in the library_return enum in the runtime library */
990 add_case (1, err_label
, &body
);
991 add_case (2, end_label
, &body
);
992 add_case (3, eor_label
, &body
);
994 tmp
= gfc_finish_block (&body
);
996 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
997 st_parameter
[IOPARM_ptype_common
].type
,
998 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
999 rc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
1000 var
, p
->field
, NULL_TREE
);
1001 rc
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (rc
),
1002 rc
, build_int_cst (TREE_TYPE (rc
),
1003 IOPARM_common_libreturn_mask
));
1005 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
1006 rc
, tmp
, NULL_TREE
);
1008 gfc_add_expr_to_block (block
, tmp
);
1012 /* Store the current file and line number to variables so that if a
1013 library call goes awry, we can tell the user where the problem is. */
1016 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
1019 tree str
, locus_file
;
1021 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
1023 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
1024 st_parameter
[IOPARM_ptype_common
].type
,
1025 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
1026 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
1027 TREE_TYPE (p
->field
), locus_file
,
1028 p
->field
, NULL_TREE
);
1029 f
= where
->lb
->file
;
1030 str
= gfc_build_cstring_const (f
->filename
);
1032 str
= gfc_build_addr_expr (pchar_type_node
, str
);
1033 gfc_add_modify (block
, locus_file
, str
);
1035 line
= LOCATION_LINE (where
->lb
->location
);
1036 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
1040 /* Translate an OPEN statement. */
1043 gfc_trans_open (gfc_code
* code
)
1045 stmtblock_t block
, post_block
;
1048 unsigned int mask
= 0;
1050 gfc_start_block (&block
);
1051 gfc_init_block (&post_block
);
1053 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
1055 set_error_locus (&block
, var
, &code
->loc
);
1059 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1063 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1067 mask
|= IOPARM_common_err
;
1070 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
1073 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
1077 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
1081 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
1084 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
,
1088 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
1092 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
1096 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
1100 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
1104 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
1107 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
1111 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
1115 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
1118 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
1120 if (p
->asynchronous
)
1121 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
1125 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
1129 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_open_newunit
,
1133 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_cc
, p
->cc
);
1136 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_share
, p
->share
);
1138 mask
|= set_parameter_const (&block
, var
, IOPARM_open_readonly
, p
->readonly
);
1140 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1143 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_unit
, p
->unit
);
1145 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1147 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1148 tmp
= build_call_expr_loc (input_location
,
1149 iocall
[IOCALL_OPEN
], 1, tmp
);
1150 gfc_add_expr_to_block (&block
, tmp
);
1152 gfc_add_block_to_block (&block
, &post_block
);
1154 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1156 return gfc_finish_block (&block
);
1160 /* Translate a CLOSE statement. */
1163 gfc_trans_close (gfc_code
* code
)
1165 stmtblock_t block
, post_block
;
1168 unsigned int mask
= 0;
1170 gfc_start_block (&block
);
1171 gfc_init_block (&post_block
);
1173 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
1175 set_error_locus (&block
, var
, &code
->loc
);
1176 p
= code
->ext
.close
;
1179 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1183 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1187 mask
|= IOPARM_common_err
;
1190 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
1193 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1196 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_unit
, p
->unit
);
1198 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1200 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1201 tmp
= build_call_expr_loc (input_location
,
1202 iocall
[IOCALL_CLOSE
], 1, tmp
);
1203 gfc_add_expr_to_block (&block
, tmp
);
1205 gfc_add_block_to_block (&block
, &post_block
);
1207 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1209 return gfc_finish_block (&block
);
1213 /* Common subroutine for building a file positioning statement. */
1216 build_filepos (tree function
, gfc_code
* code
)
1218 stmtblock_t block
, post_block
;
1221 unsigned int mask
= 0;
1223 p
= code
->ext
.filepos
;
1225 gfc_start_block (&block
);
1226 gfc_init_block (&post_block
);
1228 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1231 set_error_locus (&block
, var
, &code
->loc
);
1234 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1238 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1239 IOPARM_common_iostat
, p
->iostat
);
1242 mask
|= IOPARM_common_err
;
1244 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1247 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_unit
,
1250 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1252 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1253 tmp
= build_call_expr_loc (input_location
,
1255 gfc_add_expr_to_block (&block
, tmp
);
1257 gfc_add_block_to_block (&block
, &post_block
);
1259 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1261 return gfc_finish_block (&block
);
1265 /* Translate a BACKSPACE statement. */
1268 gfc_trans_backspace (gfc_code
* code
)
1270 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1274 /* Translate an ENDFILE statement. */
1277 gfc_trans_endfile (gfc_code
* code
)
1279 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1283 /* Translate a REWIND statement. */
1286 gfc_trans_rewind (gfc_code
* code
)
1288 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1292 /* Translate a FLUSH statement. */
1295 gfc_trans_flush (gfc_code
* code
)
1297 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1301 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1304 gfc_trans_inquire (gfc_code
* code
)
1306 stmtblock_t block
, post_block
;
1309 unsigned int mask
= 0, mask2
= 0;
1311 gfc_start_block (&block
);
1312 gfc_init_block (&post_block
);
1314 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1317 set_error_locus (&block
, var
, &code
->loc
);
1318 p
= code
->ext
.inquire
;
1321 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1325 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1329 mask
|= IOPARM_common_err
;
1332 if (p
->unit
&& p
->file
)
1333 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1336 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1340 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1344 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1348 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1352 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1356 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1360 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1364 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1368 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1372 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1376 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1380 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1384 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1385 IOPARM_inquire_recl_out
, p
->recl
);
1388 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1389 IOPARM_inquire_nextrec
, p
->nextrec
);
1392 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1396 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1400 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1404 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1408 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1412 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1416 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1420 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1424 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1428 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1429 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1431 /* The second series of flags. */
1432 if (p
->asynchronous
)
1433 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1437 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1441 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1445 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1449 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1453 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1454 IOPARM_inquire_pending
, p
->pending
);
1457 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1461 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1464 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_iqstream
,
1468 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_share
,
1472 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_cc
, p
->cc
);
1475 mask
|= set_parameter_const (&block
, var
, IOPARM_inquire_flags2
, mask2
);
1477 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1481 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1482 set_parameter_value_inquire (&block
, var
, IOPARM_common_unit
, p
->unit
);
1485 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1487 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1488 tmp
= build_call_expr_loc (input_location
,
1489 iocall
[IOCALL_INQUIRE
], 1, tmp
);
1490 gfc_add_expr_to_block (&block
, tmp
);
1492 gfc_add_block_to_block (&block
, &post_block
);
1494 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1496 return gfc_finish_block (&block
);
1501 gfc_trans_wait (gfc_code
* code
)
1503 stmtblock_t block
, post_block
;
1506 unsigned int mask
= 0;
1508 gfc_start_block (&block
);
1509 gfc_init_block (&post_block
);
1511 var
= gfc_create_var (st_parameter
[IOPARM_ptype_wait
].type
,
1514 set_error_locus (&block
, var
, &code
->loc
);
1517 /* Set parameters here. */
1519 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1523 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1527 mask
|= IOPARM_common_err
;
1530 mask
|= set_parameter_value (&block
, var
, IOPARM_wait_id
, p
->id
);
1532 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1535 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_unit
, p
->unit
);
1537 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1538 tmp
= build_call_expr_loc (input_location
,
1539 iocall
[IOCALL_WAIT
], 1, tmp
);
1540 gfc_add_expr_to_block (&block
, tmp
);
1542 gfc_add_block_to_block (&block
, &post_block
);
1544 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1546 return gfc_finish_block (&block
);
1551 /* nml_full_name builds up the fully qualified name of a
1552 derived type component. '+' is used to denote a type extension. */
1555 nml_full_name (const char* var_name
, const char* cmp_name
, bool parent
)
1557 int full_name_length
;
1560 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1561 full_name
= XCNEWVEC (char, full_name_length
+ 1);
1562 strcpy (full_name
, var_name
);
1563 full_name
= strcat (full_name
, parent
? "+" : "%");
1564 full_name
= strcat (full_name
, cmp_name
);
1569 /* nml_get_addr_expr builds an address expression from the
1570 gfc_symbol or gfc_component backend_decl's. An offset is
1571 provided so that the address of an element of an array of
1572 derived types is returned. This is used in the runtime to
1573 determine that span of the derived type. */
1576 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1579 tree decl
= NULL_TREE
;
1584 sym
->attr
.referenced
= 1;
1585 decl
= gfc_get_symbol_decl (sym
);
1587 /* If this is the enclosing function declaration, use
1588 the fake result instead. */
1589 if (decl
== current_function_decl
)
1590 decl
= gfc_get_fake_result_decl (sym
, 0);
1591 else if (decl
== DECL_CONTEXT (current_function_decl
))
1592 decl
= gfc_get_fake_result_decl (sym
, 1);
1595 decl
= c
->backend_decl
;
1597 gcc_assert (decl
&& (TREE_CODE (decl
) == FIELD_DECL
1599 || TREE_CODE (decl
) == PARM_DECL
1600 || TREE_CODE (decl
) == COMPONENT_REF
));
1604 /* Build indirect reference, if dummy argument. */
1606 if (POINTER_TYPE_P (TREE_TYPE(tmp
)))
1607 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1609 /* Treat the component of a derived type, using base_addr for
1610 the derived type. */
1612 if (TREE_CODE (decl
) == FIELD_DECL
)
1613 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
1614 base_addr
, tmp
, NULL_TREE
);
1616 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1617 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp
))))
1618 tmp
= gfc_class_data_get (tmp
);
1620 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
1621 tmp
= gfc_conv_array_data (tmp
);
1624 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1625 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1627 if (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1628 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1630 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1631 tmp
= build_fold_indirect_ref_loc (input_location
,
1635 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1641 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1642 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1643 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1645 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1648 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1649 gfc_symbol
* sym
, gfc_component
* c
,
1652 gfc_typespec
* ts
= NULL
;
1653 gfc_array_spec
* as
= NULL
;
1654 tree addr_expr
= NULL
;
1660 tree decl
= NULL_TREE
;
1661 tree gfc_int4_type_node
= gfc_get_int_type (4);
1662 tree dtio_proc
= null_pointer_node
;
1663 tree vtable
= null_pointer_node
;
1668 gcc_assert (sym
|| c
);
1670 /* Build the namelist object name. */
1672 string
= gfc_build_cstring_const (var_name
);
1673 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1675 /* Build ts, as and data address using symbol or component. */
1677 ts
= sym
? &sym
->ts
: &c
->ts
;
1679 if (ts
->type
!= BT_CLASS
)
1680 as
= sym
? sym
->as
: c
->as
;
1682 as
= sym
? CLASS_DATA (sym
)->as
: CLASS_DATA (c
)->as
;
1684 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1691 decl
= sym
? sym
->backend_decl
: c
->backend_decl
;
1692 if (sym
&& sym
->attr
.dummy
)
1693 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
1695 if (ts
->type
== BT_CLASS
)
1696 decl
= gfc_class_data_get (decl
);
1697 dt
= TREE_TYPE (decl
);
1698 dtype
= gfc_get_dtype (dt
);
1703 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1706 /* Build up the arguments for the transfer call.
1707 The call for the scalar part transfers:
1708 (address, name, type, kind or string_length, dtype) */
1710 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1712 /* Check if the derived type has a specific DTIO for the mode.
1713 Note that although namelist io is forbidden to have a format
1714 list, the specific subroutine is of the formatted kind. */
1715 if (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)
1717 gfc_symbol
*derived
;
1718 if (ts
->type
==BT_CLASS
)
1719 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
1721 derived
= ts
->u
.derived
;
1723 gfc_symtree
*tb_io_st
= gfc_find_typebound_dtio_proc (derived
,
1724 last_dt
== WRITE
, true);
1726 if (ts
->type
== BT_CLASS
&& tb_io_st
)
1728 // polymorphic DTIO call (based on the dynamic type)
1730 gfc_symtree
*st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1731 // build vtable expr
1732 gfc_expr
*expr
= gfc_get_variable_expr (st
);
1733 gfc_add_vptr_component (expr
);
1734 gfc_init_se (&se
, NULL
);
1735 se
.want_pointer
= 1;
1736 gfc_conv_expr (&se
, expr
);
1739 gfc_add_component_ref (expr
,
1740 tb_io_st
->n
.tb
->u
.generic
->specific_st
->name
);
1741 gfc_init_se (&se
, NULL
);
1742 se
.want_pointer
= 1;
1743 gfc_conv_expr (&se
, expr
);
1744 gfc_free_expr (expr
);
1745 dtio_proc
= se
.expr
;
1749 // non-polymorphic DTIO call (based on the declared type)
1750 gfc_symbol
*dtio_sub
= gfc_find_specific_dtio_proc (derived
,
1751 last_dt
== WRITE
, true);
1752 if (dtio_sub
!= NULL
)
1754 dtio_proc
= gfc_get_symbol_decl (dtio_sub
);
1755 dtio_proc
= gfc_build_addr_expr (NULL
, dtio_proc
);
1756 gfc_symbol
*vtab
= gfc_find_derived_vtab (derived
);
1757 vtable
= vtab
->backend_decl
;
1758 if (vtable
== NULL_TREE
)
1759 vtable
= gfc_get_symbol_decl (vtab
);
1760 vtable
= gfc_build_addr_expr (pvoid_type_node
, vtable
);
1765 if (ts
->type
== BT_CHARACTER
)
1766 tmp
= ts
->u
.cl
->backend_decl
;
1768 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1770 if (dtio_proc
== null_pointer_node
)
1771 tmp
= build_call_expr_loc (input_location
,
1772 iocall
[IOCALL_SET_NML_VAL
], 6,
1773 dt_parm_addr
, addr_expr
, string
,
1774 build_int_cst (gfc_int4_type_node
, ts
->kind
),
1777 tmp
= build_call_expr_loc (input_location
,
1778 iocall
[IOCALL_SET_NML_DTIO_VAL
], 8,
1779 dt_parm_addr
, addr_expr
, string
,
1780 build_int_cst (gfc_int4_type_node
, ts
->kind
),
1781 tmp
, dtype
, dtio_proc
, vtable
);
1782 gfc_add_expr_to_block (block
, tmp
);
1784 /* If the object is an array, transfer rank times:
1785 (null pointer, name, stride, lbound, ubound) */
1787 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1789 tmp
= build_call_expr_loc (input_location
,
1790 iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1792 build_int_cst (gfc_int4_type_node
, n_dim
),
1793 gfc_conv_array_stride (decl
, n_dim
),
1794 gfc_conv_array_lbound (decl
, n_dim
),
1795 gfc_conv_array_ubound (decl
, n_dim
));
1796 gfc_add_expr_to_block (block
, tmp
);
1799 if (gfc_bt_struct (ts
->type
) && ts
->u
.derived
->components
1800 && dtio_proc
== null_pointer_node
)
1804 /* Provide the RECORD_TYPE to build component references. */
1806 tree expr
= build_fold_indirect_ref_loc (input_location
,
1809 for (cmp
= ts
->u
.derived
->components
; cmp
; cmp
= cmp
->next
)
1811 char *full_name
= nml_full_name (var_name
, cmp
->name
,
1812 ts
->u
.derived
->attr
.extension
);
1813 transfer_namelist_element (block
,
1823 /* Create a data transfer statement. Not all of the fields are valid
1824 for both reading and writing, but improper use has been filtered
1828 build_dt (tree function
, gfc_code
* code
)
1830 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1835 unsigned int mask
= 0;
1837 gfc_start_block (&block
);
1838 gfc_init_block (&post_block
);
1839 gfc_init_block (&post_end_block
);
1840 gfc_init_block (&post_iu_block
);
1842 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1844 set_error_locus (&block
, var
, &code
->loc
);
1846 if (last_dt
== IOLENGTH
)
1850 inq
= code
->ext
.inquire
;
1852 /* First check that preconditions are met. */
1853 gcc_assert (inq
!= NULL
);
1854 gcc_assert (inq
->iolength
!= NULL
);
1856 /* Connect to the iolength variable. */
1857 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1858 IOPARM_dt_iolength
, inq
->iolength
);
1864 gcc_assert (dt
!= NULL
);
1867 if (dt
&& dt
->io_unit
)
1869 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1871 mask
|= set_internal_unit (&block
, &post_iu_block
,
1873 set_parameter_const (&block
, var
, IOPARM_common_unit
,
1874 dt
->io_unit
->ts
.kind
== 1 ?
1875 GFC_INTERNAL_UNIT
: GFC_INTERNAL_UNIT4
);
1879 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1884 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1888 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1889 IOPARM_common_iostat
, dt
->iostat
);
1892 mask
|= IOPARM_common_err
;
1895 mask
|= IOPARM_common_eor
;
1898 mask
|= IOPARM_common_end
;
1901 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1902 IOPARM_dt_id
, dt
->id
);
1905 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1907 if (dt
->asynchronous
)
1908 mask
|= set_string (&block
, &post_block
, var
,
1909 IOPARM_dt_asynchronous
, dt
->asynchronous
);
1912 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1916 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1920 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1924 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1928 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1932 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1936 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1939 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1942 if (dt
->format_expr
)
1943 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1946 if (dt
->format_label
)
1948 if (dt
->format_label
== &format_asterisk
)
1949 mask
|= IOPARM_dt_list_format
;
1951 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1952 dt
->format_label
->format
);
1956 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1957 IOPARM_dt_size
, dt
->size
);
1960 mask
|= IOPARM_dt_dtio
;
1962 if (dt
->default_exp
)
1963 mask
|= IOPARM_dt_default_exp
;
1967 if (dt
->format_expr
|| dt
->format_label
)
1968 gfc_internal_error ("build_dt: format with namelist");
1970 nmlname
= gfc_get_character_expr (gfc_default_character_kind
, NULL
,
1972 strlen (dt
->namelist
->name
));
1974 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1977 gfc_free_expr (nmlname
);
1979 if (last_dt
== READ
)
1980 mask
|= IOPARM_dt_namelist_read_mode
;
1982 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1986 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1987 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1991 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1993 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1994 set_parameter_value_chk (&block
, dt
->iostat
, var
,
1995 IOPARM_common_unit
, dt
->io_unit
);
1998 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
2000 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
2001 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2003 gfc_add_expr_to_block (&block
, tmp
);
2005 gfc_add_block_to_block (&block
, &post_block
);
2008 dt_post_end_block
= &post_end_block
;
2010 /* Set implied do loop exit condition. */
2011 if (last_dt
== READ
|| last_dt
== WRITE
)
2013 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
2015 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2016 st_parameter
[IOPARM_ptype_common
].type
,
2017 dt_parm
, TYPE_FIELDS (TREE_TYPE (dt_parm
)),
2019 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2020 TREE_TYPE (p
->field
), tmp
, p
->field
, NULL_TREE
);
2021 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (tmp
),
2022 tmp
, build_int_cst (TREE_TYPE (tmp
),
2023 IOPARM_common_libreturn_mask
));
2028 gfc_add_expr_to_block (&block
, gfc_trans_code_cond (code
->block
->next
, tmp
));
2030 gfc_add_block_to_block (&block
, &post_iu_block
);
2033 dt_post_end_block
= NULL
;
2035 return gfc_finish_block (&block
);
2039 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
2040 this as a third sort of data transfer statement, except that
2041 lengths are summed instead of actually transferring any data. */
2044 gfc_trans_iolength (gfc_code
* code
)
2047 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
2051 /* Translate a READ statement. */
2054 gfc_trans_read (gfc_code
* code
)
2057 return build_dt (iocall
[IOCALL_READ
], code
);
2061 /* Translate a WRITE statement */
2064 gfc_trans_write (gfc_code
* code
)
2067 return build_dt (iocall
[IOCALL_WRITE
], code
);
2071 /* Finish a data transfer statement. */
2074 gfc_trans_dt_end (gfc_code
* code
)
2079 gfc_init_block (&block
);
2084 function
= iocall
[IOCALL_READ_DONE
];
2088 function
= iocall
[IOCALL_WRITE_DONE
];
2092 function
= iocall
[IOCALL_IOLENGTH_DONE
];
2099 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2100 tmp
= build_call_expr_loc (input_location
,
2102 gfc_add_expr_to_block (&block
, tmp
);
2103 gfc_add_block_to_block (&block
, dt_post_end_block
);
2104 gfc_init_block (dt_post_end_block
);
2106 if (last_dt
!= IOLENGTH
)
2108 gcc_assert (code
->ext
.dt
!= NULL
);
2109 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
2110 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
2113 return gfc_finish_block (&block
);
2117 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
,
2118 gfc_code
* code
, tree vptr
);
2120 /* Given an array field in a derived type variable, generate the code
2121 for the loop that iterates over array elements, and the code that
2122 accesses those array elements. Use transfer_expr to generate code
2123 for transferring that element. Because elements may also be
2124 derived types, transfer_expr and transfer_array_component are mutually
2128 transfer_array_component (tree expr
, gfc_component
* cm
, locus
* where
)
2137 gfc_array_info
*ss_array
;
2139 gfc_start_block (&block
);
2140 gfc_init_se (&se
, NULL
);
2142 /* Create and initialize Scalarization Status. Unlike in
2143 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2144 care of this task, because we don't have a gfc_expr at hand.
2145 Build one manually, as in gfc_trans_subarray_assign. */
2147 ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
2149 ss_array
= &ss
->info
->data
.array
;
2150 ss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
2151 ss_array
->descriptor
= expr
;
2152 ss_array
->data
= gfc_conv_array_data (expr
);
2153 ss_array
->offset
= gfc_conv_array_offset (expr
);
2154 for (n
= 0; n
< cm
->as
->rank
; n
++)
2156 ss_array
->start
[n
] = gfc_conv_array_lbound (expr
, n
);
2157 ss_array
->stride
[n
] = gfc_index_one_node
;
2159 mpz_init (ss_array
->shape
[n
]);
2160 mpz_sub (ss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2161 cm
->as
->lower
[n
]->value
.integer
);
2162 mpz_add_ui (ss_array
->shape
[n
], ss_array
->shape
[n
], 1);
2165 /* Once we got ss, we use scalarizer to create the loop. */
2167 gfc_init_loopinfo (&loop
);
2168 gfc_add_ss_to_loop (&loop
, ss
);
2169 gfc_conv_ss_startstride (&loop
);
2170 gfc_conv_loop_setup (&loop
, where
);
2171 gfc_mark_ss_chain_used (ss
, 1);
2172 gfc_start_scalarized_body (&loop
, &body
);
2174 gfc_copy_loopinfo_to_se (&se
, &loop
);
2177 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2179 gfc_conv_tmp_array_ref (&se
);
2181 /* Now se.expr contains an element of the array. Take the address and pass
2182 it to the IO routines. */
2183 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2184 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
, NULL_TREE
);
2186 /* We are done now with the loop body. Wrap up the scalarizer and
2189 gfc_add_block_to_block (&body
, &se
.pre
);
2190 gfc_add_block_to_block (&body
, &se
.post
);
2192 gfc_trans_scalarizing_loops (&loop
, &body
);
2194 gfc_add_block_to_block (&block
, &loop
.pre
);
2195 gfc_add_block_to_block (&block
, &loop
.post
);
2197 gcc_assert (ss_array
->shape
!= NULL
);
2198 gfc_free_shape (&ss_array
->shape
, cm
->as
->rank
);
2199 gfc_cleanup_loop (&loop
);
2201 return gfc_finish_block (&block
);
2205 /* Helper function for transfer_expr that looks for the DTIO procedure
2206 either as a typebound binding or in a generic interface. If present,
2207 the address expression of the procedure is returned. It is assumed
2208 that the procedure interface has been checked during resolution. */
2211 get_dtio_proc (gfc_typespec
* ts
, gfc_code
* code
, gfc_symbol
**dtio_sub
)
2213 gfc_symbol
*derived
;
2214 bool formatted
= false;
2215 gfc_dt
*dt
= code
->ext
.dt
;
2217 if (dt
&& dt
->format_expr
)
2220 fmt
= gfc_widechar_to_char (dt
->format_expr
->value
.character
.string
,
2222 if (strtok (fmt
, "DT") != NULL
)
2225 else if (dt
&& dt
->format_label
== &format_asterisk
)
2227 /* List directed io must call the formatted DTIO procedure. */
2231 if (ts
->type
== BT_CLASS
)
2232 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
2234 derived
= ts
->u
.derived
;
2236 gfc_symtree
*tb_io_st
= gfc_find_typebound_dtio_proc (derived
,
2237 last_dt
== WRITE
, formatted
);
2238 if (ts
->type
== BT_CLASS
&& tb_io_st
)
2240 // polymorphic DTIO call (based on the dynamic type)
2242 gfc_expr
*expr
= gfc_find_and_cut_at_last_class_ref (code
->expr1
);
2243 gfc_add_vptr_component (expr
);
2244 gfc_add_component_ref (expr
,
2245 tb_io_st
->n
.tb
->u
.generic
->specific_st
->name
);
2246 *dtio_sub
= tb_io_st
->n
.tb
->u
.generic
->specific
->u
.specific
->n
.sym
;
2247 gfc_init_se (&se
, NULL
);
2248 se
.want_pointer
= 1;
2249 gfc_conv_expr (&se
, expr
);
2250 gfc_free_expr (expr
);
2255 // non-polymorphic DTIO call (based on the declared type)
2256 *dtio_sub
= gfc_find_specific_dtio_proc (derived
, last_dt
== WRITE
,
2260 return gfc_build_addr_expr (NULL
, gfc_get_symbol_decl (*dtio_sub
));
2266 /* Generate the call for a scalar transfer node. */
2269 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
,
2270 gfc_code
* code
, tree vptr
)
2272 tree tmp
, function
, arg2
, arg3
, field
, expr
;
2276 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2277 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2278 We need to translate the expression to a constant if it's either
2279 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2280 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2281 BT_DERIVED (could have been changed by gfc_conv_expr). */
2282 if ((ts
->type
== BT_DERIVED
|| ts
->type
== BT_INTEGER
)
2283 && ts
->u
.derived
!= NULL
2284 && (ts
->is_iso_c
== 1 || ts
->u
.derived
->ts
.is_iso_c
== 1))
2286 ts
->type
= BT_INTEGER
;
2287 ts
->kind
= gfc_index_integer_kind
;
2298 arg2
= build_int_cst (integer_type_node
, kind
);
2299 if (last_dt
== READ
)
2300 function
= iocall
[IOCALL_X_INTEGER
];
2302 function
= iocall
[IOCALL_X_INTEGER_WRITE
];
2307 arg2
= build_int_cst (integer_type_node
, kind
);
2308 if (last_dt
== READ
)
2310 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2311 function
= iocall
[IOCALL_X_REAL128
];
2313 function
= iocall
[IOCALL_X_REAL
];
2317 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2318 function
= iocall
[IOCALL_X_REAL128_WRITE
];
2320 function
= iocall
[IOCALL_X_REAL_WRITE
];
2326 arg2
= build_int_cst (integer_type_node
, kind
);
2327 if (last_dt
== READ
)
2329 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2330 function
= iocall
[IOCALL_X_COMPLEX128
];
2332 function
= iocall
[IOCALL_X_COMPLEX
];
2336 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2337 function
= iocall
[IOCALL_X_COMPLEX128_WRITE
];
2339 function
= iocall
[IOCALL_X_COMPLEX_WRITE
];
2345 arg2
= build_int_cst (integer_type_node
, kind
);
2346 if (last_dt
== READ
)
2347 function
= iocall
[IOCALL_X_LOGICAL
];
2349 function
= iocall
[IOCALL_X_LOGICAL_WRITE
];
2356 if (se
->string_length
)
2357 arg2
= se
->string_length
;
2360 tmp
= build_fold_indirect_ref_loc (input_location
,
2362 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2363 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2364 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2366 arg3
= build_int_cst (integer_type_node
, kind
);
2367 if (last_dt
== READ
)
2368 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2370 function
= iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
];
2372 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2373 tmp
= build_call_expr_loc (input_location
,
2374 function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2375 gfc_add_expr_to_block (&se
->pre
, tmp
);
2376 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2381 if (se
->string_length
)
2382 arg2
= se
->string_length
;
2385 tmp
= build_fold_indirect_ref_loc (input_location
,
2387 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2388 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2390 if (last_dt
== READ
)
2391 function
= iocall
[IOCALL_X_CHARACTER
];
2393 function
= iocall
[IOCALL_X_CHARACTER_WRITE
];
2399 if (ts
->u
.derived
->components
== NULL
)
2401 if (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)
2403 gfc_symbol
*derived
;
2404 gfc_symbol
*dtio_sub
= NULL
;
2405 /* Test for a specific DTIO subroutine. */
2406 if (ts
->type
== BT_DERIVED
)
2407 derived
= ts
->u
.derived
;
2409 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
2411 if (derived
->attr
.has_dtio_procs
)
2412 arg2
= get_dtio_proc (ts
, code
, &dtio_sub
);
2414 if ((dtio_sub
!= NULL
) && (last_dt
!= IOLENGTH
))
2417 decl
= build_fold_indirect_ref_loc (input_location
,
2419 /* Remember that the first dummy of the DTIO subroutines
2420 is CLASS(derived) for extensible derived types, so the
2421 conversion must be done here for derived type and for
2422 scalarized CLASS array element io-list objects. */
2423 if ((ts
->type
== BT_DERIVED
2424 && !(ts
->u
.derived
->attr
.sequence
2425 || ts
->u
.derived
->attr
.is_bind_c
))
2426 || (ts
->type
== BT_CLASS
2427 && !GFC_CLASS_TYPE_P (TREE_TYPE (decl
))))
2428 gfc_conv_derived_to_class (se
, code
->expr1
,
2429 dtio_sub
->formal
->sym
->ts
,
2430 vptr
, false, false);
2431 addr_expr
= se
->expr
;
2432 function
= iocall
[IOCALL_X_DERIVED
];
2435 else if (ts
->type
== BT_DERIVED
)
2437 /* Recurse into the elements of the derived type. */
2438 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2439 expr
= build_fold_indirect_ref_loc (input_location
,
2442 /* Make sure that the derived type has been built. An external
2443 function, if only referenced in an io statement, requires this
2444 check (see PR58771). */
2445 if (ts
->u
.derived
->backend_decl
== NULL_TREE
)
2446 (void) gfc_typenode_for_spec (ts
);
2448 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
2450 field
= c
->backend_decl
;
2451 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2453 tmp
= fold_build3_loc (UNKNOWN_LOCATION
,
2454 COMPONENT_REF
, TREE_TYPE (field
),
2455 expr
, field
, NULL_TREE
);
2457 if (c
->attr
.dimension
)
2459 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2460 gfc_add_expr_to_block (&se
->pre
, tmp
);
2464 if (!c
->attr
.pointer
)
2465 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2466 transfer_expr (se
, &c
->ts
, tmp
, code
, NULL_TREE
);
2471 /* If a CLASS object gets through to here, fall through and ICE. */
2475 gfc_internal_error ("Bad IO basetype (%d)", ts
->type
);
2478 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2479 tmp
= build_call_expr_loc (input_location
,
2480 function
, 3, tmp
, addr_expr
, arg2
);
2481 gfc_add_expr_to_block (&se
->pre
, tmp
);
2482 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2487 /* Generate a call to pass an array descriptor to the IO library. The
2488 array should be of one of the intrinsic types. */
2491 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2493 tree tmp
, charlen_arg
, kind_arg
, io_call
;
2495 if (ts
->type
== BT_CHARACTER
)
2496 charlen_arg
= se
->string_length
;
2498 charlen_arg
= build_int_cst (gfc_charlen_type_node
, 0);
2500 kind_arg
= build_int_cst (integer_type_node
, ts
->kind
);
2502 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2503 if (last_dt
== READ
)
2504 io_call
= iocall
[IOCALL_X_ARRAY
];
2506 io_call
= iocall
[IOCALL_X_ARRAY_WRITE
];
2508 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2510 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2511 gfc_add_expr_to_block (&se
->pre
, tmp
);
2512 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2516 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2519 gfc_trans_transfer (gfc_code
* code
)
2521 stmtblock_t block
, body
;
2531 gfc_start_block (&block
);
2532 gfc_init_block (&body
);
2536 gfc_init_se (&se
, NULL
);
2538 if (expr
->rank
== 0)
2540 /* Transfer a scalar value. */
2541 if (expr
->ts
.type
== BT_CLASS
)
2543 se
.want_pointer
= 1;
2544 gfc_conv_expr (&se
, expr
);
2545 vptr
= gfc_get_vptr_from_expr (se
.expr
);
2550 gfc_conv_expr_reference (&se
, expr
);
2552 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
, vptr
);
2556 /* Transfer an array. If it is an array of an intrinsic
2557 type, pass the descriptor to the library. Otherwise
2558 scalarize the transfer. */
2559 if (expr
->ref
&& !gfc_is_proc_ptr_comp (expr
))
2561 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2563 gcc_assert (ref
&& ref
->type
== REF_ARRAY
);
2566 if (!(gfc_bt_struct (expr
->ts
.type
)
2567 || expr
->ts
.type
== BT_CLASS
)
2568 && ref
&& ref
->next
== NULL
2569 && !is_subref_array (expr
))
2571 bool seen_vector
= false;
2573 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2575 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2576 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2583 if (seen_vector
&& last_dt
== READ
)
2585 /* Create a temp, read to that and copy it back. */
2586 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
, false);
2591 /* Get the descriptor. */
2592 gfc_conv_expr_descriptor (&se
, expr
);
2593 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2596 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2597 goto finish_block_label
;
2600 /* Initialize the scalarizer. */
2601 ss
= gfc_walk_expr (expr
);
2602 gfc_init_loopinfo (&loop
);
2603 gfc_add_ss_to_loop (&loop
, ss
);
2605 /* Initialize the loop. */
2606 gfc_conv_ss_startstride (&loop
);
2607 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
2609 /* The main loop body. */
2610 gfc_mark_ss_chain_used (ss
, 1);
2611 gfc_start_scalarized_body (&loop
, &body
);
2613 gfc_copy_loopinfo_to_se (&se
, &loop
);
2615 gfc_conv_expr_reference (&se
, expr
);
2616 if (expr
->ts
.type
== BT_CLASS
)
2617 vptr
= gfc_get_vptr_from_expr (ss
->info
->data
.array
.descriptor
);
2620 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
, vptr
);
2625 gfc_add_block_to_block (&body
, &se
.pre
);
2626 gfc_add_block_to_block (&body
, &se
.post
);
2629 tmp
= gfc_finish_block (&body
);
2632 gcc_assert (expr
->rank
!= 0);
2633 gcc_assert (se
.ss
== gfc_ss_terminator
);
2634 gfc_trans_scalarizing_loops (&loop
, &body
);
2636 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2637 tmp
= gfc_finish_block (&loop
.pre
);
2638 gfc_cleanup_loop (&loop
);
2641 gfc_add_expr_to_block (&block
, tmp
);
2643 return gfc_finish_block (&block
);
2646 #include "gt-fortran-trans-io.h"