1 /* IO Code translation/library interface
2 Copyright (C) 2002-2013 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
24 #include "coretypes.h"
27 #include "diagnostic-core.h" /* For internal_error. */
30 #include "trans-stmt.h"
31 #include "trans-array.h"
32 #include "trans-types.h"
33 #include "trans-const.h"
35 /* Members of the ioparm structure. */
64 typedef struct GTY(()) gfc_st_parameter_field
{
67 enum ioparam_type param_type
;
68 enum iofield_type type
;
72 gfc_st_parameter_field
;
74 typedef struct GTY(()) gfc_st_parameter
{
82 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
88 static GTY(()) gfc_st_parameter st_parameter
[] =
99 static GTY(()) gfc_st_parameter_field st_parameter_field
[] =
101 #define IOPARM(param_type, name, mask, type) \
102 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
103 #include "ioparm.def"
105 { NULL
, 0, (enum ioparam_type
) 0, (enum iofield_type
) 0, NULL
, NULL
}
108 /* Library I/O subroutines */
117 IOCALL_X_INTEGER_WRITE
,
119 IOCALL_X_LOGICAL_WRITE
,
121 IOCALL_X_CHARACTER_WRITE
,
122 IOCALL_X_CHARACTER_WIDE
,
123 IOCALL_X_CHARACTER_WIDE_WRITE
,
127 IOCALL_X_COMPLEX_WRITE
,
129 IOCALL_X_REAL128_WRITE
,
131 IOCALL_X_COMPLEX128_WRITE
,
133 IOCALL_X_ARRAY_WRITE
,
138 IOCALL_IOLENGTH_DONE
,
144 IOCALL_SET_NML_VAL_DIM
,
149 static GTY(()) tree iocall
[IOCALL_NUM
];
151 /* Variable for keeping track of what the last data transfer statement
152 was. Used for deciding which subroutine to call when the data
153 transfer is complete. */
154 static enum { READ
, WRITE
, IOLENGTH
} last_dt
;
156 /* The data transfer parameter block that should be shared by all
157 data transfer calls belonging to the same read/write/iolength. */
158 static GTY(()) tree dt_parm
;
159 static stmtblock_t
*dt_post_end_block
;
162 gfc_build_st_parameter (enum ioparam_type ptype
, tree
*types
)
165 gfc_st_parameter_field
*p
;
168 tree t
= make_node (RECORD_TYPE
);
171 len
= strlen (st_parameter
[ptype
].name
);
172 gcc_assert (len
<= sizeof (name
) - sizeof ("__st_parameter_"));
173 memcpy (name
, "__st_parameter_", sizeof ("__st_parameter_"));
174 memcpy (name
+ sizeof ("__st_parameter_") - 1, st_parameter
[ptype
].name
,
176 TYPE_NAME (t
) = get_identifier (name
);
178 for (type
= 0, p
= st_parameter_field
; type
< IOPARM_field_num
; type
++, p
++)
179 if (p
->param_type
== ptype
)
182 case IOPARM_type_int4
:
183 case IOPARM_type_intio
:
184 case IOPARM_type_pint4
:
185 case IOPARM_type_pintio
:
186 case IOPARM_type_parray
:
187 case IOPARM_type_pchar
:
188 case IOPARM_type_pad
:
189 p
->field
= gfc_add_field_to_struct (t
, get_identifier (p
->name
),
190 types
[p
->type
], &chain
);
192 case IOPARM_type_char1
:
193 p
->field
= gfc_add_field_to_struct (t
, get_identifier (p
->name
),
194 pchar_type_node
, &chain
);
196 case IOPARM_type_char2
:
197 len
= strlen (p
->name
);
198 gcc_assert (len
<= sizeof (name
) - sizeof ("_len"));
199 memcpy (name
, p
->name
, len
);
200 memcpy (name
+ len
, "_len", sizeof ("_len"));
201 p
->field_len
= gfc_add_field_to_struct (t
, get_identifier (name
),
202 gfc_charlen_type_node
,
204 if (p
->type
== IOPARM_type_char2
)
205 p
->field
= gfc_add_field_to_struct (t
, get_identifier (p
->name
),
206 pchar_type_node
, &chain
);
208 case IOPARM_type_common
:
210 = gfc_add_field_to_struct (t
,
211 get_identifier (p
->name
),
212 st_parameter
[IOPARM_ptype_common
].type
,
215 case IOPARM_type_num
:
220 st_parameter
[ptype
].type
= t
;
224 /* Build code to test an error condition and call generate_error if needed.
225 Note: This builds calls to generate_error in the runtime library function.
226 The function generate_error is dependent on certain parameters in the
227 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
228 Therefore, the code to set these flags must be generated before
229 this function is used. */
232 gfc_trans_io_runtime_check (tree cond
, tree var
, int error_code
,
233 const char * msgid
, stmtblock_t
* pblock
)
238 tree arg1
, arg2
, arg3
;
241 if (integer_zerop (cond
))
244 /* The code to generate the error. */
245 gfc_start_block (&block
);
247 arg1
= gfc_build_addr_expr (NULL_TREE
, var
);
249 arg2
= build_int_cst (integer_type_node
, error_code
),
251 asprintf (&message
, "%s", _(msgid
));
252 arg3
= gfc_build_addr_expr (pchar_type_node
,
253 gfc_build_localized_cstring_const (message
));
256 tmp
= build_call_expr_loc (input_location
,
257 gfor_fndecl_generate_error
, 3, arg1
, arg2
, arg3
);
259 gfc_add_expr_to_block (&block
, tmp
);
261 body
= gfc_finish_block (&block
);
263 if (integer_onep (cond
))
265 gfc_add_expr_to_block (pblock
, body
);
269 cond
= gfc_unlikely (cond
);
270 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt (input_location
));
271 gfc_add_expr_to_block (pblock
, tmp
);
276 /* Create function decls for IO library functions. */
279 gfc_build_io_library_fndecls (void)
281 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
282 tree gfc_intio_type_node
;
283 tree parm_type
, dt_parm_type
;
284 HOST_WIDE_INT pad_size
;
287 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
288 types
[IOPARM_type_intio
] = gfc_intio_type_node
289 = gfc_get_int_type (gfc_intio_kind
);
290 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
291 types
[IOPARM_type_pintio
]
292 = build_pointer_type (gfc_intio_type_node
);
293 types
[IOPARM_type_parray
] = pchar_type_node
;
294 types
[IOPARM_type_pchar
] = pchar_type_node
;
295 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
296 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
297 pad_idx
= build_index_type (size_int (pad_size
- 1));
298 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
300 /* pad actually contains pointers and integers so it needs to have an
301 alignment that is at least as large as the needed alignment for those
302 types. See the st_parameter_dt structure in libgfortran/io/io.h for
303 what really goes into this space. */
304 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
305 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind
)));
307 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
308 gfc_build_st_parameter ((enum ioparam_type
) ptype
, types
);
310 /* Define the transfer functions. */
312 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
314 iocall
[IOCALL_X_INTEGER
] = gfc_build_library_function_decl_with_spec (
315 get_identifier (PREFIX("transfer_integer")), ".wW",
316 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
318 iocall
[IOCALL_X_INTEGER_WRITE
] = gfc_build_library_function_decl_with_spec (
319 get_identifier (PREFIX("transfer_integer_write")), ".wR",
320 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
322 iocall
[IOCALL_X_LOGICAL
] = gfc_build_library_function_decl_with_spec (
323 get_identifier (PREFIX("transfer_logical")), ".wW",
324 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
326 iocall
[IOCALL_X_LOGICAL_WRITE
] = gfc_build_library_function_decl_with_spec (
327 get_identifier (PREFIX("transfer_logical_write")), ".wR",
328 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
330 iocall
[IOCALL_X_CHARACTER
] = gfc_build_library_function_decl_with_spec (
331 get_identifier (PREFIX("transfer_character")), ".wW",
332 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
334 iocall
[IOCALL_X_CHARACTER_WRITE
] = gfc_build_library_function_decl_with_spec (
335 get_identifier (PREFIX("transfer_character_write")), ".wR",
336 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
338 iocall
[IOCALL_X_CHARACTER_WIDE
] = gfc_build_library_function_decl_with_spec (
339 get_identifier (PREFIX("transfer_character_wide")), ".wW",
340 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
341 gfc_charlen_type_node
, gfc_int4_type_node
);
343 iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
] =
344 gfc_build_library_function_decl_with_spec (
345 get_identifier (PREFIX("transfer_character_wide_write")), ".wR",
346 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
347 gfc_charlen_type_node
, gfc_int4_type_node
);
349 iocall
[IOCALL_X_REAL
] = gfc_build_library_function_decl_with_spec (
350 get_identifier (PREFIX("transfer_real")), ".wW",
351 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
353 iocall
[IOCALL_X_REAL_WRITE
] = gfc_build_library_function_decl_with_spec (
354 get_identifier (PREFIX("transfer_real_write")), ".wR",
355 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
357 iocall
[IOCALL_X_COMPLEX
] = gfc_build_library_function_decl_with_spec (
358 get_identifier (PREFIX("transfer_complex")), ".wW",
359 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
361 iocall
[IOCALL_X_COMPLEX_WRITE
] = gfc_build_library_function_decl_with_spec (
362 get_identifier (PREFIX("transfer_complex_write")), ".wR",
363 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
365 /* Version for __float128. */
366 iocall
[IOCALL_X_REAL128
] = gfc_build_library_function_decl_with_spec (
367 get_identifier (PREFIX("transfer_real128")), ".wW",
368 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
370 iocall
[IOCALL_X_REAL128_WRITE
] = gfc_build_library_function_decl_with_spec (
371 get_identifier (PREFIX("transfer_real128_write")), ".wR",
372 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
374 iocall
[IOCALL_X_COMPLEX128
] = gfc_build_library_function_decl_with_spec (
375 get_identifier (PREFIX("transfer_complex128")), ".wW",
376 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
378 iocall
[IOCALL_X_COMPLEX128_WRITE
] = gfc_build_library_function_decl_with_spec (
379 get_identifier (PREFIX("transfer_complex128_write")), ".wR",
380 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
382 iocall
[IOCALL_X_ARRAY
] = gfc_build_library_function_decl_with_spec (
383 get_identifier (PREFIX("transfer_array")), ".ww",
384 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
385 integer_type_node
, gfc_charlen_type_node
);
387 iocall
[IOCALL_X_ARRAY_WRITE
] = gfc_build_library_function_decl_with_spec (
388 get_identifier (PREFIX("transfer_array_write")), ".wr",
389 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
390 integer_type_node
, gfc_charlen_type_node
);
392 /* Library entry points */
394 iocall
[IOCALL_READ
] = gfc_build_library_function_decl_with_spec (
395 get_identifier (PREFIX("st_read")), ".w",
396 void_type_node
, 1, dt_parm_type
);
398 iocall
[IOCALL_WRITE
] = gfc_build_library_function_decl_with_spec (
399 get_identifier (PREFIX("st_write")), ".w",
400 void_type_node
, 1, dt_parm_type
);
402 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
403 iocall
[IOCALL_OPEN
] = gfc_build_library_function_decl_with_spec (
404 get_identifier (PREFIX("st_open")), ".w",
405 void_type_node
, 1, parm_type
);
407 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
408 iocall
[IOCALL_CLOSE
] = gfc_build_library_function_decl_with_spec (
409 get_identifier (PREFIX("st_close")), ".w",
410 void_type_node
, 1, parm_type
);
412 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
413 iocall
[IOCALL_INQUIRE
] = gfc_build_library_function_decl_with_spec (
414 get_identifier (PREFIX("st_inquire")), ".w",
415 void_type_node
, 1, parm_type
);
417 iocall
[IOCALL_IOLENGTH
] = gfc_build_library_function_decl_with_spec(
418 get_identifier (PREFIX("st_iolength")), ".w",
419 void_type_node
, 1, dt_parm_type
);
421 /* TODO: Change when asynchronous I/O is implemented. */
422 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_wait
].type
);
423 iocall
[IOCALL_WAIT
] = gfc_build_library_function_decl_with_spec (
424 get_identifier (PREFIX("st_wait")), ".X",
425 void_type_node
, 1, parm_type
);
427 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
428 iocall
[IOCALL_REWIND
] = gfc_build_library_function_decl_with_spec (
429 get_identifier (PREFIX("st_rewind")), ".w",
430 void_type_node
, 1, parm_type
);
432 iocall
[IOCALL_BACKSPACE
] = gfc_build_library_function_decl_with_spec (
433 get_identifier (PREFIX("st_backspace")), ".w",
434 void_type_node
, 1, parm_type
);
436 iocall
[IOCALL_ENDFILE
] = gfc_build_library_function_decl_with_spec (
437 get_identifier (PREFIX("st_endfile")), ".w",
438 void_type_node
, 1, parm_type
);
440 iocall
[IOCALL_FLUSH
] = gfc_build_library_function_decl_with_spec (
441 get_identifier (PREFIX("st_flush")), ".w",
442 void_type_node
, 1, parm_type
);
444 /* Library helpers */
446 iocall
[IOCALL_READ_DONE
] = gfc_build_library_function_decl_with_spec (
447 get_identifier (PREFIX("st_read_done")), ".w",
448 void_type_node
, 1, dt_parm_type
);
450 iocall
[IOCALL_WRITE_DONE
] = gfc_build_library_function_decl_with_spec (
451 get_identifier (PREFIX("st_write_done")), ".w",
452 void_type_node
, 1, dt_parm_type
);
454 iocall
[IOCALL_IOLENGTH_DONE
] = gfc_build_library_function_decl_with_spec (
455 get_identifier (PREFIX("st_iolength_done")), ".w",
456 void_type_node
, 1, dt_parm_type
);
458 iocall
[IOCALL_SET_NML_VAL
] = gfc_build_library_function_decl_with_spec (
459 get_identifier (PREFIX("st_set_nml_var")), ".w.R",
460 void_type_node
, 6, dt_parm_type
, pvoid_type_node
, pvoid_type_node
,
461 void_type_node
, gfc_charlen_type_node
, gfc_int4_type_node
);
463 iocall
[IOCALL_SET_NML_VAL_DIM
] = gfc_build_library_function_decl_with_spec (
464 get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
465 void_type_node
, 5, dt_parm_type
, gfc_int4_type_node
,
466 gfc_array_index_type
, gfc_array_index_type
, gfc_array_index_type
);
470 /* Generate code to store an integer constant into the
471 st_parameter_XXX structure. */
474 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
478 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
480 if (p
->param_type
== IOPARM_ptype_common
)
481 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
482 st_parameter
[IOPARM_ptype_common
].type
,
483 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
484 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
485 var
, p
->field
, NULL_TREE
);
486 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
491 /* Generate code to store a non-string I/O parameter into the
492 st_parameter_XXX structure. This is a pass by value. */
495 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
500 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
501 tree dest_type
= TREE_TYPE (p
->field
);
503 gfc_init_se (&se
, NULL
);
504 gfc_conv_expr_val (&se
, e
);
506 /* If we're storing a UNIT number, we need to check it first. */
507 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
512 /* Don't evaluate the UNIT number multiple times. */
513 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
515 /* UNIT numbers should be greater than the min. */
516 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
517 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].pedantic_min_int
, 4);
518 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
520 fold_convert (TREE_TYPE (se
.expr
), val
));
521 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
522 "Unit number in I/O statement too small",
525 /* UNIT numbers should be less than the max. */
526 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
527 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
529 fold_convert (TREE_TYPE (se
.expr
), val
));
530 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
531 "Unit number in I/O statement too large",
536 se
.expr
= convert (dest_type
, se
.expr
);
537 gfc_add_block_to_block (block
, &se
.pre
);
539 if (p
->param_type
== IOPARM_ptype_common
)
540 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
541 st_parameter
[IOPARM_ptype_common
].type
,
542 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
544 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, dest_type
, var
,
545 p
->field
, NULL_TREE
);
546 gfc_add_modify (block
, tmp
, se
.expr
);
551 /* Generate code to store a non-string I/O parameter into the
552 st_parameter_XXX structure. This is pass by reference. */
555 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
556 tree var
, enum iofield type
, gfc_expr
*e
)
560 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
562 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
563 gfc_init_se (&se
, NULL
);
564 gfc_conv_expr_lhs (&se
, e
);
566 gfc_add_block_to_block (block
, &se
.pre
);
568 if (TYPE_MODE (TREE_TYPE (se
.expr
))
569 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
571 addr
= convert (TREE_TYPE (p
->field
), gfc_build_addr_expr (NULL_TREE
, se
.expr
));
573 /* If this is for the iostat variable initialize the
574 user variable to LIBERROR_OK which is zero. */
575 if (type
== IOPARM_common_iostat
)
576 gfc_add_modify (block
, se
.expr
,
577 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
581 /* The type used by the library has different size
582 from the type of the variable supplied by the user.
583 Need to use a temporary. */
584 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
585 st_parameter_field
[type
].name
);
587 /* If this is for the iostat variable, initialize the
588 user variable to LIBERROR_OK which is zero. */
589 if (type
== IOPARM_common_iostat
)
590 gfc_add_modify (block
, tmpvar
,
591 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
593 addr
= gfc_build_addr_expr (NULL_TREE
, tmpvar
);
594 /* After the I/O operation, we set the variable from the temporary. */
595 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
596 gfc_add_modify (postblock
, se
.expr
, tmp
);
599 if (p
->param_type
== IOPARM_ptype_common
)
600 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
601 st_parameter
[IOPARM_ptype_common
].type
,
602 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
603 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
604 var
, p
->field
, NULL_TREE
);
605 gfc_add_modify (block
, tmp
, addr
);
609 /* Given an array expr, find its address and length to get a string. If the
610 array is full, the string's address is the address of array's first element
611 and the length is the size of the whole array. If it is an element, the
612 string's address is the element's address and the length is the rest size of
616 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
622 tree type
, array
, tmp
;
626 /* If it is an element, we need its address and size of the rest. */
627 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
628 gcc_assert (e
->ref
->u
.ar
.type
== AR_ELEMENT
);
629 sym
= e
->symtree
->n
.sym
;
630 rank
= sym
->as
->rank
- 1;
631 gfc_conv_expr (se
, e
);
633 array
= sym
->backend_decl
;
634 type
= TREE_TYPE (array
);
636 if (GFC_ARRAY_TYPE_P (type
))
637 size
= GFC_TYPE_ARRAY_SIZE (type
);
640 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
641 size
= gfc_conv_array_stride (array
, rank
);
642 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
643 gfc_array_index_type
,
644 gfc_conv_array_ubound (array
, rank
),
645 gfc_conv_array_lbound (array
, rank
));
646 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
647 gfc_array_index_type
, tmp
,
649 size
= fold_build2_loc (input_location
, MULT_EXPR
,
650 gfc_array_index_type
, tmp
, size
);
654 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
655 gfc_array_index_type
, size
,
656 TREE_OPERAND (se
->expr
, 1));
657 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
658 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
659 size
= fold_build2_loc (input_location
, MULT_EXPR
,
660 gfc_array_index_type
, size
,
661 fold_convert (gfc_array_index_type
, tmp
));
662 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
666 gfc_conv_array_parameter (se
, e
, true, NULL
, NULL
, &size
);
667 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
671 /* Generate code to store a string and its length into the
672 st_parameter_XXX structure. */
675 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
676 enum iofield type
, gfc_expr
* e
)
682 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
684 gfc_init_se (&se
, NULL
);
686 if (p
->param_type
== IOPARM_ptype_common
)
687 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
688 st_parameter
[IOPARM_ptype_common
].type
,
689 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
690 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
691 var
, p
->field
, NULL_TREE
);
692 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
693 TREE_TYPE (p
->field_len
),
694 var
, p
->field_len
, NULL_TREE
);
696 /* Integer variable assigned a format label. */
697 if (e
->ts
.type
== BT_INTEGER
699 && e
->symtree
->n
.sym
->attr
.assign
== 1)
704 gfc_conv_label_variable (&se
, e
);
705 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
706 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
707 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
709 asprintf(&msg
, "Label assigned to variable '%s' (%%ld) is not a format "
710 "label", e
->symtree
->name
);
711 gfc_trans_runtime_check (true, false, cond
, &se
.pre
, &e
->where
, msg
,
712 fold_convert (long_integer_type_node
, tmp
));
715 gfc_add_modify (&se
.pre
, io
,
716 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
717 gfc_add_modify (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
721 /* General character. */
722 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
723 gfc_conv_expr (&se
, e
);
724 /* Array assigned Hollerith constant or character array. */
725 else if (e
->rank
> 0 || (e
->symtree
&& e
->symtree
->n
.sym
->as
->rank
> 0))
726 gfc_convert_array_to_string (&se
, e
);
730 gfc_conv_string_parameter (&se
);
731 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
732 gfc_add_modify (&se
.pre
, len
, se
.string_length
);
735 gfc_add_block_to_block (block
, &se
.pre
);
736 gfc_add_block_to_block (postblock
, &se
.post
);
741 /* Generate code to store the character (array) and the character length
742 for an internal unit. */
745 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
746 tree var
, gfc_expr
* e
)
753 gfc_st_parameter_field
*p
;
756 gfc_init_se (&se
, NULL
);
758 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
760 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
761 var
, p
->field
, NULL_TREE
);
762 len
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field_len
),
763 var
, p
->field_len
, NULL_TREE
);
764 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
765 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
766 var
, p
->field
, NULL_TREE
);
768 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
770 /* Character scalars. */
773 gfc_conv_expr (&se
, e
);
774 gfc_conv_string_parameter (&se
);
776 se
.expr
= build_int_cst (pchar_type_node
, 0);
779 /* Character array. */
780 else if (e
->rank
> 0)
782 if (is_subref_array (e
))
784 /* Use a temporary for components of arrays of derived types
785 or substring array references. */
786 gfc_conv_subref_array_arg (&se
, e
, 0,
787 last_dt
== READ
? INTENT_IN
: INTENT_OUT
, false);
788 tmp
= build_fold_indirect_ref_loc (input_location
,
790 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
791 tmp
= gfc_conv_descriptor_data_get (tmp
);
795 /* Return the data pointer and rank from the descriptor. */
796 gfc_conv_expr_descriptor (&se
, e
);
797 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
798 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
804 /* The cast is needed for character substrings and the descriptor
806 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
807 gfc_add_modify (&se
.pre
, len
,
808 fold_convert (TREE_TYPE (len
), se
.string_length
));
809 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
811 gfc_add_block_to_block (block
, &se
.pre
);
812 gfc_add_block_to_block (post_block
, &se
.post
);
816 /* Add a case to a IO-result switch. */
819 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
824 return; /* No label, no case */
826 value
= build_int_cst (integer_type_node
, label_value
);
828 /* Make a backend label for this case. */
829 tmp
= gfc_build_label_decl (NULL_TREE
);
831 /* And the case itself. */
832 tmp
= build_case_label (value
, NULL_TREE
, tmp
);
833 gfc_add_expr_to_block (body
, tmp
);
835 /* Jump to the label. */
836 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
837 gfc_add_expr_to_block (body
, tmp
);
841 /* Generate a switch statement that branches to the correct I/O
842 result label. The last statement of an I/O call stores the
843 result into a variable because there is often cleanup that
844 must be done before the switch, so a temporary would have to
845 be created anyway. */
848 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
849 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
853 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
855 /* If no labels are specified, ignore the result instead
856 of building an empty switch. */
857 if (err_label
== NULL
859 && eor_label
== NULL
)
862 /* Build a switch statement. */
863 gfc_start_block (&body
);
865 /* The label values here must be the same as the values
866 in the library_return enum in the runtime library */
867 add_case (1, err_label
, &body
);
868 add_case (2, end_label
, &body
);
869 add_case (3, eor_label
, &body
);
871 tmp
= gfc_finish_block (&body
);
873 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
874 st_parameter
[IOPARM_ptype_common
].type
,
875 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
876 rc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
877 var
, p
->field
, NULL_TREE
);
878 rc
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (rc
),
879 rc
, build_int_cst (TREE_TYPE (rc
),
880 IOPARM_common_libreturn_mask
));
882 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
885 gfc_add_expr_to_block (block
, tmp
);
889 /* Store the current file and line number to variables so that if a
890 library call goes awry, we can tell the user where the problem is. */
893 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
896 tree str
, locus_file
;
898 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
900 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
901 st_parameter
[IOPARM_ptype_common
].type
,
902 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
903 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
904 TREE_TYPE (p
->field
), locus_file
,
905 p
->field
, NULL_TREE
);
907 str
= gfc_build_cstring_const (f
->filename
);
909 str
= gfc_build_addr_expr (pchar_type_node
, str
);
910 gfc_add_modify (block
, locus_file
, str
);
912 line
= LOCATION_LINE (where
->lb
->location
);
913 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
917 /* Translate an OPEN statement. */
920 gfc_trans_open (gfc_code
* code
)
922 stmtblock_t block
, post_block
;
925 unsigned int mask
= 0;
927 gfc_start_block (&block
);
928 gfc_init_block (&post_block
);
930 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
932 set_error_locus (&block
, var
, &code
->loc
);
936 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
940 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
944 mask
|= IOPARM_common_err
;
947 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
950 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
954 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
958 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
961 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
964 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
968 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
972 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
976 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
980 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
983 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
987 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
991 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
994 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
997 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
1001 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
1005 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_open_newunit
,
1008 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1011 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1013 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1015 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1016 tmp
= build_call_expr_loc (input_location
,
1017 iocall
[IOCALL_OPEN
], 1, tmp
);
1018 gfc_add_expr_to_block (&block
, tmp
);
1020 gfc_add_block_to_block (&block
, &post_block
);
1022 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1024 return gfc_finish_block (&block
);
1028 /* Translate a CLOSE statement. */
1031 gfc_trans_close (gfc_code
* code
)
1033 stmtblock_t block
, post_block
;
1036 unsigned int mask
= 0;
1038 gfc_start_block (&block
);
1039 gfc_init_block (&post_block
);
1041 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
1043 set_error_locus (&block
, var
, &code
->loc
);
1044 p
= code
->ext
.close
;
1047 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1051 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1055 mask
|= IOPARM_common_err
;
1058 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
1061 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1064 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1066 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1068 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1069 tmp
= build_call_expr_loc (input_location
,
1070 iocall
[IOCALL_CLOSE
], 1, tmp
);
1071 gfc_add_expr_to_block (&block
, tmp
);
1073 gfc_add_block_to_block (&block
, &post_block
);
1075 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1077 return gfc_finish_block (&block
);
1081 /* Common subroutine for building a file positioning statement. */
1084 build_filepos (tree function
, gfc_code
* code
)
1086 stmtblock_t block
, post_block
;
1089 unsigned int mask
= 0;
1091 p
= code
->ext
.filepos
;
1093 gfc_start_block (&block
);
1094 gfc_init_block (&post_block
);
1096 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1099 set_error_locus (&block
, var
, &code
->loc
);
1102 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1106 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1110 mask
|= IOPARM_common_err
;
1112 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1115 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1117 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1119 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1120 tmp
= build_call_expr_loc (input_location
,
1122 gfc_add_expr_to_block (&block
, tmp
);
1124 gfc_add_block_to_block (&block
, &post_block
);
1126 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1128 return gfc_finish_block (&block
);
1132 /* Translate a BACKSPACE statement. */
1135 gfc_trans_backspace (gfc_code
* code
)
1137 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1141 /* Translate an ENDFILE statement. */
1144 gfc_trans_endfile (gfc_code
* code
)
1146 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1150 /* Translate a REWIND statement. */
1153 gfc_trans_rewind (gfc_code
* code
)
1155 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1159 /* Translate a FLUSH statement. */
1162 gfc_trans_flush (gfc_code
* code
)
1164 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1168 /* Create a dummy iostat variable to catch any error due to bad unit. */
1171 create_dummy_iostat (void)
1176 gfc_get_ha_sym_tree ("@iostat", &st
);
1177 st
->n
.sym
->ts
.type
= BT_INTEGER
;
1178 st
->n
.sym
->ts
.kind
= gfc_default_integer_kind
;
1179 gfc_set_sym_referenced (st
->n
.sym
);
1180 gfc_commit_symbol (st
->n
.sym
);
1181 st
->n
.sym
->backend_decl
1182 = gfc_create_var (gfc_get_int_type (st
->n
.sym
->ts
.kind
),
1185 e
= gfc_get_expr ();
1186 e
->expr_type
= EXPR_VARIABLE
;
1188 e
->ts
.type
= BT_INTEGER
;
1189 e
->ts
.kind
= st
->n
.sym
->ts
.kind
;
1195 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1198 gfc_trans_inquire (gfc_code
* code
)
1200 stmtblock_t block
, post_block
;
1203 unsigned int mask
= 0, mask2
= 0;
1205 gfc_start_block (&block
);
1206 gfc_init_block (&post_block
);
1208 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1211 set_error_locus (&block
, var
, &code
->loc
);
1212 p
= code
->ext
.inquire
;
1215 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1219 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1223 mask
|= IOPARM_common_err
;
1226 if (p
->unit
&& p
->file
)
1227 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1230 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1235 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1238 if (p
->unit
&& !p
->iostat
)
1240 p
->iostat
= create_dummy_iostat ();
1241 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1242 IOPARM_common_iostat
, p
->iostat
);
1247 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1251 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1255 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1259 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1263 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1267 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1271 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1275 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1279 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1283 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1287 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1288 IOPARM_inquire_recl_out
, p
->recl
);
1291 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1292 IOPARM_inquire_nextrec
, p
->nextrec
);
1295 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1299 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1303 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1307 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1311 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1315 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1319 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1323 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1327 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1331 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1332 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1334 /* The second series of flags. */
1335 if (p
->asynchronous
)
1336 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1340 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1344 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1348 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1352 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1356 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1357 IOPARM_inquire_pending
, p
->pending
);
1360 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1364 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1367 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_iqstream
,
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
&& ts
->u
.derived
->components
)
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 gfc_free_expr (nmlname
);
1787 if (last_dt
== READ
)
1788 mask
|= IOPARM_dt_namelist_read_mode
;
1790 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1794 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1795 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1799 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1801 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1802 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1805 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1807 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1808 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
1810 gfc_add_expr_to_block (&block
, tmp
);
1812 gfc_add_block_to_block (&block
, &post_block
);
1815 dt_post_end_block
= &post_end_block
;
1817 /* Set implied do loop exit condition. */
1818 if (last_dt
== READ
|| last_dt
== WRITE
)
1820 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
1822 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1823 st_parameter
[IOPARM_ptype_common
].type
,
1824 dt_parm
, TYPE_FIELDS (TREE_TYPE (dt_parm
)),
1826 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1827 TREE_TYPE (p
->field
), tmp
, p
->field
, NULL_TREE
);
1828 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (tmp
),
1829 tmp
, build_int_cst (TREE_TYPE (tmp
),
1830 IOPARM_common_libreturn_mask
));
1835 gfc_add_expr_to_block (&block
, gfc_trans_code_cond (code
->block
->next
, tmp
));
1837 gfc_add_block_to_block (&block
, &post_iu_block
);
1840 dt_post_end_block
= NULL
;
1842 return gfc_finish_block (&block
);
1846 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1847 this as a third sort of data transfer statement, except that
1848 lengths are summed instead of actually transferring any data. */
1851 gfc_trans_iolength (gfc_code
* code
)
1854 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1858 /* Translate a READ statement. */
1861 gfc_trans_read (gfc_code
* code
)
1864 return build_dt (iocall
[IOCALL_READ
], code
);
1868 /* Translate a WRITE statement */
1871 gfc_trans_write (gfc_code
* code
)
1874 return build_dt (iocall
[IOCALL_WRITE
], code
);
1878 /* Finish a data transfer statement. */
1881 gfc_trans_dt_end (gfc_code
* code
)
1886 gfc_init_block (&block
);
1891 function
= iocall
[IOCALL_READ_DONE
];
1895 function
= iocall
[IOCALL_WRITE_DONE
];
1899 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1906 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1907 tmp
= build_call_expr_loc (input_location
,
1909 gfc_add_expr_to_block (&block
, tmp
);
1910 gfc_add_block_to_block (&block
, dt_post_end_block
);
1911 gfc_init_block (dt_post_end_block
);
1913 if (last_dt
!= IOLENGTH
)
1915 gcc_assert (code
->ext
.dt
!= NULL
);
1916 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1917 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1920 return gfc_finish_block (&block
);
1924 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1926 /* Given an array field in a derived type variable, generate the code
1927 for the loop that iterates over array elements, and the code that
1928 accesses those array elements. Use transfer_expr to generate code
1929 for transferring that element. Because elements may also be
1930 derived types, transfer_expr and transfer_array_component are mutually
1934 transfer_array_component (tree expr
, gfc_component
* cm
, locus
* where
)
1943 gfc_array_info
*ss_array
;
1945 gfc_start_block (&block
);
1946 gfc_init_se (&se
, NULL
);
1948 /* Create and initialize Scalarization Status. Unlike in
1949 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1950 care of this task, because we don't have a gfc_expr at hand.
1951 Build one manually, as in gfc_trans_subarray_assign. */
1953 ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
1955 ss_array
= &ss
->info
->data
.array
;
1956 ss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
1957 ss_array
->descriptor
= expr
;
1958 ss_array
->data
= gfc_conv_array_data (expr
);
1959 ss_array
->offset
= gfc_conv_array_offset (expr
);
1960 for (n
= 0; n
< cm
->as
->rank
; n
++)
1962 ss_array
->start
[n
] = gfc_conv_array_lbound (expr
, n
);
1963 ss_array
->stride
[n
] = gfc_index_one_node
;
1965 mpz_init (ss_array
->shape
[n
]);
1966 mpz_sub (ss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1967 cm
->as
->lower
[n
]->value
.integer
);
1968 mpz_add_ui (ss_array
->shape
[n
], ss_array
->shape
[n
], 1);
1971 /* Once we got ss, we use scalarizer to create the loop. */
1973 gfc_init_loopinfo (&loop
);
1974 gfc_add_ss_to_loop (&loop
, ss
);
1975 gfc_conv_ss_startstride (&loop
);
1976 gfc_conv_loop_setup (&loop
, where
);
1977 gfc_mark_ss_chain_used (ss
, 1);
1978 gfc_start_scalarized_body (&loop
, &body
);
1980 gfc_copy_loopinfo_to_se (&se
, &loop
);
1983 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1985 gfc_conv_tmp_array_ref (&se
);
1987 /* Now se.expr contains an element of the array. Take the address and pass
1988 it to the IO routines. */
1989 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
1990 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1992 /* We are done now with the loop body. Wrap up the scalarizer and
1995 gfc_add_block_to_block (&body
, &se
.pre
);
1996 gfc_add_block_to_block (&body
, &se
.post
);
1998 gfc_trans_scalarizing_loops (&loop
, &body
);
2000 gfc_add_block_to_block (&block
, &loop
.pre
);
2001 gfc_add_block_to_block (&block
, &loop
.post
);
2003 gcc_assert (ss_array
->shape
!= NULL
);
2004 gfc_free_shape (&ss_array
->shape
, cm
->as
->rank
);
2005 gfc_cleanup_loop (&loop
);
2007 return gfc_finish_block (&block
);
2010 /* Generate the call for a scalar transfer node. */
2013 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
2015 tree tmp
, function
, arg2
, arg3
, field
, expr
;
2019 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2020 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2021 We need to translate the expression to a constant if it's either
2022 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2023 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2024 BT_DERIVED (could have been changed by gfc_conv_expr). */
2025 if ((ts
->type
== BT_DERIVED
|| ts
->type
== BT_INTEGER
)
2026 && ts
->u
.derived
!= NULL
2027 && (ts
->is_iso_c
== 1 || ts
->u
.derived
->ts
.is_iso_c
== 1))
2029 ts
->type
= BT_INTEGER
;
2030 ts
->kind
= gfc_index_integer_kind
;
2041 arg2
= build_int_cst (integer_type_node
, kind
);
2042 if (last_dt
== READ
)
2043 function
= iocall
[IOCALL_X_INTEGER
];
2045 function
= iocall
[IOCALL_X_INTEGER_WRITE
];
2050 arg2
= build_int_cst (integer_type_node
, kind
);
2051 if (last_dt
== READ
)
2053 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2054 function
= iocall
[IOCALL_X_REAL128
];
2056 function
= iocall
[IOCALL_X_REAL
];
2060 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2061 function
= iocall
[IOCALL_X_REAL128_WRITE
];
2063 function
= iocall
[IOCALL_X_REAL_WRITE
];
2069 arg2
= build_int_cst (integer_type_node
, kind
);
2070 if (last_dt
== READ
)
2072 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2073 function
= iocall
[IOCALL_X_COMPLEX128
];
2075 function
= iocall
[IOCALL_X_COMPLEX
];
2079 if (gfc_real16_is_float128
&& ts
->kind
== 16)
2080 function
= iocall
[IOCALL_X_COMPLEX128_WRITE
];
2082 function
= iocall
[IOCALL_X_COMPLEX_WRITE
];
2088 arg2
= build_int_cst (integer_type_node
, kind
);
2089 if (last_dt
== READ
)
2090 function
= iocall
[IOCALL_X_LOGICAL
];
2092 function
= iocall
[IOCALL_X_LOGICAL_WRITE
];
2099 if (se
->string_length
)
2100 arg2
= se
->string_length
;
2103 tmp
= build_fold_indirect_ref_loc (input_location
,
2105 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2106 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2107 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2109 arg3
= build_int_cst (integer_type_node
, kind
);
2110 if (last_dt
== READ
)
2111 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2113 function
= iocall
[IOCALL_X_CHARACTER_WIDE_WRITE
];
2115 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2116 tmp
= build_call_expr_loc (input_location
,
2117 function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2118 gfc_add_expr_to_block (&se
->pre
, tmp
);
2119 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2124 if (se
->string_length
)
2125 arg2
= se
->string_length
;
2128 tmp
= build_fold_indirect_ref_loc (input_location
,
2130 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2131 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2133 if (last_dt
== READ
)
2134 function
= iocall
[IOCALL_X_CHARACTER
];
2136 function
= iocall
[IOCALL_X_CHARACTER_WRITE
];
2141 if (ts
->u
.derived
->components
== NULL
)
2144 /* Recurse into the elements of the derived type. */
2145 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2146 expr
= build_fold_indirect_ref_loc (input_location
,
2149 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
2151 field
= c
->backend_decl
;
2152 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2154 tmp
= fold_build3_loc (UNKNOWN_LOCATION
,
2155 COMPONENT_REF
, TREE_TYPE (field
),
2156 expr
, field
, NULL_TREE
);
2158 if (c
->attr
.dimension
)
2160 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2161 gfc_add_expr_to_block (&se
->pre
, tmp
);
2165 if (!c
->attr
.pointer
)
2166 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2167 transfer_expr (se
, &c
->ts
, tmp
, code
);
2173 internal_error ("Bad IO basetype (%d)", ts
->type
);
2176 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2177 tmp
= build_call_expr_loc (input_location
,
2178 function
, 3, tmp
, addr_expr
, arg2
);
2179 gfc_add_expr_to_block (&se
->pre
, tmp
);
2180 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2185 /* Generate a call to pass an array descriptor to the IO library. The
2186 array should be of one of the intrinsic types. */
2189 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2191 tree tmp
, charlen_arg
, kind_arg
, io_call
;
2193 if (ts
->type
== BT_CHARACTER
)
2194 charlen_arg
= se
->string_length
;
2196 charlen_arg
= build_int_cst (gfc_charlen_type_node
, 0);
2198 kind_arg
= build_int_cst (integer_type_node
, ts
->kind
);
2200 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2201 if (last_dt
== READ
)
2202 io_call
= iocall
[IOCALL_X_ARRAY
];
2204 io_call
= iocall
[IOCALL_X_ARRAY_WRITE
];
2206 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2208 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2209 gfc_add_expr_to_block (&se
->pre
, tmp
);
2210 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2214 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2217 gfc_trans_transfer (gfc_code
* code
)
2219 stmtblock_t block
, body
;
2228 gfc_start_block (&block
);
2229 gfc_init_block (&body
);
2233 gfc_init_se (&se
, NULL
);
2235 if (expr
->rank
== 0)
2237 /* Transfer a scalar value. */
2238 gfc_conv_expr_reference (&se
, expr
);
2239 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2243 /* Transfer an array. If it is an array of an intrinsic
2244 type, pass the descriptor to the library. Otherwise
2245 scalarize the transfer. */
2246 if (expr
->ref
&& !gfc_is_proc_ptr_comp (expr
))
2248 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2250 gcc_assert (ref
&& ref
->type
== REF_ARRAY
);
2253 if (expr
->ts
.type
!= BT_DERIVED
2254 && ref
&& ref
->next
== NULL
2255 && !is_subref_array (expr
))
2257 bool seen_vector
= false;
2259 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2261 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2262 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2266 if (seen_vector
&& last_dt
== READ
)
2268 /* Create a temp, read to that and copy it back. */
2269 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
, false);
2274 /* Get the descriptor. */
2275 gfc_conv_expr_descriptor (&se
, expr
);
2276 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2279 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2280 goto finish_block_label
;
2283 /* Initialize the scalarizer. */
2284 ss
= gfc_walk_expr (expr
);
2285 gfc_init_loopinfo (&loop
);
2286 gfc_add_ss_to_loop (&loop
, ss
);
2288 /* Initialize the loop. */
2289 gfc_conv_ss_startstride (&loop
);
2290 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
2292 /* The main loop body. */
2293 gfc_mark_ss_chain_used (ss
, 1);
2294 gfc_start_scalarized_body (&loop
, &body
);
2296 gfc_copy_loopinfo_to_se (&se
, &loop
);
2299 gfc_conv_expr_reference (&se
, expr
);
2300 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2305 gfc_add_block_to_block (&body
, &se
.pre
);
2306 gfc_add_block_to_block (&body
, &se
.post
);
2309 tmp
= gfc_finish_block (&body
);
2312 gcc_assert (expr
->rank
!= 0);
2313 gcc_assert (se
.ss
== gfc_ss_terminator
);
2314 gfc_trans_scalarizing_loops (&loop
, &body
);
2316 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2317 tmp
= gfc_finish_block (&loop
.pre
);
2318 gfc_cleanup_loop (&loop
);
2321 gfc_add_expr_to_block (&block
, tmp
);
2323 return gfc_finish_block (&block
);
2326 #include "gt-fortran-trans-io.h"