1 /* IO Code translation/library interface
2 Copyright (C) 2002-2015 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 "fold-const.h"
29 #include "stringpool.h"
30 #include "stor-layout.h"
32 #include "diagnostic-core.h" /* For internal_error. */
34 #include "trans-stmt.h"
35 #include "trans-array.h"
36 #include "trans-types.h"
37 #include "trans-const.h"
39 /* Members of the ioparm structure. */
68 typedef struct GTY(()) gfc_st_parameter_field
{
71 enum ioparam_type param_type
;
72 enum iofield_type type
;
76 gfc_st_parameter_field
;
78 typedef struct GTY(()) gfc_st_parameter
{
86 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
92 static GTY(()) gfc_st_parameter st_parameter
[] =
103 static GTY(()) gfc_st_parameter_field st_parameter_field
[] =
105 #define IOPARM(param_type, name, mask, type) \
106 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
107 #include "ioparm.def"
109 { NULL
, 0, (enum ioparam_type
) 0, (enum iofield_type
) 0, NULL
, NULL
}
112 /* Library I/O subroutines */
121 IOCALL_X_INTEGER_WRITE
,
123 IOCALL_X_LOGICAL_WRITE
,
125 IOCALL_X_CHARACTER_WRITE
,
126 IOCALL_X_CHARACTER_WIDE
,
127 IOCALL_X_CHARACTER_WIDE_WRITE
,
131 IOCALL_X_COMPLEX_WRITE
,
133 IOCALL_X_REAL128_WRITE
,
135 IOCALL_X_COMPLEX128_WRITE
,
137 IOCALL_X_ARRAY_WRITE
,
142 IOCALL_IOLENGTH_DONE
,
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
:
224 st_parameter
[ptype
].type
= t
;
228 /* Build code to test an error condition and call generate_error if needed.
229 Note: This builds calls to generate_error in the runtime library function.
230 The function generate_error is dependent on certain parameters in the
231 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
232 Therefore, the code to set these flags must be generated before
233 this function is used. */
236 gfc_trans_io_runtime_check (bool has_iostat
, tree cond
, tree var
,
237 int error_code
, const char * msgid
,
238 stmtblock_t
* pblock
)
243 tree arg1
, arg2
, arg3
;
246 if (integer_zerop (cond
))
249 /* The code to generate the error. */
250 gfc_start_block (&block
);
253 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_FORTRAN_FAIL_IO
,
256 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_NORETURN
,
259 arg1
= gfc_build_addr_expr (NULL_TREE
, var
);
261 arg2
= build_int_cst (integer_type_node
, error_code
),
263 message
= xasprintf ("%s", _(msgid
));
264 arg3
= gfc_build_addr_expr (pchar_type_node
,
265 gfc_build_localized_cstring_const (message
));
268 tmp
= build_call_expr_loc (input_location
,
269 gfor_fndecl_generate_error
, 3, arg1
, arg2
, arg3
);
271 gfc_add_expr_to_block (&block
, tmp
);
273 body
= gfc_finish_block (&block
);
275 if (integer_onep (cond
))
277 gfc_add_expr_to_block (pblock
, body
);
281 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt (input_location
));
282 gfc_add_expr_to_block (pblock
, tmp
);
287 /* Create function decls for IO library functions. */
290 gfc_build_io_library_fndecls (void)
292 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
293 tree gfc_intio_type_node
;
294 tree parm_type
, dt_parm_type
;
295 HOST_WIDE_INT pad_size
;
298 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
299 types
[IOPARM_type_intio
] = gfc_intio_type_node
300 = gfc_get_int_type (gfc_intio_kind
);
301 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
302 types
[IOPARM_type_pintio
]
303 = build_pointer_type (gfc_intio_type_node
);
304 types
[IOPARM_type_parray
] = pchar_type_node
;
305 types
[IOPARM_type_pchar
] = pchar_type_node
;
306 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
307 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
308 pad_idx
= build_index_type (size_int (pad_size
- 1));
309 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
311 /* pad actually contains pointers and integers so it needs to have an
312 alignment that is at least as large as the needed alignment for those
313 types. See the st_parameter_dt structure in libgfortran/io/io.h for
314 what really goes into this space. */
315 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
316 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind
)));
318 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
319 gfc_build_st_parameter ((enum ioparam_type
) ptype
, types
);
321 /* Define the transfer functions. */
323 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
325 iocall
[IOCALL_X_INTEGER
] = gfc_build_library_function_decl_with_spec (
326 get_identifier (PREFIX("transfer_integer")), ".wW",
327 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
329 iocall
[IOCALL_X_INTEGER_WRITE
] = gfc_build_library_function_decl_with_spec (
330 get_identifier (PREFIX("transfer_integer_write")), ".wR",
331 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
333 iocall
[IOCALL_X_LOGICAL
] = gfc_build_library_function_decl_with_spec (
334 get_identifier (PREFIX("transfer_logical")), ".wW",
335 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
337 iocall
[IOCALL_X_LOGICAL_WRITE
] = gfc_build_library_function_decl_with_spec (
338 get_identifier (PREFIX("transfer_logical_write")), ".wR",
339 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
341 iocall
[IOCALL_X_CHARACTER
] = gfc_build_library_function_decl_with_spec (
342 get_identifier (PREFIX("transfer_character")), ".wW",
343 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
345 iocall
[IOCALL_X_CHARACTER_WRITE
] = gfc_build_library_function_decl_with_spec (
346 get_identifier (PREFIX("transfer_character_write")), ".wR",
347 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
349 iocall
[IOCALL_X_CHARACTER_WIDE
] = gfc_build_library_function_decl_with_spec (
350 get_identifier (PREFIX("transfer_character_wide")), ".wW",
351 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
352 gfc_charlen_type_node
, gfc_int4_type_node
);
354 iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
] =
355 gfc_build_library_function_decl_with_spec (
356 get_identifier (PREFIX("transfer_character_wide_write")), ".wR",
357 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
358 gfc_charlen_type_node
, gfc_int4_type_node
);
360 iocall
[IOCALL_X_REAL
] = gfc_build_library_function_decl_with_spec (
361 get_identifier (PREFIX("transfer_real")), ".wW",
362 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
364 iocall
[IOCALL_X_REAL_WRITE
] = gfc_build_library_function_decl_with_spec (
365 get_identifier (PREFIX("transfer_real_write")), ".wR",
366 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
368 iocall
[IOCALL_X_COMPLEX
] = gfc_build_library_function_decl_with_spec (
369 get_identifier (PREFIX("transfer_complex")), ".wW",
370 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
372 iocall
[IOCALL_X_COMPLEX_WRITE
] = gfc_build_library_function_decl_with_spec (
373 get_identifier (PREFIX("transfer_complex_write")), ".wR",
374 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
376 /* Version for __float128. */
377 iocall
[IOCALL_X_REAL128
] = gfc_build_library_function_decl_with_spec (
378 get_identifier (PREFIX("transfer_real128")), ".wW",
379 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
381 iocall
[IOCALL_X_REAL128_WRITE
] = gfc_build_library_function_decl_with_spec (
382 get_identifier (PREFIX("transfer_real128_write")), ".wR",
383 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
385 iocall
[IOCALL_X_COMPLEX128
] = gfc_build_library_function_decl_with_spec (
386 get_identifier (PREFIX("transfer_complex128")), ".wW",
387 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
389 iocall
[IOCALL_X_COMPLEX128_WRITE
] = gfc_build_library_function_decl_with_spec (
390 get_identifier (PREFIX("transfer_complex128_write")), ".wR",
391 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
393 iocall
[IOCALL_X_ARRAY
] = gfc_build_library_function_decl_with_spec (
394 get_identifier (PREFIX("transfer_array")), ".ww",
395 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
396 integer_type_node
, gfc_charlen_type_node
);
398 iocall
[IOCALL_X_ARRAY_WRITE
] = gfc_build_library_function_decl_with_spec (
399 get_identifier (PREFIX("transfer_array_write")), ".wr",
400 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
401 integer_type_node
, gfc_charlen_type_node
);
403 /* Library entry points */
405 iocall
[IOCALL_READ
] = gfc_build_library_function_decl_with_spec (
406 get_identifier (PREFIX("st_read")), ".w",
407 void_type_node
, 1, dt_parm_type
);
409 iocall
[IOCALL_WRITE
] = gfc_build_library_function_decl_with_spec (
410 get_identifier (PREFIX("st_write")), ".w",
411 void_type_node
, 1, dt_parm_type
);
413 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
414 iocall
[IOCALL_OPEN
] = gfc_build_library_function_decl_with_spec (
415 get_identifier (PREFIX("st_open")), ".w",
416 void_type_node
, 1, parm_type
);
418 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
419 iocall
[IOCALL_CLOSE
] = gfc_build_library_function_decl_with_spec (
420 get_identifier (PREFIX("st_close")), ".w",
421 void_type_node
, 1, parm_type
);
423 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
424 iocall
[IOCALL_INQUIRE
] = gfc_build_library_function_decl_with_spec (
425 get_identifier (PREFIX("st_inquire")), ".w",
426 void_type_node
, 1, parm_type
);
428 iocall
[IOCALL_IOLENGTH
] = gfc_build_library_function_decl_with_spec(
429 get_identifier (PREFIX("st_iolength")), ".w",
430 void_type_node
, 1, dt_parm_type
);
432 /* TODO: Change when asynchronous I/O is implemented. */
433 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_wait
].type
);
434 iocall
[IOCALL_WAIT
] = gfc_build_library_function_decl_with_spec (
435 get_identifier (PREFIX("st_wait")), ".X",
436 void_type_node
, 1, parm_type
);
438 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
439 iocall
[IOCALL_REWIND
] = gfc_build_library_function_decl_with_spec (
440 get_identifier (PREFIX("st_rewind")), ".w",
441 void_type_node
, 1, parm_type
);
443 iocall
[IOCALL_BACKSPACE
] = gfc_build_library_function_decl_with_spec (
444 get_identifier (PREFIX("st_backspace")), ".w",
445 void_type_node
, 1, parm_type
);
447 iocall
[IOCALL_ENDFILE
] = gfc_build_library_function_decl_with_spec (
448 get_identifier (PREFIX("st_endfile")), ".w",
449 void_type_node
, 1, parm_type
);
451 iocall
[IOCALL_FLUSH
] = gfc_build_library_function_decl_with_spec (
452 get_identifier (PREFIX("st_flush")), ".w",
453 void_type_node
, 1, parm_type
);
455 /* Library helpers */
457 iocall
[IOCALL_READ_DONE
] = gfc_build_library_function_decl_with_spec (
458 get_identifier (PREFIX("st_read_done")), ".w",
459 void_type_node
, 1, dt_parm_type
);
461 iocall
[IOCALL_WRITE_DONE
] = gfc_build_library_function_decl_with_spec (
462 get_identifier (PREFIX("st_write_done")), ".w",
463 void_type_node
, 1, dt_parm_type
);
465 iocall
[IOCALL_IOLENGTH_DONE
] = gfc_build_library_function_decl_with_spec (
466 get_identifier (PREFIX("st_iolength_done")), ".w",
467 void_type_node
, 1, dt_parm_type
);
469 iocall
[IOCALL_SET_NML_VAL
] = gfc_build_library_function_decl_with_spec (
470 get_identifier (PREFIX("st_set_nml_var")), ".w.R",
471 void_type_node
, 6, dt_parm_type
, pvoid_type_node
, pvoid_type_node
,
472 gfc_int4_type_node
, gfc_charlen_type_node
, gfc_int4_type_node
);
474 iocall
[IOCALL_SET_NML_VAL_DIM
] = gfc_build_library_function_decl_with_spec (
475 get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
476 void_type_node
, 5, dt_parm_type
, gfc_int4_type_node
,
477 gfc_array_index_type
, gfc_array_index_type
, gfc_array_index_type
);
481 /* Generate code to store an integer constant into the
482 st_parameter_XXX structure. */
485 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
489 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
491 if (p
->param_type
== IOPARM_ptype_common
)
492 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
493 st_parameter
[IOPARM_ptype_common
].type
,
494 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
495 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
496 var
, p
->field
, NULL_TREE
);
497 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
502 /* Generate code to store a non-string I/O parameter into the
503 st_parameter_XXX structure. This is a pass by value. */
506 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
511 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
512 tree dest_type
= TREE_TYPE (p
->field
);
514 gfc_init_se (&se
, NULL
);
515 gfc_conv_expr_val (&se
, e
);
517 se
.expr
= convert (dest_type
, se
.expr
);
518 gfc_add_block_to_block (block
, &se
.pre
);
520 if (p
->param_type
== IOPARM_ptype_common
)
521 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
522 st_parameter
[IOPARM_ptype_common
].type
,
523 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
525 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, dest_type
, var
,
526 p
->field
, NULL_TREE
);
527 gfc_add_modify (block
, tmp
, se
.expr
);
532 /* Similar to set_parameter_value except generate runtime
536 set_parameter_value_chk (stmtblock_t
*block
, bool has_iostat
, tree var
,
537 enum iofield type
, gfc_expr
*e
)
541 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
542 tree dest_type
= TREE_TYPE (p
->field
);
544 gfc_init_se (&se
, NULL
);
545 gfc_conv_expr_val (&se
, e
);
547 /* If we're storing a UNIT number, we need to check it first. */
548 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
553 /* Don't evaluate the UNIT number multiple times. */
554 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
556 /* UNIT numbers should be greater than the min. */
557 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
558 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].pedantic_min_int
, 4);
559 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
561 fold_convert (TREE_TYPE (se
.expr
), val
));
562 gfc_trans_io_runtime_check (has_iostat
, cond
, var
, LIBERROR_BAD_UNIT
,
563 "Unit number in I/O statement too small",
566 /* UNIT numbers should be less than the max. */
567 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
568 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
570 fold_convert (TREE_TYPE (se
.expr
), val
));
571 gfc_trans_io_runtime_check (has_iostat
, cond
, var
, LIBERROR_BAD_UNIT
,
572 "Unit number in I/O statement too large",
576 se
.expr
= convert (dest_type
, se
.expr
);
577 gfc_add_block_to_block (block
, &se
.pre
);
579 if (p
->param_type
== IOPARM_ptype_common
)
580 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
581 st_parameter
[IOPARM_ptype_common
].type
,
582 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
584 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, dest_type
, var
,
585 p
->field
, NULL_TREE
);
586 gfc_add_modify (block
, tmp
, se
.expr
);
591 /* Build code to check the unit range if KIND=8 is used. Similar to
592 set_parameter_value_chk but we do not generate error calls for
593 inquire statements. */
596 set_parameter_value_inquire (stmtblock_t
*block
, tree var
,
597 enum iofield type
, gfc_expr
*e
)
600 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
601 tree dest_type
= TREE_TYPE (p
->field
);
603 gfc_init_se (&se
, NULL
);
604 gfc_conv_expr_val (&se
, e
);
606 /* If we're inquiring on a UNIT number, we need to check to make
607 sure it exists for larger than kind = 4. */
608 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
610 stmtblock_t newblock
;
611 tree cond1
, cond2
, cond3
, val
, body
;
614 /* Don't evaluate the UNIT number multiple times. */
615 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
617 /* UNIT numbers should be greater than zero. */
618 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
619 cond1
= build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
621 fold_convert (TREE_TYPE (se
.expr
),
623 /* UNIT numbers should be less than the max. */
624 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
625 cond2
= build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
627 fold_convert (TREE_TYPE (se
.expr
), val
));
628 cond3
= build2_loc (input_location
, TRUTH_OR_EXPR
,
629 boolean_type_node
, cond1
, cond2
);
631 gfc_start_block (&newblock
);
633 /* The unit number GFC_INVALID_UNIT is reserved. No units can
634 ever have this value. It is used here to signal to the
635 runtime library that the inquire unit number is outside the
636 allowable range and so cannot exist. It is needed when
637 -fdefault-integer-8 is used. */
638 set_parameter_const (&newblock
, var
, IOPARM_common_unit
,
641 body
= gfc_finish_block (&newblock
);
643 cond3
= gfc_unlikely (cond3
, PRED_FORTRAN_FAIL_IO
);
644 var
= build3_v (COND_EXPR
, cond3
, body
, build_empty_stmt (input_location
));
645 gfc_add_expr_to_block (&se
.pre
, var
);
648 se
.expr
= convert (dest_type
, se
.expr
);
649 gfc_add_block_to_block (block
, &se
.pre
);
655 /* Generate code to store a non-string I/O parameter into the
656 st_parameter_XXX structure. This is pass by reference. */
659 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
660 tree var
, enum iofield type
, gfc_expr
*e
)
664 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
666 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
667 gfc_init_se (&se
, NULL
);
668 gfc_conv_expr_lhs (&se
, e
);
670 gfc_add_block_to_block (block
, &se
.pre
);
672 if (TYPE_MODE (TREE_TYPE (se
.expr
))
673 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
675 addr
= convert (TREE_TYPE (p
->field
), gfc_build_addr_expr (NULL_TREE
, se
.expr
));
677 /* If this is for the iostat variable initialize the
678 user variable to LIBERROR_OK which is zero. */
679 if (type
== IOPARM_common_iostat
)
680 gfc_add_modify (block
, se
.expr
,
681 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
685 /* The type used by the library has different size
686 from the type of the variable supplied by the user.
687 Need to use a temporary. */
688 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
689 st_parameter_field
[type
].name
);
691 /* If this is for the iostat variable, initialize the
692 user variable to LIBERROR_OK which is zero. */
693 if (type
== IOPARM_common_iostat
)
694 gfc_add_modify (block
, tmpvar
,
695 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
697 addr
= gfc_build_addr_expr (NULL_TREE
, tmpvar
);
698 /* After the I/O operation, we set the variable from the temporary. */
699 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
700 gfc_add_modify (postblock
, se
.expr
, tmp
);
703 if (p
->param_type
== IOPARM_ptype_common
)
704 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
705 st_parameter
[IOPARM_ptype_common
].type
,
706 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
707 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
708 var
, p
->field
, NULL_TREE
);
709 gfc_add_modify (block
, tmp
, addr
);
713 /* Given an array expr, find its address and length to get a string. If the
714 array is full, the string's address is the address of array's first element
715 and the length is the size of the whole array. If it is an element, the
716 string's address is the element's address and the length is the rest size of
720 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
726 tree type
, array
, tmp
;
730 /* If it is an element, we need its address and size of the rest. */
731 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
732 gcc_assert (e
->ref
->u
.ar
.type
== AR_ELEMENT
);
733 sym
= e
->symtree
->n
.sym
;
734 rank
= sym
->as
->rank
- 1;
735 gfc_conv_expr (se
, e
);
737 array
= sym
->backend_decl
;
738 type
= TREE_TYPE (array
);
740 if (GFC_ARRAY_TYPE_P (type
))
741 size
= GFC_TYPE_ARRAY_SIZE (type
);
744 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
745 size
= gfc_conv_array_stride (array
, rank
);
746 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
747 gfc_array_index_type
,
748 gfc_conv_array_ubound (array
, rank
),
749 gfc_conv_array_lbound (array
, rank
));
750 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
751 gfc_array_index_type
, tmp
,
753 size
= fold_build2_loc (input_location
, MULT_EXPR
,
754 gfc_array_index_type
, tmp
, size
);
758 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
759 gfc_array_index_type
, size
,
760 TREE_OPERAND (se
->expr
, 1));
761 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
762 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
763 size
= fold_build2_loc (input_location
, MULT_EXPR
,
764 gfc_array_index_type
, size
,
765 fold_convert (gfc_array_index_type
, tmp
));
766 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
770 gfc_conv_array_parameter (se
, e
, true, NULL
, NULL
, &size
);
771 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
775 /* Generate code to store a string and its length into the
776 st_parameter_XXX structure. */
779 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
780 enum iofield type
, gfc_expr
* e
)
786 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
788 gfc_init_se (&se
, NULL
);
790 if (p
->param_type
== IOPARM_ptype_common
)
791 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
792 st_parameter
[IOPARM_ptype_common
].type
,
793 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
794 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
795 var
, p
->field
, NULL_TREE
);
796 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
797 TREE_TYPE (p
->field_len
),
798 var
, p
->field_len
, NULL_TREE
);
800 /* Integer variable assigned a format label. */
801 if (e
->ts
.type
== BT_INTEGER
803 && e
->symtree
->n
.sym
->attr
.assign
== 1)
808 gfc_conv_label_variable (&se
, e
);
809 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
810 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
811 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
813 msg
= xasprintf ("Label assigned to variable '%s' (%%ld) is not a format "
814 "label", e
->symtree
->name
);
815 gfc_trans_runtime_check (true, false, cond
, &se
.pre
, &e
->where
, msg
,
816 fold_convert (long_integer_type_node
, tmp
));
819 gfc_add_modify (&se
.pre
, io
,
820 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
821 gfc_add_modify (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
825 /* General character. */
826 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
827 gfc_conv_expr (&se
, e
);
828 /* Array assigned Hollerith constant or character array. */
829 else if (e
->rank
> 0 || (e
->symtree
&& e
->symtree
->n
.sym
->as
->rank
> 0))
830 gfc_convert_array_to_string (&se
, e
);
834 gfc_conv_string_parameter (&se
);
835 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
836 gfc_add_modify (&se
.pre
, len
, se
.string_length
);
839 gfc_add_block_to_block (block
, &se
.pre
);
840 gfc_add_block_to_block (postblock
, &se
.post
);
845 /* Generate code to store the character (array) and the character length
846 for an internal unit. */
849 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
850 tree var
, gfc_expr
* e
)
857 gfc_st_parameter_field
*p
;
860 gfc_init_se (&se
, NULL
);
862 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
864 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
865 var
, p
->field
, NULL_TREE
);
866 len
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field_len
),
867 var
, p
->field_len
, NULL_TREE
);
868 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
869 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
870 var
, p
->field
, NULL_TREE
);
872 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
874 /* Character scalars. */
877 gfc_conv_expr (&se
, e
);
878 gfc_conv_string_parameter (&se
);
880 se
.expr
= build_int_cst (pchar_type_node
, 0);
883 /* Character array. */
884 else if (e
->rank
> 0)
886 if (is_subref_array (e
))
888 /* Use a temporary for components of arrays of derived types
889 or substring array references. */
890 gfc_conv_subref_array_arg (&se
, e
, 0,
891 last_dt
== READ
? INTENT_IN
: INTENT_OUT
, false);
892 tmp
= build_fold_indirect_ref_loc (input_location
,
894 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
895 tmp
= gfc_conv_descriptor_data_get (tmp
);
899 /* Return the data pointer and rank from the descriptor. */
900 gfc_conv_expr_descriptor (&se
, e
);
901 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
902 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
908 /* The cast is needed for character substrings and the descriptor
910 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
911 gfc_add_modify (&se
.pre
, len
,
912 fold_convert (TREE_TYPE (len
), se
.string_length
));
913 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
915 gfc_add_block_to_block (block
, &se
.pre
);
916 gfc_add_block_to_block (post_block
, &se
.post
);
920 /* Add a case to a IO-result switch. */
923 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
928 return; /* No label, no case */
930 value
= build_int_cst (integer_type_node
, label_value
);
932 /* Make a backend label for this case. */
933 tmp
= gfc_build_label_decl (NULL_TREE
);
935 /* And the case itself. */
936 tmp
= build_case_label (value
, NULL_TREE
, tmp
);
937 gfc_add_expr_to_block (body
, tmp
);
939 /* Jump to the label. */
940 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
941 gfc_add_expr_to_block (body
, tmp
);
945 /* Generate a switch statement that branches to the correct I/O
946 result label. The last statement of an I/O call stores the
947 result into a variable because there is often cleanup that
948 must be done before the switch, so a temporary would have to
949 be created anyway. */
952 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
953 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
957 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
959 /* If no labels are specified, ignore the result instead
960 of building an empty switch. */
961 if (err_label
== NULL
963 && eor_label
== NULL
)
966 /* Build a switch statement. */
967 gfc_start_block (&body
);
969 /* The label values here must be the same as the values
970 in the library_return enum in the runtime library */
971 add_case (1, err_label
, &body
);
972 add_case (2, end_label
, &body
);
973 add_case (3, eor_label
, &body
);
975 tmp
= gfc_finish_block (&body
);
977 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
978 st_parameter
[IOPARM_ptype_common
].type
,
979 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
980 rc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
981 var
, p
->field
, NULL_TREE
);
982 rc
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (rc
),
983 rc
, build_int_cst (TREE_TYPE (rc
),
984 IOPARM_common_libreturn_mask
));
986 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
989 gfc_add_expr_to_block (block
, tmp
);
993 /* Store the current file and line number to variables so that if a
994 library call goes awry, we can tell the user where the problem is. */
997 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
1000 tree str
, locus_file
;
1002 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
1004 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
1005 st_parameter
[IOPARM_ptype_common
].type
,
1006 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
1007 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
1008 TREE_TYPE (p
->field
), locus_file
,
1009 p
->field
, NULL_TREE
);
1010 f
= where
->lb
->file
;
1011 str
= gfc_build_cstring_const (f
->filename
);
1013 str
= gfc_build_addr_expr (pchar_type_node
, str
);
1014 gfc_add_modify (block
, locus_file
, str
);
1016 line
= LOCATION_LINE (where
->lb
->location
);
1017 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
1021 /* Translate an OPEN statement. */
1024 gfc_trans_open (gfc_code
* code
)
1026 stmtblock_t block
, post_block
;
1029 unsigned int mask
= 0;
1031 gfc_start_block (&block
);
1032 gfc_init_block (&post_block
);
1034 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
1036 set_error_locus (&block
, var
, &code
->loc
);
1040 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1044 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1048 mask
|= IOPARM_common_err
;
1051 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
1054 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
1058 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
1062 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
1065 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
,
1069 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
1073 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
1077 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
1081 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
1085 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
1088 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
1092 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
1096 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
1099 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
1101 if (p
->asynchronous
)
1102 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
1106 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
1110 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_open_newunit
,
1113 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1116 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_unit
, p
->unit
);
1118 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1120 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1121 tmp
= build_call_expr_loc (input_location
,
1122 iocall
[IOCALL_OPEN
], 1, tmp
);
1123 gfc_add_expr_to_block (&block
, tmp
);
1125 gfc_add_block_to_block (&block
, &post_block
);
1127 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1129 return gfc_finish_block (&block
);
1133 /* Translate a CLOSE statement. */
1136 gfc_trans_close (gfc_code
* code
)
1138 stmtblock_t block
, post_block
;
1141 unsigned int mask
= 0;
1143 gfc_start_block (&block
);
1144 gfc_init_block (&post_block
);
1146 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
1148 set_error_locus (&block
, var
, &code
->loc
);
1149 p
= code
->ext
.close
;
1152 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1156 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1160 mask
|= IOPARM_common_err
;
1163 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
1166 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1169 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_unit
, p
->unit
);
1171 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1173 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1174 tmp
= build_call_expr_loc (input_location
,
1175 iocall
[IOCALL_CLOSE
], 1, tmp
);
1176 gfc_add_expr_to_block (&block
, tmp
);
1178 gfc_add_block_to_block (&block
, &post_block
);
1180 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1182 return gfc_finish_block (&block
);
1186 /* Common subroutine for building a file positioning statement. */
1189 build_filepos (tree function
, gfc_code
* code
)
1191 stmtblock_t block
, post_block
;
1194 unsigned int mask
= 0;
1196 p
= code
->ext
.filepos
;
1198 gfc_start_block (&block
);
1199 gfc_init_block (&post_block
);
1201 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1204 set_error_locus (&block
, var
, &code
->loc
);
1207 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1211 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1212 IOPARM_common_iostat
, p
->iostat
);
1215 mask
|= IOPARM_common_err
;
1217 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1220 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_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
,
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 /* Translate a BACKSPACE statement. */
1241 gfc_trans_backspace (gfc_code
* code
)
1243 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1247 /* Translate an ENDFILE statement. */
1250 gfc_trans_endfile (gfc_code
* code
)
1252 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1256 /* Translate a REWIND statement. */
1259 gfc_trans_rewind (gfc_code
* code
)
1261 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1265 /* Translate a FLUSH statement. */
1268 gfc_trans_flush (gfc_code
* code
)
1270 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1274 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1277 gfc_trans_inquire (gfc_code
* code
)
1279 stmtblock_t block
, post_block
;
1282 unsigned int mask
= 0, mask2
= 0;
1284 gfc_start_block (&block
);
1285 gfc_init_block (&post_block
);
1287 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1290 set_error_locus (&block
, var
, &code
->loc
);
1291 p
= code
->ext
.inquire
;
1294 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1298 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1302 mask
|= IOPARM_common_err
;
1305 if (p
->unit
&& p
->file
)
1306 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1309 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1313 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1317 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1321 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1325 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1329 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1333 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1337 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1341 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1345 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1349 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1353 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1357 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1358 IOPARM_inquire_recl_out
, p
->recl
);
1361 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1362 IOPARM_inquire_nextrec
, p
->nextrec
);
1365 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1369 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1373 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1377 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1381 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1385 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1389 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1393 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1397 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1401 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1402 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1404 /* The second series of flags. */
1405 if (p
->asynchronous
)
1406 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1410 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1414 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1418 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1422 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1426 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1427 IOPARM_inquire_pending
, p
->pending
);
1430 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1434 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1437 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_iqstream
,
1441 mask
|= set_parameter_const (&block
, var
, IOPARM_inquire_flags2
, mask2
);
1443 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1447 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1448 set_parameter_value_inquire (&block
, var
, IOPARM_common_unit
, p
->unit
);
1451 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1453 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1454 tmp
= build_call_expr_loc (input_location
,
1455 iocall
[IOCALL_INQUIRE
], 1, tmp
);
1456 gfc_add_expr_to_block (&block
, tmp
);
1458 gfc_add_block_to_block (&block
, &post_block
);
1460 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1462 return gfc_finish_block (&block
);
1467 gfc_trans_wait (gfc_code
* code
)
1469 stmtblock_t block
, post_block
;
1472 unsigned int mask
= 0;
1474 gfc_start_block (&block
);
1475 gfc_init_block (&post_block
);
1477 var
= gfc_create_var (st_parameter
[IOPARM_ptype_wait
].type
,
1480 set_error_locus (&block
, var
, &code
->loc
);
1483 /* Set parameters here. */
1485 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1489 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1493 mask
|= IOPARM_common_err
;
1496 mask
|= set_parameter_value (&block
, var
, IOPARM_wait_id
, p
->id
);
1498 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1501 set_parameter_value_chk (&block
, p
->iostat
, var
, IOPARM_common_unit
, p
->unit
);
1503 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1504 tmp
= build_call_expr_loc (input_location
,
1505 iocall
[IOCALL_WAIT
], 1, tmp
);
1506 gfc_add_expr_to_block (&block
, tmp
);
1508 gfc_add_block_to_block (&block
, &post_block
);
1510 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1512 return gfc_finish_block (&block
);
1517 /* nml_full_name builds up the fully qualified name of a
1518 derived type component. '+' is used to denote a type extension. */
1521 nml_full_name (const char* var_name
, const char* cmp_name
, bool parent
)
1523 int full_name_length
;
1526 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1527 full_name
= XCNEWVEC (char, full_name_length
+ 1);
1528 strcpy (full_name
, var_name
);
1529 full_name
= strcat (full_name
, parent
? "+" : "%");
1530 full_name
= strcat (full_name
, cmp_name
);
1535 /* nml_get_addr_expr builds an address expression from the
1536 gfc_symbol or gfc_component backend_decl's. An offset is
1537 provided so that the address of an element of an array of
1538 derived types is returned. This is used in the runtime to
1539 determine that span of the derived type. */
1542 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1545 tree decl
= NULL_TREE
;
1550 sym
->attr
.referenced
= 1;
1551 decl
= gfc_get_symbol_decl (sym
);
1553 /* If this is the enclosing function declaration, use
1554 the fake result instead. */
1555 if (decl
== current_function_decl
)
1556 decl
= gfc_get_fake_result_decl (sym
, 0);
1557 else if (decl
== DECL_CONTEXT (current_function_decl
))
1558 decl
= gfc_get_fake_result_decl (sym
, 1);
1561 decl
= c
->backend_decl
;
1563 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1564 || TREE_CODE (decl
) == VAR_DECL
1565 || TREE_CODE (decl
) == PARM_DECL
)
1566 || TREE_CODE (decl
) == COMPONENT_REF
));
1570 /* Build indirect reference, if dummy argument. */
1572 if (POINTER_TYPE_P (TREE_TYPE(tmp
)))
1573 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1575 /* Treat the component of a derived type, using base_addr for
1576 the derived type. */
1578 if (TREE_CODE (decl
) == FIELD_DECL
)
1579 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
1580 base_addr
, tmp
, NULL_TREE
);
1582 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
1583 tmp
= gfc_conv_array_data (tmp
);
1586 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1587 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1589 if (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1590 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1592 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1593 tmp
= build_fold_indirect_ref_loc (input_location
,
1597 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1603 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1604 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1605 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1607 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1610 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1611 gfc_symbol
* sym
, gfc_component
* c
,
1614 gfc_typespec
* ts
= NULL
;
1615 gfc_array_spec
* as
= NULL
;
1616 tree addr_expr
= NULL
;
1622 tree decl
= NULL_TREE
;
1623 tree gfc_int4_type_node
= gfc_get_int_type (4);
1628 gcc_assert (sym
|| c
);
1630 /* Build the namelist object name. */
1632 string
= gfc_build_cstring_const (var_name
);
1633 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1635 /* Build ts, as and data address using symbol or component. */
1637 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1638 as
= (sym
) ? sym
->as
: c
->as
;
1640 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1647 decl
= (sym
) ? sym
->backend_decl
: c
->backend_decl
;
1648 if (sym
&& sym
->attr
.dummy
)
1649 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
1650 dt
= TREE_TYPE (decl
);
1651 dtype
= gfc_get_dtype (dt
);
1656 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1659 /* Build up the arguments for the transfer call.
1660 The call for the scalar part transfers:
1661 (address, name, type, kind or string_length, dtype) */
1663 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1665 if (ts
->type
== BT_CHARACTER
)
1666 tmp
= ts
->u
.cl
->backend_decl
;
1668 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1669 tmp
= build_call_expr_loc (input_location
,
1670 iocall
[IOCALL_SET_NML_VAL
], 6,
1671 dt_parm_addr
, addr_expr
, string
,
1672 build_int_cst (gfc_int4_type_node
, ts
->kind
),
1674 gfc_add_expr_to_block (block
, tmp
);
1676 /* If the object is an array, transfer rank times:
1677 (null pointer, name, stride, lbound, ubound) */
1679 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1681 tmp
= build_call_expr_loc (input_location
,
1682 iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1684 build_int_cst (gfc_int4_type_node
, n_dim
),
1685 gfc_conv_array_stride (decl
, n_dim
),
1686 gfc_conv_array_lbound (decl
, n_dim
),
1687 gfc_conv_array_ubound (decl
, n_dim
));
1688 gfc_add_expr_to_block (block
, tmp
);
1691 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->components
)
1695 /* Provide the RECORD_TYPE to build component references. */
1697 tree expr
= build_fold_indirect_ref_loc (input_location
,
1700 for (cmp
= ts
->u
.derived
->components
; cmp
; cmp
= cmp
->next
)
1702 char *full_name
= nml_full_name (var_name
, cmp
->name
,
1703 ts
->u
.derived
->attr
.extension
);
1704 transfer_namelist_element (block
,
1714 /* Create a data transfer statement. Not all of the fields are valid
1715 for both reading and writing, but improper use has been filtered
1719 build_dt (tree function
, gfc_code
* code
)
1721 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1726 unsigned int mask
= 0;
1728 gfc_start_block (&block
);
1729 gfc_init_block (&post_block
);
1730 gfc_init_block (&post_end_block
);
1731 gfc_init_block (&post_iu_block
);
1733 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1735 set_error_locus (&block
, var
, &code
->loc
);
1737 if (last_dt
== IOLENGTH
)
1741 inq
= code
->ext
.inquire
;
1743 /* First check that preconditions are met. */
1744 gcc_assert (inq
!= NULL
);
1745 gcc_assert (inq
->iolength
!= NULL
);
1747 /* Connect to the iolength variable. */
1748 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1749 IOPARM_dt_iolength
, inq
->iolength
);
1755 gcc_assert (dt
!= NULL
);
1758 if (dt
&& dt
->io_unit
)
1760 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1762 mask
|= set_internal_unit (&block
, &post_iu_block
,
1764 set_parameter_const (&block
, var
, IOPARM_common_unit
,
1765 dt
->io_unit
->ts
.kind
== 1 ? 0 : -1);
1769 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1774 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1778 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1779 IOPARM_common_iostat
, dt
->iostat
);
1782 mask
|= IOPARM_common_err
;
1785 mask
|= IOPARM_common_eor
;
1788 mask
|= IOPARM_common_end
;
1791 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1792 IOPARM_dt_id
, dt
->id
);
1795 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1797 if (dt
->asynchronous
)
1798 mask
|= set_string (&block
, &post_block
, var
,
1799 IOPARM_dt_asynchronous
, dt
->asynchronous
);
1802 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1806 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1810 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1814 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1818 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1822 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1826 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1829 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1832 if (dt
->format_expr
)
1833 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1836 if (dt
->format_label
)
1838 if (dt
->format_label
== &format_asterisk
)
1839 mask
|= IOPARM_dt_list_format
;
1841 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1842 dt
->format_label
->format
);
1846 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1847 IOPARM_dt_size
, dt
->size
);
1851 if (dt
->format_expr
|| dt
->format_label
)
1852 gfc_internal_error ("build_dt: format with namelist");
1854 nmlname
= gfc_get_character_expr (gfc_default_character_kind
, NULL
,
1856 strlen (dt
->namelist
->name
));
1858 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1861 gfc_free_expr (nmlname
);
1863 if (last_dt
== READ
)
1864 mask
|= IOPARM_dt_namelist_read_mode
;
1866 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1870 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1871 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1875 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1877 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1878 set_parameter_value_chk (&block
, dt
->iostat
, var
,
1879 IOPARM_common_unit
, dt
->io_unit
);
1882 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1884 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1885 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
1887 gfc_add_expr_to_block (&block
, tmp
);
1889 gfc_add_block_to_block (&block
, &post_block
);
1892 dt_post_end_block
= &post_end_block
;
1894 /* Set implied do loop exit condition. */
1895 if (last_dt
== READ
|| last_dt
== WRITE
)
1897 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
1899 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1900 st_parameter
[IOPARM_ptype_common
].type
,
1901 dt_parm
, TYPE_FIELDS (TREE_TYPE (dt_parm
)),
1903 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1904 TREE_TYPE (p
->field
), tmp
, p
->field
, NULL_TREE
);
1905 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (tmp
),
1906 tmp
, build_int_cst (TREE_TYPE (tmp
),
1907 IOPARM_common_libreturn_mask
));
1912 gfc_add_expr_to_block (&block
, gfc_trans_code_cond (code
->block
->next
, tmp
));
1914 gfc_add_block_to_block (&block
, &post_iu_block
);
1917 dt_post_end_block
= NULL
;
1919 return gfc_finish_block (&block
);
1923 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1924 this as a third sort of data transfer statement, except that
1925 lengths are summed instead of actually transferring any data. */
1928 gfc_trans_iolength (gfc_code
* code
)
1931 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1935 /* Translate a READ statement. */
1938 gfc_trans_read (gfc_code
* code
)
1941 return build_dt (iocall
[IOCALL_READ
], code
);
1945 /* Translate a WRITE statement */
1948 gfc_trans_write (gfc_code
* code
)
1951 return build_dt (iocall
[IOCALL_WRITE
], code
);
1955 /* Finish a data transfer statement. */
1958 gfc_trans_dt_end (gfc_code
* code
)
1963 gfc_init_block (&block
);
1968 function
= iocall
[IOCALL_READ_DONE
];
1972 function
= iocall
[IOCALL_WRITE_DONE
];
1976 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1983 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1984 tmp
= build_call_expr_loc (input_location
,
1986 gfc_add_expr_to_block (&block
, tmp
);
1987 gfc_add_block_to_block (&block
, dt_post_end_block
);
1988 gfc_init_block (dt_post_end_block
);
1990 if (last_dt
!= IOLENGTH
)
1992 gcc_assert (code
->ext
.dt
!= NULL
);
1993 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1994 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1997 return gfc_finish_block (&block
);
2001 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
2003 /* Given an array field in a derived type variable, generate the code
2004 for the loop that iterates over array elements, and the code that
2005 accesses those array elements. Use transfer_expr to generate code
2006 for transferring that element. Because elements may also be
2007 derived types, transfer_expr and transfer_array_component are mutually
2011 transfer_array_component (tree expr
, gfc_component
* cm
, locus
* where
)
2020 gfc_array_info
*ss_array
;
2022 gfc_start_block (&block
);
2023 gfc_init_se (&se
, NULL
);
2025 /* Create and initialize Scalarization Status. Unlike in
2026 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2027 care of this task, because we don't have a gfc_expr at hand.
2028 Build one manually, as in gfc_trans_subarray_assign. */
2030 ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
2032 ss_array
= &ss
->info
->data
.array
;
2033 ss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
2034 ss_array
->descriptor
= expr
;
2035 ss_array
->data
= gfc_conv_array_data (expr
);
2036 ss_array
->offset
= gfc_conv_array_offset (expr
);
2037 for (n
= 0; n
< cm
->as
->rank
; n
++)
2039 ss_array
->start
[n
] = gfc_conv_array_lbound (expr
, n
);
2040 ss_array
->stride
[n
] = gfc_index_one_node
;
2042 mpz_init (ss_array
->shape
[n
]);
2043 mpz_sub (ss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2044 cm
->as
->lower
[n
]->value
.integer
);
2045 mpz_add_ui (ss_array
->shape
[n
], ss_array
->shape
[n
], 1);
2048 /* Once we got ss, we use scalarizer to create the loop. */
2050 gfc_init_loopinfo (&loop
);
2051 gfc_add_ss_to_loop (&loop
, ss
);
2052 gfc_conv_ss_startstride (&loop
);
2053 gfc_conv_loop_setup (&loop
, where
);
2054 gfc_mark_ss_chain_used (ss
, 1);
2055 gfc_start_scalarized_body (&loop
, &body
);
2057 gfc_copy_loopinfo_to_se (&se
, &loop
);
2060 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2062 gfc_conv_tmp_array_ref (&se
);
2064 /* Now se.expr contains an element of the array. Take the address and pass
2065 it to the IO routines. */
2066 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2067 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
2069 /* We are done now with the loop body. Wrap up the scalarizer and
2072 gfc_add_block_to_block (&body
, &se
.pre
);
2073 gfc_add_block_to_block (&body
, &se
.post
);
2075 gfc_trans_scalarizing_loops (&loop
, &body
);
2077 gfc_add_block_to_block (&block
, &loop
.pre
);
2078 gfc_add_block_to_block (&block
, &loop
.post
);
2080 gcc_assert (ss_array
->shape
!= NULL
);
2081 gfc_free_shape (&ss_array
->shape
, cm
->as
->rank
);
2082 gfc_cleanup_loop (&loop
);
2084 return gfc_finish_block (&block
);
2087 /* Generate the call for a scalar transfer node. */
2090 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
2092 tree tmp
, function
, arg2
, arg3
, field
, expr
;
2096 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2097 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2098 We need to translate the expression to a constant if it's either
2099 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2100 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2101 BT_DERIVED (could have been changed by gfc_conv_expr). */
2102 if ((ts
->type
== BT_DERIVED
|| ts
->type
== BT_INTEGER
)
2103 && ts
->u
.derived
!= NULL
2104 && (ts
->is_iso_c
== 1 || ts
->u
.derived
->ts
.is_iso_c
== 1))
2106 ts
->type
= BT_INTEGER
;
2107 ts
->kind
= gfc_index_integer_kind
;
2118 arg2
= build_int_cst (integer_type_node
, kind
);
2119 if (last_dt
== READ
)
2120 function
= iocall
[IOCALL_X_INTEGER
];
2122 function
= iocall
[IOCALL_X_INTEGER_WRITE
];
2127 arg2
= build_int_cst (integer_type_node
, kind
);
2128 if (last_dt
== READ
)
2130 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2131 function
= iocall
[IOCALL_X_REAL128
];
2133 function
= iocall
[IOCALL_X_REAL
];
2137 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2138 function
= iocall
[IOCALL_X_REAL128_WRITE
];
2140 function
= iocall
[IOCALL_X_REAL_WRITE
];
2146 arg2
= build_int_cst (integer_type_node
, kind
);
2147 if (last_dt
== READ
)
2149 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2150 function
= iocall
[IOCALL_X_COMPLEX128
];
2152 function
= iocall
[IOCALL_X_COMPLEX
];
2156 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2157 function
= iocall
[IOCALL_X_COMPLEX128_WRITE
];
2159 function
= iocall
[IOCALL_X_COMPLEX_WRITE
];
2165 arg2
= build_int_cst (integer_type_node
, kind
);
2166 if (last_dt
== READ
)
2167 function
= iocall
[IOCALL_X_LOGICAL
];
2169 function
= iocall
[IOCALL_X_LOGICAL_WRITE
];
2176 if (se
->string_length
)
2177 arg2
= se
->string_length
;
2180 tmp
= build_fold_indirect_ref_loc (input_location
,
2182 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2183 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2184 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2186 arg3
= build_int_cst (integer_type_node
, kind
);
2187 if (last_dt
== READ
)
2188 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2190 function
= iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
];
2192 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2193 tmp
= build_call_expr_loc (input_location
,
2194 function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2195 gfc_add_expr_to_block (&se
->pre
, tmp
);
2196 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2201 if (se
->string_length
)
2202 arg2
= se
->string_length
;
2205 tmp
= build_fold_indirect_ref_loc (input_location
,
2207 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2208 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2210 if (last_dt
== READ
)
2211 function
= iocall
[IOCALL_X_CHARACTER
];
2213 function
= iocall
[IOCALL_X_CHARACTER_WRITE
];
2218 if (ts
->u
.derived
->components
== NULL
)
2221 /* Recurse into the elements of the derived type. */
2222 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2223 expr
= build_fold_indirect_ref_loc (input_location
,
2226 /* Make sure that the derived type has been built. An external
2227 function, if only referenced in an io statement, requires this
2228 check (see PR58771). */
2229 if (ts
->u
.derived
->backend_decl
== NULL_TREE
)
2230 (void) gfc_typenode_for_spec (ts
);
2232 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
2234 field
= c
->backend_decl
;
2235 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2237 tmp
= fold_build3_loc (UNKNOWN_LOCATION
,
2238 COMPONENT_REF
, TREE_TYPE (field
),
2239 expr
, field
, NULL_TREE
);
2241 if (c
->attr
.dimension
)
2243 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2244 gfc_add_expr_to_block (&se
->pre
, tmp
);
2248 if (!c
->attr
.pointer
)
2249 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2250 transfer_expr (se
, &c
->ts
, tmp
, code
);
2256 gfc_internal_error ("Bad IO basetype (%d)", ts
->type
);
2259 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2260 tmp
= build_call_expr_loc (input_location
,
2261 function
, 3, tmp
, addr_expr
, arg2
);
2262 gfc_add_expr_to_block (&se
->pre
, tmp
);
2263 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2268 /* Generate a call to pass an array descriptor to the IO library. The
2269 array should be of one of the intrinsic types. */
2272 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2274 tree tmp
, charlen_arg
, kind_arg
, io_call
;
2276 if (ts
->type
== BT_CHARACTER
)
2277 charlen_arg
= se
->string_length
;
2279 charlen_arg
= build_int_cst (gfc_charlen_type_node
, 0);
2281 kind_arg
= build_int_cst (integer_type_node
, ts
->kind
);
2283 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2284 if (last_dt
== READ
)
2285 io_call
= iocall
[IOCALL_X_ARRAY
];
2287 io_call
= iocall
[IOCALL_X_ARRAY_WRITE
];
2289 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2291 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2292 gfc_add_expr_to_block (&se
->pre
, tmp
);
2293 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2297 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2300 gfc_trans_transfer (gfc_code
* code
)
2302 stmtblock_t block
, body
;
2311 gfc_start_block (&block
);
2312 gfc_init_block (&body
);
2316 gfc_init_se (&se
, NULL
);
2318 if (expr
->rank
== 0)
2320 /* Transfer a scalar value. */
2321 gfc_conv_expr_reference (&se
, expr
);
2322 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2326 /* Transfer an array. If it is an array of an intrinsic
2327 type, pass the descriptor to the library. Otherwise
2328 scalarize the transfer. */
2329 if (expr
->ref
&& !gfc_is_proc_ptr_comp (expr
))
2331 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2333 gcc_assert (ref
&& ref
->type
== REF_ARRAY
);
2336 if (expr
->ts
.type
!= BT_DERIVED
2337 && ref
&& ref
->next
== NULL
2338 && !is_subref_array (expr
))
2340 bool seen_vector
= false;
2342 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2344 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2345 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2352 if (seen_vector
&& last_dt
== READ
)
2354 /* Create a temp, read to that and copy it back. */
2355 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
, false);
2360 /* Get the descriptor. */
2361 gfc_conv_expr_descriptor (&se
, expr
);
2362 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2365 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2366 goto finish_block_label
;
2369 /* Initialize the scalarizer. */
2370 ss
= gfc_walk_expr (expr
);
2371 gfc_init_loopinfo (&loop
);
2372 gfc_add_ss_to_loop (&loop
, ss
);
2374 /* Initialize the loop. */
2375 gfc_conv_ss_startstride (&loop
);
2376 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
2378 /* The main loop body. */
2379 gfc_mark_ss_chain_used (ss
, 1);
2380 gfc_start_scalarized_body (&loop
, &body
);
2382 gfc_copy_loopinfo_to_se (&se
, &loop
);
2385 gfc_conv_expr_reference (&se
, expr
);
2386 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2391 gfc_add_block_to_block (&body
, &se
.pre
);
2392 gfc_add_block_to_block (&body
, &se
.post
);
2395 tmp
= gfc_finish_block (&body
);
2398 gcc_assert (expr
->rank
!= 0);
2399 gcc_assert (se
.ss
== gfc_ss_terminator
);
2400 gfc_trans_scalarizing_loops (&loop
, &body
);
2402 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2403 tmp
= gfc_finish_block (&loop
.pre
);
2404 gfc_cleanup_loop (&loop
);
2407 gfc_add_expr_to_block (&block
, tmp
);
2409 return gfc_finish_block (&block
);
2412 #include "gt-fortran-trans-io.h"