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"
33 #include "trans-stmt.h"
34 #include "trans-array.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
38 /* Members of the ioparm structure. */
67 typedef struct GTY(()) gfc_st_parameter_field
{
70 enum ioparam_type param_type
;
71 enum iofield_type type
;
75 gfc_st_parameter_field
;
77 typedef struct GTY(()) gfc_st_parameter
{
85 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
91 static GTY(()) gfc_st_parameter st_parameter
[] =
102 static GTY(()) gfc_st_parameter_field st_parameter_field
[] =
104 #define IOPARM(param_type, name, mask, type) \
105 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
106 #include "ioparm.def"
108 { NULL
, 0, (enum ioparam_type
) 0, (enum iofield_type
) 0, NULL
, NULL
}
111 /* Library I/O subroutines */
122 IOCALL_X_CHARACTER_WIDE
,
130 IOCALL_IOLENGTH_DONE
,
136 IOCALL_SET_NML_VAL_DIM
,
141 static GTY(()) tree iocall
[IOCALL_NUM
];
143 /* Variable for keeping track of what the last data transfer statement
144 was. Used for deciding which subroutine to call when the data
145 transfer is complete. */
146 static enum { READ
, WRITE
, IOLENGTH
} last_dt
;
148 /* The data transfer parameter block that should be shared by all
149 data transfer calls belonging to the same read/write/iolength. */
150 static GTY(()) tree dt_parm
;
151 static stmtblock_t
*dt_post_end_block
;
154 gfc_build_st_parameter (enum ioparam_type ptype
, tree
*types
)
157 gfc_st_parameter_field
*p
;
160 tree t
= make_node (RECORD_TYPE
);
162 len
= strlen (st_parameter
[ptype
].name
);
163 gcc_assert (len
<= sizeof (name
) - sizeof ("__st_parameter_"));
164 memcpy (name
, "__st_parameter_", sizeof ("__st_parameter_"));
165 memcpy (name
+ sizeof ("__st_parameter_") - 1, st_parameter
[ptype
].name
,
167 TYPE_NAME (t
) = get_identifier (name
);
169 for (type
= 0, p
= st_parameter_field
; type
< IOPARM_field_num
; type
++, p
++)
170 if (p
->param_type
== ptype
)
173 case IOPARM_type_int4
:
174 case IOPARM_type_intio
:
175 case IOPARM_type_pint4
:
176 case IOPARM_type_pintio
:
177 case IOPARM_type_parray
:
178 case IOPARM_type_pchar
:
179 case IOPARM_type_pad
:
180 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
181 get_identifier (p
->name
),
184 case IOPARM_type_char1
:
185 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
186 get_identifier (p
->name
),
189 case IOPARM_type_char2
:
190 len
= strlen (p
->name
);
191 gcc_assert (len
<= sizeof (name
) - sizeof ("_len"));
192 memcpy (name
, p
->name
, len
);
193 memcpy (name
+ len
, "_len", sizeof ("_len"));
194 p
->field_len
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
195 get_identifier (name
),
196 gfc_charlen_type_node
);
197 if (p
->type
== IOPARM_type_char2
)
198 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
199 get_identifier (p
->name
),
202 case IOPARM_type_common
:
204 = gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
205 get_identifier (p
->name
),
206 st_parameter
[IOPARM_ptype_common
].type
);
208 case IOPARM_type_num
:
213 st_parameter
[ptype
].type
= t
;
217 /* Build code to test an error condition and call generate_error if needed.
218 Note: This builds calls to generate_error in the runtime library function.
219 The function generate_error is dependent on certain parameters in the
220 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
221 Therefore, the code to set these flags must be generated before
222 this function is used. */
225 gfc_trans_io_runtime_check (tree cond
, tree var
, int error_code
,
226 const char * msgid
, stmtblock_t
* pblock
)
231 tree arg1
, arg2
, arg3
;
234 if (integer_zerop (cond
))
237 /* The code to generate the error. */
238 gfc_start_block (&block
);
240 arg1
= gfc_build_addr_expr (NULL_TREE
, var
);
242 arg2
= build_int_cst (integer_type_node
, error_code
),
244 asprintf (&message
, "%s", _(msgid
));
245 arg3
= gfc_build_addr_expr (pchar_type_node
,
246 gfc_build_localized_cstring_const (message
));
249 tmp
= build_call_expr_loc (input_location
,
250 gfor_fndecl_generate_error
, 3, arg1
, arg2
, arg3
);
252 gfc_add_expr_to_block (&block
, tmp
);
254 body
= gfc_finish_block (&block
);
256 if (integer_onep (cond
))
258 gfc_add_expr_to_block (pblock
, body
);
262 /* Tell the compiler that this isn't likely. */
263 cond
= fold_convert (long_integer_type_node
, cond
);
264 tmp
= build_int_cst (long_integer_type_node
, 0);
265 cond
= build_call_expr_loc (input_location
,
266 built_in_decls
[BUILT_IN_EXPECT
], 2, cond
, tmp
);
267 cond
= fold_convert (boolean_type_node
, cond
);
269 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt (input_location
));
270 gfc_add_expr_to_block (pblock
, tmp
);
275 /* Create function decls for IO library functions. */
278 gfc_build_io_library_fndecls (void)
280 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
281 tree gfc_intio_type_node
;
282 tree parm_type
, dt_parm_type
;
283 HOST_WIDE_INT pad_size
;
286 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
287 types
[IOPARM_type_intio
] = gfc_intio_type_node
288 = gfc_get_int_type (gfc_intio_kind
);
289 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
290 types
[IOPARM_type_pintio
]
291 = build_pointer_type (gfc_intio_type_node
);
292 types
[IOPARM_type_parray
] = pchar_type_node
;
293 types
[IOPARM_type_pchar
] = pchar_type_node
;
294 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
295 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
296 pad_idx
= build_index_type (build_int_cst (NULL_TREE
, pad_size
- 1));
297 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
299 /* pad actually contains pointers and integers so it needs to have an
300 alignment that is at least as large as the needed alignment for those
301 types. See the st_parameter_dt structure in libgfortran/io/io.h for
302 what really goes into this space. */
303 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
304 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind
)));
306 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
307 gfc_build_st_parameter ((enum ioparam_type
) ptype
, types
);
309 /* Define the transfer functions. */
311 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
313 iocall
[IOCALL_X_INTEGER
] =
314 gfc_build_library_function_decl (get_identifier
315 (PREFIX("transfer_integer")),
316 void_type_node
, 3, dt_parm_type
,
317 pvoid_type_node
, gfc_int4_type_node
);
319 iocall
[IOCALL_X_LOGICAL
] =
320 gfc_build_library_function_decl (get_identifier
321 (PREFIX("transfer_logical")),
322 void_type_node
, 3, dt_parm_type
,
323 pvoid_type_node
, gfc_int4_type_node
);
325 iocall
[IOCALL_X_CHARACTER
] =
326 gfc_build_library_function_decl (get_identifier
327 (PREFIX("transfer_character")),
328 void_type_node
, 3, dt_parm_type
,
329 pvoid_type_node
, gfc_int4_type_node
);
331 iocall
[IOCALL_X_CHARACTER_WIDE
] =
332 gfc_build_library_function_decl (get_identifier
333 (PREFIX("transfer_character_wide")),
334 void_type_node
, 4, dt_parm_type
,
335 pvoid_type_node
, gfc_charlen_type_node
,
338 iocall
[IOCALL_X_REAL
] =
339 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
340 void_type_node
, 3, dt_parm_type
,
341 pvoid_type_node
, gfc_int4_type_node
);
343 iocall
[IOCALL_X_COMPLEX
] =
344 gfc_build_library_function_decl (get_identifier
345 (PREFIX("transfer_complex")),
346 void_type_node
, 3, dt_parm_type
,
347 pvoid_type_node
, gfc_int4_type_node
);
349 iocall
[IOCALL_X_ARRAY
] =
350 gfc_build_library_function_decl (get_identifier
351 (PREFIX("transfer_array")),
352 void_type_node
, 4, dt_parm_type
,
353 pvoid_type_node
, integer_type_node
,
354 gfc_charlen_type_node
);
356 /* Library entry points */
358 iocall
[IOCALL_READ
] =
359 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
360 void_type_node
, 1, dt_parm_type
);
362 iocall
[IOCALL_WRITE
] =
363 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
364 void_type_node
, 1, dt_parm_type
);
366 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
367 iocall
[IOCALL_OPEN
] =
368 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
369 void_type_node
, 1, parm_type
);
372 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
373 iocall
[IOCALL_CLOSE
] =
374 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
375 void_type_node
, 1, parm_type
);
377 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
378 iocall
[IOCALL_INQUIRE
] =
379 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
380 gfc_int4_type_node
, 1, parm_type
);
382 iocall
[IOCALL_IOLENGTH
] =
383 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
384 void_type_node
, 1, dt_parm_type
);
386 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_wait
].type
);
387 iocall
[IOCALL_WAIT
] =
388 gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")),
389 gfc_int4_type_node
, 1, parm_type
);
391 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
392 iocall
[IOCALL_REWIND
] =
393 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
394 gfc_int4_type_node
, 1, parm_type
);
396 iocall
[IOCALL_BACKSPACE
] =
397 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
398 gfc_int4_type_node
, 1, parm_type
);
400 iocall
[IOCALL_ENDFILE
] =
401 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
402 gfc_int4_type_node
, 1, parm_type
);
404 iocall
[IOCALL_FLUSH
] =
405 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
406 gfc_int4_type_node
, 1, parm_type
);
408 /* Library helpers */
410 iocall
[IOCALL_READ_DONE
] =
411 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
412 gfc_int4_type_node
, 1, dt_parm_type
);
414 iocall
[IOCALL_WRITE_DONE
] =
415 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
416 gfc_int4_type_node
, 1, dt_parm_type
);
418 iocall
[IOCALL_IOLENGTH_DONE
] =
419 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
420 gfc_int4_type_node
, 1, dt_parm_type
);
423 iocall
[IOCALL_SET_NML_VAL
] =
424 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
425 void_type_node
, 6, dt_parm_type
,
426 pvoid_type_node
, pvoid_type_node
,
427 gfc_int4_type_node
, gfc_charlen_type_node
,
430 iocall
[IOCALL_SET_NML_VAL_DIM
] =
431 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
432 void_type_node
, 5, dt_parm_type
,
433 gfc_int4_type_node
, gfc_array_index_type
,
434 gfc_array_index_type
, gfc_array_index_type
);
438 /* Generate code to store an integer constant into the
439 st_parameter_XXX structure. */
442 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
446 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
448 if (p
->param_type
== IOPARM_ptype_common
)
449 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
450 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
451 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
453 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
458 /* Generate code to store a non-string I/O parameter into the
459 st_parameter_XXX structure. This is a pass by value. */
462 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
467 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
468 tree dest_type
= TREE_TYPE (p
->field
);
470 gfc_init_se (&se
, NULL
);
471 gfc_conv_expr_val (&se
, e
);
473 /* If we're storing a UNIT number, we need to check it first. */
474 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
479 /* Don't evaluate the UNIT number multiple times. */
480 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
482 /* UNIT numbers should be greater than the min. */
483 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
484 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].pedantic_min_int
, 4);
485 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, se
.expr
,
486 fold_convert (TREE_TYPE (se
.expr
), val
));
487 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
488 "Unit number in I/O statement too small",
491 /* UNIT numbers should be less than the max. */
492 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
493 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, se
.expr
,
494 fold_convert (TREE_TYPE (se
.expr
), val
));
495 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
496 "Unit number in I/O statement too large",
501 se
.expr
= convert (dest_type
, se
.expr
);
502 gfc_add_block_to_block (block
, &se
.pre
);
504 if (p
->param_type
== IOPARM_ptype_common
)
505 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
506 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
508 tmp
= fold_build3 (COMPONENT_REF
, dest_type
, var
, p
->field
, NULL_TREE
);
509 gfc_add_modify (block
, tmp
, se
.expr
);
514 /* Generate code to store a non-string I/O parameter into the
515 st_parameter_XXX structure. This is pass by reference. */
518 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
519 tree var
, enum iofield type
, gfc_expr
*e
)
523 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
525 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
526 gfc_init_se (&se
, NULL
);
527 gfc_conv_expr_lhs (&se
, e
);
529 gfc_add_block_to_block (block
, &se
.pre
);
531 if (TYPE_MODE (TREE_TYPE (se
.expr
))
532 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
534 addr
= convert (TREE_TYPE (p
->field
), gfc_build_addr_expr (NULL_TREE
, se
.expr
));
536 /* If this is for the iostat variable initialize the
537 user variable to LIBERROR_OK which is zero. */
538 if (type
== IOPARM_common_iostat
)
539 gfc_add_modify (block
, se
.expr
,
540 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
544 /* The type used by the library has different size
545 from the type of the variable supplied by the user.
546 Need to use a temporary. */
547 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
548 st_parameter_field
[type
].name
);
550 /* If this is for the iostat variable, initialize the
551 user variable to LIBERROR_OK which is zero. */
552 if (type
== IOPARM_common_iostat
)
553 gfc_add_modify (block
, tmpvar
,
554 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
556 addr
= gfc_build_addr_expr (NULL_TREE
, tmpvar
);
557 /* After the I/O operation, we set the variable from the temporary. */
558 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
559 gfc_add_modify (postblock
, se
.expr
, tmp
);
562 if (p
->param_type
== IOPARM_ptype_common
)
563 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
564 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
565 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
566 var
, p
->field
, NULL_TREE
);
567 gfc_add_modify (block
, tmp
, addr
);
571 /* Given an array expr, find its address and length to get a string. If the
572 array is full, the string's address is the address of array's first element
573 and the length is the size of the whole array. If it is an element, the
574 string's address is the element's address and the length is the rest size of
578 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
584 tree type
, array
, tmp
;
588 /* If it is an element, we need its address and size of the rest. */
589 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
590 gcc_assert (e
->ref
->u
.ar
.type
== AR_ELEMENT
);
591 sym
= e
->symtree
->n
.sym
;
592 rank
= sym
->as
->rank
- 1;
593 gfc_conv_expr (se
, e
);
595 array
= sym
->backend_decl
;
596 type
= TREE_TYPE (array
);
598 if (GFC_ARRAY_TYPE_P (type
))
599 size
= GFC_TYPE_ARRAY_SIZE (type
);
602 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
603 size
= gfc_conv_array_stride (array
, rank
);
604 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
605 gfc_conv_array_ubound (array
, rank
),
606 gfc_conv_array_lbound (array
, rank
));
607 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
609 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
613 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
614 TREE_OPERAND (se
->expr
, 1));
615 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
616 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
617 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
618 fold_convert (gfc_array_index_type
, tmp
));
619 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
623 gfc_conv_array_parameter (se
, e
, gfc_walk_expr (e
), true, NULL
, NULL
, &size
);
624 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
628 /* Generate code to store a string and its length into the
629 st_parameter_XXX structure. */
632 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
633 enum iofield type
, gfc_expr
* e
)
639 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
641 gfc_init_se (&se
, NULL
);
643 if (p
->param_type
== IOPARM_ptype_common
)
644 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
645 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
646 io
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
647 var
, p
->field
, NULL_TREE
);
648 len
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
),
649 var
, p
->field_len
, NULL_TREE
);
651 /* Integer variable assigned a format label. */
652 if (e
->ts
.type
== BT_INTEGER
654 && e
->symtree
->n
.sym
->attr
.assign
== 1)
659 gfc_conv_label_variable (&se
, e
);
660 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
661 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
662 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
664 asprintf(&msg
, "Label assigned to variable '%s' (%%ld) is not a format "
665 "label", e
->symtree
->name
);
666 gfc_trans_runtime_check (true, false, cond
, &se
.pre
, &e
->where
, msg
,
667 fold_convert (long_integer_type_node
, tmp
));
670 gfc_add_modify (&se
.pre
, io
,
671 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
672 gfc_add_modify (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
676 /* General character. */
677 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
678 gfc_conv_expr (&se
, e
);
679 /* Array assigned Hollerith constant or character array. */
680 else if (e
->rank
> 0 || (e
->symtree
&& e
->symtree
->n
.sym
->as
->rank
> 0))
681 gfc_convert_array_to_string (&se
, e
);
685 gfc_conv_string_parameter (&se
);
686 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
687 gfc_add_modify (&se
.pre
, len
, se
.string_length
);
690 gfc_add_block_to_block (block
, &se
.pre
);
691 gfc_add_block_to_block (postblock
, &se
.post
);
696 /* Generate code to store the character (array) and the character length
697 for an internal unit. */
700 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
701 tree var
, gfc_expr
* e
)
708 gfc_st_parameter_field
*p
;
711 gfc_init_se (&se
, NULL
);
713 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
715 io
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
716 var
, p
->field
, NULL_TREE
);
717 len
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
),
718 var
, p
->field_len
, NULL_TREE
);
719 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
720 desc
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
721 var
, p
->field
, NULL_TREE
);
723 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
725 /* Character scalars. */
728 gfc_conv_expr (&se
, e
);
729 gfc_conv_string_parameter (&se
);
731 se
.expr
= build_int_cst (pchar_type_node
, 0);
734 /* Character array. */
735 else if (e
->rank
> 0)
737 se
.ss
= gfc_walk_expr (e
);
739 if (is_subref_array (e
))
741 /* Use a temporary for components of arrays of derived types
742 or substring array references. */
743 gfc_conv_subref_array_arg (&se
, e
, 0,
744 last_dt
== READ
? INTENT_IN
: INTENT_OUT
, false);
745 tmp
= build_fold_indirect_ref_loc (input_location
,
747 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
748 tmp
= gfc_conv_descriptor_data_get (tmp
);
752 /* Return the data pointer and rank from the descriptor. */
753 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
754 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
755 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
761 /* The cast is needed for character substrings and the descriptor
763 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
764 gfc_add_modify (&se
.pre
, len
,
765 fold_convert (TREE_TYPE (len
), se
.string_length
));
766 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
768 gfc_add_block_to_block (block
, &se
.pre
);
769 gfc_add_block_to_block (post_block
, &se
.post
);
773 /* Add a case to a IO-result switch. */
776 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
781 return; /* No label, no case */
783 value
= build_int_cst (NULL_TREE
, label_value
);
785 /* Make a backend label for this case. */
786 tmp
= gfc_build_label_decl (NULL_TREE
);
788 /* And the case itself. */
789 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
790 gfc_add_expr_to_block (body
, tmp
);
792 /* Jump to the label. */
793 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
794 gfc_add_expr_to_block (body
, tmp
);
798 /* Generate a switch statement that branches to the correct I/O
799 result label. The last statement of an I/O call stores the
800 result into a variable because there is often cleanup that
801 must be done before the switch, so a temporary would have to
802 be created anyway. */
805 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
806 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
810 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
812 /* If no labels are specified, ignore the result instead
813 of building an empty switch. */
814 if (err_label
== NULL
816 && eor_label
== NULL
)
819 /* Build a switch statement. */
820 gfc_start_block (&body
);
822 /* The label values here must be the same as the values
823 in the library_return enum in the runtime library */
824 add_case (1, err_label
, &body
);
825 add_case (2, end_label
, &body
);
826 add_case (3, eor_label
, &body
);
828 tmp
= gfc_finish_block (&body
);
830 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
831 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
832 rc
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
833 var
, p
->field
, NULL_TREE
);
834 rc
= fold_build2 (BIT_AND_EXPR
, TREE_TYPE (rc
),
835 rc
, build_int_cst (TREE_TYPE (rc
),
836 IOPARM_common_libreturn_mask
));
838 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
840 gfc_add_expr_to_block (block
, tmp
);
844 /* Store the current file and line number to variables so that if a
845 library call goes awry, we can tell the user where the problem is. */
848 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
851 tree str
, locus_file
;
853 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
855 locus_file
= fold_build3 (COMPONENT_REF
,
856 st_parameter
[IOPARM_ptype_common
].type
,
857 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
858 locus_file
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
859 locus_file
, p
->field
, NULL_TREE
);
861 str
= gfc_build_cstring_const (f
->filename
);
863 str
= gfc_build_addr_expr (pchar_type_node
, str
);
864 gfc_add_modify (block
, locus_file
, str
);
866 line
= LOCATION_LINE (where
->lb
->location
);
867 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
871 /* Translate an OPEN statement. */
874 gfc_trans_open (gfc_code
* code
)
876 stmtblock_t block
, post_block
;
879 unsigned int mask
= 0;
881 gfc_start_block (&block
);
882 gfc_init_block (&post_block
);
884 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
886 set_error_locus (&block
, var
, &code
->loc
);
890 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
894 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
898 mask
|= IOPARM_common_err
;
901 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
904 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
908 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
912 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
915 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
918 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
922 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
926 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
930 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
934 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
937 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
941 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
945 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
948 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
951 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
955 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
959 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_open_newunit
,
962 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
965 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
967 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
969 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
970 tmp
= build_call_expr_loc (input_location
,
971 iocall
[IOCALL_OPEN
], 1, tmp
);
972 gfc_add_expr_to_block (&block
, tmp
);
974 gfc_add_block_to_block (&block
, &post_block
);
976 io_result (&block
, var
, p
->err
, NULL
, NULL
);
978 return gfc_finish_block (&block
);
982 /* Translate a CLOSE statement. */
985 gfc_trans_close (gfc_code
* code
)
987 stmtblock_t block
, post_block
;
990 unsigned int mask
= 0;
992 gfc_start_block (&block
);
993 gfc_init_block (&post_block
);
995 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
997 set_error_locus (&block
, var
, &code
->loc
);
1001 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1005 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1009 mask
|= IOPARM_common_err
;
1012 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
1015 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1018 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1020 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1022 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1023 tmp
= build_call_expr_loc (input_location
,
1024 iocall
[IOCALL_CLOSE
], 1, tmp
);
1025 gfc_add_expr_to_block (&block
, tmp
);
1027 gfc_add_block_to_block (&block
, &post_block
);
1029 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1031 return gfc_finish_block (&block
);
1035 /* Common subroutine for building a file positioning statement. */
1038 build_filepos (tree function
, gfc_code
* code
)
1040 stmtblock_t block
, post_block
;
1043 unsigned int mask
= 0;
1045 p
= code
->ext
.filepos
;
1047 gfc_start_block (&block
);
1048 gfc_init_block (&post_block
);
1050 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1053 set_error_locus (&block
, var
, &code
->loc
);
1056 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1060 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1064 mask
|= IOPARM_common_err
;
1066 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1069 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1071 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1073 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1074 tmp
= build_call_expr_loc (input_location
,
1076 gfc_add_expr_to_block (&block
, tmp
);
1078 gfc_add_block_to_block (&block
, &post_block
);
1080 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1082 return gfc_finish_block (&block
);
1086 /* Translate a BACKSPACE statement. */
1089 gfc_trans_backspace (gfc_code
* code
)
1091 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1095 /* Translate an ENDFILE statement. */
1098 gfc_trans_endfile (gfc_code
* code
)
1100 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1104 /* Translate a REWIND statement. */
1107 gfc_trans_rewind (gfc_code
* code
)
1109 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1113 /* Translate a FLUSH statement. */
1116 gfc_trans_flush (gfc_code
* code
)
1118 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1122 /* Create a dummy iostat variable to catch any error due to bad unit. */
1125 create_dummy_iostat (void)
1130 gfc_get_ha_sym_tree ("@iostat", &st
);
1131 st
->n
.sym
->ts
.type
= BT_INTEGER
;
1132 st
->n
.sym
->ts
.kind
= gfc_default_integer_kind
;
1133 gfc_set_sym_referenced (st
->n
.sym
);
1134 gfc_commit_symbol (st
->n
.sym
);
1135 st
->n
.sym
->backend_decl
1136 = gfc_create_var (gfc_get_int_type (st
->n
.sym
->ts
.kind
),
1139 e
= gfc_get_expr ();
1140 e
->expr_type
= EXPR_VARIABLE
;
1142 e
->ts
.type
= BT_INTEGER
;
1143 e
->ts
.kind
= st
->n
.sym
->ts
.kind
;
1149 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1152 gfc_trans_inquire (gfc_code
* code
)
1154 stmtblock_t block
, post_block
;
1157 unsigned int mask
= 0, mask2
= 0;
1159 gfc_start_block (&block
);
1160 gfc_init_block (&post_block
);
1162 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1165 set_error_locus (&block
, var
, &code
->loc
);
1166 p
= code
->ext
.inquire
;
1169 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1173 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1177 mask
|= IOPARM_common_err
;
1180 if (p
->unit
&& p
->file
)
1181 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1184 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1189 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1192 if (p
->unit
&& !p
->iostat
)
1194 p
->iostat
= create_dummy_iostat ();
1195 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1196 IOPARM_common_iostat
, p
->iostat
);
1201 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1205 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1209 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1213 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1217 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1221 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1225 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1229 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1233 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1237 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1241 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1242 IOPARM_inquire_recl_out
, p
->recl
);
1245 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1246 IOPARM_inquire_nextrec
, p
->nextrec
);
1249 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1253 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1257 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1261 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1265 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1269 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1273 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1277 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1281 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1285 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1286 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1288 /* The second series of flags. */
1289 if (p
->asynchronous
)
1290 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1294 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1298 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1302 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1306 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1310 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1311 IOPARM_inquire_pending
, p
->pending
);
1314 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1318 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1322 mask
|= set_parameter_const (&block
, var
, IOPARM_inquire_flags2
, mask2
);
1324 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1327 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1329 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1331 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1332 tmp
= build_call_expr_loc (input_location
,
1333 iocall
[IOCALL_INQUIRE
], 1, tmp
);
1334 gfc_add_expr_to_block (&block
, tmp
);
1336 gfc_add_block_to_block (&block
, &post_block
);
1338 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1340 return gfc_finish_block (&block
);
1345 gfc_trans_wait (gfc_code
* code
)
1347 stmtblock_t block
, post_block
;
1350 unsigned int mask
= 0;
1352 gfc_start_block (&block
);
1353 gfc_init_block (&post_block
);
1355 var
= gfc_create_var (st_parameter
[IOPARM_ptype_wait
].type
,
1358 set_error_locus (&block
, var
, &code
->loc
);
1361 /* Set parameters here. */
1363 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1367 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1371 mask
|= IOPARM_common_err
;
1374 mask
|= set_parameter_value (&block
, var
, IOPARM_wait_id
, p
->id
);
1376 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1379 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1381 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1382 tmp
= build_call_expr_loc (input_location
,
1383 iocall
[IOCALL_WAIT
], 1, tmp
);
1384 gfc_add_expr_to_block (&block
, tmp
);
1386 gfc_add_block_to_block (&block
, &post_block
);
1388 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1390 return gfc_finish_block (&block
);
1395 /* nml_full_name builds up the fully qualified name of a
1396 derived type component. */
1399 nml_full_name (const char* var_name
, const char* cmp_name
)
1401 int full_name_length
;
1404 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1405 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1406 strcpy (full_name
, var_name
);
1407 full_name
= strcat (full_name
, "%");
1408 full_name
= strcat (full_name
, cmp_name
);
1412 /* nml_get_addr_expr builds an address expression from the
1413 gfc_symbol or gfc_component backend_decl's. An offset is
1414 provided so that the address of an element of an array of
1415 derived types is returned. This is used in the runtime to
1416 determine that span of the derived type. */
1419 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1422 tree decl
= NULL_TREE
;
1426 int dummy_arg_flagged
;
1430 sym
->attr
.referenced
= 1;
1431 decl
= gfc_get_symbol_decl (sym
);
1433 /* If this is the enclosing function declaration, use
1434 the fake result instead. */
1435 if (decl
== current_function_decl
)
1436 decl
= gfc_get_fake_result_decl (sym
, 0);
1437 else if (decl
== DECL_CONTEXT (current_function_decl
))
1438 decl
= gfc_get_fake_result_decl (sym
, 1);
1441 decl
= c
->backend_decl
;
1443 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1444 || TREE_CODE (decl
) == VAR_DECL
1445 || TREE_CODE (decl
) == PARM_DECL
)
1446 || TREE_CODE (decl
) == COMPONENT_REF
));
1450 /* Build indirect reference, if dummy argument. */
1452 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1454 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref_loc (input_location
,
1457 /* If an array, set flag and use indirect ref. if built. */
1459 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1460 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1465 /* Treat the component of a derived type, using base_addr for
1466 the derived type. */
1468 if (TREE_CODE (decl
) == FIELD_DECL
)
1469 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1470 base_addr
, tmp
, NULL_TREE
);
1472 /* If we have a derived type component, a reference to the first
1473 element of the array is built. This is done so that base_addr,
1474 used in the build of the component reference, always points to
1478 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1480 /* Now build the address expression. */
1482 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1484 /* If scalar dummy, resolve indirect reference now. */
1486 if (dummy_arg_flagged
&& !array_flagged
)
1487 tmp
= build_fold_indirect_ref_loc (input_location
,
1490 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1495 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1496 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1497 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1499 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1502 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1503 gfc_symbol
* sym
, gfc_component
* c
,
1506 gfc_typespec
* ts
= NULL
;
1507 gfc_array_spec
* as
= NULL
;
1508 tree addr_expr
= NULL
;
1518 gcc_assert (sym
|| c
);
1520 /* Build the namelist object name. */
1522 string
= gfc_build_cstring_const (var_name
);
1523 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1525 /* Build ts, as and data address using symbol or component. */
1527 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1528 as
= (sym
) ? sym
->as
: c
->as
;
1530 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1537 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1538 dtype
= gfc_get_dtype (dt
);
1542 itype
= GFC_DTYPE_UNKNOWN
;
1548 itype
= GFC_DTYPE_INTEGER
;
1551 itype
= GFC_DTYPE_LOGICAL
;
1554 itype
= GFC_DTYPE_REAL
;
1557 itype
= GFC_DTYPE_COMPLEX
;
1560 itype
= GFC_DTYPE_DERIVED
;
1563 itype
= GFC_DTYPE_CHARACTER
;
1569 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1572 /* Build up the arguments for the transfer call.
1573 The call for the scalar part transfers:
1574 (address, name, type, kind or string_length, dtype) */
1576 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1578 if (ts
->type
== BT_CHARACTER
)
1579 tmp
= ts
->u
.cl
->backend_decl
;
1581 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1582 tmp
= build_call_expr_loc (input_location
,
1583 iocall
[IOCALL_SET_NML_VAL
], 6,
1584 dt_parm_addr
, addr_expr
, string
,
1585 IARG (ts
->kind
), tmp
, dtype
);
1586 gfc_add_expr_to_block (block
, tmp
);
1588 /* If the object is an array, transfer rank times:
1589 (null pointer, name, stride, lbound, ubound) */
1591 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1593 tmp
= build_call_expr_loc (input_location
,
1594 iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1597 GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
),
1598 GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
),
1599 GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1600 gfc_add_expr_to_block (block
, tmp
);
1603 if (ts
->type
== BT_DERIVED
)
1607 /* Provide the RECORD_TYPE to build component references. */
1609 tree expr
= build_fold_indirect_ref_loc (input_location
,
1612 for (cmp
= ts
->u
.derived
->components
; cmp
; cmp
= cmp
->next
)
1614 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1615 transfer_namelist_element (block
,
1618 gfc_free (full_name
);
1625 /* Create a data transfer statement. Not all of the fields are valid
1626 for both reading and writing, but improper use has been filtered
1630 build_dt (tree function
, gfc_code
* code
)
1632 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1637 unsigned int mask
= 0;
1639 gfc_start_block (&block
);
1640 gfc_init_block (&post_block
);
1641 gfc_init_block (&post_end_block
);
1642 gfc_init_block (&post_iu_block
);
1644 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1646 set_error_locus (&block
, var
, &code
->loc
);
1648 if (last_dt
== IOLENGTH
)
1652 inq
= code
->ext
.inquire
;
1654 /* First check that preconditions are met. */
1655 gcc_assert (inq
!= NULL
);
1656 gcc_assert (inq
->iolength
!= NULL
);
1658 /* Connect to the iolength variable. */
1659 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1660 IOPARM_dt_iolength
, inq
->iolength
);
1666 gcc_assert (dt
!= NULL
);
1669 if (dt
&& dt
->io_unit
)
1671 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1673 mask
|= set_internal_unit (&block
, &post_iu_block
,
1675 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1679 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1684 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1688 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1689 IOPARM_common_iostat
, dt
->iostat
);
1692 mask
|= IOPARM_common_err
;
1695 mask
|= IOPARM_common_eor
;
1698 mask
|= IOPARM_common_end
;
1701 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1702 IOPARM_dt_id
, dt
->id
);
1705 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1707 if (dt
->asynchronous
)
1708 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_asynchronous
,
1712 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1716 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1720 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1724 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1728 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1732 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1736 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1739 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1742 if (dt
->format_expr
)
1743 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1746 if (dt
->format_label
)
1748 if (dt
->format_label
== &format_asterisk
)
1749 mask
|= IOPARM_dt_list_format
;
1751 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1752 dt
->format_label
->format
);
1756 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1757 IOPARM_dt_size
, dt
->size
);
1761 if (dt
->format_expr
|| dt
->format_label
)
1762 gfc_internal_error ("build_dt: format with namelist");
1764 nmlname
= gfc_get_character_expr (gfc_default_character_kind
, NULL
,
1766 strlen (dt
->namelist
->name
));
1768 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1771 if (last_dt
== READ
)
1772 mask
|= IOPARM_dt_namelist_read_mode
;
1774 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1778 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1779 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1783 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1785 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1786 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1789 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1791 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1792 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
1794 gfc_add_expr_to_block (&block
, tmp
);
1796 gfc_add_block_to_block (&block
, &post_block
);
1799 dt_post_end_block
= &post_end_block
;
1801 /* Set implied do loop exit condition. */
1802 if (last_dt
== READ
|| last_dt
== WRITE
)
1804 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
1806 tmp
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
1807 dt_parm
, TYPE_FIELDS (TREE_TYPE (dt_parm
)), NULL_TREE
);
1808 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
1809 tmp
, p
->field
, NULL_TREE
);
1810 tmp
= fold_build2 (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"