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 cond
= gfc_unlikely (cond
);
271 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt (input_location
));
272 gfc_add_expr_to_block (pblock
, tmp
);
277 /* Create function decls for IO library functions. */
280 gfc_build_io_library_fndecls (void)
282 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
283 tree gfc_intio_type_node
;
284 tree parm_type
, dt_parm_type
;
285 HOST_WIDE_INT pad_size
;
288 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
289 types
[IOPARM_type_intio
] = gfc_intio_type_node
290 = gfc_get_int_type (gfc_intio_kind
);
291 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
292 types
[IOPARM_type_pintio
]
293 = build_pointer_type (gfc_intio_type_node
);
294 types
[IOPARM_type_parray
] = pchar_type_node
;
295 types
[IOPARM_type_pchar
] = pchar_type_node
;
296 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
297 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
298 pad_idx
= build_index_type (size_int (pad_size
- 1));
299 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
301 /* pad actually contains pointers and integers so it needs to have an
302 alignment that is at least as large as the needed alignment for those
303 types. See the st_parameter_dt structure in libgfortran/io/io.h for
304 what really goes into this space. */
305 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
306 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind
)));
308 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
309 gfc_build_st_parameter ((enum ioparam_type
) ptype
, types
);
311 /* Define the transfer functions. */
313 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
315 iocall
[IOCALL_X_INTEGER
] = gfc_build_library_function_decl_with_spec (
316 get_identifier (PREFIX("transfer_integer")), ".wW",
317 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
319 iocall
[IOCALL_X_INTEGER_WRITE
] = gfc_build_library_function_decl_with_spec (
320 get_identifier (PREFIX("transfer_integer_write")), ".wR",
321 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
323 iocall
[IOCALL_X_LOGICAL
] = gfc_build_library_function_decl_with_spec (
324 get_identifier (PREFIX("transfer_logical")), ".wW",
325 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
327 iocall
[IOCALL_X_LOGICAL_WRITE
] = gfc_build_library_function_decl_with_spec (
328 get_identifier (PREFIX("transfer_logical_write")), ".wR",
329 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
331 iocall
[IOCALL_X_CHARACTER
] = gfc_build_library_function_decl_with_spec (
332 get_identifier (PREFIX("transfer_character")), ".wW",
333 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
335 iocall
[IOCALL_X_CHARACTER_WRITE
] = gfc_build_library_function_decl_with_spec (
336 get_identifier (PREFIX("transfer_character_write")), ".wR",
337 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
339 iocall
[IOCALL_X_CHARACTER_WIDE
] = gfc_build_library_function_decl_with_spec (
340 get_identifier (PREFIX("transfer_character_wide")), ".wW",
341 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
342 gfc_charlen_type_node
, gfc_int4_type_node
);
344 iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
] =
345 gfc_build_library_function_decl_with_spec (
346 get_identifier (PREFIX("transfer_character_wide_write")), ".wR",
347 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
348 gfc_charlen_type_node
, gfc_int4_type_node
);
350 iocall
[IOCALL_X_REAL
] = gfc_build_library_function_decl_with_spec (
351 get_identifier (PREFIX("transfer_real")), ".wW",
352 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
354 iocall
[IOCALL_X_REAL_WRITE
] = gfc_build_library_function_decl_with_spec (
355 get_identifier (PREFIX("transfer_real_write")), ".wR",
356 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
358 iocall
[IOCALL_X_COMPLEX
] = gfc_build_library_function_decl_with_spec (
359 get_identifier (PREFIX("transfer_complex")), ".wW",
360 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
362 iocall
[IOCALL_X_COMPLEX_WRITE
] = gfc_build_library_function_decl_with_spec (
363 get_identifier (PREFIX("transfer_complex_write")), ".wR",
364 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
366 /* Version for __float128. */
367 iocall
[IOCALL_X_REAL128
] = gfc_build_library_function_decl_with_spec (
368 get_identifier (PREFIX("transfer_real128")), ".wW",
369 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
371 iocall
[IOCALL_X_REAL128_WRITE
] = gfc_build_library_function_decl_with_spec (
372 get_identifier (PREFIX("transfer_real128_write")), ".wR",
373 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
375 iocall
[IOCALL_X_COMPLEX128
] = gfc_build_library_function_decl_with_spec (
376 get_identifier (PREFIX("transfer_complex128")), ".wW",
377 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
379 iocall
[IOCALL_X_COMPLEX128_WRITE
] = gfc_build_library_function_decl_with_spec (
380 get_identifier (PREFIX("transfer_complex128_write")), ".wR",
381 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
383 iocall
[IOCALL_X_ARRAY
] = gfc_build_library_function_decl_with_spec (
384 get_identifier (PREFIX("transfer_array")), ".ww",
385 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
386 integer_type_node
, gfc_charlen_type_node
);
388 iocall
[IOCALL_X_ARRAY_WRITE
] = gfc_build_library_function_decl_with_spec (
389 get_identifier (PREFIX("transfer_array_write")), ".wr",
390 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
391 integer_type_node
, gfc_charlen_type_node
);
393 /* Library entry points */
395 iocall
[IOCALL_READ
] = gfc_build_library_function_decl_with_spec (
396 get_identifier (PREFIX("st_read")), ".w",
397 void_type_node
, 1, dt_parm_type
);
399 iocall
[IOCALL_WRITE
] = gfc_build_library_function_decl_with_spec (
400 get_identifier (PREFIX("st_write")), ".w",
401 void_type_node
, 1, dt_parm_type
);
403 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
404 iocall
[IOCALL_OPEN
] = gfc_build_library_function_decl_with_spec (
405 get_identifier (PREFIX("st_open")), ".w",
406 void_type_node
, 1, parm_type
);
408 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
409 iocall
[IOCALL_CLOSE
] = gfc_build_library_function_decl_with_spec (
410 get_identifier (PREFIX("st_close")), ".w",
411 void_type_node
, 1, parm_type
);
413 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
414 iocall
[IOCALL_INQUIRE
] = gfc_build_library_function_decl_with_spec (
415 get_identifier (PREFIX("st_inquire")), ".w",
416 void_type_node
, 1, parm_type
);
418 iocall
[IOCALL_IOLENGTH
] = gfc_build_library_function_decl_with_spec(
419 get_identifier (PREFIX("st_iolength")), ".w",
420 void_type_node
, 1, dt_parm_type
);
422 /* TODO: Change when asynchronous I/O is implemented. */
423 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_wait
].type
);
424 iocall
[IOCALL_WAIT
] = gfc_build_library_function_decl_with_spec (
425 get_identifier (PREFIX("st_wait")), ".X",
426 void_type_node
, 1, parm_type
);
428 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
429 iocall
[IOCALL_REWIND
] = gfc_build_library_function_decl_with_spec (
430 get_identifier (PREFIX("st_rewind")), ".w",
431 void_type_node
, 1, parm_type
);
433 iocall
[IOCALL_BACKSPACE
] = gfc_build_library_function_decl_with_spec (
434 get_identifier (PREFIX("st_backspace")), ".w",
435 void_type_node
, 1, parm_type
);
437 iocall
[IOCALL_ENDFILE
] = gfc_build_library_function_decl_with_spec (
438 get_identifier (PREFIX("st_endfile")), ".w",
439 void_type_node
, 1, parm_type
);
441 iocall
[IOCALL_FLUSH
] = gfc_build_library_function_decl_with_spec (
442 get_identifier (PREFIX("st_flush")), ".w",
443 void_type_node
, 1, parm_type
);
445 /* Library helpers */
447 iocall
[IOCALL_READ_DONE
] = gfc_build_library_function_decl_with_spec (
448 get_identifier (PREFIX("st_read_done")), ".w",
449 void_type_node
, 1, dt_parm_type
);
451 iocall
[IOCALL_WRITE_DONE
] = gfc_build_library_function_decl_with_spec (
452 get_identifier (PREFIX("st_write_done")), ".w",
453 void_type_node
, 1, dt_parm_type
);
455 iocall
[IOCALL_IOLENGTH_DONE
] = gfc_build_library_function_decl_with_spec (
456 get_identifier (PREFIX("st_iolength_done")), ".w",
457 void_type_node
, 1, dt_parm_type
);
459 iocall
[IOCALL_SET_NML_VAL
] = gfc_build_library_function_decl_with_spec (
460 get_identifier (PREFIX("st_set_nml_var")), ".w.R",
461 void_type_node
, 6, dt_parm_type
, pvoid_type_node
, pvoid_type_node
,
462 void_type_node
, gfc_charlen_type_node
, gfc_int4_type_node
);
464 iocall
[IOCALL_SET_NML_VAL_DIM
] = gfc_build_library_function_decl_with_spec (
465 get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
466 void_type_node
, 5, dt_parm_type
, gfc_int4_type_node
,
467 gfc_array_index_type
, gfc_array_index_type
, gfc_array_index_type
);
471 /* Generate code to store an integer constant into the
472 st_parameter_XXX structure. */
475 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
479 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
481 if (p
->param_type
== IOPARM_ptype_common
)
482 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
483 st_parameter
[IOPARM_ptype_common
].type
,
484 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
485 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
486 var
, p
->field
, NULL_TREE
);
487 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
492 /* Generate code to store a non-string I/O parameter into the
493 st_parameter_XXX structure. This is a pass by value. */
496 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
501 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
502 tree dest_type
= TREE_TYPE (p
->field
);
504 gfc_init_se (&se
, NULL
);
505 gfc_conv_expr_val (&se
, e
);
507 /* If we're storing a UNIT number, we need to check it first. */
508 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
513 /* Don't evaluate the UNIT number multiple times. */
514 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
516 /* UNIT numbers should be greater than the min. */
517 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
518 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].pedantic_min_int
, 4);
519 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
521 fold_convert (TREE_TYPE (se
.expr
), val
));
522 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
523 "Unit number in I/O statement too small",
526 /* UNIT numbers should be less than the max. */
527 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
528 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
530 fold_convert (TREE_TYPE (se
.expr
), val
));
531 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
532 "Unit number in I/O statement too large",
537 se
.expr
= convert (dest_type
, se
.expr
);
538 gfc_add_block_to_block (block
, &se
.pre
);
540 if (p
->param_type
== IOPARM_ptype_common
)
541 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
542 st_parameter
[IOPARM_ptype_common
].type
,
543 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
545 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, dest_type
, var
,
546 p
->field
, NULL_TREE
);
547 gfc_add_modify (block
, tmp
, se
.expr
);
552 /* Generate code to store a non-string I/O parameter into the
553 st_parameter_XXX structure. This is pass by reference. */
556 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
557 tree var
, enum iofield type
, gfc_expr
*e
)
561 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
563 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
564 gfc_init_se (&se
, NULL
);
565 gfc_conv_expr_lhs (&se
, e
);
567 gfc_add_block_to_block (block
, &se
.pre
);
569 if (TYPE_MODE (TREE_TYPE (se
.expr
))
570 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
572 addr
= convert (TREE_TYPE (p
->field
), gfc_build_addr_expr (NULL_TREE
, se
.expr
));
574 /* If this is for the iostat variable initialize the
575 user variable to LIBERROR_OK which is zero. */
576 if (type
== IOPARM_common_iostat
)
577 gfc_add_modify (block
, se
.expr
,
578 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
582 /* The type used by the library has different size
583 from the type of the variable supplied by the user.
584 Need to use a temporary. */
585 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
586 st_parameter_field
[type
].name
);
588 /* If this is for the iostat variable, initialize the
589 user variable to LIBERROR_OK which is zero. */
590 if (type
== IOPARM_common_iostat
)
591 gfc_add_modify (block
, tmpvar
,
592 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
594 addr
= gfc_build_addr_expr (NULL_TREE
, tmpvar
);
595 /* After the I/O operation, we set the variable from the temporary. */
596 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
597 gfc_add_modify (postblock
, se
.expr
, tmp
);
600 if (p
->param_type
== IOPARM_ptype_common
)
601 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
602 st_parameter
[IOPARM_ptype_common
].type
,
603 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
604 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
605 var
, p
->field
, NULL_TREE
);
606 gfc_add_modify (block
, tmp
, addr
);
610 /* Given an array expr, find its address and length to get a string. If the
611 array is full, the string's address is the address of array's first element
612 and the length is the size of the whole array. If it is an element, the
613 string's address is the element's address and the length is the rest size of
617 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
623 tree type
, array
, tmp
;
627 /* If it is an element, we need its address and size of the rest. */
628 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
629 gcc_assert (e
->ref
->u
.ar
.type
== AR_ELEMENT
);
630 sym
= e
->symtree
->n
.sym
;
631 rank
= sym
->as
->rank
- 1;
632 gfc_conv_expr (se
, e
);
634 array
= sym
->backend_decl
;
635 type
= TREE_TYPE (array
);
637 if (GFC_ARRAY_TYPE_P (type
))
638 size
= GFC_TYPE_ARRAY_SIZE (type
);
641 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
642 size
= gfc_conv_array_stride (array
, rank
);
643 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
644 gfc_array_index_type
,
645 gfc_conv_array_ubound (array
, rank
),
646 gfc_conv_array_lbound (array
, rank
));
647 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
648 gfc_array_index_type
, tmp
,
650 size
= fold_build2_loc (input_location
, MULT_EXPR
,
651 gfc_array_index_type
, tmp
, size
);
655 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
656 gfc_array_index_type
, size
,
657 TREE_OPERAND (se
->expr
, 1));
658 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
659 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
660 size
= fold_build2_loc (input_location
, MULT_EXPR
,
661 gfc_array_index_type
, size
,
662 fold_convert (gfc_array_index_type
, tmp
));
663 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
667 gfc_conv_array_parameter (se
, e
, gfc_walk_expr (e
), true, NULL
, NULL
, &size
);
668 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
672 /* Generate code to store a string and its length into the
673 st_parameter_XXX structure. */
676 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
677 enum iofield type
, gfc_expr
* e
)
683 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
685 gfc_init_se (&se
, NULL
);
687 if (p
->param_type
== IOPARM_ptype_common
)
688 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
689 st_parameter
[IOPARM_ptype_common
].type
,
690 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
691 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
692 var
, p
->field
, NULL_TREE
);
693 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
694 TREE_TYPE (p
->field_len
),
695 var
, p
->field_len
, NULL_TREE
);
697 /* Integer variable assigned a format label. */
698 if (e
->ts
.type
== BT_INTEGER
700 && e
->symtree
->n
.sym
->attr
.assign
== 1)
705 gfc_conv_label_variable (&se
, e
);
706 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
707 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
708 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
710 asprintf(&msg
, "Label assigned to variable '%s' (%%ld) is not a format "
711 "label", e
->symtree
->name
);
712 gfc_trans_runtime_check (true, false, cond
, &se
.pre
, &e
->where
, msg
,
713 fold_convert (long_integer_type_node
, tmp
));
716 gfc_add_modify (&se
.pre
, io
,
717 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
718 gfc_add_modify (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
722 /* General character. */
723 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
724 gfc_conv_expr (&se
, e
);
725 /* Array assigned Hollerith constant or character array. */
726 else if (e
->rank
> 0 || (e
->symtree
&& e
->symtree
->n
.sym
->as
->rank
> 0))
727 gfc_convert_array_to_string (&se
, e
);
731 gfc_conv_string_parameter (&se
);
732 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
733 gfc_add_modify (&se
.pre
, len
, se
.string_length
);
736 gfc_add_block_to_block (block
, &se
.pre
);
737 gfc_add_block_to_block (postblock
, &se
.post
);
742 /* Generate code to store the character (array) and the character length
743 for an internal unit. */
746 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
747 tree var
, gfc_expr
* e
)
754 gfc_st_parameter_field
*p
;
757 gfc_init_se (&se
, NULL
);
759 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
761 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
762 var
, p
->field
, NULL_TREE
);
763 len
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field_len
),
764 var
, p
->field_len
, NULL_TREE
);
765 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
766 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
767 var
, p
->field
, NULL_TREE
);
769 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
771 /* Character scalars. */
774 gfc_conv_expr (&se
, e
);
775 gfc_conv_string_parameter (&se
);
777 se
.expr
= build_int_cst (pchar_type_node
, 0);
780 /* Character array. */
781 else if (e
->rank
> 0)
783 se
.ss
= gfc_walk_expr (e
);
785 if (is_subref_array (e
))
787 /* Use a temporary for components of arrays of derived types
788 or substring array references. */
789 gfc_conv_subref_array_arg (&se
, e
, 0,
790 last_dt
== READ
? INTENT_IN
: INTENT_OUT
, false);
791 tmp
= build_fold_indirect_ref_loc (input_location
,
793 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
794 tmp
= gfc_conv_descriptor_data_get (tmp
);
798 /* Return the data pointer and rank from the descriptor. */
799 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
800 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
801 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
807 /* The cast is needed for character substrings and the descriptor
809 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
810 gfc_add_modify (&se
.pre
, len
,
811 fold_convert (TREE_TYPE (len
), se
.string_length
));
812 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
814 gfc_add_block_to_block (block
, &se
.pre
);
815 gfc_add_block_to_block (post_block
, &se
.post
);
819 /* Add a case to a IO-result switch. */
822 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
827 return; /* No label, no case */
829 value
= build_int_cst (integer_type_node
, label_value
);
831 /* Make a backend label for this case. */
832 tmp
= gfc_build_label_decl (NULL_TREE
);
834 /* And the case itself. */
835 tmp
= build_case_label (value
, NULL_TREE
, tmp
);
836 gfc_add_expr_to_block (body
, tmp
);
838 /* Jump to the label. */
839 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
840 gfc_add_expr_to_block (body
, tmp
);
844 /* Generate a switch statement that branches to the correct I/O
845 result label. The last statement of an I/O call stores the
846 result into a variable because there is often cleanup that
847 must be done before the switch, so a temporary would have to
848 be created anyway. */
851 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
852 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
856 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
858 /* If no labels are specified, ignore the result instead
859 of building an empty switch. */
860 if (err_label
== NULL
862 && eor_label
== NULL
)
865 /* Build a switch statement. */
866 gfc_start_block (&body
);
868 /* The label values here must be the same as the values
869 in the library_return enum in the runtime library */
870 add_case (1, err_label
, &body
);
871 add_case (2, end_label
, &body
);
872 add_case (3, eor_label
, &body
);
874 tmp
= gfc_finish_block (&body
);
876 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
877 st_parameter
[IOPARM_ptype_common
].type
,
878 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
879 rc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
880 var
, p
->field
, NULL_TREE
);
881 rc
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (rc
),
882 rc
, build_int_cst (TREE_TYPE (rc
),
883 IOPARM_common_libreturn_mask
));
885 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
888 gfc_add_expr_to_block (block
, tmp
);
892 /* Store the current file and line number to variables so that if a
893 library call goes awry, we can tell the user where the problem is. */
896 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
899 tree str
, locus_file
;
901 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
903 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
904 st_parameter
[IOPARM_ptype_common
].type
,
905 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
906 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
907 TREE_TYPE (p
->field
), locus_file
,
908 p
->field
, NULL_TREE
);
910 str
= gfc_build_cstring_const (f
->filename
);
912 str
= gfc_build_addr_expr (pchar_type_node
, str
);
913 gfc_add_modify (block
, locus_file
, str
);
915 line
= LOCATION_LINE (where
->lb
->location
);
916 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
920 /* Translate an OPEN statement. */
923 gfc_trans_open (gfc_code
* code
)
925 stmtblock_t block
, post_block
;
928 unsigned int mask
= 0;
930 gfc_start_block (&block
);
931 gfc_init_block (&post_block
);
933 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
935 set_error_locus (&block
, var
, &code
->loc
);
939 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
943 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
947 mask
|= IOPARM_common_err
;
950 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
953 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
957 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
961 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
964 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
967 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
971 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
975 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
979 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
983 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
986 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
990 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
994 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
997 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
1000 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
1004 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
1008 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_open_newunit
,
1011 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1014 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1016 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1018 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1019 tmp
= build_call_expr_loc (input_location
,
1020 iocall
[IOCALL_OPEN
], 1, tmp
);
1021 gfc_add_expr_to_block (&block
, tmp
);
1023 gfc_add_block_to_block (&block
, &post_block
);
1025 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1027 return gfc_finish_block (&block
);
1031 /* Translate a CLOSE statement. */
1034 gfc_trans_close (gfc_code
* code
)
1036 stmtblock_t block
, post_block
;
1039 unsigned int mask
= 0;
1041 gfc_start_block (&block
);
1042 gfc_init_block (&post_block
);
1044 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
1046 set_error_locus (&block
, var
, &code
->loc
);
1047 p
= code
->ext
.close
;
1050 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1054 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1058 mask
|= IOPARM_common_err
;
1061 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
1064 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1067 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1069 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1071 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1072 tmp
= build_call_expr_loc (input_location
,
1073 iocall
[IOCALL_CLOSE
], 1, tmp
);
1074 gfc_add_expr_to_block (&block
, tmp
);
1076 gfc_add_block_to_block (&block
, &post_block
);
1078 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1080 return gfc_finish_block (&block
);
1084 /* Common subroutine for building a file positioning statement. */
1087 build_filepos (tree function
, gfc_code
* code
)
1089 stmtblock_t block
, post_block
;
1092 unsigned int mask
= 0;
1094 p
= code
->ext
.filepos
;
1096 gfc_start_block (&block
);
1097 gfc_init_block (&post_block
);
1099 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1102 set_error_locus (&block
, var
, &code
->loc
);
1105 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1109 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1113 mask
|= IOPARM_common_err
;
1115 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1118 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1120 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1122 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1123 tmp
= build_call_expr_loc (input_location
,
1125 gfc_add_expr_to_block (&block
, tmp
);
1127 gfc_add_block_to_block (&block
, &post_block
);
1129 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1131 return gfc_finish_block (&block
);
1135 /* Translate a BACKSPACE statement. */
1138 gfc_trans_backspace (gfc_code
* code
)
1140 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1144 /* Translate an ENDFILE statement. */
1147 gfc_trans_endfile (gfc_code
* code
)
1149 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1153 /* Translate a REWIND statement. */
1156 gfc_trans_rewind (gfc_code
* code
)
1158 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1162 /* Translate a FLUSH statement. */
1165 gfc_trans_flush (gfc_code
* code
)
1167 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1171 /* Create a dummy iostat variable to catch any error due to bad unit. */
1174 create_dummy_iostat (void)
1179 gfc_get_ha_sym_tree ("@iostat", &st
);
1180 st
->n
.sym
->ts
.type
= BT_INTEGER
;
1181 st
->n
.sym
->ts
.kind
= gfc_default_integer_kind
;
1182 gfc_set_sym_referenced (st
->n
.sym
);
1183 gfc_commit_symbol (st
->n
.sym
);
1184 st
->n
.sym
->backend_decl
1185 = gfc_create_var (gfc_get_int_type (st
->n
.sym
->ts
.kind
),
1188 e
= gfc_get_expr ();
1189 e
->expr_type
= EXPR_VARIABLE
;
1191 e
->ts
.type
= BT_INTEGER
;
1192 e
->ts
.kind
= st
->n
.sym
->ts
.kind
;
1198 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1201 gfc_trans_inquire (gfc_code
* code
)
1203 stmtblock_t block
, post_block
;
1206 unsigned int mask
= 0, mask2
= 0;
1208 gfc_start_block (&block
);
1209 gfc_init_block (&post_block
);
1211 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1214 set_error_locus (&block
, var
, &code
->loc
);
1215 p
= code
->ext
.inquire
;
1218 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1222 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1226 mask
|= IOPARM_common_err
;
1229 if (p
->unit
&& p
->file
)
1230 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1233 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1238 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1241 if (p
->unit
&& !p
->iostat
)
1243 p
->iostat
= create_dummy_iostat ();
1244 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1245 IOPARM_common_iostat
, p
->iostat
);
1250 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1254 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1258 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1262 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1266 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1270 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1274 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1278 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1282 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1286 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1290 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1291 IOPARM_inquire_recl_out
, p
->recl
);
1294 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1295 IOPARM_inquire_nextrec
, p
->nextrec
);
1298 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1302 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1306 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1310 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1314 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1318 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1322 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1326 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1330 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1334 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1335 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1337 /* The second series of flags. */
1338 if (p
->asynchronous
)
1339 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1343 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1347 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1351 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1355 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1359 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1360 IOPARM_inquire_pending
, p
->pending
);
1363 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1367 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1371 mask
|= set_parameter_const (&block
, var
, IOPARM_inquire_flags2
, mask2
);
1373 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1376 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1378 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1380 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1381 tmp
= build_call_expr_loc (input_location
,
1382 iocall
[IOCALL_INQUIRE
], 1, tmp
);
1383 gfc_add_expr_to_block (&block
, tmp
);
1385 gfc_add_block_to_block (&block
, &post_block
);
1387 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1389 return gfc_finish_block (&block
);
1394 gfc_trans_wait (gfc_code
* code
)
1396 stmtblock_t block
, post_block
;
1399 unsigned int mask
= 0;
1401 gfc_start_block (&block
);
1402 gfc_init_block (&post_block
);
1404 var
= gfc_create_var (st_parameter
[IOPARM_ptype_wait
].type
,
1407 set_error_locus (&block
, var
, &code
->loc
);
1410 /* Set parameters here. */
1412 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1416 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1420 mask
|= IOPARM_common_err
;
1423 mask
|= set_parameter_value (&block
, var
, IOPARM_wait_id
, p
->id
);
1425 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1428 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1430 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1431 tmp
= build_call_expr_loc (input_location
,
1432 iocall
[IOCALL_WAIT
], 1, tmp
);
1433 gfc_add_expr_to_block (&block
, tmp
);
1435 gfc_add_block_to_block (&block
, &post_block
);
1437 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1439 return gfc_finish_block (&block
);
1444 /* nml_full_name builds up the fully qualified name of a
1445 derived type component. */
1448 nml_full_name (const char* var_name
, const char* cmp_name
)
1450 int full_name_length
;
1453 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1454 full_name
= XCNEWVEC (char, full_name_length
+ 1);
1455 strcpy (full_name
, var_name
);
1456 full_name
= strcat (full_name
, "%");
1457 full_name
= strcat (full_name
, cmp_name
);
1462 /* nml_get_addr_expr builds an address expression from the
1463 gfc_symbol or gfc_component backend_decl's. An offset is
1464 provided so that the address of an element of an array of
1465 derived types is returned. This is used in the runtime to
1466 determine that span of the derived type. */
1469 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1472 tree decl
= NULL_TREE
;
1477 sym
->attr
.referenced
= 1;
1478 decl
= gfc_get_symbol_decl (sym
);
1480 /* If this is the enclosing function declaration, use
1481 the fake result instead. */
1482 if (decl
== current_function_decl
)
1483 decl
= gfc_get_fake_result_decl (sym
, 0);
1484 else if (decl
== DECL_CONTEXT (current_function_decl
))
1485 decl
= gfc_get_fake_result_decl (sym
, 1);
1488 decl
= c
->backend_decl
;
1490 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1491 || TREE_CODE (decl
) == VAR_DECL
1492 || TREE_CODE (decl
) == PARM_DECL
)
1493 || TREE_CODE (decl
) == COMPONENT_REF
));
1497 /* Build indirect reference, if dummy argument. */
1499 if (POINTER_TYPE_P (TREE_TYPE(tmp
)))
1500 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1502 /* Treat the component of a derived type, using base_addr for
1503 the derived type. */
1505 if (TREE_CODE (decl
) == FIELD_DECL
)
1506 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
1507 base_addr
, tmp
, NULL_TREE
);
1509 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
1510 tmp
= gfc_conv_array_data (tmp
);
1513 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1514 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1516 if (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1517 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1519 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1520 tmp
= build_fold_indirect_ref_loc (input_location
,
1524 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1530 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1531 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1532 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1534 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1537 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1538 gfc_symbol
* sym
, gfc_component
* c
,
1541 gfc_typespec
* ts
= NULL
;
1542 gfc_array_spec
* as
= NULL
;
1543 tree addr_expr
= NULL
;
1549 tree decl
= NULL_TREE
;
1554 gcc_assert (sym
|| c
);
1556 /* Build the namelist object name. */
1558 string
= gfc_build_cstring_const (var_name
);
1559 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1561 /* Build ts, as and data address using symbol or component. */
1563 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1564 as
= (sym
) ? sym
->as
: c
->as
;
1566 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1573 decl
= (sym
) ? sym
->backend_decl
: c
->backend_decl
;
1574 if (sym
&& sym
->attr
.dummy
)
1575 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
1576 dt
= TREE_TYPE (decl
);
1577 dtype
= gfc_get_dtype (dt
);
1582 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1585 /* Build up the arguments for the transfer call.
1586 The call for the scalar part transfers:
1587 (address, name, type, kind or string_length, dtype) */
1589 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1591 if (ts
->type
== BT_CHARACTER
)
1592 tmp
= ts
->u
.cl
->backend_decl
;
1594 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1595 tmp
= build_call_expr_loc (input_location
,
1596 iocall
[IOCALL_SET_NML_VAL
], 6,
1597 dt_parm_addr
, addr_expr
, string
,
1598 IARG (ts
->kind
), tmp
, dtype
);
1599 gfc_add_expr_to_block (block
, tmp
);
1601 /* If the object is an array, transfer rank times:
1602 (null pointer, name, stride, lbound, ubound) */
1604 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1606 tmp
= build_call_expr_loc (input_location
,
1607 iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1610 gfc_conv_array_stride (decl
, n_dim
),
1611 gfc_conv_array_lbound (decl
, n_dim
),
1612 gfc_conv_array_ubound (decl
, n_dim
));
1613 gfc_add_expr_to_block (block
, tmp
);
1616 if (ts
->type
== BT_DERIVED
)
1620 /* Provide the RECORD_TYPE to build component references. */
1622 tree expr
= build_fold_indirect_ref_loc (input_location
,
1625 for (cmp
= ts
->u
.derived
->components
; cmp
; cmp
= cmp
->next
)
1627 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1628 transfer_namelist_element (block
,
1638 /* Create a data transfer statement. Not all of the fields are valid
1639 for both reading and writing, but improper use has been filtered
1643 build_dt (tree function
, gfc_code
* code
)
1645 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1650 unsigned int mask
= 0;
1652 gfc_start_block (&block
);
1653 gfc_init_block (&post_block
);
1654 gfc_init_block (&post_end_block
);
1655 gfc_init_block (&post_iu_block
);
1657 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1659 set_error_locus (&block
, var
, &code
->loc
);
1661 if (last_dt
== IOLENGTH
)
1665 inq
= code
->ext
.inquire
;
1667 /* First check that preconditions are met. */
1668 gcc_assert (inq
!= NULL
);
1669 gcc_assert (inq
->iolength
!= NULL
);
1671 /* Connect to the iolength variable. */
1672 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1673 IOPARM_dt_iolength
, inq
->iolength
);
1679 gcc_assert (dt
!= NULL
);
1682 if (dt
&& dt
->io_unit
)
1684 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1686 mask
|= set_internal_unit (&block
, &post_iu_block
,
1688 set_parameter_const (&block
, var
, IOPARM_common_unit
,
1689 dt
->io_unit
->ts
.kind
== 1 ? 0 : -1);
1693 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1698 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1702 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1703 IOPARM_common_iostat
, dt
->iostat
);
1706 mask
|= IOPARM_common_err
;
1709 mask
|= IOPARM_common_eor
;
1712 mask
|= IOPARM_common_end
;
1715 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1716 IOPARM_dt_id
, dt
->id
);
1719 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1721 if (dt
->asynchronous
)
1722 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_asynchronous
,
1726 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1730 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1734 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1738 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1742 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1746 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1750 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1753 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1756 if (dt
->format_expr
)
1757 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1760 if (dt
->format_label
)
1762 if (dt
->format_label
== &format_asterisk
)
1763 mask
|= IOPARM_dt_list_format
;
1765 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1766 dt
->format_label
->format
);
1770 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1771 IOPARM_dt_size
, dt
->size
);
1775 if (dt
->format_expr
|| dt
->format_label
)
1776 gfc_internal_error ("build_dt: format with namelist");
1778 nmlname
= gfc_get_character_expr (gfc_default_character_kind
, NULL
,
1780 strlen (dt
->namelist
->name
));
1782 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1785 if (last_dt
== READ
)
1786 mask
|= IOPARM_dt_namelist_read_mode
;
1788 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1792 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1793 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1797 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1799 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1800 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1803 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1805 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1806 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
1808 gfc_add_expr_to_block (&block
, tmp
);
1810 gfc_add_block_to_block (&block
, &post_block
);
1813 dt_post_end_block
= &post_end_block
;
1815 /* Set implied do loop exit condition. */
1816 if (last_dt
== READ
|| last_dt
== WRITE
)
1818 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
1820 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1821 st_parameter
[IOPARM_ptype_common
].type
,
1822 dt_parm
, TYPE_FIELDS (TREE_TYPE (dt_parm
)),
1824 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1825 TREE_TYPE (p
->field
), tmp
, p
->field
, NULL_TREE
);
1826 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (tmp
),
1827 tmp
, build_int_cst (TREE_TYPE (tmp
),
1828 IOPARM_common_libreturn_mask
));
1833 gfc_add_expr_to_block (&block
, gfc_trans_code_cond (code
->block
->next
, tmp
));
1835 gfc_add_block_to_block (&block
, &post_iu_block
);
1838 dt_post_end_block
= NULL
;
1840 return gfc_finish_block (&block
);
1844 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1845 this as a third sort of data transfer statement, except that
1846 lengths are summed instead of actually transferring any data. */
1849 gfc_trans_iolength (gfc_code
* code
)
1852 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1856 /* Translate a READ statement. */
1859 gfc_trans_read (gfc_code
* code
)
1862 return build_dt (iocall
[IOCALL_READ
], code
);
1866 /* Translate a WRITE statement */
1869 gfc_trans_write (gfc_code
* code
)
1872 return build_dt (iocall
[IOCALL_WRITE
], code
);
1876 /* Finish a data transfer statement. */
1879 gfc_trans_dt_end (gfc_code
* code
)
1884 gfc_init_block (&block
);
1889 function
= iocall
[IOCALL_READ_DONE
];
1893 function
= iocall
[IOCALL_WRITE_DONE
];
1897 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1904 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1905 tmp
= build_call_expr_loc (input_location
,
1907 gfc_add_expr_to_block (&block
, tmp
);
1908 gfc_add_block_to_block (&block
, dt_post_end_block
);
1909 gfc_init_block (dt_post_end_block
);
1911 if (last_dt
!= IOLENGTH
)
1913 gcc_assert (code
->ext
.dt
!= NULL
);
1914 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1915 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1918 return gfc_finish_block (&block
);
1922 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1924 /* Given an array field in a derived type variable, generate the code
1925 for the loop that iterates over array elements, and the code that
1926 accesses those array elements. Use transfer_expr to generate code
1927 for transferring that element. Because elements may also be
1928 derived types, transfer_expr and transfer_array_component are mutually
1932 transfer_array_component (tree expr
, gfc_component
* cm
, locus
* where
)
1941 gfc_array_info
*ss_array
;
1943 gfc_start_block (&block
);
1944 gfc_init_se (&se
, NULL
);
1946 /* Create and initialize Scalarization Status. Unlike in
1947 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1948 care of this task, because we don't have a gfc_expr at hand.
1949 Build one manually, as in gfc_trans_subarray_assign. */
1951 ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
1953 ss_array
= &ss
->info
->data
.array
;
1954 ss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
1955 ss_array
->descriptor
= expr
;
1956 ss_array
->data
= gfc_conv_array_data (expr
);
1957 ss_array
->offset
= gfc_conv_array_offset (expr
);
1958 for (n
= 0; n
< cm
->as
->rank
; n
++)
1960 ss_array
->start
[n
] = gfc_conv_array_lbound (expr
, n
);
1961 ss_array
->stride
[n
] = gfc_index_one_node
;
1963 mpz_init (ss_array
->shape
[n
]);
1964 mpz_sub (ss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1965 cm
->as
->lower
[n
]->value
.integer
);
1966 mpz_add_ui (ss_array
->shape
[n
], ss_array
->shape
[n
], 1);
1969 /* Once we got ss, we use scalarizer to create the loop. */
1971 gfc_init_loopinfo (&loop
);
1972 gfc_add_ss_to_loop (&loop
, ss
);
1973 gfc_conv_ss_startstride (&loop
);
1974 gfc_conv_loop_setup (&loop
, where
);
1975 gfc_mark_ss_chain_used (ss
, 1);
1976 gfc_start_scalarized_body (&loop
, &body
);
1978 gfc_copy_loopinfo_to_se (&se
, &loop
);
1981 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1983 gfc_conv_tmp_array_ref (&se
);
1985 /* Now se.expr contains an element of the array. Take the address and pass
1986 it to the IO routines. */
1987 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
1988 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1990 /* We are done now with the loop body. Wrap up the scalarizer and
1993 gfc_add_block_to_block (&body
, &se
.pre
);
1994 gfc_add_block_to_block (&body
, &se
.post
);
1996 gfc_trans_scalarizing_loops (&loop
, &body
);
1998 gfc_add_block_to_block (&block
, &loop
.pre
);
1999 gfc_add_block_to_block (&block
, &loop
.post
);
2001 gcc_assert (ss_array
->shape
!= NULL
);
2002 gfc_free_shape (&ss_array
->shape
, cm
->as
->rank
);
2003 gfc_cleanup_loop (&loop
);
2005 return gfc_finish_block (&block
);
2008 /* Generate the call for a scalar transfer node. */
2011 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
2013 tree tmp
, function
, arg2
, arg3
, field
, expr
;
2017 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2018 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2019 We need to translate the expression to a constant if it's either
2020 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2021 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2022 BT_DERIVED (could have been changed by gfc_conv_expr). */
2023 if ((ts
->type
== BT_DERIVED
|| ts
->type
== BT_INTEGER
)
2024 && ts
->u
.derived
!= NULL
2025 && (ts
->is_iso_c
== 1 || ts
->u
.derived
->ts
.is_iso_c
== 1))
2027 /* C_PTR and C_FUNPTR have private components which means they can not
2028 be printed. However, if -std=gnu and not -pedantic, allow
2029 the component to be printed to help debugging. */
2030 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
2032 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
2033 ts
->u
.derived
->name
, code
!= NULL
? &(code
->loc
) :
2034 &gfc_current_locus
);
2038 ts
->type
= ts
->u
.derived
->ts
.type
;
2039 ts
->kind
= ts
->u
.derived
->ts
.kind
;
2040 ts
->f90_type
= ts
->u
.derived
->ts
.f90_type
;
2051 arg2
= build_int_cst (integer_type_node
, kind
);
2052 if (last_dt
== READ
)
2053 function
= iocall
[IOCALL_X_INTEGER
];
2055 function
= iocall
[IOCALL_X_INTEGER_WRITE
];
2060 arg2
= build_int_cst (integer_type_node
, kind
);
2061 if (last_dt
== READ
)
2063 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2064 function
= iocall
[IOCALL_X_REAL128
];
2066 function
= iocall
[IOCALL_X_REAL
];
2070 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2071 function
= iocall
[IOCALL_X_REAL128_WRITE
];
2073 function
= iocall
[IOCALL_X_REAL_WRITE
];
2079 arg2
= build_int_cst (integer_type_node
, kind
);
2080 if (last_dt
== READ
)
2082 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2083 function
= iocall
[IOCALL_X_COMPLEX128
];
2085 function
= iocall
[IOCALL_X_COMPLEX
];
2089 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2090 function
= iocall
[IOCALL_X_COMPLEX128_WRITE
];
2092 function
= iocall
[IOCALL_X_COMPLEX_WRITE
];
2098 arg2
= build_int_cst (integer_type_node
, kind
);
2099 if (last_dt
== READ
)
2100 function
= iocall
[IOCALL_X_LOGICAL
];
2102 function
= iocall
[IOCALL_X_LOGICAL_WRITE
];
2109 if (se
->string_length
)
2110 arg2
= se
->string_length
;
2113 tmp
= build_fold_indirect_ref_loc (input_location
,
2115 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2116 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2117 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2119 arg3
= build_int_cst (integer_type_node
, kind
);
2120 if (last_dt
== READ
)
2121 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2123 function
= iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
];
2125 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2126 tmp
= build_call_expr_loc (input_location
,
2127 function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2128 gfc_add_expr_to_block (&se
->pre
, tmp
);
2129 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2134 if (se
->string_length
)
2135 arg2
= se
->string_length
;
2138 tmp
= build_fold_indirect_ref_loc (input_location
,
2140 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2141 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2143 if (last_dt
== READ
)
2144 function
= iocall
[IOCALL_X_CHARACTER
];
2146 function
= iocall
[IOCALL_X_CHARACTER_WRITE
];
2151 /* Recurse into the elements of the derived type. */
2152 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2153 expr
= build_fold_indirect_ref_loc (input_location
,
2156 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
2158 field
= c
->backend_decl
;
2159 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2161 tmp
= fold_build3_loc (UNKNOWN_LOCATION
,
2162 COMPONENT_REF
, TREE_TYPE (field
),
2163 expr
, field
, NULL_TREE
);
2165 if (c
->attr
.dimension
)
2167 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2168 gfc_add_expr_to_block (&se
->pre
, tmp
);
2172 if (!c
->attr
.pointer
)
2173 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2174 transfer_expr (se
, &c
->ts
, tmp
, code
);
2180 internal_error ("Bad IO basetype (%d)", ts
->type
);
2183 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2184 tmp
= build_call_expr_loc (input_location
,
2185 function
, 3, tmp
, addr_expr
, arg2
);
2186 gfc_add_expr_to_block (&se
->pre
, tmp
);
2187 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2192 /* Generate a call to pass an array descriptor to the IO library. The
2193 array should be of one of the intrinsic types. */
2196 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2198 tree tmp
, charlen_arg
, kind_arg
, io_call
;
2200 if (ts
->type
== BT_CHARACTER
)
2201 charlen_arg
= se
->string_length
;
2203 charlen_arg
= build_int_cst (gfc_charlen_type_node
, 0);
2205 kind_arg
= build_int_cst (integer_type_node
, ts
->kind
);
2207 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2208 if (last_dt
== READ
)
2209 io_call
= iocall
[IOCALL_X_ARRAY
];
2211 io_call
= iocall
[IOCALL_X_ARRAY_WRITE
];
2213 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2215 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2216 gfc_add_expr_to_block (&se
->pre
, tmp
);
2217 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2221 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2224 gfc_trans_transfer (gfc_code
* code
)
2226 stmtblock_t block
, body
;
2235 gfc_start_block (&block
);
2236 gfc_init_block (&body
);
2239 ss
= gfc_walk_expr (expr
);
2242 gfc_init_se (&se
, NULL
);
2244 if (ss
== gfc_ss_terminator
)
2246 /* Transfer a scalar value. */
2247 gfc_conv_expr_reference (&se
, expr
);
2248 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2252 /* Transfer an array. If it is an array of an intrinsic
2253 type, pass the descriptor to the library. Otherwise
2254 scalarize the transfer. */
2255 if (expr
->ref
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
2257 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2259 gcc_assert (ref
->type
== REF_ARRAY
);
2262 if (expr
->ts
.type
!= BT_DERIVED
2263 && ref
&& ref
->next
== NULL
2264 && !is_subref_array (expr
))
2266 bool seen_vector
= false;
2268 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2270 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2271 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2275 if (seen_vector
&& last_dt
== READ
)
2277 /* Create a temp, read to that and copy it back. */
2278 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
, false);
2283 /* Get the descriptor. */
2284 gfc_conv_expr_descriptor (&se
, expr
, ss
);
2285 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2288 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2289 goto finish_block_label
;
2292 /* Initialize the scalarizer. */
2293 gfc_init_loopinfo (&loop
);
2294 gfc_add_ss_to_loop (&loop
, ss
);
2296 /* Initialize the loop. */
2297 gfc_conv_ss_startstride (&loop
);
2298 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
2300 /* The main loop body. */
2301 gfc_mark_ss_chain_used (ss
, 1);
2302 gfc_start_scalarized_body (&loop
, &body
);
2304 gfc_copy_loopinfo_to_se (&se
, &loop
);
2307 gfc_conv_expr_reference (&se
, expr
);
2308 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2313 gfc_add_block_to_block (&body
, &se
.pre
);
2314 gfc_add_block_to_block (&body
, &se
.post
);
2317 tmp
= gfc_finish_block (&body
);
2320 gcc_assert (se
.ss
== gfc_ss_terminator
);
2321 gfc_trans_scalarizing_loops (&loop
, &body
);
2323 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2324 tmp
= gfc_finish_block (&loop
.pre
);
2325 gfc_cleanup_loop (&loop
);
2328 gfc_add_expr_to_block (&block
, tmp
);
2330 return gfc_finish_block (&block
);
2333 #include "gt-fortran-trans-io.h"