1 /* IO Code translation/library interface
2 Copyright (C) 2002-2022 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.cc)
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")), ". w W . ",
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")), ". w R . ",
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")), ". w W . ",
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")), ". w R . ",
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")), ". w W . ",
348 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_charlen_type_node
);
350 iocall
[IOCALL_X_CHARACTER_WRITE
] = gfc_build_library_function_decl_with_spec (
351 get_identifier (PREFIX("transfer_character_write")), ". w R . ",
352 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_charlen_type_node
);
354 iocall
[IOCALL_X_CHARACTER_WIDE
] = gfc_build_library_function_decl_with_spec (
355 get_identifier (PREFIX("transfer_character_wide")), ". w W . . ",
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")), ". w R . . ",
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")), ". w W . ",
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")), ". w R . ",
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")), ". w W . ",
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")), ". w R . ",
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")), ". w W . ",
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")), ". w R . ",
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")), ". w W . ",
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")), ". w R . ",
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")), ". w w . . ",
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")), ". w r . . ",
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")), ". w r ",
410 void_type_node
, 2, dt_parm_type
, pvoid_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 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_wait
].type
);
442 iocall
[IOCALL_WAIT
] = gfc_build_library_function_decl_with_spec (
443 get_identifier (PREFIX("st_wait_async")), ". w ",
444 void_type_node
, 1, parm_type
);
446 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
447 iocall
[IOCALL_REWIND
] = gfc_build_library_function_decl_with_spec (
448 get_identifier (PREFIX("st_rewind")), ". w ",
449 void_type_node
, 1, parm_type
);
451 iocall
[IOCALL_BACKSPACE
] = gfc_build_library_function_decl_with_spec (
452 get_identifier (PREFIX("st_backspace")), ". w ",
453 void_type_node
, 1, parm_type
);
455 iocall
[IOCALL_ENDFILE
] = gfc_build_library_function_decl_with_spec (
456 get_identifier (PREFIX("st_endfile")), ". w ",
457 void_type_node
, 1, parm_type
);
459 iocall
[IOCALL_FLUSH
] = gfc_build_library_function_decl_with_spec (
460 get_identifier (PREFIX("st_flush")), ". w ",
461 void_type_node
, 1, parm_type
);
463 /* Library helpers */
465 iocall
[IOCALL_READ_DONE
] = gfc_build_library_function_decl_with_spec (
466 get_identifier (PREFIX("st_read_done")), ". w ",
467 void_type_node
, 1, dt_parm_type
);
469 iocall
[IOCALL_WRITE_DONE
] = gfc_build_library_function_decl_with_spec (
470 get_identifier (PREFIX("st_write_done")), ". w ",
471 void_type_node
, 1, dt_parm_type
);
473 iocall
[IOCALL_IOLENGTH_DONE
] = gfc_build_library_function_decl_with_spec (
474 get_identifier (PREFIX("st_iolength_done")), ". w ",
475 void_type_node
, 1, dt_parm_type
);
477 iocall
[IOCALL_SET_NML_VAL
] = gfc_build_library_function_decl_with_spec (
478 get_identifier (PREFIX("st_set_nml_var")), ". w . R . . . ",
479 void_type_node
, 6, dt_parm_type
, pvoid_type_node
, pvoid_type_node
,
480 gfc_int4_type_node
, gfc_charlen_type_node
, get_dtype_type_node());
482 iocall
[IOCALL_SET_NML_DTIO_VAL
] = gfc_build_library_function_decl_with_spec (
483 get_identifier (PREFIX("st_set_nml_dtio_var")), ". w . R . . . . . ",
484 void_type_node
, 8, dt_parm_type
, pvoid_type_node
, pvoid_type_node
,
485 gfc_int4_type_node
, gfc_charlen_type_node
, get_dtype_type_node(),
486 pvoid_type_node
, pvoid_type_node
);
488 iocall
[IOCALL_SET_NML_VAL_DIM
] = gfc_build_library_function_decl_with_spec (
489 get_identifier (PREFIX("st_set_nml_var_dim")), ". w . . . . ",
490 void_type_node
, 5, dt_parm_type
, gfc_int4_type_node
,
491 gfc_array_index_type
, gfc_array_index_type
, gfc_array_index_type
);
496 set_parameter_tree (stmtblock_t
*block
, tree var
, enum iofield type
, tree value
)
499 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
501 if (p
->param_type
== IOPARM_ptype_common
)
502 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
503 st_parameter
[IOPARM_ptype_common
].type
,
504 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
505 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
506 var
, p
->field
, NULL_TREE
);
507 gfc_add_modify (block
, tmp
, value
);
511 /* Generate code to store an integer constant into the
512 st_parameter_XXX structure. */
515 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
518 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
520 set_parameter_tree (block
, var
, type
,
521 build_int_cst (TREE_TYPE (p
->field
), val
));
526 /* Generate code to store a non-string I/O parameter into the
527 st_parameter_XXX structure. This is a pass by value. */
530 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
535 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
536 tree dest_type
= TREE_TYPE (p
->field
);
538 gfc_init_se (&se
, NULL
);
539 gfc_conv_expr_val (&se
, e
);
541 se
.expr
= convert (dest_type
, se
.expr
);
542 gfc_add_block_to_block (block
, &se
.pre
);
544 if (p
->param_type
== IOPARM_ptype_common
)
545 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
546 st_parameter
[IOPARM_ptype_common
].type
,
547 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
549 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, dest_type
, var
,
550 p
->field
, NULL_TREE
);
551 gfc_add_modify (block
, tmp
, se
.expr
);
556 /* Similar to set_parameter_value except generate runtime
560 set_parameter_value_chk (stmtblock_t
*block
, bool has_iostat
, tree var
,
561 enum iofield type
, gfc_expr
*e
)
565 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
566 tree dest_type
= TREE_TYPE (p
->field
);
568 gfc_init_se (&se
, NULL
);
569 gfc_conv_expr_val (&se
, e
);
571 /* If we're storing a UNIT number, we need to check it first. */
572 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
577 /* Don't evaluate the UNIT number multiple times. */
578 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
580 /* UNIT numbers should be greater than the min. */
581 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
582 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].pedantic_min_int
, 4);
583 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
585 fold_convert (TREE_TYPE (se
.expr
), val
));
586 gfc_trans_io_runtime_check (has_iostat
, cond
, var
, LIBERROR_BAD_UNIT
,
587 "Unit number in I/O statement too small",
590 /* UNIT numbers should be less than the max. */
591 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
592 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
594 fold_convert (TREE_TYPE (se
.expr
), val
));
595 gfc_trans_io_runtime_check (has_iostat
, cond
, var
, LIBERROR_BAD_UNIT
,
596 "Unit number in I/O statement too large",
600 se
.expr
= convert (dest_type
, se
.expr
);
601 gfc_add_block_to_block (block
, &se
.pre
);
603 if (p
->param_type
== IOPARM_ptype_common
)
604 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
605 st_parameter
[IOPARM_ptype_common
].type
,
606 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
608 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, dest_type
, var
,
609 p
->field
, NULL_TREE
);
610 gfc_add_modify (block
, tmp
, se
.expr
);
615 /* Build code to check the unit range if KIND=8 is used. Similar to
616 set_parameter_value_chk but we do not generate error calls for
617 inquire statements. */
620 set_parameter_value_inquire (stmtblock_t
*block
, tree var
,
621 enum iofield type
, gfc_expr
*e
)
624 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
625 tree dest_type
= TREE_TYPE (p
->field
);
627 gfc_init_se (&se
, NULL
);
628 gfc_conv_expr_val (&se
, e
);
630 /* If we're inquiring on a UNIT number, we need to check to make
631 sure it exists for larger than kind = 4. */
632 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
634 stmtblock_t newblock
;
635 tree cond1
, cond2
, cond3
, val
, body
;
638 /* Don't evaluate the UNIT number multiple times. */
639 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
641 /* UNIT numbers should be greater than the min. */
642 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
643 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].pedantic_min_int
, 4);
644 cond1
= build2_loc (input_location
, LT_EXPR
, logical_type_node
,
646 fold_convert (TREE_TYPE (se
.expr
), val
));
647 /* UNIT numbers should be less than the max. */
648 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
649 cond2
= build2_loc (input_location
, GT_EXPR
, logical_type_node
,
651 fold_convert (TREE_TYPE (se
.expr
), val
));
652 cond3
= build2_loc (input_location
, TRUTH_OR_EXPR
,
653 logical_type_node
, cond1
, cond2
);
655 gfc_start_block (&newblock
);
657 /* The unit number GFC_INVALID_UNIT is reserved. No units can
658 ever have this value. It is used here to signal to the
659 runtime library that the inquire unit number is outside the
660 allowable range and so cannot exist. It is needed when
661 -fdefault-integer-8 is used. */
662 set_parameter_const (&newblock
, var
, IOPARM_common_unit
,
665 body
= gfc_finish_block (&newblock
);
667 cond3
= gfc_unlikely (cond3
, PRED_FORTRAN_FAIL_IO
);
668 var
= build3_v (COND_EXPR
, cond3
, body
, build_empty_stmt (input_location
));
669 gfc_add_expr_to_block (&se
.pre
, var
);
672 se
.expr
= convert (dest_type
, se
.expr
);
673 gfc_add_block_to_block (block
, &se
.pre
);
679 /* Generate code to store a non-string I/O parameter into the
680 st_parameter_XXX structure. This is pass by reference. */
683 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
684 tree var
, enum iofield type
, gfc_expr
*e
)
688 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
690 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
691 gfc_init_se (&se
, NULL
);
692 gfc_conv_expr_lhs (&se
, e
);
694 gfc_add_block_to_block (block
, &se
.pre
);
696 if (TYPE_MODE (TREE_TYPE (se
.expr
))
697 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
699 addr
= convert (TREE_TYPE (p
->field
), gfc_build_addr_expr (NULL_TREE
, se
.expr
));
701 /* If this is for the iostat variable initialize the
702 user variable to LIBERROR_OK which is zero. */
703 if (type
== IOPARM_common_iostat
)
704 gfc_add_modify (block
, se
.expr
,
705 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
709 /* The type used by the library has different size
710 from the type of the variable supplied by the user.
711 Need to use a temporary. */
712 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
713 st_parameter_field
[type
].name
);
715 /* If this is for the iostat variable, initialize the
716 user variable to LIBERROR_OK which is zero. */
717 if (type
== IOPARM_common_iostat
)
718 gfc_add_modify (block
, tmpvar
,
719 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
721 addr
= gfc_build_addr_expr (NULL_TREE
, tmpvar
);
722 /* After the I/O operation, we set the variable from the temporary. */
723 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
724 gfc_add_modify (postblock
, se
.expr
, tmp
);
727 set_parameter_tree (block
, var
, type
, addr
);
731 /* Given an array expr, find its address and length to get a string. If the
732 array is full, the string's address is the address of array's first element
733 and the length is the size of the whole array. If it is an element, the
734 string's address is the element's address and the length is the rest size of
738 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
743 tree type
, array
, tmp
;
747 /* If it is an element, we need its address and size of the rest. */
748 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
749 gcc_assert (e
->ref
->u
.ar
.type
== AR_ELEMENT
);
750 sym
= e
->symtree
->n
.sym
;
751 rank
= sym
->as
->rank
- 1;
752 gfc_conv_expr (se
, e
);
754 array
= sym
->backend_decl
;
755 type
= TREE_TYPE (array
);
758 if (GFC_ARRAY_TYPE_P (type
))
759 elts_count
= GFC_TYPE_ARRAY_SIZE (type
);
762 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
763 tree stride
= gfc_conv_array_stride (array
, rank
);
764 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
765 gfc_array_index_type
,
766 gfc_conv_array_ubound (array
, rank
),
767 gfc_conv_array_lbound (array
, rank
));
768 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
769 gfc_array_index_type
, tmp
,
771 elts_count
= fold_build2_loc (input_location
, MULT_EXPR
,
772 gfc_array_index_type
, tmp
, stride
);
774 gcc_assert (elts_count
);
776 tree elt_size
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
777 elt_size
= fold_convert (gfc_array_index_type
, elt_size
);
780 if (TREE_CODE (se
->expr
) == ARRAY_REF
)
782 tree index
= TREE_OPERAND (se
->expr
, 1);
783 index
= fold_convert (gfc_array_index_type
, index
);
785 elts_count
= fold_build2_loc (input_location
, MINUS_EXPR
,
786 gfc_array_index_type
,
789 size
= fold_build2_loc (input_location
, MULT_EXPR
,
790 gfc_array_index_type
, elts_count
, elt_size
);
794 gcc_assert (TREE_CODE (se
->expr
) == INDIRECT_REF
);
795 tree ptr
= TREE_OPERAND (se
->expr
, 0);
797 gcc_assert (TREE_CODE (ptr
) == POINTER_PLUS_EXPR
);
798 tree offset
= fold_convert_loc (input_location
, gfc_array_index_type
,
799 TREE_OPERAND (ptr
, 1));
801 size
= fold_build2_loc (input_location
, MULT_EXPR
,
802 gfc_array_index_type
, elts_count
, elt_size
);
803 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
804 gfc_array_index_type
, size
, offset
);
808 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
809 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
814 gfc_conv_array_parameter (se
, e
, true, NULL
, NULL
, &size
);
815 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
819 /* Generate code to store a string and its length into the
820 st_parameter_XXX structure. */
823 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
824 enum iofield type
, gfc_expr
* e
)
830 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
832 gfc_init_se (&se
, NULL
);
834 if (p
->param_type
== IOPARM_ptype_common
)
835 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
836 st_parameter
[IOPARM_ptype_common
].type
,
837 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
838 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
839 var
, p
->field
, NULL_TREE
);
840 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
841 TREE_TYPE (p
->field_len
),
842 var
, p
->field_len
, NULL_TREE
);
844 /* Integer variable assigned a format label. */
845 if (e
->ts
.type
== BT_INTEGER
847 && e
->symtree
->n
.sym
->attr
.assign
== 1)
852 gfc_conv_label_variable (&se
, e
);
853 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
854 cond
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
855 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
857 msg
= xasprintf ("Label assigned to variable '%s' (%%ld) is not a format "
858 "label", e
->symtree
->name
);
859 gfc_trans_runtime_check (true, false, cond
, &se
.pre
, &e
->where
, msg
,
860 fold_convert (long_integer_type_node
, tmp
));
863 gfc_add_modify (&se
.pre
, io
,
864 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
865 gfc_add_modify (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
869 /* General character. */
870 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
871 gfc_conv_expr (&se
, e
);
872 /* Array assigned Hollerith constant or character array. */
873 else if (e
->rank
> 0 || (e
->symtree
&& e
->symtree
->n
.sym
->as
->rank
> 0))
874 gfc_convert_array_to_string (&se
, e
);
878 gfc_conv_string_parameter (&se
);
879 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
880 gfc_add_modify (&se
.pre
, len
, fold_convert (TREE_TYPE (len
),
884 gfc_add_block_to_block (block
, &se
.pre
);
885 gfc_add_block_to_block (postblock
, &se
.post
);
890 /* Generate code to store the character (array) and the character length
891 for an internal unit. */
894 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
895 tree var
, gfc_expr
* e
)
902 gfc_st_parameter_field
*p
;
905 gfc_init_se (&se
, NULL
);
907 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
909 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
910 var
, p
->field
, NULL_TREE
);
911 len
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field_len
),
912 var
, p
->field_len
, NULL_TREE
);
913 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
914 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
915 var
, p
->field
, NULL_TREE
);
917 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
919 /* Character scalars. */
922 gfc_conv_expr (&se
, e
);
923 gfc_conv_string_parameter (&se
);
925 se
.expr
= build_int_cst (pchar_type_node
, 0);
928 /* Character array. */
929 else if (e
->rank
> 0)
931 if (is_subref_array (e
))
933 /* Use a temporary for components of arrays of derived types
934 or substring array references. */
935 gfc_conv_subref_array_arg (&se
, e
, 0,
936 last_dt
== READ
? INTENT_IN
: INTENT_OUT
, false);
937 tmp
= build_fold_indirect_ref_loc (input_location
,
939 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
940 tmp
= gfc_conv_descriptor_data_get (tmp
);
944 /* Return the data pointer and rank from the descriptor. */
945 gfc_conv_expr_descriptor (&se
, e
);
946 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
947 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
953 /* The cast is needed for character substrings and the descriptor
955 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
956 gfc_add_modify (&se
.pre
, len
,
957 fold_convert (TREE_TYPE (len
), se
.string_length
));
958 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
960 gfc_add_block_to_block (block
, &se
.pre
);
961 gfc_add_block_to_block (post_block
, &se
.post
);
965 /* Add a case to a IO-result switch. */
968 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
973 return; /* No label, no case */
975 value
= build_int_cst (integer_type_node
, label_value
);
977 /* Make a backend label for this case. */
978 tmp
= gfc_build_label_decl (NULL_TREE
);
980 /* And the case itself. */
981 tmp
= build_case_label (value
, NULL_TREE
, tmp
);
982 gfc_add_expr_to_block (body
, tmp
);
984 /* Jump to the label. */
985 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
986 gfc_add_expr_to_block (body
, tmp
);
990 /* Generate a switch statement that branches to the correct I/O
991 result label. The last statement of an I/O call stores the
992 result into a variable because there is often cleanup that
993 must be done before the switch, so a temporary would have to
994 be created anyway. */
997 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
998 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
1002 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
1004 /* If no labels are specified, ignore the result instead
1005 of building an empty switch. */
1006 if (err_label
== NULL
1007 && end_label
== NULL
1008 && eor_label
== NULL
)
1011 /* Build a switch statement. */
1012 gfc_start_block (&body
);
1014 /* The label values here must be the same as the values
1015 in the library_return enum in the runtime library */
1016 add_case (1, err_label
, &body
);
1017 add_case (2, end_label
, &body
);
1018 add_case (3, eor_label
, &body
);
1020 tmp
= gfc_finish_block (&body
);
1022 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
1023 st_parameter
[IOPARM_ptype_common
].type
,
1024 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
1025 rc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
1026 var
, p
->field
, NULL_TREE
);
1027 rc
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (rc
),
1028 rc
, build_int_cst (TREE_TYPE (rc
),
1029 IOPARM_common_libreturn_mask
));
1031 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
, rc
, tmp
);
1033 gfc_add_expr_to_block (block
, tmp
);
1037 /* Store the current file and line number to variables so that if a
1038 library call goes awry, we can tell the user where the problem is. */
1041 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
1044 tree str
, locus_file
;
1046 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
1048 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
1049 st_parameter
[IOPARM_ptype_common
].type
,
1050 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
1051 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
1052 TREE_TYPE (p
->field
), locus_file
,
1053 p
->field
, NULL_TREE
);
1054 f
= where
->lb
->file
;
1055 str
= gfc_build_cstring_const (f
->filename
);
1057 str
= gfc_build_addr_expr (pchar_type_node
, str
);
1058 gfc_add_modify (block
, locus_file
, str
);
1060 line
= LOCATION_LINE (where
->lb
->location
);
1061 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
1065 /* Translate an OPEN statement. */
1068 gfc_trans_open (gfc_code
* code
)
1070 stmtblock_t block
, post_block
;
1073 unsigned int mask
= 0;
1075 gfc_start_block (&block
);
1076 gfc_init_block (&post_block
);
1078 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
1080 set_error_locus (&block
, var
, &code
->loc
);
1084 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1088 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1092 mask
|= IOPARM_common_err
;
1095 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
1098 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
1102 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
1106 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
1109 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
,
1113 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
1117 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
1121 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
1125 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
1129 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
1132 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
1136 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
1140 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
1143 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
1145 if (p
->asynchronous
)
1146 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
1150 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
1154 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_open_newunit
,
1158 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_cc
, p
->cc
);
1161 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_share
, p
->share
);
1163 mask
|= set_parameter_const (&block
, var
, IOPARM_open_readonly
, p
->readonly
);
1165 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1168 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_unit
, p
->unit
);
1170 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1172 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1173 tmp
= build_call_expr_loc (input_location
,
1174 iocall
[IOCALL_OPEN
], 1, tmp
);
1175 gfc_add_expr_to_block (&block
, tmp
);
1177 gfc_add_block_to_block (&block
, &post_block
);
1179 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1181 return gfc_finish_block (&block
);
1185 /* Translate a CLOSE statement. */
1188 gfc_trans_close (gfc_code
* code
)
1190 stmtblock_t block
, post_block
;
1193 unsigned int mask
= 0;
1195 gfc_start_block (&block
);
1196 gfc_init_block (&post_block
);
1198 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
1200 set_error_locus (&block
, var
, &code
->loc
);
1201 p
= code
->ext
.close
;
1204 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1208 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1212 mask
|= IOPARM_common_err
;
1215 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
1218 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1221 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_unit
, p
->unit
);
1223 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1225 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1226 tmp
= build_call_expr_loc (input_location
,
1227 iocall
[IOCALL_CLOSE
], 1, tmp
);
1228 gfc_add_expr_to_block (&block
, tmp
);
1230 gfc_add_block_to_block (&block
, &post_block
);
1232 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1234 return gfc_finish_block (&block
);
1238 /* Common subroutine for building a file positioning statement. */
1241 build_filepos (tree function
, gfc_code
* code
)
1243 stmtblock_t block
, post_block
;
1246 unsigned int mask
= 0;
1248 p
= code
->ext
.filepos
;
1250 gfc_start_block (&block
);
1251 gfc_init_block (&post_block
);
1253 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1256 set_error_locus (&block
, var
, &code
->loc
);
1259 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1263 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1264 IOPARM_common_iostat
, p
->iostat
);
1267 mask
|= IOPARM_common_err
;
1269 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1272 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_unit
,
1275 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1277 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1278 tmp
= build_call_expr_loc (input_location
,
1280 gfc_add_expr_to_block (&block
, tmp
);
1282 gfc_add_block_to_block (&block
, &post_block
);
1284 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1286 return gfc_finish_block (&block
);
1290 /* Translate a BACKSPACE statement. */
1293 gfc_trans_backspace (gfc_code
* code
)
1295 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1299 /* Translate an ENDFILE statement. */
1302 gfc_trans_endfile (gfc_code
* code
)
1304 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1308 /* Translate a REWIND statement. */
1311 gfc_trans_rewind (gfc_code
* code
)
1313 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1317 /* Translate a FLUSH statement. */
1320 gfc_trans_flush (gfc_code
* code
)
1322 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1326 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1329 gfc_trans_inquire (gfc_code
* code
)
1331 stmtblock_t block
, post_block
;
1334 unsigned int mask
= 0, mask2
= 0;
1336 gfc_start_block (&block
);
1337 gfc_init_block (&post_block
);
1339 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1342 set_error_locus (&block
, var
, &code
->loc
);
1343 p
= code
->ext
.inquire
;
1346 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1350 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1354 mask
|= IOPARM_common_err
;
1357 if (p
->unit
&& p
->file
)
1358 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1361 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1365 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1369 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1373 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1377 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1381 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1385 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1389 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1393 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1397 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1401 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1405 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1409 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1410 IOPARM_inquire_recl_out
, p
->recl
);
1413 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1414 IOPARM_inquire_nextrec
, p
->nextrec
);
1417 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1421 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1425 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1429 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1433 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1437 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1441 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1445 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1449 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1453 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1454 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1456 /* The second series of flags. */
1457 if (p
->asynchronous
)
1458 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1462 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1466 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1470 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1474 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1478 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1479 IOPARM_inquire_pending
, p
->pending
);
1482 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1486 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1489 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_iqstream
,
1493 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_share
,
1497 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_cc
, p
->cc
);
1500 mask
|= set_parameter_const (&block
, var
, IOPARM_inquire_flags2
, mask2
);
1502 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1506 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1507 set_parameter_value_inquire (&block
, var
, IOPARM_common_unit
, p
->unit
);
1510 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1512 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1513 tmp
= build_call_expr_loc (input_location
,
1514 iocall
[IOCALL_INQUIRE
], 1, tmp
);
1515 gfc_add_expr_to_block (&block
, tmp
);
1517 gfc_add_block_to_block (&block
, &post_block
);
1519 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1521 return gfc_finish_block (&block
);
1526 gfc_trans_wait (gfc_code
* code
)
1528 stmtblock_t block
, post_block
;
1531 unsigned int mask
= 0;
1533 gfc_start_block (&block
);
1534 gfc_init_block (&post_block
);
1536 var
= gfc_create_var (st_parameter
[IOPARM_ptype_wait
].type
,
1539 set_error_locus (&block
, var
, &code
->loc
);
1542 /* Set parameters here. */
1544 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1548 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1552 mask
|= IOPARM_common_err
;
1555 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_wait_id
, p
->id
);
1557 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1560 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_unit
, p
->unit
);
1562 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1563 tmp
= build_call_expr_loc (input_location
,
1564 iocall
[IOCALL_WAIT
], 1, tmp
);
1565 gfc_add_expr_to_block (&block
, tmp
);
1567 gfc_add_block_to_block (&block
, &post_block
);
1569 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1571 return gfc_finish_block (&block
);
1576 /* nml_full_name builds up the fully qualified name of a
1577 derived type component. '+' is used to denote a type extension. */
1580 nml_full_name (const char* var_name
, const char* cmp_name
, bool parent
)
1582 int full_name_length
;
1585 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1586 full_name
= XCNEWVEC (char, full_name_length
+ 1);
1587 strcpy (full_name
, var_name
);
1588 full_name
= strcat (full_name
, parent
? "+" : "%");
1589 full_name
= strcat (full_name
, cmp_name
);
1594 /* nml_get_addr_expr builds an address expression from the
1595 gfc_symbol or gfc_component backend_decl's. An offset is
1596 provided so that the address of an element of an array of
1597 derived types is returned. This is used in the runtime to
1598 determine that span of the derived type. */
1601 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1604 tree decl
= NULL_TREE
;
1609 sym
->attr
.referenced
= 1;
1610 decl
= gfc_get_symbol_decl (sym
);
1612 /* If this is the enclosing function declaration, use
1613 the fake result instead. */
1614 if (decl
== current_function_decl
)
1615 decl
= gfc_get_fake_result_decl (sym
, 0);
1616 else if (decl
== DECL_CONTEXT (current_function_decl
))
1617 decl
= gfc_get_fake_result_decl (sym
, 1);
1620 decl
= c
->backend_decl
;
1622 gcc_assert (decl
&& (TREE_CODE (decl
) == FIELD_DECL
1624 || TREE_CODE (decl
) == PARM_DECL
1625 || TREE_CODE (decl
) == COMPONENT_REF
));
1629 /* Build indirect reference, if dummy argument. */
1631 if (POINTER_TYPE_P (TREE_TYPE(tmp
)))
1632 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1634 /* Treat the component of a derived type, using base_addr for
1635 the derived type. */
1637 if (TREE_CODE (decl
) == FIELD_DECL
)
1638 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
1639 base_addr
, tmp
, NULL_TREE
);
1641 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
1642 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp
))))
1643 tmp
= gfc_class_data_get (tmp
);
1645 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
1646 tmp
= gfc_conv_array_data (tmp
);
1649 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1650 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1652 if (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1653 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1655 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1656 tmp
= build_fold_indirect_ref_loc (input_location
,
1660 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1666 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1667 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1668 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1670 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1673 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1674 gfc_symbol
* sym
, gfc_component
* c
,
1677 gfc_typespec
* ts
= NULL
;
1678 gfc_array_spec
* as
= NULL
;
1679 tree addr_expr
= NULL
;
1685 tree decl
= NULL_TREE
;
1686 tree gfc_int4_type_node
= gfc_get_int_type (4);
1687 tree dtio_proc
= null_pointer_node
;
1688 tree vtable
= null_pointer_node
;
1692 gcc_assert (sym
|| c
);
1694 /* Build the namelist object name. */
1696 string
= gfc_build_cstring_const (var_name
);
1697 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1699 /* Build ts, as and data address using symbol or component. */
1701 ts
= sym
? &sym
->ts
: &c
->ts
;
1703 if (ts
->type
!= BT_CLASS
)
1704 as
= sym
? sym
->as
: c
->as
;
1706 as
= sym
? CLASS_DATA (sym
)->as
: CLASS_DATA (c
)->as
;
1708 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1715 decl
= sym
? sym
->backend_decl
: c
->backend_decl
;
1716 if (sym
&& sym
->attr
.dummy
)
1717 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
1719 if (ts
->type
== BT_CLASS
)
1720 decl
= gfc_class_data_get (decl
);
1721 dt
= TREE_TYPE (decl
);
1722 dtype
= gfc_get_dtype (dt
);
1726 dt
= gfc_typenode_for_spec (ts
);
1727 dtype
= gfc_get_dtype_rank_type (0, dt
);
1730 /* Build up the arguments for the transfer call.
1731 The call for the scalar part transfers:
1732 (address, name, type, kind or string_length, dtype) */
1734 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1736 /* Check if the derived type has a specific DTIO for the mode.
1737 Note that although namelist io is forbidden to have a format
1738 list, the specific subroutine is of the formatted kind. */
1739 if (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)
1741 gfc_symbol
*derived
;
1742 if (ts
->type
==BT_CLASS
)
1743 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
1745 derived
= ts
->u
.derived
;
1747 gfc_symtree
*tb_io_st
= gfc_find_typebound_dtio_proc (derived
,
1748 last_dt
== WRITE
, true);
1750 if (ts
->type
== BT_CLASS
&& tb_io_st
)
1752 // polymorphic DTIO call (based on the dynamic type)
1754 gfc_symtree
*st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
1755 // build vtable expr
1756 gfc_expr
*expr
= gfc_get_variable_expr (st
);
1757 gfc_add_vptr_component (expr
);
1758 gfc_init_se (&se
, NULL
);
1759 se
.want_pointer
= 1;
1760 gfc_conv_expr (&se
, expr
);
1763 gfc_add_component_ref (expr
,
1764 tb_io_st
->n
.tb
->u
.generic
->specific_st
->name
);
1765 gfc_init_se (&se
, NULL
);
1766 se
.want_pointer
= 1;
1767 gfc_conv_expr (&se
, expr
);
1768 gfc_free_expr (expr
);
1769 dtio_proc
= se
.expr
;
1773 // non-polymorphic DTIO call (based on the declared type)
1774 gfc_symbol
*dtio_sub
= gfc_find_specific_dtio_proc (derived
,
1775 last_dt
== WRITE
, true);
1776 if (dtio_sub
!= NULL
)
1778 dtio_proc
= gfc_get_symbol_decl (dtio_sub
);
1779 dtio_proc
= gfc_build_addr_expr (NULL
, dtio_proc
);
1780 gfc_symbol
*vtab
= gfc_find_derived_vtab (derived
);
1781 vtable
= vtab
->backend_decl
;
1782 if (vtable
== NULL_TREE
)
1783 vtable
= gfc_get_symbol_decl (vtab
);
1784 vtable
= gfc_build_addr_expr (pvoid_type_node
, vtable
);
1789 if (ts
->type
== BT_CHARACTER
)
1790 tmp
= ts
->u
.cl
->backend_decl
;
1792 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1794 int abi_kind
= gfc_type_abi_kind (ts
);
1795 if (dtio_proc
== null_pointer_node
)
1796 tmp
= build_call_expr_loc (input_location
, iocall
[IOCALL_SET_NML_VAL
], 6,
1797 dt_parm_addr
, addr_expr
, string
,
1798 build_int_cst (gfc_int4_type_node
, abi_kind
),
1801 tmp
= build_call_expr_loc (input_location
, iocall
[IOCALL_SET_NML_DTIO_VAL
],
1802 8, dt_parm_addr
, addr_expr
, string
,
1803 build_int_cst (gfc_int4_type_node
, abi_kind
),
1804 tmp
, dtype
, dtio_proc
, vtable
);
1805 gfc_add_expr_to_block (block
, tmp
);
1807 /* If the object is an array, transfer rank times:
1808 (null pointer, name, stride, lbound, ubound) */
1810 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1812 tmp
= build_call_expr_loc (input_location
,
1813 iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1815 build_int_cst (gfc_int4_type_node
, n_dim
),
1816 gfc_conv_array_stride (decl
, n_dim
),
1817 gfc_conv_array_lbound (decl
, n_dim
),
1818 gfc_conv_array_ubound (decl
, n_dim
));
1819 gfc_add_expr_to_block (block
, tmp
);
1822 if (gfc_bt_struct (ts
->type
) && ts
->u
.derived
->components
1823 && dtio_proc
== null_pointer_node
)
1827 /* Provide the RECORD_TYPE to build component references. */
1829 tree expr
= build_fold_indirect_ref_loc (input_location
,
1832 for (cmp
= ts
->u
.derived
->components
; cmp
; cmp
= cmp
->next
)
1834 char *full_name
= nml_full_name (var_name
, cmp
->name
,
1835 ts
->u
.derived
->attr
.extension
);
1836 transfer_namelist_element (block
,
1846 /* Create a data transfer statement. Not all of the fields are valid
1847 for both reading and writing, but improper use has been filtered
1851 build_dt (tree function
, gfc_code
* code
)
1853 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1858 unsigned int mask
= 0;
1860 gfc_start_block (&block
);
1861 gfc_init_block (&post_block
);
1862 gfc_init_block (&post_end_block
);
1863 gfc_init_block (&post_iu_block
);
1865 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1867 set_error_locus (&block
, var
, &code
->loc
);
1869 if (last_dt
== IOLENGTH
)
1873 inq
= code
->ext
.inquire
;
1875 /* First check that preconditions are met. */
1876 gcc_assert (inq
!= NULL
);
1877 gcc_assert (inq
->iolength
!= NULL
);
1879 /* Connect to the iolength variable. */
1880 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1881 IOPARM_dt_iolength
, inq
->iolength
);
1887 gcc_assert (dt
!= NULL
);
1890 if (dt
&& dt
->io_unit
)
1892 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1894 mask
|= set_internal_unit (&block
, &post_iu_block
,
1896 set_parameter_const (&block
, var
, IOPARM_common_unit
,
1897 dt
->io_unit
->ts
.kind
== 1 ?
1898 GFC_INTERNAL_UNIT
: GFC_INTERNAL_UNIT4
);
1902 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1907 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1911 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1912 IOPARM_common_iostat
, dt
->iostat
);
1915 mask
|= IOPARM_common_err
;
1918 mask
|= IOPARM_common_eor
;
1921 mask
|= IOPARM_common_end
;
1924 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1925 IOPARM_dt_id
, dt
->id
);
1928 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1930 if (dt
->asynchronous
)
1931 mask
|= set_string (&block
, &post_block
, var
,
1932 IOPARM_dt_asynchronous
, dt
->asynchronous
);
1935 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1939 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1943 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1947 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1951 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1955 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1959 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1962 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1965 if (dt
->format_expr
)
1966 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1969 if (dt
->format_label
)
1971 if (dt
->format_label
== &format_asterisk
)
1972 mask
|= IOPARM_dt_list_format
;
1974 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1975 dt
->format_label
->format
);
1979 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1980 IOPARM_dt_size
, dt
->size
);
1983 mask
|= IOPARM_dt_dtio
;
1986 mask
|= IOPARM_dt_dec_ext
;
1990 if (dt
->format_expr
|| dt
->format_label
)
1991 gfc_internal_error ("build_dt: format with namelist");
1993 nmlname
= gfc_get_character_expr (gfc_default_character_kind
, NULL
,
1995 strlen (dt
->namelist
->name
));
1997 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
2000 gfc_free_expr (nmlname
);
2002 if (last_dt
== READ
)
2003 mask
|= IOPARM_dt_namelist_read_mode
;
2005 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
2009 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
2010 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
2014 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
2016 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
2017 set_parameter_value_chk (&block
, dt
->iostat
, var
,
2018 IOPARM_common_unit
, dt
->io_unit
);
2021 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
2023 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
2024 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2026 gfc_add_expr_to_block (&block
, tmp
);
2028 gfc_add_block_to_block (&block
, &post_block
);
2031 dt_post_end_block
= &post_end_block
;
2033 /* Set implied do loop exit condition. */
2034 if (last_dt
== READ
|| last_dt
== WRITE
)
2036 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
2038 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2039 st_parameter
[IOPARM_ptype_common
].type
,
2040 dt_parm
, TYPE_FIELDS (TREE_TYPE (dt_parm
)),
2042 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2043 TREE_TYPE (p
->field
), tmp
, p
->field
, NULL_TREE
);
2044 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (tmp
),
2045 tmp
, build_int_cst (TREE_TYPE (tmp
),
2046 IOPARM_common_libreturn_mask
));
2051 gfc_add_expr_to_block (&block
, gfc_trans_code_cond (code
->block
->next
, tmp
));
2053 gfc_add_block_to_block (&block
, &post_iu_block
);
2056 dt_post_end_block
= NULL
;
2058 return gfc_finish_block (&block
);
2062 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
2063 this as a third sort of data transfer statement, except that
2064 lengths are summed instead of actually transferring any data. */
2067 gfc_trans_iolength (gfc_code
* code
)
2070 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
2074 /* Translate a READ statement. */
2077 gfc_trans_read (gfc_code
* code
)
2080 return build_dt (iocall
[IOCALL_READ
], code
);
2084 /* Translate a WRITE statement */
2087 gfc_trans_write (gfc_code
* code
)
2090 return build_dt (iocall
[IOCALL_WRITE
], code
);
2094 /* Finish a data transfer statement. */
2097 gfc_trans_dt_end (gfc_code
* code
)
2102 gfc_init_block (&block
);
2107 function
= iocall
[IOCALL_READ_DONE
];
2111 function
= iocall
[IOCALL_WRITE_DONE
];
2115 function
= iocall
[IOCALL_IOLENGTH_DONE
];
2122 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2123 tmp
= build_call_expr_loc (input_location
,
2125 gfc_add_expr_to_block (&block
, tmp
);
2126 gfc_add_block_to_block (&block
, dt_post_end_block
);
2127 gfc_init_block (dt_post_end_block
);
2129 if (last_dt
!= IOLENGTH
)
2131 gcc_assert (code
->ext
.dt
!= NULL
);
2132 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
2133 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
2136 return gfc_finish_block (&block
);
2140 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
,
2141 gfc_code
* code
, tree vptr
);
2143 /* Given an array field in a derived type variable, generate the code
2144 for the loop that iterates over array elements, and the code that
2145 accesses those array elements. Use transfer_expr to generate code
2146 for transferring that element. Because elements may also be
2147 derived types, transfer_expr and transfer_array_component are mutually
2151 transfer_array_component (tree expr
, gfc_component
* cm
, locus
* where
)
2160 gfc_array_info
*ss_array
;
2162 gfc_start_block (&block
);
2163 gfc_init_se (&se
, NULL
);
2165 /* Create and initialize Scalarization Status. Unlike in
2166 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2167 care of this task, because we don't have a gfc_expr at hand.
2168 Build one manually, as in gfc_trans_subarray_assign. */
2170 ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
2172 ss_array
= &ss
->info
->data
.array
;
2174 if (cm
->attr
.pdt_array
)
2175 ss_array
->shape
= NULL
;
2177 ss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
2179 ss_array
->descriptor
= expr
;
2180 ss_array
->data
= gfc_conv_array_data (expr
);
2181 ss_array
->offset
= gfc_conv_array_offset (expr
);
2182 for (n
= 0; n
< cm
->as
->rank
; n
++)
2184 ss_array
->start
[n
] = gfc_conv_array_lbound (expr
, n
);
2185 ss_array
->stride
[n
] = gfc_index_one_node
;
2187 if (cm
->attr
.pdt_array
)
2188 ss_array
->end
[n
] = gfc_conv_array_ubound (expr
, n
);
2191 mpz_init (ss_array
->shape
[n
]);
2192 mpz_sub (ss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2193 cm
->as
->lower
[n
]->value
.integer
);
2194 mpz_add_ui (ss_array
->shape
[n
], ss_array
->shape
[n
], 1);
2198 /* Once we got ss, we use scalarizer to create the loop. */
2200 gfc_init_loopinfo (&loop
);
2201 gfc_add_ss_to_loop (&loop
, ss
);
2202 gfc_conv_ss_startstride (&loop
);
2203 gfc_conv_loop_setup (&loop
, where
);
2204 gfc_mark_ss_chain_used (ss
, 1);
2205 gfc_start_scalarized_body (&loop
, &body
);
2207 gfc_copy_loopinfo_to_se (&se
, &loop
);
2210 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2212 gfc_conv_tmp_array_ref (&se
);
2214 /* Now se.expr contains an element of the array. Take the address and pass
2215 it to the IO routines. */
2216 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2217 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
, NULL_TREE
);
2219 /* We are done now with the loop body. Wrap up the scalarizer and
2222 gfc_add_block_to_block (&body
, &se
.pre
);
2223 gfc_add_block_to_block (&body
, &se
.post
);
2225 gfc_trans_scalarizing_loops (&loop
, &body
);
2227 gfc_add_block_to_block (&block
, &loop
.pre
);
2228 gfc_add_block_to_block (&block
, &loop
.post
);
2230 if (!cm
->attr
.pdt_array
)
2232 gcc_assert (ss_array
->shape
!= NULL
);
2233 gfc_free_shape (&ss_array
->shape
, cm
->as
->rank
);
2235 gfc_cleanup_loop (&loop
);
2237 return gfc_finish_block (&block
);
2241 /* Helper function for transfer_expr that looks for the DTIO procedure
2242 either as a typebound binding or in a generic interface. If present,
2243 the address expression of the procedure is returned. It is assumed
2244 that the procedure interface has been checked during resolution. */
2247 get_dtio_proc (gfc_typespec
* ts
, gfc_code
* code
, gfc_symbol
**dtio_sub
)
2249 gfc_symbol
*derived
;
2250 bool formatted
= false;
2251 gfc_dt
*dt
= code
->ext
.dt
;
2253 /* Determine when to use the formatted DTIO procedure. */
2254 if (dt
&& (dt
->format_expr
|| dt
->format_label
))
2257 if (ts
->type
== BT_CLASS
)
2258 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
2260 derived
= ts
->u
.derived
;
2262 gfc_symtree
*tb_io_st
= gfc_find_typebound_dtio_proc (derived
,
2263 last_dt
== WRITE
, formatted
);
2264 if (ts
->type
== BT_CLASS
&& tb_io_st
)
2266 // polymorphic DTIO call (based on the dynamic type)
2268 gfc_expr
*expr
= gfc_find_and_cut_at_last_class_ref (code
->expr1
);
2269 gfc_add_vptr_component (expr
);
2270 gfc_add_component_ref (expr
,
2271 tb_io_st
->n
.tb
->u
.generic
->specific_st
->name
);
2272 *dtio_sub
= tb_io_st
->n
.tb
->u
.generic
->specific
->u
.specific
->n
.sym
;
2273 gfc_init_se (&se
, NULL
);
2274 se
.want_pointer
= 1;
2275 gfc_conv_expr (&se
, expr
);
2276 gfc_free_expr (expr
);
2281 // non-polymorphic DTIO call (based on the declared type)
2282 *dtio_sub
= gfc_find_specific_dtio_proc (derived
, last_dt
== WRITE
,
2286 return gfc_build_addr_expr (NULL
, gfc_get_symbol_decl (*dtio_sub
));
2292 /* Generate the call for a scalar transfer node. */
2295 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
,
2296 gfc_code
* code
, tree vptr
)
2298 tree tmp
, function
, arg2
, arg3
, field
, expr
;
2302 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2303 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2304 We need to translate the expression to a constant if it's either
2305 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2306 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2307 BT_DERIVED (could have been changed by gfc_conv_expr). */
2308 if ((ts
->type
== BT_DERIVED
|| ts
->type
== BT_INTEGER
)
2309 && ts
->u
.derived
!= NULL
2310 && (ts
->is_iso_c
== 1 || ts
->u
.derived
->ts
.is_iso_c
== 1))
2312 ts
->type
= BT_INTEGER
;
2313 ts
->kind
= gfc_index_integer_kind
;
2316 /* gfortran reaches here for "print *, c_loc(xxx)". */
2317 if (ts
->type
== BT_VOID
2318 && code
->expr1
&& code
->expr1
->ts
.type
== BT_VOID
2319 && code
->expr1
->symtree
2320 && strcmp (code
->expr1
->symtree
->name
, "c_loc") == 0)
2322 ts
->type
= BT_INTEGER
;
2323 ts
->kind
= gfc_index_integer_kind
;
2326 kind
= gfc_type_abi_kind (ts
);
2334 arg2
= build_int_cst (integer_type_node
, kind
);
2335 if (last_dt
== READ
)
2336 function
= iocall
[IOCALL_X_INTEGER
];
2338 function
= iocall
[IOCALL_X_INTEGER_WRITE
];
2343 arg2
= build_int_cst (integer_type_node
, kind
);
2344 if (last_dt
== READ
)
2346 if ((gfc_real16_is_float128
&& kind
== 16) || kind
== 17)
2347 function
= iocall
[IOCALL_X_REAL128
];
2349 function
= iocall
[IOCALL_X_REAL
];
2353 if ((gfc_real16_is_float128
&& kind
== 16) || kind
== 17)
2354 function
= iocall
[IOCALL_X_REAL128_WRITE
];
2356 function
= iocall
[IOCALL_X_REAL_WRITE
];
2362 arg2
= build_int_cst (integer_type_node
, kind
);
2363 if (last_dt
== READ
)
2365 if ((gfc_real16_is_float128
&& kind
== 16) || kind
== 17)
2366 function
= iocall
[IOCALL_X_COMPLEX128
];
2368 function
= iocall
[IOCALL_X_COMPLEX
];
2372 if ((gfc_real16_is_float128
&& kind
== 16) || kind
== 17)
2373 function
= iocall
[IOCALL_X_COMPLEX128_WRITE
];
2375 function
= iocall
[IOCALL_X_COMPLEX_WRITE
];
2381 arg2
= build_int_cst (integer_type_node
, kind
);
2382 if (last_dt
== READ
)
2383 function
= iocall
[IOCALL_X_LOGICAL
];
2385 function
= iocall
[IOCALL_X_LOGICAL_WRITE
];
2392 if (se
->string_length
)
2393 arg2
= se
->string_length
;
2396 tmp
= build_fold_indirect_ref_loc (input_location
,
2398 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2399 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2400 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2402 arg3
= build_int_cst (integer_type_node
, kind
);
2403 if (last_dt
== READ
)
2404 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2406 function
= iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
];
2408 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2409 tmp
= build_call_expr_loc (input_location
,
2410 function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2411 gfc_add_expr_to_block (&se
->pre
, tmp
);
2412 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2417 if (se
->string_length
)
2418 arg2
= se
->string_length
;
2421 tmp
= build_fold_indirect_ref_loc (input_location
,
2423 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2424 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2426 if (last_dt
== READ
)
2427 function
= iocall
[IOCALL_X_CHARACTER
];
2429 function
= iocall
[IOCALL_X_CHARACTER_WRITE
];
2435 if (gfc_bt_struct (ts
->type
) || ts
->type
== BT_CLASS
)
2437 gfc_symbol
*derived
;
2438 gfc_symbol
*dtio_sub
= NULL
;
2439 /* Test for a specific DTIO subroutine. */
2440 if (ts
->type
== BT_DERIVED
)
2441 derived
= ts
->u
.derived
;
2443 derived
= ts
->u
.derived
->components
->ts
.u
.derived
;
2445 if (derived
->attr
.has_dtio_procs
)
2446 arg2
= get_dtio_proc (ts
, code
, &dtio_sub
);
2448 if ((dtio_sub
!= NULL
) && (last_dt
!= IOLENGTH
))
2451 decl
= build_fold_indirect_ref_loc (input_location
,
2453 /* Remember that the first dummy of the DTIO subroutines
2454 is CLASS(derived) for extensible derived types, so the
2455 conversion must be done here for derived type and for
2456 scalarized CLASS array element io-list objects. */
2457 if ((ts
->type
== BT_DERIVED
2458 && !(ts
->u
.derived
->attr
.sequence
2459 || ts
->u
.derived
->attr
.is_bind_c
))
2460 || (ts
->type
== BT_CLASS
2461 && !GFC_CLASS_TYPE_P (TREE_TYPE (decl
))))
2462 gfc_conv_derived_to_class (se
, code
->expr1
,
2463 dtio_sub
->formal
->sym
->ts
,
2464 vptr
, false, false);
2465 addr_expr
= se
->expr
;
2466 function
= iocall
[IOCALL_X_DERIVED
];
2469 else if (gfc_bt_struct (ts
->type
))
2471 /* Recurse into the elements of the derived type. */
2472 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2473 expr
= build_fold_indirect_ref_loc (input_location
, expr
);
2475 /* Make sure that the derived type has been built. An external
2476 function, if only referenced in an io statement, requires this
2477 check (see PR58771). */
2478 if (ts
->u
.derived
->backend_decl
== NULL_TREE
)
2479 (void) gfc_typenode_for_spec (ts
);
2481 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
2483 /* Ignore hidden string lengths. */
2484 if (c
->name
[0] == '_')
2487 field
= c
->backend_decl
;
2488 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2490 tmp
= fold_build3_loc (UNKNOWN_LOCATION
,
2491 COMPONENT_REF
, TREE_TYPE (field
),
2492 expr
, field
, NULL_TREE
);
2494 if (c
->attr
.dimension
)
2496 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2497 gfc_add_expr_to_block (&se
->pre
, tmp
);
2501 tree strlen
= NULL_TREE
;
2503 if (!c
->attr
.pointer
&& !c
->attr
.pdt_string
)
2504 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2506 /* Use the hidden string length for pdt strings. */
2507 if (c
->attr
.pdt_string
2508 && gfc_deferred_strlen (c
, &strlen
)
2509 && strlen
!= NULL_TREE
)
2511 strlen
= fold_build3_loc (UNKNOWN_LOCATION
,
2514 expr
, strlen
, NULL_TREE
);
2515 se
->string_length
= strlen
;
2518 transfer_expr (se
, &c
->ts
, tmp
, code
, NULL_TREE
);
2520 /* Reset so that the pdt string length does not propagate
2521 through to other strings. */
2522 if (c
->attr
.pdt_string
&& strlen
)
2523 se
->string_length
= NULL_TREE
;
2528 /* If a CLASS object gets through to here, fall through and ICE. */
2532 gfc_internal_error ("Bad IO basetype (%d)", ts
->type
);
2535 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2536 tmp
= build_call_expr_loc (input_location
,
2537 function
, 3, tmp
, addr_expr
, arg2
);
2538 gfc_add_expr_to_block (&se
->pre
, tmp
);
2539 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2544 /* Generate a call to pass an array descriptor to the IO library. The
2545 array should be of one of the intrinsic types. */
2548 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2550 tree tmp
, charlen_arg
, kind_arg
, io_call
;
2552 if (ts
->type
== BT_CHARACTER
)
2553 charlen_arg
= se
->string_length
;
2555 charlen_arg
= build_int_cst (gfc_charlen_type_node
, 0);
2557 kind_arg
= build_int_cst (integer_type_node
, gfc_type_abi_kind (ts
));
2559 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2560 if (last_dt
== READ
)
2561 io_call
= iocall
[IOCALL_X_ARRAY
];
2563 io_call
= iocall
[IOCALL_X_ARRAY_WRITE
];
2565 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2567 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2568 gfc_add_expr_to_block (&se
->pre
, tmp
);
2569 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2573 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2576 gfc_trans_transfer (gfc_code
* code
)
2578 stmtblock_t block
, body
;
2588 gfc_start_block (&block
);
2589 gfc_init_block (&body
);
2593 gfc_init_se (&se
, NULL
);
2595 if (expr
->rank
== 0)
2597 /* Transfer a scalar value. */
2598 if (expr
->ts
.type
== BT_CLASS
)
2600 se
.want_pointer
= 1;
2601 gfc_conv_expr (&se
, expr
);
2602 vptr
= gfc_get_vptr_from_expr (se
.expr
);
2607 gfc_conv_expr_reference (&se
, expr
);
2609 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
, vptr
);
2613 /* Transfer an array. If it is an array of an intrinsic
2614 type, pass the descriptor to the library. Otherwise
2615 scalarize the transfer. */
2616 if (expr
->ref
&& !gfc_is_proc_ptr_comp (expr
))
2618 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2620 gcc_assert (ref
&& ref
->type
== REF_ARRAY
);
2623 if (expr
->ts
.type
!= BT_CLASS
2624 && expr
->expr_type
== EXPR_VARIABLE
2625 && gfc_expr_attr (expr
).pointer
)
2629 if (!(gfc_bt_struct (expr
->ts
.type
)
2630 || expr
->ts
.type
== BT_CLASS
)
2631 && ref
&& ref
->next
== NULL
2632 && !is_subref_array (expr
))
2634 bool seen_vector
= false;
2636 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2638 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2639 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2646 if (seen_vector
&& last_dt
== READ
)
2648 /* Create a temp, read to that and copy it back. */
2649 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
, false);
2654 /* Get the descriptor. */
2655 gfc_conv_expr_descriptor (&se
, expr
);
2656 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2659 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2660 goto finish_block_label
;
2664 /* Initialize the scalarizer. */
2665 ss
= gfc_walk_expr (expr
);
2666 gfc_init_loopinfo (&loop
);
2667 gfc_add_ss_to_loop (&loop
, ss
);
2669 /* Initialize the loop. */
2670 gfc_conv_ss_startstride (&loop
);
2671 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
2673 /* The main loop body. */
2674 gfc_mark_ss_chain_used (ss
, 1);
2675 gfc_start_scalarized_body (&loop
, &body
);
2677 gfc_copy_loopinfo_to_se (&se
, &loop
);
2680 gfc_conv_expr_reference (&se
, expr
);
2682 if (expr
->ts
.type
== BT_CLASS
)
2683 vptr
= gfc_get_vptr_from_expr (ss
->info
->data
.array
.descriptor
);
2686 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
, vptr
);
2691 gfc_add_block_to_block (&body
, &se
.pre
);
2692 gfc_add_block_to_block (&body
, &se
.post
);
2695 tmp
= gfc_finish_block (&body
);
2698 gcc_assert (expr
->rank
!= 0);
2699 gcc_assert (se
.ss
== gfc_ss_terminator
);
2700 gfc_trans_scalarizing_loops (&loop
, &body
);
2702 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2703 tmp
= gfc_finish_block (&loop
.pre
);
2704 gfc_cleanup_loop (&loop
);
2707 gfc_add_expr_to_block (&block
, tmp
);
2709 return gfc_finish_block (&block
);
2712 #include "gt-fortran-trans-io.h"