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
, 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 if (is_subref_array (e
))
785 /* Use a temporary for components of arrays of derived types
786 or substring array references. */
787 gfc_conv_subref_array_arg (&se
, e
, 0,
788 last_dt
== READ
? INTENT_IN
: INTENT_OUT
, false);
789 tmp
= build_fold_indirect_ref_loc (input_location
,
791 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
792 tmp
= gfc_conv_descriptor_data_get (tmp
);
796 /* Return the data pointer and rank from the descriptor. */
797 gfc_conv_expr_descriptor (&se
, e
);
798 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
799 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
805 /* The cast is needed for character substrings and the descriptor
807 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
808 gfc_add_modify (&se
.pre
, len
,
809 fold_convert (TREE_TYPE (len
), se
.string_length
));
810 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
812 gfc_add_block_to_block (block
, &se
.pre
);
813 gfc_add_block_to_block (post_block
, &se
.post
);
817 /* Add a case to a IO-result switch. */
820 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
825 return; /* No label, no case */
827 value
= build_int_cst (integer_type_node
, label_value
);
829 /* Make a backend label for this case. */
830 tmp
= gfc_build_label_decl (NULL_TREE
);
832 /* And the case itself. */
833 tmp
= build_case_label (value
, NULL_TREE
, tmp
);
834 gfc_add_expr_to_block (body
, tmp
);
836 /* Jump to the label. */
837 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
838 gfc_add_expr_to_block (body
, tmp
);
842 /* Generate a switch statement that branches to the correct I/O
843 result label. The last statement of an I/O call stores the
844 result into a variable because there is often cleanup that
845 must be done before the switch, so a temporary would have to
846 be created anyway. */
849 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
850 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
854 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
856 /* If no labels are specified, ignore the result instead
857 of building an empty switch. */
858 if (err_label
== NULL
860 && eor_label
== NULL
)
863 /* Build a switch statement. */
864 gfc_start_block (&body
);
866 /* The label values here must be the same as the values
867 in the library_return enum in the runtime library */
868 add_case (1, err_label
, &body
);
869 add_case (2, end_label
, &body
);
870 add_case (3, eor_label
, &body
);
872 tmp
= gfc_finish_block (&body
);
874 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
875 st_parameter
[IOPARM_ptype_common
].type
,
876 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
877 rc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
878 var
, p
->field
, NULL_TREE
);
879 rc
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (rc
),
880 rc
, build_int_cst (TREE_TYPE (rc
),
881 IOPARM_common_libreturn_mask
));
883 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
886 gfc_add_expr_to_block (block
, tmp
);
890 /* Store the current file and line number to variables so that if a
891 library call goes awry, we can tell the user where the problem is. */
894 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
897 tree str
, locus_file
;
899 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
901 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
902 st_parameter
[IOPARM_ptype_common
].type
,
903 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
904 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
905 TREE_TYPE (p
->field
), locus_file
,
906 p
->field
, NULL_TREE
);
908 str
= gfc_build_cstring_const (f
->filename
);
910 str
= gfc_build_addr_expr (pchar_type_node
, str
);
911 gfc_add_modify (block
, locus_file
, str
);
913 line
= LOCATION_LINE (where
->lb
->location
);
914 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
918 /* Translate an OPEN statement. */
921 gfc_trans_open (gfc_code
* code
)
923 stmtblock_t block
, post_block
;
926 unsigned int mask
= 0;
928 gfc_start_block (&block
);
929 gfc_init_block (&post_block
);
931 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
933 set_error_locus (&block
, var
, &code
->loc
);
937 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
941 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
945 mask
|= IOPARM_common_err
;
948 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
951 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
955 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
959 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
962 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
965 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
969 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
973 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
977 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
981 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
984 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
988 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
992 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
995 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
998 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
1002 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
1006 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_open_newunit
,
1009 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1012 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1014 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1016 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1017 tmp
= build_call_expr_loc (input_location
,
1018 iocall
[IOCALL_OPEN
], 1, tmp
);
1019 gfc_add_expr_to_block (&block
, tmp
);
1021 gfc_add_block_to_block (&block
, &post_block
);
1023 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1025 return gfc_finish_block (&block
);
1029 /* Translate a CLOSE statement. */
1032 gfc_trans_close (gfc_code
* code
)
1034 stmtblock_t block
, post_block
;
1037 unsigned int mask
= 0;
1039 gfc_start_block (&block
);
1040 gfc_init_block (&post_block
);
1042 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
1044 set_error_locus (&block
, var
, &code
->loc
);
1045 p
= code
->ext
.close
;
1048 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1052 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1056 mask
|= IOPARM_common_err
;
1059 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
1062 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1065 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1067 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1069 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1070 tmp
= build_call_expr_loc (input_location
,
1071 iocall
[IOCALL_CLOSE
], 1, tmp
);
1072 gfc_add_expr_to_block (&block
, tmp
);
1074 gfc_add_block_to_block (&block
, &post_block
);
1076 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1078 return gfc_finish_block (&block
);
1082 /* Common subroutine for building a file positioning statement. */
1085 build_filepos (tree function
, gfc_code
* code
)
1087 stmtblock_t block
, post_block
;
1090 unsigned int mask
= 0;
1092 p
= code
->ext
.filepos
;
1094 gfc_start_block (&block
);
1095 gfc_init_block (&post_block
);
1097 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1100 set_error_locus (&block
, var
, &code
->loc
);
1103 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1107 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1111 mask
|= IOPARM_common_err
;
1113 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1116 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1118 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1120 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1121 tmp
= build_call_expr_loc (input_location
,
1123 gfc_add_expr_to_block (&block
, tmp
);
1125 gfc_add_block_to_block (&block
, &post_block
);
1127 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1129 return gfc_finish_block (&block
);
1133 /* Translate a BACKSPACE statement. */
1136 gfc_trans_backspace (gfc_code
* code
)
1138 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1142 /* Translate an ENDFILE statement. */
1145 gfc_trans_endfile (gfc_code
* code
)
1147 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1151 /* Translate a REWIND statement. */
1154 gfc_trans_rewind (gfc_code
* code
)
1156 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1160 /* Translate a FLUSH statement. */
1163 gfc_trans_flush (gfc_code
* code
)
1165 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1169 /* Create a dummy iostat variable to catch any error due to bad unit. */
1172 create_dummy_iostat (void)
1177 gfc_get_ha_sym_tree ("@iostat", &st
);
1178 st
->n
.sym
->ts
.type
= BT_INTEGER
;
1179 st
->n
.sym
->ts
.kind
= gfc_default_integer_kind
;
1180 gfc_set_sym_referenced (st
->n
.sym
);
1181 gfc_commit_symbol (st
->n
.sym
);
1182 st
->n
.sym
->backend_decl
1183 = gfc_create_var (gfc_get_int_type (st
->n
.sym
->ts
.kind
),
1186 e
= gfc_get_expr ();
1187 e
->expr_type
= EXPR_VARIABLE
;
1189 e
->ts
.type
= BT_INTEGER
;
1190 e
->ts
.kind
= st
->n
.sym
->ts
.kind
;
1196 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1199 gfc_trans_inquire (gfc_code
* code
)
1201 stmtblock_t block
, post_block
;
1204 unsigned int mask
= 0, mask2
= 0;
1206 gfc_start_block (&block
);
1207 gfc_init_block (&post_block
);
1209 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1212 set_error_locus (&block
, var
, &code
->loc
);
1213 p
= code
->ext
.inquire
;
1216 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1220 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1224 mask
|= IOPARM_common_err
;
1227 if (p
->unit
&& p
->file
)
1228 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1231 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1236 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1239 if (p
->unit
&& !p
->iostat
)
1241 p
->iostat
= create_dummy_iostat ();
1242 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1243 IOPARM_common_iostat
, p
->iostat
);
1248 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1252 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1256 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1260 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1264 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1268 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1272 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1276 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1280 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1284 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1288 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1289 IOPARM_inquire_recl_out
, p
->recl
);
1292 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1293 IOPARM_inquire_nextrec
, p
->nextrec
);
1296 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1300 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1304 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1308 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1312 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1316 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1320 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1324 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1328 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1332 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1333 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1335 /* The second series of flags. */
1336 if (p
->asynchronous
)
1337 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1341 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1345 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1349 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1353 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1357 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1358 IOPARM_inquire_pending
, p
->pending
);
1361 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1365 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1369 mask
|= set_parameter_const (&block
, var
, IOPARM_inquire_flags2
, mask2
);
1371 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1374 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1376 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1378 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1379 tmp
= build_call_expr_loc (input_location
,
1380 iocall
[IOCALL_INQUIRE
], 1, tmp
);
1381 gfc_add_expr_to_block (&block
, tmp
);
1383 gfc_add_block_to_block (&block
, &post_block
);
1385 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1387 return gfc_finish_block (&block
);
1392 gfc_trans_wait (gfc_code
* code
)
1394 stmtblock_t block
, post_block
;
1397 unsigned int mask
= 0;
1399 gfc_start_block (&block
);
1400 gfc_init_block (&post_block
);
1402 var
= gfc_create_var (st_parameter
[IOPARM_ptype_wait
].type
,
1405 set_error_locus (&block
, var
, &code
->loc
);
1408 /* Set parameters here. */
1410 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1414 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1418 mask
|= IOPARM_common_err
;
1421 mask
|= set_parameter_value (&block
, var
, IOPARM_wait_id
, p
->id
);
1423 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1426 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1428 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1429 tmp
= build_call_expr_loc (input_location
,
1430 iocall
[IOCALL_WAIT
], 1, tmp
);
1431 gfc_add_expr_to_block (&block
, tmp
);
1433 gfc_add_block_to_block (&block
, &post_block
);
1435 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1437 return gfc_finish_block (&block
);
1442 /* nml_full_name builds up the fully qualified name of a
1443 derived type component. */
1446 nml_full_name (const char* var_name
, const char* cmp_name
)
1448 int full_name_length
;
1451 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1452 full_name
= XCNEWVEC (char, full_name_length
+ 1);
1453 strcpy (full_name
, var_name
);
1454 full_name
= strcat (full_name
, "%");
1455 full_name
= strcat (full_name
, cmp_name
);
1460 /* nml_get_addr_expr builds an address expression from the
1461 gfc_symbol or gfc_component backend_decl's. An offset is
1462 provided so that the address of an element of an array of
1463 derived types is returned. This is used in the runtime to
1464 determine that span of the derived type. */
1467 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1470 tree decl
= NULL_TREE
;
1475 sym
->attr
.referenced
= 1;
1476 decl
= gfc_get_symbol_decl (sym
);
1478 /* If this is the enclosing function declaration, use
1479 the fake result instead. */
1480 if (decl
== current_function_decl
)
1481 decl
= gfc_get_fake_result_decl (sym
, 0);
1482 else if (decl
== DECL_CONTEXT (current_function_decl
))
1483 decl
= gfc_get_fake_result_decl (sym
, 1);
1486 decl
= c
->backend_decl
;
1488 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1489 || TREE_CODE (decl
) == VAR_DECL
1490 || TREE_CODE (decl
) == PARM_DECL
)
1491 || TREE_CODE (decl
) == COMPONENT_REF
));
1495 /* Build indirect reference, if dummy argument. */
1497 if (POINTER_TYPE_P (TREE_TYPE(tmp
)))
1498 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1500 /* Treat the component of a derived type, using base_addr for
1501 the derived type. */
1503 if (TREE_CODE (decl
) == FIELD_DECL
)
1504 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
1505 base_addr
, tmp
, NULL_TREE
);
1507 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
1508 tmp
= gfc_conv_array_data (tmp
);
1511 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1512 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1514 if (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1515 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1517 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1518 tmp
= build_fold_indirect_ref_loc (input_location
,
1522 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1528 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1529 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1530 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1532 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1535 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1536 gfc_symbol
* sym
, gfc_component
* c
,
1539 gfc_typespec
* ts
= NULL
;
1540 gfc_array_spec
* as
= NULL
;
1541 tree addr_expr
= NULL
;
1547 tree decl
= NULL_TREE
;
1552 gcc_assert (sym
|| c
);
1554 /* Build the namelist object name. */
1556 string
= gfc_build_cstring_const (var_name
);
1557 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1559 /* Build ts, as and data address using symbol or component. */
1561 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1562 as
= (sym
) ? sym
->as
: c
->as
;
1564 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1571 decl
= (sym
) ? sym
->backend_decl
: c
->backend_decl
;
1572 if (sym
&& sym
->attr
.dummy
)
1573 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
1574 dt
= TREE_TYPE (decl
);
1575 dtype
= gfc_get_dtype (dt
);
1580 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1583 /* Build up the arguments for the transfer call.
1584 The call for the scalar part transfers:
1585 (address, name, type, kind or string_length, dtype) */
1587 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1589 if (ts
->type
== BT_CHARACTER
)
1590 tmp
= ts
->u
.cl
->backend_decl
;
1592 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1593 tmp
= build_call_expr_loc (input_location
,
1594 iocall
[IOCALL_SET_NML_VAL
], 6,
1595 dt_parm_addr
, addr_expr
, string
,
1596 IARG (ts
->kind
), tmp
, dtype
);
1597 gfc_add_expr_to_block (block
, tmp
);
1599 /* If the object is an array, transfer rank times:
1600 (null pointer, name, stride, lbound, ubound) */
1602 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1604 tmp
= build_call_expr_loc (input_location
,
1605 iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1608 gfc_conv_array_stride (decl
, n_dim
),
1609 gfc_conv_array_lbound (decl
, n_dim
),
1610 gfc_conv_array_ubound (decl
, n_dim
));
1611 gfc_add_expr_to_block (block
, tmp
);
1614 if (ts
->type
== BT_DERIVED
)
1618 /* Provide the RECORD_TYPE to build component references. */
1620 tree expr
= build_fold_indirect_ref_loc (input_location
,
1623 for (cmp
= ts
->u
.derived
->components
; cmp
; cmp
= cmp
->next
)
1625 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1626 transfer_namelist_element (block
,
1636 /* Create a data transfer statement. Not all of the fields are valid
1637 for both reading and writing, but improper use has been filtered
1641 build_dt (tree function
, gfc_code
* code
)
1643 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1648 unsigned int mask
= 0;
1650 gfc_start_block (&block
);
1651 gfc_init_block (&post_block
);
1652 gfc_init_block (&post_end_block
);
1653 gfc_init_block (&post_iu_block
);
1655 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1657 set_error_locus (&block
, var
, &code
->loc
);
1659 if (last_dt
== IOLENGTH
)
1663 inq
= code
->ext
.inquire
;
1665 /* First check that preconditions are met. */
1666 gcc_assert (inq
!= NULL
);
1667 gcc_assert (inq
->iolength
!= NULL
);
1669 /* Connect to the iolength variable. */
1670 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1671 IOPARM_dt_iolength
, inq
->iolength
);
1677 gcc_assert (dt
!= NULL
);
1680 if (dt
&& dt
->io_unit
)
1682 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1684 mask
|= set_internal_unit (&block
, &post_iu_block
,
1686 set_parameter_const (&block
, var
, IOPARM_common_unit
,
1687 dt
->io_unit
->ts
.kind
== 1 ? 0 : -1);
1691 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1696 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1700 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1701 IOPARM_common_iostat
, dt
->iostat
);
1704 mask
|= IOPARM_common_err
;
1707 mask
|= IOPARM_common_eor
;
1710 mask
|= IOPARM_common_end
;
1713 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1714 IOPARM_dt_id
, dt
->id
);
1717 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1719 if (dt
->asynchronous
)
1720 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_asynchronous
,
1724 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1728 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1732 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1736 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1740 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1744 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1748 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1751 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1754 if (dt
->format_expr
)
1755 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1758 if (dt
->format_label
)
1760 if (dt
->format_label
== &format_asterisk
)
1761 mask
|= IOPARM_dt_list_format
;
1763 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1764 dt
->format_label
->format
);
1768 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1769 IOPARM_dt_size
, dt
->size
);
1773 if (dt
->format_expr
|| dt
->format_label
)
1774 gfc_internal_error ("build_dt: format with namelist");
1776 nmlname
= gfc_get_character_expr (gfc_default_character_kind
, NULL
,
1778 strlen (dt
->namelist
->name
));
1780 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1783 if (last_dt
== READ
)
1784 mask
|= IOPARM_dt_namelist_read_mode
;
1786 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1790 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1791 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1795 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1797 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1798 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1801 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1803 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1804 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
1806 gfc_add_expr_to_block (&block
, tmp
);
1808 gfc_add_block_to_block (&block
, &post_block
);
1811 dt_post_end_block
= &post_end_block
;
1813 /* Set implied do loop exit condition. */
1814 if (last_dt
== READ
|| last_dt
== WRITE
)
1816 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
1818 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1819 st_parameter
[IOPARM_ptype_common
].type
,
1820 dt_parm
, TYPE_FIELDS (TREE_TYPE (dt_parm
)),
1822 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1823 TREE_TYPE (p
->field
), tmp
, p
->field
, NULL_TREE
);
1824 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (tmp
),
1825 tmp
, build_int_cst (TREE_TYPE (tmp
),
1826 IOPARM_common_libreturn_mask
));
1831 gfc_add_expr_to_block (&block
, gfc_trans_code_cond (code
->block
->next
, tmp
));
1833 gfc_add_block_to_block (&block
, &post_iu_block
);
1836 dt_post_end_block
= NULL
;
1838 return gfc_finish_block (&block
);
1842 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1843 this as a third sort of data transfer statement, except that
1844 lengths are summed instead of actually transferring any data. */
1847 gfc_trans_iolength (gfc_code
* code
)
1850 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1854 /* Translate a READ statement. */
1857 gfc_trans_read (gfc_code
* code
)
1860 return build_dt (iocall
[IOCALL_READ
], code
);
1864 /* Translate a WRITE statement */
1867 gfc_trans_write (gfc_code
* code
)
1870 return build_dt (iocall
[IOCALL_WRITE
], code
);
1874 /* Finish a data transfer statement. */
1877 gfc_trans_dt_end (gfc_code
* code
)
1882 gfc_init_block (&block
);
1887 function
= iocall
[IOCALL_READ_DONE
];
1891 function
= iocall
[IOCALL_WRITE_DONE
];
1895 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1902 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1903 tmp
= build_call_expr_loc (input_location
,
1905 gfc_add_expr_to_block (&block
, tmp
);
1906 gfc_add_block_to_block (&block
, dt_post_end_block
);
1907 gfc_init_block (dt_post_end_block
);
1909 if (last_dt
!= IOLENGTH
)
1911 gcc_assert (code
->ext
.dt
!= NULL
);
1912 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1913 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1916 return gfc_finish_block (&block
);
1920 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1922 /* Given an array field in a derived type variable, generate the code
1923 for the loop that iterates over array elements, and the code that
1924 accesses those array elements. Use transfer_expr to generate code
1925 for transferring that element. Because elements may also be
1926 derived types, transfer_expr and transfer_array_component are mutually
1930 transfer_array_component (tree expr
, gfc_component
* cm
, locus
* where
)
1939 gfc_array_info
*ss_array
;
1941 gfc_start_block (&block
);
1942 gfc_init_se (&se
, NULL
);
1944 /* Create and initialize Scalarization Status. Unlike in
1945 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1946 care of this task, because we don't have a gfc_expr at hand.
1947 Build one manually, as in gfc_trans_subarray_assign. */
1949 ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
1951 ss_array
= &ss
->info
->data
.array
;
1952 ss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
1953 ss_array
->descriptor
= expr
;
1954 ss_array
->data
= gfc_conv_array_data (expr
);
1955 ss_array
->offset
= gfc_conv_array_offset (expr
);
1956 for (n
= 0; n
< cm
->as
->rank
; n
++)
1958 ss_array
->start
[n
] = gfc_conv_array_lbound (expr
, n
);
1959 ss_array
->stride
[n
] = gfc_index_one_node
;
1961 mpz_init (ss_array
->shape
[n
]);
1962 mpz_sub (ss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1963 cm
->as
->lower
[n
]->value
.integer
);
1964 mpz_add_ui (ss_array
->shape
[n
], ss_array
->shape
[n
], 1);
1967 /* Once we got ss, we use scalarizer to create the loop. */
1969 gfc_init_loopinfo (&loop
);
1970 gfc_add_ss_to_loop (&loop
, ss
);
1971 gfc_conv_ss_startstride (&loop
);
1972 gfc_conv_loop_setup (&loop
, where
);
1973 gfc_mark_ss_chain_used (ss
, 1);
1974 gfc_start_scalarized_body (&loop
, &body
);
1976 gfc_copy_loopinfo_to_se (&se
, &loop
);
1979 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1981 gfc_conv_tmp_array_ref (&se
);
1983 /* Now se.expr contains an element of the array. Take the address and pass
1984 it to the IO routines. */
1985 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
1986 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1988 /* We are done now with the loop body. Wrap up the scalarizer and
1991 gfc_add_block_to_block (&body
, &se
.pre
);
1992 gfc_add_block_to_block (&body
, &se
.post
);
1994 gfc_trans_scalarizing_loops (&loop
, &body
);
1996 gfc_add_block_to_block (&block
, &loop
.pre
);
1997 gfc_add_block_to_block (&block
, &loop
.post
);
1999 gcc_assert (ss_array
->shape
!= NULL
);
2000 gfc_free_shape (&ss_array
->shape
, cm
->as
->rank
);
2001 gfc_cleanup_loop (&loop
);
2003 return gfc_finish_block (&block
);
2006 /* Generate the call for a scalar transfer node. */
2009 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
2011 tree tmp
, function
, arg2
, arg3
, field
, expr
;
2015 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2016 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2017 We need to translate the expression to a constant if it's either
2018 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2019 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2020 BT_DERIVED (could have been changed by gfc_conv_expr). */
2021 if ((ts
->type
== BT_DERIVED
|| ts
->type
== BT_INTEGER
)
2022 && ts
->u
.derived
!= NULL
2023 && (ts
->is_iso_c
== 1 || ts
->u
.derived
->ts
.is_iso_c
== 1))
2025 /* C_PTR and C_FUNPTR have private components which means they can not
2026 be printed. However, if -std=gnu and not -pedantic, allow
2027 the component to be printed to help debugging. */
2028 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
2030 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
2031 ts
->u
.derived
->name
, code
!= NULL
? &(code
->loc
) :
2032 &gfc_current_locus
);
2036 ts
->type
= ts
->u
.derived
->ts
.type
;
2037 ts
->kind
= ts
->u
.derived
->ts
.kind
;
2038 ts
->f90_type
= ts
->u
.derived
->ts
.f90_type
;
2049 arg2
= build_int_cst (integer_type_node
, kind
);
2050 if (last_dt
== READ
)
2051 function
= iocall
[IOCALL_X_INTEGER
];
2053 function
= iocall
[IOCALL_X_INTEGER_WRITE
];
2058 arg2
= build_int_cst (integer_type_node
, kind
);
2059 if (last_dt
== READ
)
2061 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2062 function
= iocall
[IOCALL_X_REAL128
];
2064 function
= iocall
[IOCALL_X_REAL
];
2068 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2069 function
= iocall
[IOCALL_X_REAL128_WRITE
];
2071 function
= iocall
[IOCALL_X_REAL_WRITE
];
2077 arg2
= build_int_cst (integer_type_node
, kind
);
2078 if (last_dt
== READ
)
2080 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2081 function
= iocall
[IOCALL_X_COMPLEX128
];
2083 function
= iocall
[IOCALL_X_COMPLEX
];
2087 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2088 function
= iocall
[IOCALL_X_COMPLEX128_WRITE
];
2090 function
= iocall
[IOCALL_X_COMPLEX_WRITE
];
2096 arg2
= build_int_cst (integer_type_node
, kind
);
2097 if (last_dt
== READ
)
2098 function
= iocall
[IOCALL_X_LOGICAL
];
2100 function
= iocall
[IOCALL_X_LOGICAL_WRITE
];
2107 if (se
->string_length
)
2108 arg2
= se
->string_length
;
2111 tmp
= build_fold_indirect_ref_loc (input_location
,
2113 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2114 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2115 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2117 arg3
= build_int_cst (integer_type_node
, kind
);
2118 if (last_dt
== READ
)
2119 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2121 function
= iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
];
2123 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2124 tmp
= build_call_expr_loc (input_location
,
2125 function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2126 gfc_add_expr_to_block (&se
->pre
, tmp
);
2127 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2132 if (se
->string_length
)
2133 arg2
= se
->string_length
;
2136 tmp
= build_fold_indirect_ref_loc (input_location
,
2138 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2139 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2141 if (last_dt
== READ
)
2142 function
= iocall
[IOCALL_X_CHARACTER
];
2144 function
= iocall
[IOCALL_X_CHARACTER_WRITE
];
2149 /* Recurse into the elements of the derived type. */
2150 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2151 expr
= build_fold_indirect_ref_loc (input_location
,
2154 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
2156 field
= c
->backend_decl
;
2157 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2159 tmp
= fold_build3_loc (UNKNOWN_LOCATION
,
2160 COMPONENT_REF
, TREE_TYPE (field
),
2161 expr
, field
, NULL_TREE
);
2163 if (c
->attr
.dimension
)
2165 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2166 gfc_add_expr_to_block (&se
->pre
, tmp
);
2170 if (!c
->attr
.pointer
)
2171 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2172 transfer_expr (se
, &c
->ts
, tmp
, code
);
2178 internal_error ("Bad IO basetype (%d)", ts
->type
);
2181 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2182 tmp
= build_call_expr_loc (input_location
,
2183 function
, 3, tmp
, addr_expr
, arg2
);
2184 gfc_add_expr_to_block (&se
->pre
, tmp
);
2185 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2190 /* Generate a call to pass an array descriptor to the IO library. The
2191 array should be of one of the intrinsic types. */
2194 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2196 tree tmp
, charlen_arg
, kind_arg
, io_call
;
2198 if (ts
->type
== BT_CHARACTER
)
2199 charlen_arg
= se
->string_length
;
2201 charlen_arg
= build_int_cst (gfc_charlen_type_node
, 0);
2203 kind_arg
= build_int_cst (integer_type_node
, ts
->kind
);
2205 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2206 if (last_dt
== READ
)
2207 io_call
= iocall
[IOCALL_X_ARRAY
];
2209 io_call
= iocall
[IOCALL_X_ARRAY_WRITE
];
2211 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2213 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2214 gfc_add_expr_to_block (&se
->pre
, tmp
);
2215 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2219 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2222 gfc_trans_transfer (gfc_code
* code
)
2224 stmtblock_t block
, body
;
2233 gfc_start_block (&block
);
2234 gfc_init_block (&body
);
2238 gfc_init_se (&se
, NULL
);
2240 if (expr
->rank
== 0)
2242 /* Transfer a scalar value. */
2243 gfc_conv_expr_reference (&se
, expr
);
2244 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2248 /* Transfer an array. If it is an array of an intrinsic
2249 type, pass the descriptor to the library. Otherwise
2250 scalarize the transfer. */
2251 if (expr
->ref
&& !gfc_is_proc_ptr_comp (expr
))
2253 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2255 gcc_assert (ref
->type
== REF_ARRAY
);
2258 if (expr
->ts
.type
!= BT_DERIVED
2259 && ref
&& ref
->next
== NULL
2260 && !is_subref_array (expr
))
2262 bool seen_vector
= false;
2264 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2266 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2267 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2271 if (seen_vector
&& last_dt
== READ
)
2273 /* Create a temp, read to that and copy it back. */
2274 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
, false);
2279 /* Get the descriptor. */
2280 gfc_conv_expr_descriptor (&se
, expr
);
2281 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2284 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2285 goto finish_block_label
;
2288 /* Initialize the scalarizer. */
2289 ss
= gfc_walk_expr (expr
);
2290 gfc_init_loopinfo (&loop
);
2291 gfc_add_ss_to_loop (&loop
, ss
);
2293 /* Initialize the loop. */
2294 gfc_conv_ss_startstride (&loop
);
2295 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
2297 /* The main loop body. */
2298 gfc_mark_ss_chain_used (ss
, 1);
2299 gfc_start_scalarized_body (&loop
, &body
);
2301 gfc_copy_loopinfo_to_se (&se
, &loop
);
2304 gfc_conv_expr_reference (&se
, expr
);
2305 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2310 gfc_add_block_to_block (&body
, &se
.pre
);
2311 gfc_add_block_to_block (&body
, &se
.post
);
2314 tmp
= gfc_finish_block (&body
);
2317 gcc_assert (se
.ss
== gfc_ss_terminator
);
2318 gfc_trans_scalarizing_loops (&loop
, &body
);
2320 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2321 tmp
= gfc_finish_block (&loop
.pre
);
2322 gfc_cleanup_loop (&loop
);
2325 gfc_add_expr_to_block (&block
, tmp
);
2327 return gfc_finish_block (&block
);
2330 #include "gt-fortran-trans-io.h"