1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
28 #include "diagnostic-core.h" /* For internal_error. */
31 #include "trans-stmt.h"
32 #include "trans-array.h"
33 #include "trans-types.h"
34 #include "trans-const.h"
36 /* Members of the ioparm structure. */
65 typedef struct GTY(()) gfc_st_parameter_field
{
68 enum ioparam_type param_type
;
69 enum iofield_type type
;
73 gfc_st_parameter_field
;
75 typedef struct GTY(()) gfc_st_parameter
{
83 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
89 static GTY(()) gfc_st_parameter st_parameter
[] =
100 static GTY(()) gfc_st_parameter_field st_parameter_field
[] =
102 #define IOPARM(param_type, name, mask, type) \
103 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
104 #include "ioparm.def"
106 { NULL
, 0, (enum ioparam_type
) 0, (enum iofield_type
) 0, NULL
, NULL
}
109 /* Library I/O subroutines */
118 IOCALL_X_INTEGER_WRITE
,
120 IOCALL_X_LOGICAL_WRITE
,
122 IOCALL_X_CHARACTER_WRITE
,
123 IOCALL_X_CHARACTER_WIDE
,
124 IOCALL_X_CHARACTER_WIDE_WRITE
,
128 IOCALL_X_COMPLEX_WRITE
,
130 IOCALL_X_REAL128_WRITE
,
132 IOCALL_X_COMPLEX128_WRITE
,
134 IOCALL_X_ARRAY_WRITE
,
139 IOCALL_IOLENGTH_DONE
,
145 IOCALL_SET_NML_VAL_DIM
,
150 static GTY(()) tree iocall
[IOCALL_NUM
];
152 /* Variable for keeping track of what the last data transfer statement
153 was. Used for deciding which subroutine to call when the data
154 transfer is complete. */
155 static enum { READ
, WRITE
, IOLENGTH
} last_dt
;
157 /* The data transfer parameter block that should be shared by all
158 data transfer calls belonging to the same read/write/iolength. */
159 static GTY(()) tree dt_parm
;
160 static stmtblock_t
*dt_post_end_block
;
163 gfc_build_st_parameter (enum ioparam_type ptype
, tree
*types
)
166 gfc_st_parameter_field
*p
;
169 tree t
= make_node (RECORD_TYPE
);
172 len
= strlen (st_parameter
[ptype
].name
);
173 gcc_assert (len
<= sizeof (name
) - sizeof ("__st_parameter_"));
174 memcpy (name
, "__st_parameter_", sizeof ("__st_parameter_"));
175 memcpy (name
+ sizeof ("__st_parameter_") - 1, st_parameter
[ptype
].name
,
177 TYPE_NAME (t
) = get_identifier (name
);
179 for (type
= 0, p
= st_parameter_field
; type
< IOPARM_field_num
; type
++, p
++)
180 if (p
->param_type
== ptype
)
183 case IOPARM_type_int4
:
184 case IOPARM_type_intio
:
185 case IOPARM_type_pint4
:
186 case IOPARM_type_pintio
:
187 case IOPARM_type_parray
:
188 case IOPARM_type_pchar
:
189 case IOPARM_type_pad
:
190 p
->field
= gfc_add_field_to_struct (t
, get_identifier (p
->name
),
191 types
[p
->type
], &chain
);
193 case IOPARM_type_char1
:
194 p
->field
= gfc_add_field_to_struct (t
, get_identifier (p
->name
),
195 pchar_type_node
, &chain
);
197 case IOPARM_type_char2
:
198 len
= strlen (p
->name
);
199 gcc_assert (len
<= sizeof (name
) - sizeof ("_len"));
200 memcpy (name
, p
->name
, len
);
201 memcpy (name
+ len
, "_len", sizeof ("_len"));
202 p
->field_len
= gfc_add_field_to_struct (t
, get_identifier (name
),
203 gfc_charlen_type_node
,
205 if (p
->type
== IOPARM_type_char2
)
206 p
->field
= gfc_add_field_to_struct (t
, get_identifier (p
->name
),
207 pchar_type_node
, &chain
);
209 case IOPARM_type_common
:
211 = gfc_add_field_to_struct (t
,
212 get_identifier (p
->name
),
213 st_parameter
[IOPARM_ptype_common
].type
,
216 case IOPARM_type_num
:
221 st_parameter
[ptype
].type
= t
;
225 /* Build code to test an error condition and call generate_error if needed.
226 Note: This builds calls to generate_error in the runtime library function.
227 The function generate_error is dependent on certain parameters in the
228 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
229 Therefore, the code to set these flags must be generated before
230 this function is used. */
233 gfc_trans_io_runtime_check (tree cond
, tree var
, int error_code
,
234 const char * msgid
, stmtblock_t
* pblock
)
239 tree arg1
, arg2
, arg3
;
242 if (integer_zerop (cond
))
245 /* The code to generate the error. */
246 gfc_start_block (&block
);
248 arg1
= gfc_build_addr_expr (NULL_TREE
, var
);
250 arg2
= build_int_cst (integer_type_node
, error_code
),
252 asprintf (&message
, "%s", _(msgid
));
253 arg3
= gfc_build_addr_expr (pchar_type_node
,
254 gfc_build_localized_cstring_const (message
));
257 tmp
= build_call_expr_loc (input_location
,
258 gfor_fndecl_generate_error
, 3, arg1
, arg2
, arg3
);
260 gfc_add_expr_to_block (&block
, tmp
);
262 body
= gfc_finish_block (&block
);
264 if (integer_onep (cond
))
266 gfc_add_expr_to_block (pblock
, body
);
270 /* Tell the compiler that this isn't likely. */
271 cond
= fold_convert (long_integer_type_node
, cond
);
272 tmp
= build_int_cst (long_integer_type_node
, 0);
273 cond
= build_call_expr_loc (input_location
,
274 built_in_decls
[BUILT_IN_EXPECT
], 2, cond
, tmp
);
275 cond
= fold_convert (boolean_type_node
, cond
);
277 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt (input_location
));
278 gfc_add_expr_to_block (pblock
, tmp
);
283 /* Create function decls for IO library functions. */
286 gfc_build_io_library_fndecls (void)
288 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
289 tree gfc_intio_type_node
;
290 tree parm_type
, dt_parm_type
;
291 HOST_WIDE_INT pad_size
;
294 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
295 types
[IOPARM_type_intio
] = gfc_intio_type_node
296 = gfc_get_int_type (gfc_intio_kind
);
297 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
298 types
[IOPARM_type_pintio
]
299 = build_pointer_type (gfc_intio_type_node
);
300 types
[IOPARM_type_parray
] = pchar_type_node
;
301 types
[IOPARM_type_pchar
] = pchar_type_node
;
302 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
303 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
304 pad_idx
= build_index_type (build_int_cst (NULL_TREE
, pad_size
- 1));
305 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
307 /* pad actually contains pointers and integers so it needs to have an
308 alignment that is at least as large as the needed alignment for those
309 types. See the st_parameter_dt structure in libgfortran/io/io.h for
310 what really goes into this space. */
311 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
312 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind
)));
314 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
315 gfc_build_st_parameter ((enum ioparam_type
) ptype
, types
);
317 /* Define the transfer functions. */
319 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
321 iocall
[IOCALL_X_INTEGER
] = gfc_build_library_function_decl_with_spec (
322 get_identifier (PREFIX("transfer_integer")), ".wW",
323 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
325 iocall
[IOCALL_X_INTEGER_WRITE
] = gfc_build_library_function_decl_with_spec (
326 get_identifier (PREFIX("transfer_integer_write")), ".wR",
327 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
329 iocall
[IOCALL_X_LOGICAL
] = gfc_build_library_function_decl_with_spec (
330 get_identifier (PREFIX("transfer_logical")), ".wW",
331 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
333 iocall
[IOCALL_X_LOGICAL_WRITE
] = gfc_build_library_function_decl_with_spec (
334 get_identifier (PREFIX("transfer_logical_write")), ".wR",
335 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
337 iocall
[IOCALL_X_CHARACTER
] = gfc_build_library_function_decl_with_spec (
338 get_identifier (PREFIX("transfer_character")), ".wW",
339 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
341 iocall
[IOCALL_X_CHARACTER_WRITE
] = gfc_build_library_function_decl_with_spec (
342 get_identifier (PREFIX("transfer_character_write")), ".wR",
343 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
345 iocall
[IOCALL_X_CHARACTER_WIDE
] = gfc_build_library_function_decl_with_spec (
346 get_identifier (PREFIX("transfer_character_wide")), ".wW",
347 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
348 gfc_charlen_type_node
, gfc_int4_type_node
);
350 iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
] =
351 gfc_build_library_function_decl_with_spec (
352 get_identifier (PREFIX("transfer_character_wide_write")), ".wR",
353 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
354 gfc_charlen_type_node
, gfc_int4_type_node
);
356 iocall
[IOCALL_X_REAL
] = gfc_build_library_function_decl_with_spec (
357 get_identifier (PREFIX("transfer_real")), ".wW",
358 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
360 iocall
[IOCALL_X_REAL_WRITE
] = gfc_build_library_function_decl_with_spec (
361 get_identifier (PREFIX("transfer_real_write")), ".wR",
362 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
364 iocall
[IOCALL_X_COMPLEX
] = gfc_build_library_function_decl_with_spec (
365 get_identifier (PREFIX("transfer_complex")), ".wW",
366 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
368 iocall
[IOCALL_X_COMPLEX_WRITE
] = gfc_build_library_function_decl_with_spec (
369 get_identifier (PREFIX("transfer_complex_write")), ".wR",
370 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
372 /* Version for __float128. */
373 iocall
[IOCALL_X_REAL128
] = gfc_build_library_function_decl_with_spec (
374 get_identifier (PREFIX("transfer_real128")), ".wW",
375 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
377 iocall
[IOCALL_X_REAL128_WRITE
] = gfc_build_library_function_decl_with_spec (
378 get_identifier (PREFIX("transfer_real128_write")), ".wR",
379 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
381 iocall
[IOCALL_X_COMPLEX128
] = gfc_build_library_function_decl_with_spec (
382 get_identifier (PREFIX("transfer_complex128")), ".wW",
383 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
385 iocall
[IOCALL_X_COMPLEX128_WRITE
] = gfc_build_library_function_decl_with_spec (
386 get_identifier (PREFIX("transfer_complex128_write")), ".wR",
387 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
389 iocall
[IOCALL_X_ARRAY
] = gfc_build_library_function_decl_with_spec (
390 get_identifier (PREFIX("transfer_array")), ".ww",
391 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
392 integer_type_node
, gfc_charlen_type_node
);
394 iocall
[IOCALL_X_ARRAY_WRITE
] = gfc_build_library_function_decl_with_spec (
395 get_identifier (PREFIX("transfer_array_write")), ".wr",
396 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
397 integer_type_node
, gfc_charlen_type_node
);
399 /* Library entry points */
401 iocall
[IOCALL_READ
] = gfc_build_library_function_decl_with_spec (
402 get_identifier (PREFIX("st_read")), ".w",
403 void_type_node
, 1, dt_parm_type
);
405 iocall
[IOCALL_WRITE
] = gfc_build_library_function_decl_with_spec (
406 get_identifier (PREFIX("st_write")), ".w",
407 void_type_node
, 1, dt_parm_type
);
409 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
410 iocall
[IOCALL_OPEN
] = gfc_build_library_function_decl_with_spec (
411 get_identifier (PREFIX("st_open")), ".w",
412 void_type_node
, 1, parm_type
);
414 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
415 iocall
[IOCALL_CLOSE
] = gfc_build_library_function_decl_with_spec (
416 get_identifier (PREFIX("st_close")), ".w",
417 void_type_node
, 1, parm_type
);
419 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
420 iocall
[IOCALL_INQUIRE
] = gfc_build_library_function_decl_with_spec (
421 get_identifier (PREFIX("st_inquire")), ".w",
422 void_type_node
, 1, parm_type
);
424 iocall
[IOCALL_IOLENGTH
] = gfc_build_library_function_decl_with_spec(
425 get_identifier (PREFIX("st_iolength")), ".w",
426 void_type_node
, 1, dt_parm_type
);
428 /* TODO: Change when asynchronous I/O is implemented. */
429 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_wait
].type
);
430 iocall
[IOCALL_WAIT
] = gfc_build_library_function_decl_with_spec (
431 get_identifier (PREFIX("st_wait")), ".X",
432 void_type_node
, 1, parm_type
);
434 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
435 iocall
[IOCALL_REWIND
] = gfc_build_library_function_decl_with_spec (
436 get_identifier (PREFIX("st_rewind")), ".w",
437 void_type_node
, 1, parm_type
);
439 iocall
[IOCALL_BACKSPACE
] = gfc_build_library_function_decl_with_spec (
440 get_identifier (PREFIX("st_backspace")), ".w",
441 void_type_node
, 1, parm_type
);
443 iocall
[IOCALL_ENDFILE
] = gfc_build_library_function_decl_with_spec (
444 get_identifier (PREFIX("st_endfile")), ".w",
445 void_type_node
, 1, parm_type
);
447 iocall
[IOCALL_FLUSH
] = gfc_build_library_function_decl_with_spec (
448 get_identifier (PREFIX("st_flush")), ".w",
449 void_type_node
, 1, parm_type
);
451 /* Library helpers */
453 iocall
[IOCALL_READ_DONE
] = gfc_build_library_function_decl_with_spec (
454 get_identifier (PREFIX("st_read_done")), ".w",
455 void_type_node
, 1, dt_parm_type
);
457 iocall
[IOCALL_WRITE_DONE
] = gfc_build_library_function_decl_with_spec (
458 get_identifier (PREFIX("st_write_done")), ".w",
459 void_type_node
, 1, dt_parm_type
);
461 iocall
[IOCALL_IOLENGTH_DONE
] = gfc_build_library_function_decl_with_spec (
462 get_identifier (PREFIX("st_iolength_done")), ".w",
463 void_type_node
, 1, dt_parm_type
);
465 iocall
[IOCALL_SET_NML_VAL
] = gfc_build_library_function_decl_with_spec (
466 get_identifier (PREFIX("st_set_nml_var")), ".w.R",
467 void_type_node
, 6, dt_parm_type
, pvoid_type_node
, pvoid_type_node
,
468 void_type_node
, gfc_charlen_type_node
, gfc_int4_type_node
);
470 iocall
[IOCALL_SET_NML_VAL_DIM
] = gfc_build_library_function_decl_with_spec (
471 get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
472 void_type_node
, 5, dt_parm_type
, gfc_int4_type_node
,
473 gfc_array_index_type
, gfc_array_index_type
, gfc_array_index_type
);
477 /* Generate code to store an integer constant into the
478 st_parameter_XXX structure. */
481 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
485 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
487 if (p
->param_type
== IOPARM_ptype_common
)
488 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
489 st_parameter
[IOPARM_ptype_common
].type
,
490 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
491 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
492 var
, p
->field
, NULL_TREE
);
493 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
498 /* Generate code to store a non-string I/O parameter into the
499 st_parameter_XXX structure. This is a pass by value. */
502 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
507 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
508 tree dest_type
= TREE_TYPE (p
->field
);
510 gfc_init_se (&se
, NULL
);
511 gfc_conv_expr_val (&se
, e
);
513 /* If we're storing a UNIT number, we need to check it first. */
514 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
519 /* Don't evaluate the UNIT number multiple times. */
520 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
522 /* UNIT numbers should be greater than the min. */
523 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
524 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].pedantic_min_int
, 4);
525 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
527 fold_convert (TREE_TYPE (se
.expr
), val
));
528 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
529 "Unit number in I/O statement too small",
532 /* UNIT numbers should be less than the max. */
533 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
534 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
536 fold_convert (TREE_TYPE (se
.expr
), val
));
537 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
538 "Unit number in I/O statement too large",
543 se
.expr
= convert (dest_type
, se
.expr
);
544 gfc_add_block_to_block (block
, &se
.pre
);
546 if (p
->param_type
== IOPARM_ptype_common
)
547 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
548 st_parameter
[IOPARM_ptype_common
].type
,
549 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
551 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, dest_type
, var
,
552 p
->field
, NULL_TREE
);
553 gfc_add_modify (block
, tmp
, se
.expr
);
558 /* Generate code to store a non-string I/O parameter into the
559 st_parameter_XXX structure. This is pass by reference. */
562 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
563 tree var
, enum iofield type
, gfc_expr
*e
)
567 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
569 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
570 gfc_init_se (&se
, NULL
);
571 gfc_conv_expr_lhs (&se
, e
);
573 gfc_add_block_to_block (block
, &se
.pre
);
575 if (TYPE_MODE (TREE_TYPE (se
.expr
))
576 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
578 addr
= convert (TREE_TYPE (p
->field
), gfc_build_addr_expr (NULL_TREE
, se
.expr
));
580 /* If this is for the iostat variable initialize the
581 user variable to LIBERROR_OK which is zero. */
582 if (type
== IOPARM_common_iostat
)
583 gfc_add_modify (block
, se
.expr
,
584 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
588 /* The type used by the library has different size
589 from the type of the variable supplied by the user.
590 Need to use a temporary. */
591 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
592 st_parameter_field
[type
].name
);
594 /* If this is for the iostat variable, initialize the
595 user variable to LIBERROR_OK which is zero. */
596 if (type
== IOPARM_common_iostat
)
597 gfc_add_modify (block
, tmpvar
,
598 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
600 addr
= gfc_build_addr_expr (NULL_TREE
, tmpvar
);
601 /* After the I/O operation, we set the variable from the temporary. */
602 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
603 gfc_add_modify (postblock
, se
.expr
, tmp
);
606 if (p
->param_type
== IOPARM_ptype_common
)
607 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
608 st_parameter
[IOPARM_ptype_common
].type
,
609 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
610 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
611 var
, p
->field
, NULL_TREE
);
612 gfc_add_modify (block
, tmp
, addr
);
616 /* Given an array expr, find its address and length to get a string. If the
617 array is full, the string's address is the address of array's first element
618 and the length is the size of the whole array. If it is an element, the
619 string's address is the element's address and the length is the rest size of
623 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
629 tree type
, array
, tmp
;
633 /* If it is an element, we need its address and size of the rest. */
634 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
635 gcc_assert (e
->ref
->u
.ar
.type
== AR_ELEMENT
);
636 sym
= e
->symtree
->n
.sym
;
637 rank
= sym
->as
->rank
- 1;
638 gfc_conv_expr (se
, e
);
640 array
= sym
->backend_decl
;
641 type
= TREE_TYPE (array
);
643 if (GFC_ARRAY_TYPE_P (type
))
644 size
= GFC_TYPE_ARRAY_SIZE (type
);
647 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
648 size
= gfc_conv_array_stride (array
, rank
);
649 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
650 gfc_array_index_type
,
651 gfc_conv_array_ubound (array
, rank
),
652 gfc_conv_array_lbound (array
, rank
));
653 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
654 gfc_array_index_type
, tmp
,
656 size
= fold_build2_loc (input_location
, MULT_EXPR
,
657 gfc_array_index_type
, tmp
, size
);
661 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
662 gfc_array_index_type
, size
,
663 TREE_OPERAND (se
->expr
, 1));
664 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
665 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
666 size
= fold_build2_loc (input_location
, MULT_EXPR
,
667 gfc_array_index_type
, size
,
668 fold_convert (gfc_array_index_type
, tmp
));
669 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
673 gfc_conv_array_parameter (se
, e
, gfc_walk_expr (e
), true, NULL
, NULL
, &size
);
674 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
678 /* Generate code to store a string and its length into the
679 st_parameter_XXX structure. */
682 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
683 enum iofield type
, gfc_expr
* e
)
689 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
691 gfc_init_se (&se
, NULL
);
693 if (p
->param_type
== IOPARM_ptype_common
)
694 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
695 st_parameter
[IOPARM_ptype_common
].type
,
696 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
697 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
698 var
, p
->field
, NULL_TREE
);
699 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
700 TREE_TYPE (p
->field_len
),
701 var
, p
->field_len
, NULL_TREE
);
703 /* Integer variable assigned a format label. */
704 if (e
->ts
.type
== BT_INTEGER
706 && e
->symtree
->n
.sym
->attr
.assign
== 1)
711 gfc_conv_label_variable (&se
, e
);
712 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
713 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
714 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
716 asprintf(&msg
, "Label assigned to variable '%s' (%%ld) is not a format "
717 "label", e
->symtree
->name
);
718 gfc_trans_runtime_check (true, false, cond
, &se
.pre
, &e
->where
, msg
,
719 fold_convert (long_integer_type_node
, tmp
));
722 gfc_add_modify (&se
.pre
, io
,
723 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
724 gfc_add_modify (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
728 /* General character. */
729 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
730 gfc_conv_expr (&se
, e
);
731 /* Array assigned Hollerith constant or character array. */
732 else if (e
->rank
> 0 || (e
->symtree
&& e
->symtree
->n
.sym
->as
->rank
> 0))
733 gfc_convert_array_to_string (&se
, e
);
737 gfc_conv_string_parameter (&se
);
738 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
739 gfc_add_modify (&se
.pre
, len
, se
.string_length
);
742 gfc_add_block_to_block (block
, &se
.pre
);
743 gfc_add_block_to_block (postblock
, &se
.post
);
748 /* Generate code to store the character (array) and the character length
749 for an internal unit. */
752 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
753 tree var
, gfc_expr
* e
)
760 gfc_st_parameter_field
*p
;
763 gfc_init_se (&se
, NULL
);
765 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
767 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
768 var
, p
->field
, NULL_TREE
);
769 len
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field_len
),
770 var
, p
->field_len
, NULL_TREE
);
771 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
772 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
773 var
, p
->field
, NULL_TREE
);
775 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
777 /* Character scalars. */
780 gfc_conv_expr (&se
, e
);
781 gfc_conv_string_parameter (&se
);
783 se
.expr
= build_int_cst (pchar_type_node
, 0);
786 /* Character array. */
787 else if (e
->rank
> 0)
789 se
.ss
= gfc_walk_expr (e
);
791 if (is_subref_array (e
))
793 /* Use a temporary for components of arrays of derived types
794 or substring array references. */
795 gfc_conv_subref_array_arg (&se
, e
, 0,
796 last_dt
== READ
? INTENT_IN
: INTENT_OUT
, false);
797 tmp
= build_fold_indirect_ref_loc (input_location
,
799 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
800 tmp
= gfc_conv_descriptor_data_get (tmp
);
804 /* Return the data pointer and rank from the descriptor. */
805 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
806 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
807 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
813 /* The cast is needed for character substrings and the descriptor
815 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
816 gfc_add_modify (&se
.pre
, len
,
817 fold_convert (TREE_TYPE (len
), se
.string_length
));
818 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
820 gfc_add_block_to_block (block
, &se
.pre
);
821 gfc_add_block_to_block (post_block
, &se
.post
);
825 /* Add a case to a IO-result switch. */
828 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
833 return; /* No label, no case */
835 value
= build_int_cst (NULL_TREE
, label_value
);
837 /* Make a backend label for this case. */
838 tmp
= gfc_build_label_decl (NULL_TREE
);
840 /* And the case itself. */
841 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
842 gfc_add_expr_to_block (body
, tmp
);
844 /* Jump to the label. */
845 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
846 gfc_add_expr_to_block (body
, tmp
);
850 /* Generate a switch statement that branches to the correct I/O
851 result label. The last statement of an I/O call stores the
852 result into a variable because there is often cleanup that
853 must be done before the switch, so a temporary would have to
854 be created anyway. */
857 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
858 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
862 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
864 /* If no labels are specified, ignore the result instead
865 of building an empty switch. */
866 if (err_label
== NULL
868 && eor_label
== NULL
)
871 /* Build a switch statement. */
872 gfc_start_block (&body
);
874 /* The label values here must be the same as the values
875 in the library_return enum in the runtime library */
876 add_case (1, err_label
, &body
);
877 add_case (2, end_label
, &body
);
878 add_case (3, eor_label
, &body
);
880 tmp
= gfc_finish_block (&body
);
882 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
883 st_parameter
[IOPARM_ptype_common
].type
,
884 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
885 rc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
886 var
, p
->field
, NULL_TREE
);
887 rc
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (rc
),
888 rc
, build_int_cst (TREE_TYPE (rc
),
889 IOPARM_common_libreturn_mask
));
891 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
893 gfc_add_expr_to_block (block
, tmp
);
897 /* Store the current file and line number to variables so that if a
898 library call goes awry, we can tell the user where the problem is. */
901 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
904 tree str
, locus_file
;
906 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
908 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
909 st_parameter
[IOPARM_ptype_common
].type
,
910 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
911 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
912 TREE_TYPE (p
->field
), locus_file
,
913 p
->field
, NULL_TREE
);
915 str
= gfc_build_cstring_const (f
->filename
);
917 str
= gfc_build_addr_expr (pchar_type_node
, str
);
918 gfc_add_modify (block
, locus_file
, str
);
920 line
= LOCATION_LINE (where
->lb
->location
);
921 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
925 /* Translate an OPEN statement. */
928 gfc_trans_open (gfc_code
* code
)
930 stmtblock_t block
, post_block
;
933 unsigned int mask
= 0;
935 gfc_start_block (&block
);
936 gfc_init_block (&post_block
);
938 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
940 set_error_locus (&block
, var
, &code
->loc
);
944 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
948 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
952 mask
|= IOPARM_common_err
;
955 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
958 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
962 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
966 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
969 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
972 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
976 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
980 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
984 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
988 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
991 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
995 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
999 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
1002 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
1004 if (p
->asynchronous
)
1005 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
1009 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
1013 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_open_newunit
,
1016 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1019 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1021 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1023 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1024 tmp
= build_call_expr_loc (input_location
,
1025 iocall
[IOCALL_OPEN
], 1, tmp
);
1026 gfc_add_expr_to_block (&block
, tmp
);
1028 gfc_add_block_to_block (&block
, &post_block
);
1030 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1032 return gfc_finish_block (&block
);
1036 /* Translate a CLOSE statement. */
1039 gfc_trans_close (gfc_code
* code
)
1041 stmtblock_t block
, post_block
;
1044 unsigned int mask
= 0;
1046 gfc_start_block (&block
);
1047 gfc_init_block (&post_block
);
1049 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
1051 set_error_locus (&block
, var
, &code
->loc
);
1052 p
= code
->ext
.close
;
1055 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1059 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1063 mask
|= IOPARM_common_err
;
1066 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
1069 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1072 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1074 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1076 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1077 tmp
= build_call_expr_loc (input_location
,
1078 iocall
[IOCALL_CLOSE
], 1, tmp
);
1079 gfc_add_expr_to_block (&block
, tmp
);
1081 gfc_add_block_to_block (&block
, &post_block
);
1083 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1085 return gfc_finish_block (&block
);
1089 /* Common subroutine for building a file positioning statement. */
1092 build_filepos (tree function
, gfc_code
* code
)
1094 stmtblock_t block
, post_block
;
1097 unsigned int mask
= 0;
1099 p
= code
->ext
.filepos
;
1101 gfc_start_block (&block
);
1102 gfc_init_block (&post_block
);
1104 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1107 set_error_locus (&block
, var
, &code
->loc
);
1110 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1114 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1118 mask
|= IOPARM_common_err
;
1120 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1123 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1125 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1127 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1128 tmp
= build_call_expr_loc (input_location
,
1130 gfc_add_expr_to_block (&block
, tmp
);
1132 gfc_add_block_to_block (&block
, &post_block
);
1134 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1136 return gfc_finish_block (&block
);
1140 /* Translate a BACKSPACE statement. */
1143 gfc_trans_backspace (gfc_code
* code
)
1145 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1149 /* Translate an ENDFILE statement. */
1152 gfc_trans_endfile (gfc_code
* code
)
1154 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1158 /* Translate a REWIND statement. */
1161 gfc_trans_rewind (gfc_code
* code
)
1163 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1167 /* Translate a FLUSH statement. */
1170 gfc_trans_flush (gfc_code
* code
)
1172 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1176 /* Create a dummy iostat variable to catch any error due to bad unit. */
1179 create_dummy_iostat (void)
1184 gfc_get_ha_sym_tree ("@iostat", &st
);
1185 st
->n
.sym
->ts
.type
= BT_INTEGER
;
1186 st
->n
.sym
->ts
.kind
= gfc_default_integer_kind
;
1187 gfc_set_sym_referenced (st
->n
.sym
);
1188 gfc_commit_symbol (st
->n
.sym
);
1189 st
->n
.sym
->backend_decl
1190 = gfc_create_var (gfc_get_int_type (st
->n
.sym
->ts
.kind
),
1193 e
= gfc_get_expr ();
1194 e
->expr_type
= EXPR_VARIABLE
;
1196 e
->ts
.type
= BT_INTEGER
;
1197 e
->ts
.kind
= st
->n
.sym
->ts
.kind
;
1203 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1206 gfc_trans_inquire (gfc_code
* code
)
1208 stmtblock_t block
, post_block
;
1211 unsigned int mask
= 0, mask2
= 0;
1213 gfc_start_block (&block
);
1214 gfc_init_block (&post_block
);
1216 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1219 set_error_locus (&block
, var
, &code
->loc
);
1220 p
= code
->ext
.inquire
;
1223 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1227 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1231 mask
|= IOPARM_common_err
;
1234 if (p
->unit
&& p
->file
)
1235 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1238 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1243 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1246 if (p
->unit
&& !p
->iostat
)
1248 p
->iostat
= create_dummy_iostat ();
1249 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1250 IOPARM_common_iostat
, p
->iostat
);
1255 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1259 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1263 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1267 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1271 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1275 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1279 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1283 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1287 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1291 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1295 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1296 IOPARM_inquire_recl_out
, p
->recl
);
1299 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1300 IOPARM_inquire_nextrec
, p
->nextrec
);
1303 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1307 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1311 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1315 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1319 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1323 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1327 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1331 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1335 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1339 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1340 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1342 /* The second series of flags. */
1343 if (p
->asynchronous
)
1344 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1348 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1352 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1356 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1360 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1364 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1365 IOPARM_inquire_pending
, p
->pending
);
1368 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1372 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1376 mask
|= set_parameter_const (&block
, var
, IOPARM_inquire_flags2
, mask2
);
1378 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1381 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1383 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1385 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1386 tmp
= build_call_expr_loc (input_location
,
1387 iocall
[IOCALL_INQUIRE
], 1, tmp
);
1388 gfc_add_expr_to_block (&block
, tmp
);
1390 gfc_add_block_to_block (&block
, &post_block
);
1392 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1394 return gfc_finish_block (&block
);
1399 gfc_trans_wait (gfc_code
* code
)
1401 stmtblock_t block
, post_block
;
1404 unsigned int mask
= 0;
1406 gfc_start_block (&block
);
1407 gfc_init_block (&post_block
);
1409 var
= gfc_create_var (st_parameter
[IOPARM_ptype_wait
].type
,
1412 set_error_locus (&block
, var
, &code
->loc
);
1415 /* Set parameters here. */
1417 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1421 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1425 mask
|= IOPARM_common_err
;
1428 mask
|= set_parameter_value (&block
, var
, IOPARM_wait_id
, p
->id
);
1430 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1433 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1435 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1436 tmp
= build_call_expr_loc (input_location
,
1437 iocall
[IOCALL_WAIT
], 1, tmp
);
1438 gfc_add_expr_to_block (&block
, tmp
);
1440 gfc_add_block_to_block (&block
, &post_block
);
1442 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1444 return gfc_finish_block (&block
);
1449 /* nml_full_name builds up the fully qualified name of a
1450 derived type component. */
1453 nml_full_name (const char* var_name
, const char* cmp_name
)
1455 int full_name_length
;
1458 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1459 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1460 strcpy (full_name
, var_name
);
1461 full_name
= strcat (full_name
, "%");
1462 full_name
= strcat (full_name
, cmp_name
);
1467 /* nml_get_addr_expr builds an address expression from the
1468 gfc_symbol or gfc_component backend_decl's. An offset is
1469 provided so that the address of an element of an array of
1470 derived types is returned. This is used in the runtime to
1471 determine that span of the derived type. */
1474 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1477 tree decl
= NULL_TREE
;
1482 sym
->attr
.referenced
= 1;
1483 decl
= gfc_get_symbol_decl (sym
);
1485 /* If this is the enclosing function declaration, use
1486 the fake result instead. */
1487 if (decl
== current_function_decl
)
1488 decl
= gfc_get_fake_result_decl (sym
, 0);
1489 else if (decl
== DECL_CONTEXT (current_function_decl
))
1490 decl
= gfc_get_fake_result_decl (sym
, 1);
1493 decl
= c
->backend_decl
;
1495 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1496 || TREE_CODE (decl
) == VAR_DECL
1497 || TREE_CODE (decl
) == PARM_DECL
)
1498 || TREE_CODE (decl
) == COMPONENT_REF
));
1502 /* Build indirect reference, if dummy argument. */
1504 if (POINTER_TYPE_P (TREE_TYPE(tmp
)))
1505 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1507 /* Treat the component of a derived type, using base_addr for
1508 the derived type. */
1510 if (TREE_CODE (decl
) == FIELD_DECL
)
1511 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
1512 base_addr
, tmp
, NULL_TREE
);
1514 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
1515 tmp
= gfc_conv_array_data (tmp
);
1518 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1519 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1521 if (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1522 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1524 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1525 tmp
= build_fold_indirect_ref_loc (input_location
,
1529 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1535 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1536 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1537 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1539 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1542 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1543 gfc_symbol
* sym
, gfc_component
* c
,
1546 gfc_typespec
* ts
= NULL
;
1547 gfc_array_spec
* as
= NULL
;
1548 tree addr_expr
= NULL
;
1554 tree decl
= NULL_TREE
;
1559 gcc_assert (sym
|| c
);
1561 /* Build the namelist object name. */
1563 string
= gfc_build_cstring_const (var_name
);
1564 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1566 /* Build ts, as and data address using symbol or component. */
1568 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1569 as
= (sym
) ? sym
->as
: c
->as
;
1571 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1578 decl
= (sym
) ? sym
->backend_decl
: c
->backend_decl
;
1579 if (sym
&& sym
->attr
.dummy
)
1580 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
1581 dt
= TREE_TYPE (decl
);
1582 dtype
= gfc_get_dtype (dt
);
1587 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1590 /* Build up the arguments for the transfer call.
1591 The call for the scalar part transfers:
1592 (address, name, type, kind or string_length, dtype) */
1594 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1596 if (ts
->type
== BT_CHARACTER
)
1597 tmp
= ts
->u
.cl
->backend_decl
;
1599 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1600 tmp
= build_call_expr_loc (input_location
,
1601 iocall
[IOCALL_SET_NML_VAL
], 6,
1602 dt_parm_addr
, addr_expr
, string
,
1603 IARG (ts
->kind
), tmp
, dtype
);
1604 gfc_add_expr_to_block (block
, tmp
);
1606 /* If the object is an array, transfer rank times:
1607 (null pointer, name, stride, lbound, ubound) */
1609 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1611 tmp
= build_call_expr_loc (input_location
,
1612 iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1615 gfc_conv_array_stride (decl
, n_dim
),
1616 gfc_conv_array_lbound (decl
, n_dim
),
1617 gfc_conv_array_ubound (decl
, n_dim
));
1618 gfc_add_expr_to_block (block
, tmp
);
1621 if (ts
->type
== BT_DERIVED
)
1625 /* Provide the RECORD_TYPE to build component references. */
1627 tree expr
= build_fold_indirect_ref_loc (input_location
,
1630 for (cmp
= ts
->u
.derived
->components
; cmp
; cmp
= cmp
->next
)
1632 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1633 transfer_namelist_element (block
,
1636 gfc_free (full_name
);
1643 /* Create a data transfer statement. Not all of the fields are valid
1644 for both reading and writing, but improper use has been filtered
1648 build_dt (tree function
, gfc_code
* code
)
1650 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1655 unsigned int mask
= 0;
1657 gfc_start_block (&block
);
1658 gfc_init_block (&post_block
);
1659 gfc_init_block (&post_end_block
);
1660 gfc_init_block (&post_iu_block
);
1662 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1664 set_error_locus (&block
, var
, &code
->loc
);
1666 if (last_dt
== IOLENGTH
)
1670 inq
= code
->ext
.inquire
;
1672 /* First check that preconditions are met. */
1673 gcc_assert (inq
!= NULL
);
1674 gcc_assert (inq
->iolength
!= NULL
);
1676 /* Connect to the iolength variable. */
1677 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1678 IOPARM_dt_iolength
, inq
->iolength
);
1684 gcc_assert (dt
!= NULL
);
1687 if (dt
&& dt
->io_unit
)
1689 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1691 mask
|= set_internal_unit (&block
, &post_iu_block
,
1693 set_parameter_const (&block
, var
, IOPARM_common_unit
,
1694 dt
->io_unit
->ts
.kind
== 1 ? 0 : -1);
1698 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1703 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1707 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1708 IOPARM_common_iostat
, dt
->iostat
);
1711 mask
|= IOPARM_common_err
;
1714 mask
|= IOPARM_common_eor
;
1717 mask
|= IOPARM_common_end
;
1720 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1721 IOPARM_dt_id
, dt
->id
);
1724 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1726 if (dt
->asynchronous
)
1727 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_asynchronous
,
1731 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1735 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1739 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1743 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1747 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1751 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1755 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1758 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1761 if (dt
->format_expr
)
1762 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1765 if (dt
->format_label
)
1767 if (dt
->format_label
== &format_asterisk
)
1768 mask
|= IOPARM_dt_list_format
;
1770 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1771 dt
->format_label
->format
);
1775 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1776 IOPARM_dt_size
, dt
->size
);
1780 if (dt
->format_expr
|| dt
->format_label
)
1781 gfc_internal_error ("build_dt: format with namelist");
1783 nmlname
= gfc_get_character_expr (gfc_default_character_kind
, NULL
,
1785 strlen (dt
->namelist
->name
));
1787 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1790 if (last_dt
== READ
)
1791 mask
|= IOPARM_dt_namelist_read_mode
;
1793 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1797 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1798 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1802 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1804 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1805 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1808 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1810 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1811 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
1813 gfc_add_expr_to_block (&block
, tmp
);
1815 gfc_add_block_to_block (&block
, &post_block
);
1818 dt_post_end_block
= &post_end_block
;
1820 /* Set implied do loop exit condition. */
1821 if (last_dt
== READ
|| last_dt
== WRITE
)
1823 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
1825 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1826 st_parameter
[IOPARM_ptype_common
].type
,
1827 dt_parm
, TYPE_FIELDS (TREE_TYPE (dt_parm
)),
1829 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1830 TREE_TYPE (p
->field
), tmp
, p
->field
, NULL_TREE
);
1831 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (tmp
),
1832 tmp
, build_int_cst (TREE_TYPE (tmp
),
1833 IOPARM_common_libreturn_mask
));
1838 gfc_add_expr_to_block (&block
, gfc_trans_code_cond (code
->block
->next
, tmp
));
1840 gfc_add_block_to_block (&block
, &post_iu_block
);
1843 dt_post_end_block
= NULL
;
1845 return gfc_finish_block (&block
);
1849 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1850 this as a third sort of data transfer statement, except that
1851 lengths are summed instead of actually transferring any data. */
1854 gfc_trans_iolength (gfc_code
* code
)
1857 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1861 /* Translate a READ statement. */
1864 gfc_trans_read (gfc_code
* code
)
1867 return build_dt (iocall
[IOCALL_READ
], code
);
1871 /* Translate a WRITE statement */
1874 gfc_trans_write (gfc_code
* code
)
1877 return build_dt (iocall
[IOCALL_WRITE
], code
);
1881 /* Finish a data transfer statement. */
1884 gfc_trans_dt_end (gfc_code
* code
)
1889 gfc_init_block (&block
);
1894 function
= iocall
[IOCALL_READ_DONE
];
1898 function
= iocall
[IOCALL_WRITE_DONE
];
1902 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1909 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1910 tmp
= build_call_expr_loc (input_location
,
1912 gfc_add_expr_to_block (&block
, tmp
);
1913 gfc_add_block_to_block (&block
, dt_post_end_block
);
1914 gfc_init_block (dt_post_end_block
);
1916 if (last_dt
!= IOLENGTH
)
1918 gcc_assert (code
->ext
.dt
!= NULL
);
1919 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1920 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1923 return gfc_finish_block (&block
);
1927 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1929 /* Given an array field in a derived type variable, generate the code
1930 for the loop that iterates over array elements, and the code that
1931 accesses those array elements. Use transfer_expr to generate code
1932 for transferring that element. Because elements may also be
1933 derived types, transfer_expr and transfer_array_component are mutually
1937 transfer_array_component (tree expr
, gfc_component
* cm
, locus
* where
)
1947 gfc_start_block (&block
);
1948 gfc_init_se (&se
, NULL
);
1950 /* Create and initialize Scalarization Status. Unlike in
1951 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1952 care of this task, because we don't have a gfc_expr at hand.
1953 Build one manually, as in gfc_trans_subarray_assign. */
1956 ss
->type
= GFC_SS_COMPONENT
;
1958 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1959 ss
->next
= gfc_ss_terminator
;
1960 ss
->data
.info
.dimen
= cm
->as
->rank
;
1961 ss
->data
.info
.descriptor
= expr
;
1962 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1963 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1964 for (n
= 0; n
< cm
->as
->rank
; n
++)
1966 ss
->data
.info
.dim
[n
] = n
;
1967 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1968 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1970 mpz_init (ss
->shape
[n
]);
1971 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1972 cm
->as
->lower
[n
]->value
.integer
);
1973 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1976 /* Once we got ss, we use scalarizer to create the loop. */
1978 gfc_init_loopinfo (&loop
);
1979 gfc_add_ss_to_loop (&loop
, ss
);
1980 gfc_conv_ss_startstride (&loop
);
1981 gfc_conv_loop_setup (&loop
, where
);
1982 gfc_mark_ss_chain_used (ss
, 1);
1983 gfc_start_scalarized_body (&loop
, &body
);
1985 gfc_copy_loopinfo_to_se (&se
, &loop
);
1988 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1990 gfc_conv_tmp_array_ref (&se
);
1992 /* Now se.expr contains an element of the array. Take the address and pass
1993 it to the IO routines. */
1994 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
1995 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1997 /* We are done now with the loop body. Wrap up the scalarizer and
2000 gfc_add_block_to_block (&body
, &se
.pre
);
2001 gfc_add_block_to_block (&body
, &se
.post
);
2003 gfc_trans_scalarizing_loops (&loop
, &body
);
2005 gfc_add_block_to_block (&block
, &loop
.pre
);
2006 gfc_add_block_to_block (&block
, &loop
.post
);
2008 for (n
= 0; n
< cm
->as
->rank
; n
++)
2009 mpz_clear (ss
->shape
[n
]);
2010 gfc_free (ss
->shape
);
2012 gfc_cleanup_loop (&loop
);
2014 return gfc_finish_block (&block
);
2017 /* Generate the call for a scalar transfer node. */
2020 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
2022 tree tmp
, function
, arg2
, arg3
, field
, expr
;
2026 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2027 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2028 We need to translate the expression to a constant if it's either
2029 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2030 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2031 BT_DERIVED (could have been changed by gfc_conv_expr). */
2032 if ((ts
->type
== BT_DERIVED
|| ts
->type
== BT_INTEGER
)
2033 && ts
->u
.derived
!= NULL
2034 && (ts
->is_iso_c
== 1 || ts
->u
.derived
->ts
.is_iso_c
== 1))
2036 /* C_PTR and C_FUNPTR have private components which means they can not
2037 be printed. However, if -std=gnu and not -pedantic, allow
2038 the component to be printed to help debugging. */
2039 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
2041 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
2042 ts
->u
.derived
->name
, code
!= NULL
? &(code
->loc
) :
2043 &gfc_current_locus
);
2047 ts
->type
= ts
->u
.derived
->ts
.type
;
2048 ts
->kind
= ts
->u
.derived
->ts
.kind
;
2049 ts
->f90_type
= ts
->u
.derived
->ts
.f90_type
;
2060 arg2
= build_int_cst (NULL_TREE
, kind
);
2061 if (last_dt
== READ
)
2062 function
= iocall
[IOCALL_X_INTEGER
];
2064 function
= iocall
[IOCALL_X_INTEGER_WRITE
];
2069 arg2
= build_int_cst (NULL_TREE
, kind
);
2070 if (last_dt
== READ
)
2072 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2073 function
= iocall
[IOCALL_X_REAL128
];
2075 function
= iocall
[IOCALL_X_REAL
];
2079 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2080 function
= iocall
[IOCALL_X_REAL128_WRITE
];
2082 function
= iocall
[IOCALL_X_REAL_WRITE
];
2088 arg2
= build_int_cst (NULL_TREE
, kind
);
2089 if (last_dt
== READ
)
2091 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2092 function
= iocall
[IOCALL_X_COMPLEX128
];
2094 function
= iocall
[IOCALL_X_COMPLEX
];
2098 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2099 function
= iocall
[IOCALL_X_COMPLEX128_WRITE
];
2101 function
= iocall
[IOCALL_X_COMPLEX_WRITE
];
2107 arg2
= build_int_cst (NULL_TREE
, kind
);
2108 if (last_dt
== READ
)
2109 function
= iocall
[IOCALL_X_LOGICAL
];
2111 function
= iocall
[IOCALL_X_LOGICAL_WRITE
];
2118 if (se
->string_length
)
2119 arg2
= se
->string_length
;
2122 tmp
= build_fold_indirect_ref_loc (input_location
,
2124 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2125 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2126 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2128 arg3
= build_int_cst (NULL_TREE
, kind
);
2129 if (last_dt
== READ
)
2130 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2132 function
= iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
];
2134 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2135 tmp
= build_call_expr_loc (input_location
,
2136 function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2137 gfc_add_expr_to_block (&se
->pre
, tmp
);
2138 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2143 if (se
->string_length
)
2144 arg2
= se
->string_length
;
2147 tmp
= build_fold_indirect_ref_loc (input_location
,
2149 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2150 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2152 if (last_dt
== READ
)
2153 function
= iocall
[IOCALL_X_CHARACTER
];
2155 function
= iocall
[IOCALL_X_CHARACTER_WRITE
];
2160 /* Recurse into the elements of the derived type. */
2161 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2162 expr
= build_fold_indirect_ref_loc (input_location
,
2165 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
2167 field
= c
->backend_decl
;
2168 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2170 tmp
= fold_build3_loc (UNKNOWN_LOCATION
,
2171 COMPONENT_REF
, TREE_TYPE (field
),
2172 expr
, field
, NULL_TREE
);
2174 if (c
->attr
.dimension
)
2176 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2177 gfc_add_expr_to_block (&se
->pre
, tmp
);
2181 if (!c
->attr
.pointer
)
2182 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2183 transfer_expr (se
, &c
->ts
, tmp
, code
);
2189 internal_error ("Bad IO basetype (%d)", ts
->type
);
2192 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2193 tmp
= build_call_expr_loc (input_location
,
2194 function
, 3, tmp
, addr_expr
, arg2
);
2195 gfc_add_expr_to_block (&se
->pre
, tmp
);
2196 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2201 /* Generate a call to pass an array descriptor to the IO library. The
2202 array should be of one of the intrinsic types. */
2205 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2207 tree tmp
, charlen_arg
, kind_arg
, io_call
;
2209 if (ts
->type
== BT_CHARACTER
)
2210 charlen_arg
= se
->string_length
;
2212 charlen_arg
= build_int_cst (NULL_TREE
, 0);
2214 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
2216 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2217 if (last_dt
== READ
)
2218 io_call
= iocall
[IOCALL_X_ARRAY
];
2220 io_call
= iocall
[IOCALL_X_ARRAY_WRITE
];
2222 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2224 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2225 gfc_add_expr_to_block (&se
->pre
, tmp
);
2226 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2230 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2233 gfc_trans_transfer (gfc_code
* code
)
2235 stmtblock_t block
, body
;
2244 gfc_start_block (&block
);
2245 gfc_init_block (&body
);
2248 ss
= gfc_walk_expr (expr
);
2251 gfc_init_se (&se
, NULL
);
2253 if (ss
== gfc_ss_terminator
)
2255 /* Transfer a scalar value. */
2256 gfc_conv_expr_reference (&se
, expr
);
2257 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2261 /* Transfer an array. If it is an array of an intrinsic
2262 type, pass the descriptor to the library. Otherwise
2263 scalarize the transfer. */
2264 if (expr
->ref
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
2266 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2268 gcc_assert (ref
->type
== REF_ARRAY
);
2271 if (expr
->ts
.type
!= BT_DERIVED
2272 && ref
&& ref
->next
== NULL
2273 && !is_subref_array (expr
))
2275 bool seen_vector
= false;
2277 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2279 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2280 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2284 if (seen_vector
&& last_dt
== READ
)
2286 /* Create a temp, read to that and copy it back. */
2287 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
, false);
2292 /* Get the descriptor. */
2293 gfc_conv_expr_descriptor (&se
, expr
, ss
);
2294 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2297 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2298 goto finish_block_label
;
2301 /* Initialize the scalarizer. */
2302 gfc_init_loopinfo (&loop
);
2303 gfc_add_ss_to_loop (&loop
, ss
);
2305 /* Initialize the loop. */
2306 gfc_conv_ss_startstride (&loop
);
2307 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
2309 /* The main loop body. */
2310 gfc_mark_ss_chain_used (ss
, 1);
2311 gfc_start_scalarized_body (&loop
, &body
);
2313 gfc_copy_loopinfo_to_se (&se
, &loop
);
2316 gfc_conv_expr_reference (&se
, expr
);
2317 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2322 gfc_add_block_to_block (&body
, &se
.pre
);
2323 gfc_add_block_to_block (&body
, &se
.post
);
2326 tmp
= gfc_finish_block (&body
);
2329 gcc_assert (se
.ss
== gfc_ss_terminator
);
2330 gfc_trans_scalarizing_loops (&loop
, &body
);
2332 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2333 tmp
= gfc_finish_block (&loop
.pre
);
2334 gfc_cleanup_loop (&loop
);
2337 gfc_add_expr_to_block (&block
, tmp
);
2339 return gfc_finish_block (&block
);
2342 #include "gt-fortran-trans-io.h"