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 */
120 IOCALL_X_CHARACTER_WIDE
,
128 IOCALL_IOLENGTH_DONE
,
134 IOCALL_SET_NML_VAL_DIM
,
139 static GTY(()) tree iocall
[IOCALL_NUM
];
141 /* Variable for keeping track of what the last data transfer statement
142 was. Used for deciding which subroutine to call when the data
143 transfer is complete. */
144 static enum { READ
, WRITE
, IOLENGTH
} last_dt
;
146 /* The data transfer parameter block that should be shared by all
147 data transfer calls belonging to the same read/write/iolength. */
148 static GTY(()) tree dt_parm
;
149 static stmtblock_t
*dt_post_end_block
;
152 gfc_build_st_parameter (enum ioparam_type ptype
, tree
*types
)
155 gfc_st_parameter_field
*p
;
158 tree t
= make_node (RECORD_TYPE
);
161 len
= strlen (st_parameter
[ptype
].name
);
162 gcc_assert (len
<= sizeof (name
) - sizeof ("__st_parameter_"));
163 memcpy (name
, "__st_parameter_", sizeof ("__st_parameter_"));
164 memcpy (name
+ sizeof ("__st_parameter_") - 1, st_parameter
[ptype
].name
,
166 TYPE_NAME (t
) = get_identifier (name
);
168 for (type
= 0, p
= st_parameter_field
; type
< IOPARM_field_num
; type
++, p
++)
169 if (p
->param_type
== ptype
)
172 case IOPARM_type_int4
:
173 case IOPARM_type_intio
:
174 case IOPARM_type_pint4
:
175 case IOPARM_type_pintio
:
176 case IOPARM_type_parray
:
177 case IOPARM_type_pchar
:
178 case IOPARM_type_pad
:
179 p
->field
= gfc_add_field_to_struct (t
, get_identifier (p
->name
),
180 types
[p
->type
], &chain
);
182 case IOPARM_type_char1
:
183 p
->field
= gfc_add_field_to_struct (t
, get_identifier (p
->name
),
184 pchar_type_node
, &chain
);
186 case IOPARM_type_char2
:
187 len
= strlen (p
->name
);
188 gcc_assert (len
<= sizeof (name
) - sizeof ("_len"));
189 memcpy (name
, p
->name
, len
);
190 memcpy (name
+ len
, "_len", sizeof ("_len"));
191 p
->field_len
= gfc_add_field_to_struct (t
, get_identifier (name
),
192 gfc_charlen_type_node
,
194 if (p
->type
== IOPARM_type_char2
)
195 p
->field
= gfc_add_field_to_struct (t
, get_identifier (p
->name
),
196 pchar_type_node
, &chain
);
198 case IOPARM_type_common
:
200 = gfc_add_field_to_struct (t
,
201 get_identifier (p
->name
),
202 st_parameter
[IOPARM_ptype_common
].type
,
205 case IOPARM_type_num
:
210 st_parameter
[ptype
].type
= t
;
214 /* Build code to test an error condition and call generate_error if needed.
215 Note: This builds calls to generate_error in the runtime library function.
216 The function generate_error is dependent on certain parameters in the
217 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
218 Therefore, the code to set these flags must be generated before
219 this function is used. */
222 gfc_trans_io_runtime_check (tree cond
, tree var
, int error_code
,
223 const char * msgid
, stmtblock_t
* pblock
)
228 tree arg1
, arg2
, arg3
;
231 if (integer_zerop (cond
))
234 /* The code to generate the error. */
235 gfc_start_block (&block
);
237 arg1
= gfc_build_addr_expr (NULL_TREE
, var
);
239 arg2
= build_int_cst (integer_type_node
, error_code
),
241 asprintf (&message
, "%s", _(msgid
));
242 arg3
= gfc_build_addr_expr (pchar_type_node
,
243 gfc_build_localized_cstring_const (message
));
246 tmp
= build_call_expr_loc (input_location
,
247 gfor_fndecl_generate_error
, 3, arg1
, arg2
, arg3
);
249 gfc_add_expr_to_block (&block
, tmp
);
251 body
= gfc_finish_block (&block
);
253 if (integer_onep (cond
))
255 gfc_add_expr_to_block (pblock
, body
);
259 /* Tell the compiler that this isn't likely. */
260 cond
= fold_convert (long_integer_type_node
, cond
);
261 tmp
= build_int_cst (long_integer_type_node
, 0);
262 cond
= build_call_expr_loc (input_location
,
263 built_in_decls
[BUILT_IN_EXPECT
], 2, cond
, tmp
);
264 cond
= fold_convert (boolean_type_node
, cond
);
266 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt (input_location
));
267 gfc_add_expr_to_block (pblock
, tmp
);
272 /* Create function decls for IO library functions. */
275 gfc_build_io_library_fndecls (void)
277 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
278 tree gfc_intio_type_node
;
279 tree parm_type
, dt_parm_type
;
280 HOST_WIDE_INT pad_size
;
283 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
284 types
[IOPARM_type_intio
] = gfc_intio_type_node
285 = gfc_get_int_type (gfc_intio_kind
);
286 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
287 types
[IOPARM_type_pintio
]
288 = build_pointer_type (gfc_intio_type_node
);
289 types
[IOPARM_type_parray
] = pchar_type_node
;
290 types
[IOPARM_type_pchar
] = pchar_type_node
;
291 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
292 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
293 pad_idx
= build_index_type (build_int_cst (NULL_TREE
, pad_size
- 1));
294 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
296 /* pad actually contains pointers and integers so it needs to have an
297 alignment that is at least as large as the needed alignment for those
298 types. See the st_parameter_dt structure in libgfortran/io/io.h for
299 what really goes into this space. */
300 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
301 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind
)));
303 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
304 gfc_build_st_parameter ((enum ioparam_type
) ptype
, types
);
306 /* Define the transfer functions.
307 TODO: Split them between READ and WRITE to allow further
308 optimizations, e.g. by using aliases? */
310 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
312 iocall
[IOCALL_X_INTEGER
] = gfc_build_library_function_decl_with_spec (
313 get_identifier (PREFIX("transfer_integer")), ".wW",
314 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
316 iocall
[IOCALL_X_LOGICAL
] = gfc_build_library_function_decl_with_spec (
317 get_identifier (PREFIX("transfer_logical")), ".wW",
318 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
320 iocall
[IOCALL_X_CHARACTER
] = gfc_build_library_function_decl_with_spec (
321 get_identifier (PREFIX("transfer_character")), ".wW",
322 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
324 iocall
[IOCALL_X_CHARACTER_WIDE
] = gfc_build_library_function_decl_with_spec (
325 get_identifier (PREFIX("transfer_character_wide")), ".wW",
326 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
327 gfc_charlen_type_node
, gfc_int4_type_node
);
329 iocall
[IOCALL_X_REAL
] = gfc_build_library_function_decl_with_spec (
330 get_identifier (PREFIX("transfer_real")), ".wW",
331 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
333 iocall
[IOCALL_X_COMPLEX
] = gfc_build_library_function_decl_with_spec (
334 get_identifier (PREFIX("transfer_complex")), ".wW",
335 void_type_node
, 3, dt_parm_type
, pvoid_type_node
, gfc_int4_type_node
);
337 iocall
[IOCALL_X_ARRAY
] = gfc_build_library_function_decl_with_spec (
338 get_identifier (PREFIX("transfer_array")), ".wW",
339 void_type_node
, 4, dt_parm_type
, pvoid_type_node
,
340 integer_type_node
, gfc_charlen_type_node
);
342 /* Library entry points */
344 iocall
[IOCALL_READ
] = gfc_build_library_function_decl_with_spec (
345 get_identifier (PREFIX("st_read")), ".w",
346 void_type_node
, 1, dt_parm_type
);
348 iocall
[IOCALL_WRITE
] = gfc_build_library_function_decl_with_spec (
349 get_identifier (PREFIX("st_write")), ".w",
350 void_type_node
, 1, dt_parm_type
);
352 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
353 iocall
[IOCALL_OPEN
] = gfc_build_library_function_decl_with_spec (
354 get_identifier (PREFIX("st_open")), ".w",
355 void_type_node
, 1, parm_type
);
357 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
358 iocall
[IOCALL_CLOSE
] = gfc_build_library_function_decl_with_spec (
359 get_identifier (PREFIX("st_close")), ".w",
360 void_type_node
, 1, parm_type
);
362 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
363 iocall
[IOCALL_INQUIRE
] = gfc_build_library_function_decl_with_spec (
364 get_identifier (PREFIX("st_inquire")), ".w",
365 void_type_node
, 1, parm_type
);
367 iocall
[IOCALL_IOLENGTH
] = gfc_build_library_function_decl_with_spec(
368 get_identifier (PREFIX("st_iolength")), ".w",
369 void_type_node
, 1, dt_parm_type
);
371 /* TODO: Change when asynchronous I/O is implemented. */
372 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_wait
].type
);
373 iocall
[IOCALL_WAIT
] = gfc_build_library_function_decl_with_spec (
374 get_identifier (PREFIX("st_wait")), ".X",
375 void_type_node
, 1, parm_type
);
377 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
378 iocall
[IOCALL_REWIND
] = gfc_build_library_function_decl_with_spec (
379 get_identifier (PREFIX("st_rewind")), ".w",
380 void_type_node
, 1, parm_type
);
382 iocall
[IOCALL_BACKSPACE
] = gfc_build_library_function_decl_with_spec (
383 get_identifier (PREFIX("st_backspace")), ".w",
384 void_type_node
, 1, parm_type
);
386 iocall
[IOCALL_ENDFILE
] = gfc_build_library_function_decl_with_spec (
387 get_identifier (PREFIX("st_endfile")), ".w",
388 void_type_node
, 1, parm_type
);
390 iocall
[IOCALL_FLUSH
] = gfc_build_library_function_decl_with_spec (
391 get_identifier (PREFIX("st_flush")), ".w",
392 void_type_node
, 1, parm_type
);
394 /* Library helpers */
396 iocall
[IOCALL_READ_DONE
] = gfc_build_library_function_decl_with_spec (
397 get_identifier (PREFIX("st_read_done")), ".w",
398 void_type_node
, 1, dt_parm_type
);
400 iocall
[IOCALL_WRITE_DONE
] = gfc_build_library_function_decl_with_spec (
401 get_identifier (PREFIX("st_write_done")), ".w",
402 void_type_node
, 1, dt_parm_type
);
404 iocall
[IOCALL_IOLENGTH_DONE
] = gfc_build_library_function_decl_with_spec (
405 get_identifier (PREFIX("st_iolength_done")), ".w",
406 void_type_node
, 1, dt_parm_type
);
408 iocall
[IOCALL_SET_NML_VAL
] = gfc_build_library_function_decl_with_spec (
409 get_identifier (PREFIX("st_set_nml_var")), ".w.R",
410 void_type_node
, 6, dt_parm_type
, pvoid_type_node
, pvoid_type_node
,
411 void_type_node
, gfc_charlen_type_node
, gfc_int4_type_node
);
413 iocall
[IOCALL_SET_NML_VAL_DIM
] = gfc_build_library_function_decl_with_spec (
414 get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
415 void_type_node
, 5, dt_parm_type
, gfc_int4_type_node
,
416 gfc_array_index_type
, gfc_array_index_type
, gfc_array_index_type
);
420 /* Generate code to store an integer constant into the
421 st_parameter_XXX structure. */
424 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
428 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
430 if (p
->param_type
== IOPARM_ptype_common
)
431 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
432 st_parameter
[IOPARM_ptype_common
].type
,
433 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
434 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
435 var
, p
->field
, NULL_TREE
);
436 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
441 /* Generate code to store a non-string I/O parameter into the
442 st_parameter_XXX structure. This is a pass by value. */
445 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
450 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
451 tree dest_type
= TREE_TYPE (p
->field
);
453 gfc_init_se (&se
, NULL
);
454 gfc_conv_expr_val (&se
, e
);
456 /* If we're storing a UNIT number, we need to check it first. */
457 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
462 /* Don't evaluate the UNIT number multiple times. */
463 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
465 /* UNIT numbers should be greater than the min. */
466 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
467 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].pedantic_min_int
, 4);
468 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
470 fold_convert (TREE_TYPE (se
.expr
), val
));
471 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
472 "Unit number in I/O statement too small",
475 /* UNIT numbers should be less than the max. */
476 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
477 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
479 fold_convert (TREE_TYPE (se
.expr
), val
));
480 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
481 "Unit number in I/O statement too large",
486 se
.expr
= convert (dest_type
, se
.expr
);
487 gfc_add_block_to_block (block
, &se
.pre
);
489 if (p
->param_type
== IOPARM_ptype_common
)
490 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
491 st_parameter
[IOPARM_ptype_common
].type
,
492 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
494 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, dest_type
, var
,
495 p
->field
, NULL_TREE
);
496 gfc_add_modify (block
, tmp
, se
.expr
);
501 /* Generate code to store a non-string I/O parameter into the
502 st_parameter_XXX structure. This is pass by reference. */
505 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
506 tree var
, enum iofield type
, gfc_expr
*e
)
510 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
512 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
513 gfc_init_se (&se
, NULL
);
514 gfc_conv_expr_lhs (&se
, e
);
516 gfc_add_block_to_block (block
, &se
.pre
);
518 if (TYPE_MODE (TREE_TYPE (se
.expr
))
519 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
521 addr
= convert (TREE_TYPE (p
->field
), gfc_build_addr_expr (NULL_TREE
, se
.expr
));
523 /* If this is for the iostat variable initialize the
524 user variable to LIBERROR_OK which is zero. */
525 if (type
== IOPARM_common_iostat
)
526 gfc_add_modify (block
, se
.expr
,
527 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
531 /* The type used by the library has different size
532 from the type of the variable supplied by the user.
533 Need to use a temporary. */
534 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
535 st_parameter_field
[type
].name
);
537 /* If this is for the iostat variable, initialize the
538 user variable to LIBERROR_OK which is zero. */
539 if (type
== IOPARM_common_iostat
)
540 gfc_add_modify (block
, tmpvar
,
541 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
543 addr
= gfc_build_addr_expr (NULL_TREE
, tmpvar
);
544 /* After the I/O operation, we set the variable from the temporary. */
545 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
546 gfc_add_modify (postblock
, se
.expr
, tmp
);
549 if (p
->param_type
== IOPARM_ptype_common
)
550 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
551 st_parameter
[IOPARM_ptype_common
].type
,
552 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
553 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
554 var
, p
->field
, NULL_TREE
);
555 gfc_add_modify (block
, tmp
, addr
);
559 /* Given an array expr, find its address and length to get a string. If the
560 array is full, the string's address is the address of array's first element
561 and the length is the size of the whole array. If it is an element, the
562 string's address is the element's address and the length is the rest size of
566 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
572 tree type
, array
, tmp
;
576 /* If it is an element, we need its address and size of the rest. */
577 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
578 gcc_assert (e
->ref
->u
.ar
.type
== AR_ELEMENT
);
579 sym
= e
->symtree
->n
.sym
;
580 rank
= sym
->as
->rank
- 1;
581 gfc_conv_expr (se
, e
);
583 array
= sym
->backend_decl
;
584 type
= TREE_TYPE (array
);
586 if (GFC_ARRAY_TYPE_P (type
))
587 size
= GFC_TYPE_ARRAY_SIZE (type
);
590 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
591 size
= gfc_conv_array_stride (array
, rank
);
592 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
593 gfc_array_index_type
,
594 gfc_conv_array_ubound (array
, rank
),
595 gfc_conv_array_lbound (array
, rank
));
596 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
597 gfc_array_index_type
, tmp
,
599 size
= fold_build2_loc (input_location
, MULT_EXPR
,
600 gfc_array_index_type
, tmp
, size
);
604 size
= fold_build2_loc (input_location
, MINUS_EXPR
,
605 gfc_array_index_type
, size
,
606 TREE_OPERAND (se
->expr
, 1));
607 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
608 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
609 size
= fold_build2_loc (input_location
, MULT_EXPR
,
610 gfc_array_index_type
, size
,
611 fold_convert (gfc_array_index_type
, tmp
));
612 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
616 gfc_conv_array_parameter (se
, e
, gfc_walk_expr (e
), true, NULL
, NULL
, &size
);
617 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
621 /* Generate code to store a string and its length into the
622 st_parameter_XXX structure. */
625 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
626 enum iofield type
, gfc_expr
* e
)
632 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
634 gfc_init_se (&se
, NULL
);
636 if (p
->param_type
== IOPARM_ptype_common
)
637 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
638 st_parameter
[IOPARM_ptype_common
].type
,
639 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
640 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
641 var
, p
->field
, NULL_TREE
);
642 len
= fold_build3_loc (input_location
, COMPONENT_REF
,
643 TREE_TYPE (p
->field_len
),
644 var
, p
->field_len
, NULL_TREE
);
646 /* Integer variable assigned a format label. */
647 if (e
->ts
.type
== BT_INTEGER
649 && e
->symtree
->n
.sym
->attr
.assign
== 1)
654 gfc_conv_label_variable (&se
, e
);
655 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
656 cond
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
657 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
659 asprintf(&msg
, "Label assigned to variable '%s' (%%ld) is not a format "
660 "label", e
->symtree
->name
);
661 gfc_trans_runtime_check (true, false, cond
, &se
.pre
, &e
->where
, msg
,
662 fold_convert (long_integer_type_node
, tmp
));
665 gfc_add_modify (&se
.pre
, io
,
666 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
667 gfc_add_modify (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
671 /* General character. */
672 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
673 gfc_conv_expr (&se
, e
);
674 /* Array assigned Hollerith constant or character array. */
675 else if (e
->rank
> 0 || (e
->symtree
&& e
->symtree
->n
.sym
->as
->rank
> 0))
676 gfc_convert_array_to_string (&se
, e
);
680 gfc_conv_string_parameter (&se
);
681 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
682 gfc_add_modify (&se
.pre
, len
, se
.string_length
);
685 gfc_add_block_to_block (block
, &se
.pre
);
686 gfc_add_block_to_block (postblock
, &se
.post
);
691 /* Generate code to store the character (array) and the character length
692 for an internal unit. */
695 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
696 tree var
, gfc_expr
* e
)
703 gfc_st_parameter_field
*p
;
706 gfc_init_se (&se
, NULL
);
708 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
710 io
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
711 var
, p
->field
, NULL_TREE
);
712 len
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field_len
),
713 var
, p
->field_len
, NULL_TREE
);
714 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
715 desc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
716 var
, p
->field
, NULL_TREE
);
718 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
720 /* Character scalars. */
723 gfc_conv_expr (&se
, e
);
724 gfc_conv_string_parameter (&se
);
726 se
.expr
= build_int_cst (pchar_type_node
, 0);
729 /* Character array. */
730 else if (e
->rank
> 0)
732 se
.ss
= gfc_walk_expr (e
);
734 if (is_subref_array (e
))
736 /* Use a temporary for components of arrays of derived types
737 or substring array references. */
738 gfc_conv_subref_array_arg (&se
, e
, 0,
739 last_dt
== READ
? INTENT_IN
: INTENT_OUT
, false);
740 tmp
= build_fold_indirect_ref_loc (input_location
,
742 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
743 tmp
= gfc_conv_descriptor_data_get (tmp
);
747 /* Return the data pointer and rank from the descriptor. */
748 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
749 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
750 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
756 /* The cast is needed for character substrings and the descriptor
758 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
759 gfc_add_modify (&se
.pre
, len
,
760 fold_convert (TREE_TYPE (len
), se
.string_length
));
761 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
763 gfc_add_block_to_block (block
, &se
.pre
);
764 gfc_add_block_to_block (post_block
, &se
.post
);
768 /* Add a case to a IO-result switch. */
771 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
776 return; /* No label, no case */
778 value
= build_int_cst (NULL_TREE
, label_value
);
780 /* Make a backend label for this case. */
781 tmp
= gfc_build_label_decl (NULL_TREE
);
783 /* And the case itself. */
784 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
785 gfc_add_expr_to_block (body
, tmp
);
787 /* Jump to the label. */
788 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
789 gfc_add_expr_to_block (body
, tmp
);
793 /* Generate a switch statement that branches to the correct I/O
794 result label. The last statement of an I/O call stores the
795 result into a variable because there is often cleanup that
796 must be done before the switch, so a temporary would have to
797 be created anyway. */
800 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
801 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
805 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
807 /* If no labels are specified, ignore the result instead
808 of building an empty switch. */
809 if (err_label
== NULL
811 && eor_label
== NULL
)
814 /* Build a switch statement. */
815 gfc_start_block (&body
);
817 /* The label values here must be the same as the values
818 in the library_return enum in the runtime library */
819 add_case (1, err_label
, &body
);
820 add_case (2, end_label
, &body
);
821 add_case (3, eor_label
, &body
);
823 tmp
= gfc_finish_block (&body
);
825 var
= fold_build3_loc (input_location
, COMPONENT_REF
,
826 st_parameter
[IOPARM_ptype_common
].type
,
827 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
828 rc
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (p
->field
),
829 var
, p
->field
, NULL_TREE
);
830 rc
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (rc
),
831 rc
, build_int_cst (TREE_TYPE (rc
),
832 IOPARM_common_libreturn_mask
));
834 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
836 gfc_add_expr_to_block (block
, tmp
);
840 /* Store the current file and line number to variables so that if a
841 library call goes awry, we can tell the user where the problem is. */
844 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
847 tree str
, locus_file
;
849 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
851 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
852 st_parameter
[IOPARM_ptype_common
].type
,
853 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
854 locus_file
= fold_build3_loc (input_location
, COMPONENT_REF
,
855 TREE_TYPE (p
->field
), locus_file
,
856 p
->field
, NULL_TREE
);
858 str
= gfc_build_cstring_const (f
->filename
);
860 str
= gfc_build_addr_expr (pchar_type_node
, str
);
861 gfc_add_modify (block
, locus_file
, str
);
863 line
= LOCATION_LINE (where
->lb
->location
);
864 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
868 /* Translate an OPEN statement. */
871 gfc_trans_open (gfc_code
* code
)
873 stmtblock_t block
, post_block
;
876 unsigned int mask
= 0;
878 gfc_start_block (&block
);
879 gfc_init_block (&post_block
);
881 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
883 set_error_locus (&block
, var
, &code
->loc
);
887 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
891 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
895 mask
|= IOPARM_common_err
;
898 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
901 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
905 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
909 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
912 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
915 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
919 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
923 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
927 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
931 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
934 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
938 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
942 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
945 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
948 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
952 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
956 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_open_newunit
,
959 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
962 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
964 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
966 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
967 tmp
= build_call_expr_loc (input_location
,
968 iocall
[IOCALL_OPEN
], 1, tmp
);
969 gfc_add_expr_to_block (&block
, tmp
);
971 gfc_add_block_to_block (&block
, &post_block
);
973 io_result (&block
, var
, p
->err
, NULL
, NULL
);
975 return gfc_finish_block (&block
);
979 /* Translate a CLOSE statement. */
982 gfc_trans_close (gfc_code
* code
)
984 stmtblock_t block
, post_block
;
987 unsigned int mask
= 0;
989 gfc_start_block (&block
);
990 gfc_init_block (&post_block
);
992 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
994 set_error_locus (&block
, var
, &code
->loc
);
998 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1002 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1006 mask
|= IOPARM_common_err
;
1009 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
1012 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1015 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1017 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1019 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1020 tmp
= build_call_expr_loc (input_location
,
1021 iocall
[IOCALL_CLOSE
], 1, tmp
);
1022 gfc_add_expr_to_block (&block
, tmp
);
1024 gfc_add_block_to_block (&block
, &post_block
);
1026 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1028 return gfc_finish_block (&block
);
1032 /* Common subroutine for building a file positioning statement. */
1035 build_filepos (tree function
, gfc_code
* code
)
1037 stmtblock_t block
, post_block
;
1040 unsigned int mask
= 0;
1042 p
= code
->ext
.filepos
;
1044 gfc_start_block (&block
);
1045 gfc_init_block (&post_block
);
1047 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1050 set_error_locus (&block
, var
, &code
->loc
);
1053 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1057 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1061 mask
|= IOPARM_common_err
;
1063 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1066 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1068 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1070 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1071 tmp
= build_call_expr_loc (input_location
,
1073 gfc_add_expr_to_block (&block
, tmp
);
1075 gfc_add_block_to_block (&block
, &post_block
);
1077 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1079 return gfc_finish_block (&block
);
1083 /* Translate a BACKSPACE statement. */
1086 gfc_trans_backspace (gfc_code
* code
)
1088 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1092 /* Translate an ENDFILE statement. */
1095 gfc_trans_endfile (gfc_code
* code
)
1097 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1101 /* Translate a REWIND statement. */
1104 gfc_trans_rewind (gfc_code
* code
)
1106 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1110 /* Translate a FLUSH statement. */
1113 gfc_trans_flush (gfc_code
* code
)
1115 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1119 /* Create a dummy iostat variable to catch any error due to bad unit. */
1122 create_dummy_iostat (void)
1127 gfc_get_ha_sym_tree ("@iostat", &st
);
1128 st
->n
.sym
->ts
.type
= BT_INTEGER
;
1129 st
->n
.sym
->ts
.kind
= gfc_default_integer_kind
;
1130 gfc_set_sym_referenced (st
->n
.sym
);
1131 gfc_commit_symbol (st
->n
.sym
);
1132 st
->n
.sym
->backend_decl
1133 = gfc_create_var (gfc_get_int_type (st
->n
.sym
->ts
.kind
),
1136 e
= gfc_get_expr ();
1137 e
->expr_type
= EXPR_VARIABLE
;
1139 e
->ts
.type
= BT_INTEGER
;
1140 e
->ts
.kind
= st
->n
.sym
->ts
.kind
;
1146 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1149 gfc_trans_inquire (gfc_code
* code
)
1151 stmtblock_t block
, post_block
;
1154 unsigned int mask
= 0, mask2
= 0;
1156 gfc_start_block (&block
);
1157 gfc_init_block (&post_block
);
1159 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1162 set_error_locus (&block
, var
, &code
->loc
);
1163 p
= code
->ext
.inquire
;
1166 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1170 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1174 mask
|= IOPARM_common_err
;
1177 if (p
->unit
&& p
->file
)
1178 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1181 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1186 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1189 if (p
->unit
&& !p
->iostat
)
1191 p
->iostat
= create_dummy_iostat ();
1192 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1193 IOPARM_common_iostat
, p
->iostat
);
1198 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1202 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1206 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1210 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1214 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1218 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1222 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1226 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1230 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1234 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1238 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1239 IOPARM_inquire_recl_out
, p
->recl
);
1242 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1243 IOPARM_inquire_nextrec
, p
->nextrec
);
1246 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1250 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1254 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1258 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1262 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1266 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1270 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1274 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1278 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1282 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1283 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1285 /* The second series of flags. */
1286 if (p
->asynchronous
)
1287 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1291 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1295 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1299 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1303 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1307 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1308 IOPARM_inquire_pending
, p
->pending
);
1311 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1315 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1319 mask
|= set_parameter_const (&block
, var
, IOPARM_inquire_flags2
, mask2
);
1321 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1324 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1326 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1328 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1329 tmp
= build_call_expr_loc (input_location
,
1330 iocall
[IOCALL_INQUIRE
], 1, tmp
);
1331 gfc_add_expr_to_block (&block
, tmp
);
1333 gfc_add_block_to_block (&block
, &post_block
);
1335 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1337 return gfc_finish_block (&block
);
1342 gfc_trans_wait (gfc_code
* code
)
1344 stmtblock_t block
, post_block
;
1347 unsigned int mask
= 0;
1349 gfc_start_block (&block
);
1350 gfc_init_block (&post_block
);
1352 var
= gfc_create_var (st_parameter
[IOPARM_ptype_wait
].type
,
1355 set_error_locus (&block
, var
, &code
->loc
);
1358 /* Set parameters here. */
1360 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1364 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1368 mask
|= IOPARM_common_err
;
1371 mask
|= set_parameter_value (&block
, var
, IOPARM_wait_id
, p
->id
);
1373 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1376 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1378 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1379 tmp
= build_call_expr_loc (input_location
,
1380 iocall
[IOCALL_WAIT
], 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 /* nml_full_name builds up the fully qualified name of a
1393 derived type component. */
1396 nml_full_name (const char* var_name
, const char* cmp_name
)
1398 int full_name_length
;
1401 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1402 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1403 strcpy (full_name
, var_name
);
1404 full_name
= strcat (full_name
, "%");
1405 full_name
= strcat (full_name
, cmp_name
);
1409 /* nml_get_addr_expr builds an address expression from the
1410 gfc_symbol or gfc_component backend_decl's. An offset is
1411 provided so that the address of an element of an array of
1412 derived types is returned. This is used in the runtime to
1413 determine that span of the derived type. */
1416 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1419 tree decl
= NULL_TREE
;
1423 int dummy_arg_flagged
;
1427 sym
->attr
.referenced
= 1;
1428 decl
= gfc_get_symbol_decl (sym
);
1430 /* If this is the enclosing function declaration, use
1431 the fake result instead. */
1432 if (decl
== current_function_decl
)
1433 decl
= gfc_get_fake_result_decl (sym
, 0);
1434 else if (decl
== DECL_CONTEXT (current_function_decl
))
1435 decl
= gfc_get_fake_result_decl (sym
, 1);
1438 decl
= c
->backend_decl
;
1440 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1441 || TREE_CODE (decl
) == VAR_DECL
1442 || TREE_CODE (decl
) == PARM_DECL
)
1443 || TREE_CODE (decl
) == COMPONENT_REF
));
1447 /* Build indirect reference, if dummy argument. */
1449 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1451 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref_loc (input_location
,
1454 /* If an array, set flag and use indirect ref. if built. */
1456 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1457 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1462 /* Treat the component of a derived type, using base_addr for
1463 the derived type. */
1465 if (TREE_CODE (decl
) == FIELD_DECL
)
1466 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (tmp
),
1467 base_addr
, tmp
, NULL_TREE
);
1469 /* If we have a derived type component, a reference to the first
1470 element of the array is built. This is done so that base_addr,
1471 used in the build of the component reference, always points to
1475 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1477 /* Now build the address expression. */
1479 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1481 /* If scalar dummy, resolve indirect reference now. */
1483 if (dummy_arg_flagged
&& !array_flagged
)
1484 tmp
= build_fold_indirect_ref_loc (input_location
,
1487 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1492 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1493 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1494 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1496 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1499 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1500 gfc_symbol
* sym
, gfc_component
* c
,
1503 gfc_typespec
* ts
= NULL
;
1504 gfc_array_spec
* as
= NULL
;
1505 tree addr_expr
= NULL
;
1515 gcc_assert (sym
|| c
);
1517 /* Build the namelist object name. */
1519 string
= gfc_build_cstring_const (var_name
);
1520 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1522 /* Build ts, as and data address using symbol or component. */
1524 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1525 as
= (sym
) ? sym
->as
: c
->as
;
1527 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1534 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1535 dtype
= gfc_get_dtype (dt
);
1539 itype
= GFC_DTYPE_UNKNOWN
;
1545 itype
= GFC_DTYPE_INTEGER
;
1548 itype
= GFC_DTYPE_LOGICAL
;
1551 itype
= GFC_DTYPE_REAL
;
1554 itype
= GFC_DTYPE_COMPLEX
;
1557 itype
= GFC_DTYPE_DERIVED
;
1560 itype
= GFC_DTYPE_CHARACTER
;
1566 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1569 /* Build up the arguments for the transfer call.
1570 The call for the scalar part transfers:
1571 (address, name, type, kind or string_length, dtype) */
1573 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1575 if (ts
->type
== BT_CHARACTER
)
1576 tmp
= ts
->u
.cl
->backend_decl
;
1578 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1579 tmp
= build_call_expr_loc (input_location
,
1580 iocall
[IOCALL_SET_NML_VAL
], 6,
1581 dt_parm_addr
, addr_expr
, string
,
1582 IARG (ts
->kind
), tmp
, dtype
);
1583 gfc_add_expr_to_block (block
, tmp
);
1585 /* If the object is an array, transfer rank times:
1586 (null pointer, name, stride, lbound, ubound) */
1588 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1590 tmp
= build_call_expr_loc (input_location
,
1591 iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1594 GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
),
1595 GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
),
1596 GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1597 gfc_add_expr_to_block (block
, tmp
);
1600 if (ts
->type
== BT_DERIVED
)
1604 /* Provide the RECORD_TYPE to build component references. */
1606 tree expr
= build_fold_indirect_ref_loc (input_location
,
1609 for (cmp
= ts
->u
.derived
->components
; cmp
; cmp
= cmp
->next
)
1611 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1612 transfer_namelist_element (block
,
1615 gfc_free (full_name
);
1622 /* Create a data transfer statement. Not all of the fields are valid
1623 for both reading and writing, but improper use has been filtered
1627 build_dt (tree function
, gfc_code
* code
)
1629 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1634 unsigned int mask
= 0;
1636 gfc_start_block (&block
);
1637 gfc_init_block (&post_block
);
1638 gfc_init_block (&post_end_block
);
1639 gfc_init_block (&post_iu_block
);
1641 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1643 set_error_locus (&block
, var
, &code
->loc
);
1645 if (last_dt
== IOLENGTH
)
1649 inq
= code
->ext
.inquire
;
1651 /* First check that preconditions are met. */
1652 gcc_assert (inq
!= NULL
);
1653 gcc_assert (inq
->iolength
!= NULL
);
1655 /* Connect to the iolength variable. */
1656 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1657 IOPARM_dt_iolength
, inq
->iolength
);
1663 gcc_assert (dt
!= NULL
);
1666 if (dt
&& dt
->io_unit
)
1668 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1670 mask
|= set_internal_unit (&block
, &post_iu_block
,
1672 set_parameter_const (&block
, var
, IOPARM_common_unit
,
1673 dt
->io_unit
->ts
.kind
== 1 ? 0 : -1);
1677 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1682 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1686 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1687 IOPARM_common_iostat
, dt
->iostat
);
1690 mask
|= IOPARM_common_err
;
1693 mask
|= IOPARM_common_eor
;
1696 mask
|= IOPARM_common_end
;
1699 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1700 IOPARM_dt_id
, dt
->id
);
1703 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1705 if (dt
->asynchronous
)
1706 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_asynchronous
,
1710 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1714 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1718 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1722 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1726 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1730 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1734 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1737 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1740 if (dt
->format_expr
)
1741 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1744 if (dt
->format_label
)
1746 if (dt
->format_label
== &format_asterisk
)
1747 mask
|= IOPARM_dt_list_format
;
1749 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1750 dt
->format_label
->format
);
1754 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1755 IOPARM_dt_size
, dt
->size
);
1759 if (dt
->format_expr
|| dt
->format_label
)
1760 gfc_internal_error ("build_dt: format with namelist");
1762 nmlname
= gfc_get_character_expr (gfc_default_character_kind
, NULL
,
1764 strlen (dt
->namelist
->name
));
1766 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1769 if (last_dt
== READ
)
1770 mask
|= IOPARM_dt_namelist_read_mode
;
1772 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1776 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1777 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1781 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1783 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1784 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1787 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1789 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1790 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
1792 gfc_add_expr_to_block (&block
, tmp
);
1794 gfc_add_block_to_block (&block
, &post_block
);
1797 dt_post_end_block
= &post_end_block
;
1799 /* Set implied do loop exit condition. */
1800 if (last_dt
== READ
|| last_dt
== WRITE
)
1802 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
1804 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1805 st_parameter
[IOPARM_ptype_common
].type
,
1806 dt_parm
, TYPE_FIELDS (TREE_TYPE (dt_parm
)),
1808 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1809 TREE_TYPE (p
->field
), tmp
, p
->field
, NULL_TREE
);
1810 tmp
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (tmp
),
1811 tmp
, build_int_cst (TREE_TYPE (tmp
),
1812 IOPARM_common_libreturn_mask
));
1817 gfc_add_expr_to_block (&block
, gfc_trans_code_cond (code
->block
->next
, tmp
));
1819 gfc_add_block_to_block (&block
, &post_iu_block
);
1822 dt_post_end_block
= NULL
;
1824 return gfc_finish_block (&block
);
1828 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1829 this as a third sort of data transfer statement, except that
1830 lengths are summed instead of actually transferring any data. */
1833 gfc_trans_iolength (gfc_code
* code
)
1836 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1840 /* Translate a READ statement. */
1843 gfc_trans_read (gfc_code
* code
)
1846 return build_dt (iocall
[IOCALL_READ
], code
);
1850 /* Translate a WRITE statement */
1853 gfc_trans_write (gfc_code
* code
)
1856 return build_dt (iocall
[IOCALL_WRITE
], code
);
1860 /* Finish a data transfer statement. */
1863 gfc_trans_dt_end (gfc_code
* code
)
1868 gfc_init_block (&block
);
1873 function
= iocall
[IOCALL_READ_DONE
];
1877 function
= iocall
[IOCALL_WRITE_DONE
];
1881 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1888 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1889 tmp
= build_call_expr_loc (input_location
,
1891 gfc_add_expr_to_block (&block
, tmp
);
1892 gfc_add_block_to_block (&block
, dt_post_end_block
);
1893 gfc_init_block (dt_post_end_block
);
1895 if (last_dt
!= IOLENGTH
)
1897 gcc_assert (code
->ext
.dt
!= NULL
);
1898 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1899 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1902 return gfc_finish_block (&block
);
1906 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1908 /* Given an array field in a derived type variable, generate the code
1909 for the loop that iterates over array elements, and the code that
1910 accesses those array elements. Use transfer_expr to generate code
1911 for transferring that element. Because elements may also be
1912 derived types, transfer_expr and transfer_array_component are mutually
1916 transfer_array_component (tree expr
, gfc_component
* cm
, locus
* where
)
1926 gfc_start_block (&block
);
1927 gfc_init_se (&se
, NULL
);
1929 /* Create and initialize Scalarization Status. Unlike in
1930 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1931 care of this task, because we don't have a gfc_expr at hand.
1932 Build one manually, as in gfc_trans_subarray_assign. */
1935 ss
->type
= GFC_SS_COMPONENT
;
1937 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1938 ss
->next
= gfc_ss_terminator
;
1939 ss
->data
.info
.dimen
= cm
->as
->rank
;
1940 ss
->data
.info
.descriptor
= expr
;
1941 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1942 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1943 for (n
= 0; n
< cm
->as
->rank
; n
++)
1945 ss
->data
.info
.dim
[n
] = n
;
1946 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1947 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1949 mpz_init (ss
->shape
[n
]);
1950 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1951 cm
->as
->lower
[n
]->value
.integer
);
1952 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1955 /* Once we got ss, we use scalarizer to create the loop. */
1957 gfc_init_loopinfo (&loop
);
1958 gfc_add_ss_to_loop (&loop
, ss
);
1959 gfc_conv_ss_startstride (&loop
);
1960 gfc_conv_loop_setup (&loop
, where
);
1961 gfc_mark_ss_chain_used (ss
, 1);
1962 gfc_start_scalarized_body (&loop
, &body
);
1964 gfc_copy_loopinfo_to_se (&se
, &loop
);
1967 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1969 gfc_conv_tmp_array_ref (&se
);
1971 /* Now se.expr contains an element of the array. Take the address and pass
1972 it to the IO routines. */
1973 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
1974 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1976 /* We are done now with the loop body. Wrap up the scalarizer and
1979 gfc_add_block_to_block (&body
, &se
.pre
);
1980 gfc_add_block_to_block (&body
, &se
.post
);
1982 gfc_trans_scalarizing_loops (&loop
, &body
);
1984 gfc_add_block_to_block (&block
, &loop
.pre
);
1985 gfc_add_block_to_block (&block
, &loop
.post
);
1987 for (n
= 0; n
< cm
->as
->rank
; n
++)
1988 mpz_clear (ss
->shape
[n
]);
1989 gfc_free (ss
->shape
);
1991 gfc_cleanup_loop (&loop
);
1993 return gfc_finish_block (&block
);
1996 /* Generate the call for a scalar transfer node. */
1999 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
2001 tree tmp
, function
, arg2
, arg3
, field
, expr
;
2005 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2006 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2007 We need to translate the expression to a constant if it's either
2008 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2009 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2010 BT_DERIVED (could have been changed by gfc_conv_expr). */
2011 if ((ts
->type
== BT_DERIVED
|| ts
->type
== BT_INTEGER
)
2012 && ts
->u
.derived
!= NULL
2013 && (ts
->is_iso_c
== 1 || ts
->u
.derived
->ts
.is_iso_c
== 1))
2015 /* C_PTR and C_FUNPTR have private components which means they can not
2016 be printed. However, if -std=gnu and not -pedantic, allow
2017 the component to be printed to help debugging. */
2018 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
2020 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
2021 ts
->u
.derived
->name
, code
!= NULL
? &(code
->loc
) :
2022 &gfc_current_locus
);
2026 ts
->type
= ts
->u
.derived
->ts
.type
;
2027 ts
->kind
= ts
->u
.derived
->ts
.kind
;
2028 ts
->f90_type
= ts
->u
.derived
->ts
.f90_type
;
2039 arg2
= build_int_cst (NULL_TREE
, kind
);
2040 function
= iocall
[IOCALL_X_INTEGER
];
2044 arg2
= build_int_cst (NULL_TREE
, kind
);
2045 function
= iocall
[IOCALL_X_REAL
];
2049 arg2
= build_int_cst (NULL_TREE
, kind
);
2050 function
= iocall
[IOCALL_X_COMPLEX
];
2054 arg2
= build_int_cst (NULL_TREE
, kind
);
2055 function
= iocall
[IOCALL_X_LOGICAL
];
2061 if (se
->string_length
)
2062 arg2
= se
->string_length
;
2065 tmp
= build_fold_indirect_ref_loc (input_location
,
2067 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2068 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2069 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2071 arg3
= build_int_cst (NULL_TREE
, kind
);
2072 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2073 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2074 tmp
= build_call_expr_loc (input_location
,
2075 function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2076 gfc_add_expr_to_block (&se
->pre
, tmp
);
2077 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2082 if (se
->string_length
)
2083 arg2
= se
->string_length
;
2086 tmp
= build_fold_indirect_ref_loc (input_location
,
2088 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2089 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2091 function
= iocall
[IOCALL_X_CHARACTER
];
2095 /* Recurse into the elements of the derived type. */
2096 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2097 expr
= build_fold_indirect_ref_loc (input_location
,
2100 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
2102 field
= c
->backend_decl
;
2103 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2105 tmp
= fold_build3_loc (UNKNOWN_LOCATION
,
2106 COMPONENT_REF
, TREE_TYPE (field
),
2107 expr
, field
, NULL_TREE
);
2109 if (c
->attr
.dimension
)
2111 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2112 gfc_add_expr_to_block (&se
->pre
, tmp
);
2116 if (!c
->attr
.pointer
)
2117 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2118 transfer_expr (se
, &c
->ts
, tmp
, code
);
2124 internal_error ("Bad IO basetype (%d)", ts
->type
);
2127 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2128 tmp
= build_call_expr_loc (input_location
,
2129 function
, 3, tmp
, addr_expr
, arg2
);
2130 gfc_add_expr_to_block (&se
->pre
, tmp
);
2131 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2136 /* Generate a call to pass an array descriptor to the IO library. The
2137 array should be of one of the intrinsic types. */
2140 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2142 tree tmp
, charlen_arg
, kind_arg
;
2144 if (ts
->type
== BT_CHARACTER
)
2145 charlen_arg
= se
->string_length
;
2147 charlen_arg
= build_int_cst (NULL_TREE
, 0);
2149 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
2151 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2152 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2153 iocall
[IOCALL_X_ARRAY
], 4,
2154 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2155 gfc_add_expr_to_block (&se
->pre
, tmp
);
2156 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2160 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2163 gfc_trans_transfer (gfc_code
* code
)
2165 stmtblock_t block
, body
;
2174 gfc_start_block (&block
);
2175 gfc_init_block (&body
);
2178 ss
= gfc_walk_expr (expr
);
2181 gfc_init_se (&se
, NULL
);
2183 if (ss
== gfc_ss_terminator
)
2185 /* Transfer a scalar value. */
2186 gfc_conv_expr_reference (&se
, expr
);
2187 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2191 /* Transfer an array. If it is an array of an intrinsic
2192 type, pass the descriptor to the library. Otherwise
2193 scalarize the transfer. */
2194 if (expr
->ref
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
2196 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2198 gcc_assert (ref
->type
== REF_ARRAY
);
2201 if (expr
->ts
.type
!= BT_DERIVED
2202 && ref
&& ref
->next
== NULL
2203 && !is_subref_array (expr
))
2205 bool seen_vector
= false;
2207 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2209 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2210 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2214 if (seen_vector
&& last_dt
== READ
)
2216 /* Create a temp, read to that and copy it back. */
2217 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
, false);
2222 /* Get the descriptor. */
2223 gfc_conv_expr_descriptor (&se
, expr
, ss
);
2224 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2227 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2228 goto finish_block_label
;
2231 /* Initialize the scalarizer. */
2232 gfc_init_loopinfo (&loop
);
2233 gfc_add_ss_to_loop (&loop
, ss
);
2235 /* Initialize the loop. */
2236 gfc_conv_ss_startstride (&loop
);
2237 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
2239 /* The main loop body. */
2240 gfc_mark_ss_chain_used (ss
, 1);
2241 gfc_start_scalarized_body (&loop
, &body
);
2243 gfc_copy_loopinfo_to_se (&se
, &loop
);
2246 gfc_conv_expr_reference (&se
, expr
);
2247 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2252 gfc_add_block_to_block (&body
, &se
.pre
);
2253 gfc_add_block_to_block (&body
, &se
.post
);
2256 tmp
= gfc_finish_block (&body
);
2259 gcc_assert (se
.ss
== gfc_ss_terminator
);
2260 gfc_trans_scalarizing_loops (&loop
, &body
);
2262 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2263 tmp
= gfc_finish_block (&loop
.pre
);
2264 gfc_cleanup_loop (&loop
);
2267 gfc_add_expr_to_block (&block
, tmp
);
2269 return gfc_finish_block (&block
);
2272 #include "gt-fortran-trans-io.h"