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 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
432 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
433 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
435 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
440 /* Generate code to store a non-string I/O parameter into the
441 st_parameter_XXX structure. This is a pass by value. */
444 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
449 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
450 tree dest_type
= TREE_TYPE (p
->field
);
452 gfc_init_se (&se
, NULL
);
453 gfc_conv_expr_val (&se
, e
);
455 /* If we're storing a UNIT number, we need to check it first. */
456 if (type
== IOPARM_common_unit
&& e
->ts
.kind
> 4)
461 /* Don't evaluate the UNIT number multiple times. */
462 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
464 /* UNIT numbers should be greater than the min. */
465 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
466 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].pedantic_min_int
, 4);
467 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, se
.expr
,
468 fold_convert (TREE_TYPE (se
.expr
), val
));
469 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
470 "Unit number in I/O statement too small",
473 /* UNIT numbers should be less than the max. */
474 val
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
475 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, se
.expr
,
476 fold_convert (TREE_TYPE (se
.expr
), val
));
477 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
478 "Unit number in I/O statement too large",
483 se
.expr
= convert (dest_type
, se
.expr
);
484 gfc_add_block_to_block (block
, &se
.pre
);
486 if (p
->param_type
== IOPARM_ptype_common
)
487 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
488 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
490 tmp
= fold_build3 (COMPONENT_REF
, dest_type
, var
, p
->field
, NULL_TREE
);
491 gfc_add_modify (block
, tmp
, se
.expr
);
496 /* Generate code to store a non-string I/O parameter into the
497 st_parameter_XXX structure. This is pass by reference. */
500 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
501 tree var
, enum iofield type
, gfc_expr
*e
)
505 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
507 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
508 gfc_init_se (&se
, NULL
);
509 gfc_conv_expr_lhs (&se
, e
);
511 gfc_add_block_to_block (block
, &se
.pre
);
513 if (TYPE_MODE (TREE_TYPE (se
.expr
))
514 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
516 addr
= convert (TREE_TYPE (p
->field
), gfc_build_addr_expr (NULL_TREE
, se
.expr
));
518 /* If this is for the iostat variable initialize the
519 user variable to LIBERROR_OK which is zero. */
520 if (type
== IOPARM_common_iostat
)
521 gfc_add_modify (block
, se
.expr
,
522 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
526 /* The type used by the library has different size
527 from the type of the variable supplied by the user.
528 Need to use a temporary. */
529 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
530 st_parameter_field
[type
].name
);
532 /* If this is for the iostat variable, initialize the
533 user variable to LIBERROR_OK which is zero. */
534 if (type
== IOPARM_common_iostat
)
535 gfc_add_modify (block
, tmpvar
,
536 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
538 addr
= gfc_build_addr_expr (NULL_TREE
, tmpvar
);
539 /* After the I/O operation, we set the variable from the temporary. */
540 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
541 gfc_add_modify (postblock
, se
.expr
, tmp
);
544 if (p
->param_type
== IOPARM_ptype_common
)
545 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
546 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
547 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
548 var
, p
->field
, NULL_TREE
);
549 gfc_add_modify (block
, tmp
, addr
);
553 /* Given an array expr, find its address and length to get a string. If the
554 array is full, the string's address is the address of array's first element
555 and the length is the size of the whole array. If it is an element, the
556 string's address is the element's address and the length is the rest size of
560 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
566 tree type
, array
, tmp
;
570 /* If it is an element, we need its address and size of the rest. */
571 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
572 gcc_assert (e
->ref
->u
.ar
.type
== AR_ELEMENT
);
573 sym
= e
->symtree
->n
.sym
;
574 rank
= sym
->as
->rank
- 1;
575 gfc_conv_expr (se
, e
);
577 array
= sym
->backend_decl
;
578 type
= TREE_TYPE (array
);
580 if (GFC_ARRAY_TYPE_P (type
))
581 size
= GFC_TYPE_ARRAY_SIZE (type
);
584 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
585 size
= gfc_conv_array_stride (array
, rank
);
586 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
587 gfc_conv_array_ubound (array
, rank
),
588 gfc_conv_array_lbound (array
, rank
));
589 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
591 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
595 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
596 TREE_OPERAND (se
->expr
, 1));
597 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
598 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
599 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
600 fold_convert (gfc_array_index_type
, tmp
));
601 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
605 gfc_conv_array_parameter (se
, e
, gfc_walk_expr (e
), true, NULL
, NULL
, &size
);
606 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
610 /* Generate code to store a string and its length into the
611 st_parameter_XXX structure. */
614 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
615 enum iofield type
, gfc_expr
* e
)
621 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
623 gfc_init_se (&se
, NULL
);
625 if (p
->param_type
== IOPARM_ptype_common
)
626 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
627 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
628 io
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
629 var
, p
->field
, NULL_TREE
);
630 len
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
),
631 var
, p
->field_len
, NULL_TREE
);
633 /* Integer variable assigned a format label. */
634 if (e
->ts
.type
== BT_INTEGER
636 && e
->symtree
->n
.sym
->attr
.assign
== 1)
641 gfc_conv_label_variable (&se
, e
);
642 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
643 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
644 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
646 asprintf(&msg
, "Label assigned to variable '%s' (%%ld) is not a format "
647 "label", e
->symtree
->name
);
648 gfc_trans_runtime_check (true, false, cond
, &se
.pre
, &e
->where
, msg
,
649 fold_convert (long_integer_type_node
, tmp
));
652 gfc_add_modify (&se
.pre
, io
,
653 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
654 gfc_add_modify (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
658 /* General character. */
659 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
660 gfc_conv_expr (&se
, e
);
661 /* Array assigned Hollerith constant or character array. */
662 else if (e
->rank
> 0 || (e
->symtree
&& e
->symtree
->n
.sym
->as
->rank
> 0))
663 gfc_convert_array_to_string (&se
, e
);
667 gfc_conv_string_parameter (&se
);
668 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
669 gfc_add_modify (&se
.pre
, len
, se
.string_length
);
672 gfc_add_block_to_block (block
, &se
.pre
);
673 gfc_add_block_to_block (postblock
, &se
.post
);
678 /* Generate code to store the character (array) and the character length
679 for an internal unit. */
682 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
683 tree var
, gfc_expr
* e
)
690 gfc_st_parameter_field
*p
;
693 gfc_init_se (&se
, NULL
);
695 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
697 io
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
698 var
, p
->field
, NULL_TREE
);
699 len
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
),
700 var
, p
->field_len
, NULL_TREE
);
701 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
702 desc
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
703 var
, p
->field
, NULL_TREE
);
705 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
707 /* Character scalars. */
710 gfc_conv_expr (&se
, e
);
711 gfc_conv_string_parameter (&se
);
713 se
.expr
= build_int_cst (pchar_type_node
, 0);
716 /* Character array. */
717 else if (e
->rank
> 0)
719 se
.ss
= gfc_walk_expr (e
);
721 if (is_subref_array (e
))
723 /* Use a temporary for components of arrays of derived types
724 or substring array references. */
725 gfc_conv_subref_array_arg (&se
, e
, 0,
726 last_dt
== READ
? INTENT_IN
: INTENT_OUT
, false);
727 tmp
= build_fold_indirect_ref_loc (input_location
,
729 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
730 tmp
= gfc_conv_descriptor_data_get (tmp
);
734 /* Return the data pointer and rank from the descriptor. */
735 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
736 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
737 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
743 /* The cast is needed for character substrings and the descriptor
745 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
746 gfc_add_modify (&se
.pre
, len
,
747 fold_convert (TREE_TYPE (len
), se
.string_length
));
748 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
750 gfc_add_block_to_block (block
, &se
.pre
);
751 gfc_add_block_to_block (post_block
, &se
.post
);
755 /* Add a case to a IO-result switch. */
758 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
763 return; /* No label, no case */
765 value
= build_int_cst (NULL_TREE
, label_value
);
767 /* Make a backend label for this case. */
768 tmp
= gfc_build_label_decl (NULL_TREE
);
770 /* And the case itself. */
771 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
772 gfc_add_expr_to_block (body
, tmp
);
774 /* Jump to the label. */
775 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
776 gfc_add_expr_to_block (body
, tmp
);
780 /* Generate a switch statement that branches to the correct I/O
781 result label. The last statement of an I/O call stores the
782 result into a variable because there is often cleanup that
783 must be done before the switch, so a temporary would have to
784 be created anyway. */
787 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
788 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
792 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
794 /* If no labels are specified, ignore the result instead
795 of building an empty switch. */
796 if (err_label
== NULL
798 && eor_label
== NULL
)
801 /* Build a switch statement. */
802 gfc_start_block (&body
);
804 /* The label values here must be the same as the values
805 in the library_return enum in the runtime library */
806 add_case (1, err_label
, &body
);
807 add_case (2, end_label
, &body
);
808 add_case (3, eor_label
, &body
);
810 tmp
= gfc_finish_block (&body
);
812 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
813 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
814 rc
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
815 var
, p
->field
, NULL_TREE
);
816 rc
= fold_build2 (BIT_AND_EXPR
, TREE_TYPE (rc
),
817 rc
, build_int_cst (TREE_TYPE (rc
),
818 IOPARM_common_libreturn_mask
));
820 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
822 gfc_add_expr_to_block (block
, tmp
);
826 /* Store the current file and line number to variables so that if a
827 library call goes awry, we can tell the user where the problem is. */
830 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
833 tree str
, locus_file
;
835 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
837 locus_file
= fold_build3 (COMPONENT_REF
,
838 st_parameter
[IOPARM_ptype_common
].type
,
839 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
840 locus_file
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
841 locus_file
, p
->field
, NULL_TREE
);
843 str
= gfc_build_cstring_const (f
->filename
);
845 str
= gfc_build_addr_expr (pchar_type_node
, str
);
846 gfc_add_modify (block
, locus_file
, str
);
848 line
= LOCATION_LINE (where
->lb
->location
);
849 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
853 /* Translate an OPEN statement. */
856 gfc_trans_open (gfc_code
* code
)
858 stmtblock_t block
, post_block
;
861 unsigned int mask
= 0;
863 gfc_start_block (&block
);
864 gfc_init_block (&post_block
);
866 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
868 set_error_locus (&block
, var
, &code
->loc
);
872 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
876 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
880 mask
|= IOPARM_common_err
;
883 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
886 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
890 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
894 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
897 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
900 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
904 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
908 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
912 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
916 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
919 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
923 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
927 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
930 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
933 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
937 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
941 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_open_newunit
,
944 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
947 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
949 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
951 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
952 tmp
= build_call_expr_loc (input_location
,
953 iocall
[IOCALL_OPEN
], 1, tmp
);
954 gfc_add_expr_to_block (&block
, tmp
);
956 gfc_add_block_to_block (&block
, &post_block
);
958 io_result (&block
, var
, p
->err
, NULL
, NULL
);
960 return gfc_finish_block (&block
);
964 /* Translate a CLOSE statement. */
967 gfc_trans_close (gfc_code
* code
)
969 stmtblock_t block
, post_block
;
972 unsigned int mask
= 0;
974 gfc_start_block (&block
);
975 gfc_init_block (&post_block
);
977 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
979 set_error_locus (&block
, var
, &code
->loc
);
983 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
987 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
991 mask
|= IOPARM_common_err
;
994 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
997 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1000 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1002 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1004 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1005 tmp
= build_call_expr_loc (input_location
,
1006 iocall
[IOCALL_CLOSE
], 1, tmp
);
1007 gfc_add_expr_to_block (&block
, tmp
);
1009 gfc_add_block_to_block (&block
, &post_block
);
1011 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1013 return gfc_finish_block (&block
);
1017 /* Common subroutine for building a file positioning statement. */
1020 build_filepos (tree function
, gfc_code
* code
)
1022 stmtblock_t block
, post_block
;
1025 unsigned int mask
= 0;
1027 p
= code
->ext
.filepos
;
1029 gfc_start_block (&block
);
1030 gfc_init_block (&post_block
);
1032 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1035 set_error_locus (&block
, var
, &code
->loc
);
1038 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1042 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1046 mask
|= IOPARM_common_err
;
1048 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1051 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1053 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1055 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1056 tmp
= build_call_expr_loc (input_location
,
1058 gfc_add_expr_to_block (&block
, tmp
);
1060 gfc_add_block_to_block (&block
, &post_block
);
1062 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1064 return gfc_finish_block (&block
);
1068 /* Translate a BACKSPACE statement. */
1071 gfc_trans_backspace (gfc_code
* code
)
1073 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1077 /* Translate an ENDFILE statement. */
1080 gfc_trans_endfile (gfc_code
* code
)
1082 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1086 /* Translate a REWIND statement. */
1089 gfc_trans_rewind (gfc_code
* code
)
1091 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1095 /* Translate a FLUSH statement. */
1098 gfc_trans_flush (gfc_code
* code
)
1100 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1104 /* Create a dummy iostat variable to catch any error due to bad unit. */
1107 create_dummy_iostat (void)
1112 gfc_get_ha_sym_tree ("@iostat", &st
);
1113 st
->n
.sym
->ts
.type
= BT_INTEGER
;
1114 st
->n
.sym
->ts
.kind
= gfc_default_integer_kind
;
1115 gfc_set_sym_referenced (st
->n
.sym
);
1116 gfc_commit_symbol (st
->n
.sym
);
1117 st
->n
.sym
->backend_decl
1118 = gfc_create_var (gfc_get_int_type (st
->n
.sym
->ts
.kind
),
1121 e
= gfc_get_expr ();
1122 e
->expr_type
= EXPR_VARIABLE
;
1124 e
->ts
.type
= BT_INTEGER
;
1125 e
->ts
.kind
= st
->n
.sym
->ts
.kind
;
1131 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1134 gfc_trans_inquire (gfc_code
* code
)
1136 stmtblock_t block
, post_block
;
1139 unsigned int mask
= 0, mask2
= 0;
1141 gfc_start_block (&block
);
1142 gfc_init_block (&post_block
);
1144 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1147 set_error_locus (&block
, var
, &code
->loc
);
1148 p
= code
->ext
.inquire
;
1151 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1155 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1159 mask
|= IOPARM_common_err
;
1162 if (p
->unit
&& p
->file
)
1163 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1166 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1171 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1174 if (p
->unit
&& !p
->iostat
)
1176 p
->iostat
= create_dummy_iostat ();
1177 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1178 IOPARM_common_iostat
, p
->iostat
);
1183 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1187 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1191 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1195 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1199 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1203 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1207 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1211 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1215 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1219 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1223 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1224 IOPARM_inquire_recl_out
, p
->recl
);
1227 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1228 IOPARM_inquire_nextrec
, p
->nextrec
);
1231 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1235 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1239 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1243 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1247 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1251 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1255 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1259 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1263 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1267 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1268 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1270 /* The second series of flags. */
1271 if (p
->asynchronous
)
1272 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1276 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1280 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1284 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1288 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1292 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1293 IOPARM_inquire_pending
, p
->pending
);
1296 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1300 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1304 mask
|= set_parameter_const (&block
, var
, IOPARM_inquire_flags2
, mask2
);
1306 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1309 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1311 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1313 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1314 tmp
= build_call_expr_loc (input_location
,
1315 iocall
[IOCALL_INQUIRE
], 1, tmp
);
1316 gfc_add_expr_to_block (&block
, tmp
);
1318 gfc_add_block_to_block (&block
, &post_block
);
1320 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1322 return gfc_finish_block (&block
);
1327 gfc_trans_wait (gfc_code
* code
)
1329 stmtblock_t block
, post_block
;
1332 unsigned int mask
= 0;
1334 gfc_start_block (&block
);
1335 gfc_init_block (&post_block
);
1337 var
= gfc_create_var (st_parameter
[IOPARM_ptype_wait
].type
,
1340 set_error_locus (&block
, var
, &code
->loc
);
1343 /* Set parameters here. */
1345 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1349 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1353 mask
|= IOPARM_common_err
;
1356 mask
|= set_parameter_value (&block
, var
, IOPARM_wait_id
, p
->id
);
1358 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1361 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1363 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1364 tmp
= build_call_expr_loc (input_location
,
1365 iocall
[IOCALL_WAIT
], 1, tmp
);
1366 gfc_add_expr_to_block (&block
, tmp
);
1368 gfc_add_block_to_block (&block
, &post_block
);
1370 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1372 return gfc_finish_block (&block
);
1377 /* nml_full_name builds up the fully qualified name of a
1378 derived type component. */
1381 nml_full_name (const char* var_name
, const char* cmp_name
)
1383 int full_name_length
;
1386 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1387 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1388 strcpy (full_name
, var_name
);
1389 full_name
= strcat (full_name
, "%");
1390 full_name
= strcat (full_name
, cmp_name
);
1394 /* nml_get_addr_expr builds an address expression from the
1395 gfc_symbol or gfc_component backend_decl's. An offset is
1396 provided so that the address of an element of an array of
1397 derived types is returned. This is used in the runtime to
1398 determine that span of the derived type. */
1401 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1404 tree decl
= NULL_TREE
;
1408 int dummy_arg_flagged
;
1412 sym
->attr
.referenced
= 1;
1413 decl
= gfc_get_symbol_decl (sym
);
1415 /* If this is the enclosing function declaration, use
1416 the fake result instead. */
1417 if (decl
== current_function_decl
)
1418 decl
= gfc_get_fake_result_decl (sym
, 0);
1419 else if (decl
== DECL_CONTEXT (current_function_decl
))
1420 decl
= gfc_get_fake_result_decl (sym
, 1);
1423 decl
= c
->backend_decl
;
1425 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1426 || TREE_CODE (decl
) == VAR_DECL
1427 || TREE_CODE (decl
) == PARM_DECL
)
1428 || TREE_CODE (decl
) == COMPONENT_REF
));
1432 /* Build indirect reference, if dummy argument. */
1434 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1436 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref_loc (input_location
,
1439 /* If an array, set flag and use indirect ref. if built. */
1441 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1442 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1447 /* Treat the component of a derived type, using base_addr for
1448 the derived type. */
1450 if (TREE_CODE (decl
) == FIELD_DECL
)
1451 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1452 base_addr
, tmp
, NULL_TREE
);
1454 /* If we have a derived type component, a reference to the first
1455 element of the array is built. This is done so that base_addr,
1456 used in the build of the component reference, always points to
1460 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1462 /* Now build the address expression. */
1464 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1466 /* If scalar dummy, resolve indirect reference now. */
1468 if (dummy_arg_flagged
&& !array_flagged
)
1469 tmp
= build_fold_indirect_ref_loc (input_location
,
1472 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1477 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1478 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1479 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1481 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1484 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1485 gfc_symbol
* sym
, gfc_component
* c
,
1488 gfc_typespec
* ts
= NULL
;
1489 gfc_array_spec
* as
= NULL
;
1490 tree addr_expr
= NULL
;
1500 gcc_assert (sym
|| c
);
1502 /* Build the namelist object name. */
1504 string
= gfc_build_cstring_const (var_name
);
1505 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1507 /* Build ts, as and data address using symbol or component. */
1509 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1510 as
= (sym
) ? sym
->as
: c
->as
;
1512 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1519 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1520 dtype
= gfc_get_dtype (dt
);
1524 itype
= GFC_DTYPE_UNKNOWN
;
1530 itype
= GFC_DTYPE_INTEGER
;
1533 itype
= GFC_DTYPE_LOGICAL
;
1536 itype
= GFC_DTYPE_REAL
;
1539 itype
= GFC_DTYPE_COMPLEX
;
1542 itype
= GFC_DTYPE_DERIVED
;
1545 itype
= GFC_DTYPE_CHARACTER
;
1551 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1554 /* Build up the arguments for the transfer call.
1555 The call for the scalar part transfers:
1556 (address, name, type, kind or string_length, dtype) */
1558 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1560 if (ts
->type
== BT_CHARACTER
)
1561 tmp
= ts
->u
.cl
->backend_decl
;
1563 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1564 tmp
= build_call_expr_loc (input_location
,
1565 iocall
[IOCALL_SET_NML_VAL
], 6,
1566 dt_parm_addr
, addr_expr
, string
,
1567 IARG (ts
->kind
), tmp
, dtype
);
1568 gfc_add_expr_to_block (block
, tmp
);
1570 /* If the object is an array, transfer rank times:
1571 (null pointer, name, stride, lbound, ubound) */
1573 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1575 tmp
= build_call_expr_loc (input_location
,
1576 iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1579 GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
),
1580 GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
),
1581 GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1582 gfc_add_expr_to_block (block
, tmp
);
1585 if (ts
->type
== BT_DERIVED
)
1589 /* Provide the RECORD_TYPE to build component references. */
1591 tree expr
= build_fold_indirect_ref_loc (input_location
,
1594 for (cmp
= ts
->u
.derived
->components
; cmp
; cmp
= cmp
->next
)
1596 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1597 transfer_namelist_element (block
,
1600 gfc_free (full_name
);
1607 /* Create a data transfer statement. Not all of the fields are valid
1608 for both reading and writing, but improper use has been filtered
1612 build_dt (tree function
, gfc_code
* code
)
1614 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1619 unsigned int mask
= 0;
1621 gfc_start_block (&block
);
1622 gfc_init_block (&post_block
);
1623 gfc_init_block (&post_end_block
);
1624 gfc_init_block (&post_iu_block
);
1626 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1628 set_error_locus (&block
, var
, &code
->loc
);
1630 if (last_dt
== IOLENGTH
)
1634 inq
= code
->ext
.inquire
;
1636 /* First check that preconditions are met. */
1637 gcc_assert (inq
!= NULL
);
1638 gcc_assert (inq
->iolength
!= NULL
);
1640 /* Connect to the iolength variable. */
1641 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1642 IOPARM_dt_iolength
, inq
->iolength
);
1648 gcc_assert (dt
!= NULL
);
1651 if (dt
&& dt
->io_unit
)
1653 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1655 mask
|= set_internal_unit (&block
, &post_iu_block
,
1657 set_parameter_const (&block
, var
, IOPARM_common_unit
,
1658 dt
->io_unit
->ts
.kind
== 1 ? 0 : -1);
1662 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1667 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1671 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1672 IOPARM_common_iostat
, dt
->iostat
);
1675 mask
|= IOPARM_common_err
;
1678 mask
|= IOPARM_common_eor
;
1681 mask
|= IOPARM_common_end
;
1684 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1685 IOPARM_dt_id
, dt
->id
);
1688 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1690 if (dt
->asynchronous
)
1691 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_asynchronous
,
1695 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1699 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1703 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1707 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1711 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1715 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1719 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1722 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1725 if (dt
->format_expr
)
1726 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1729 if (dt
->format_label
)
1731 if (dt
->format_label
== &format_asterisk
)
1732 mask
|= IOPARM_dt_list_format
;
1734 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1735 dt
->format_label
->format
);
1739 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1740 IOPARM_dt_size
, dt
->size
);
1744 if (dt
->format_expr
|| dt
->format_label
)
1745 gfc_internal_error ("build_dt: format with namelist");
1747 nmlname
= gfc_get_character_expr (gfc_default_character_kind
, NULL
,
1749 strlen (dt
->namelist
->name
));
1751 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1754 if (last_dt
== READ
)
1755 mask
|= IOPARM_dt_namelist_read_mode
;
1757 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1761 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1762 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1766 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1768 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1769 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1772 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1774 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1775 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
1777 gfc_add_expr_to_block (&block
, tmp
);
1779 gfc_add_block_to_block (&block
, &post_block
);
1782 dt_post_end_block
= &post_end_block
;
1784 /* Set implied do loop exit condition. */
1785 if (last_dt
== READ
|| last_dt
== WRITE
)
1787 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
1789 tmp
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
1790 dt_parm
, TYPE_FIELDS (TREE_TYPE (dt_parm
)), NULL_TREE
);
1791 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
1792 tmp
, p
->field
, NULL_TREE
);
1793 tmp
= fold_build2 (BIT_AND_EXPR
, TREE_TYPE (tmp
),
1794 tmp
, build_int_cst (TREE_TYPE (tmp
),
1795 IOPARM_common_libreturn_mask
));
1800 gfc_add_expr_to_block (&block
, gfc_trans_code_cond (code
->block
->next
, tmp
));
1802 gfc_add_block_to_block (&block
, &post_iu_block
);
1805 dt_post_end_block
= NULL
;
1807 return gfc_finish_block (&block
);
1811 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1812 this as a third sort of data transfer statement, except that
1813 lengths are summed instead of actually transferring any data. */
1816 gfc_trans_iolength (gfc_code
* code
)
1819 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1823 /* Translate a READ statement. */
1826 gfc_trans_read (gfc_code
* code
)
1829 return build_dt (iocall
[IOCALL_READ
], code
);
1833 /* Translate a WRITE statement */
1836 gfc_trans_write (gfc_code
* code
)
1839 return build_dt (iocall
[IOCALL_WRITE
], code
);
1843 /* Finish a data transfer statement. */
1846 gfc_trans_dt_end (gfc_code
* code
)
1851 gfc_init_block (&block
);
1856 function
= iocall
[IOCALL_READ_DONE
];
1860 function
= iocall
[IOCALL_WRITE_DONE
];
1864 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1871 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1872 tmp
= build_call_expr_loc (input_location
,
1874 gfc_add_expr_to_block (&block
, tmp
);
1875 gfc_add_block_to_block (&block
, dt_post_end_block
);
1876 gfc_init_block (dt_post_end_block
);
1878 if (last_dt
!= IOLENGTH
)
1880 gcc_assert (code
->ext
.dt
!= NULL
);
1881 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1882 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1885 return gfc_finish_block (&block
);
1889 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1891 /* Given an array field in a derived type variable, generate the code
1892 for the loop that iterates over array elements, and the code that
1893 accesses those array elements. Use transfer_expr to generate code
1894 for transferring that element. Because elements may also be
1895 derived types, transfer_expr and transfer_array_component are mutually
1899 transfer_array_component (tree expr
, gfc_component
* cm
, locus
* where
)
1909 gfc_start_block (&block
);
1910 gfc_init_se (&se
, NULL
);
1912 /* Create and initialize Scalarization Status. Unlike in
1913 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1914 care of this task, because we don't have a gfc_expr at hand.
1915 Build one manually, as in gfc_trans_subarray_assign. */
1918 ss
->type
= GFC_SS_COMPONENT
;
1920 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1921 ss
->next
= gfc_ss_terminator
;
1922 ss
->data
.info
.dimen
= cm
->as
->rank
;
1923 ss
->data
.info
.descriptor
= expr
;
1924 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1925 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1926 for (n
= 0; n
< cm
->as
->rank
; n
++)
1928 ss
->data
.info
.dim
[n
] = n
;
1929 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1930 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1932 mpz_init (ss
->shape
[n
]);
1933 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1934 cm
->as
->lower
[n
]->value
.integer
);
1935 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1938 /* Once we got ss, we use scalarizer to create the loop. */
1940 gfc_init_loopinfo (&loop
);
1941 gfc_add_ss_to_loop (&loop
, ss
);
1942 gfc_conv_ss_startstride (&loop
);
1943 gfc_conv_loop_setup (&loop
, where
);
1944 gfc_mark_ss_chain_used (ss
, 1);
1945 gfc_start_scalarized_body (&loop
, &body
);
1947 gfc_copy_loopinfo_to_se (&se
, &loop
);
1950 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1952 gfc_conv_tmp_array_ref (&se
);
1954 /* Now se.expr contains an element of the array. Take the address and pass
1955 it to the IO routines. */
1956 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
1957 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1959 /* We are done now with the loop body. Wrap up the scalarizer and
1962 gfc_add_block_to_block (&body
, &se
.pre
);
1963 gfc_add_block_to_block (&body
, &se
.post
);
1965 gfc_trans_scalarizing_loops (&loop
, &body
);
1967 gfc_add_block_to_block (&block
, &loop
.pre
);
1968 gfc_add_block_to_block (&block
, &loop
.post
);
1970 for (n
= 0; n
< cm
->as
->rank
; n
++)
1971 mpz_clear (ss
->shape
[n
]);
1972 gfc_free (ss
->shape
);
1974 gfc_cleanup_loop (&loop
);
1976 return gfc_finish_block (&block
);
1979 /* Generate the call for a scalar transfer node. */
1982 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
1984 tree tmp
, function
, arg2
, arg3
, field
, expr
;
1988 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
1989 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
1990 We need to translate the expression to a constant if it's either
1991 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
1992 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
1993 BT_DERIVED (could have been changed by gfc_conv_expr). */
1994 if ((ts
->type
== BT_DERIVED
|| ts
->type
== BT_INTEGER
)
1995 && ts
->u
.derived
!= NULL
1996 && (ts
->is_iso_c
== 1 || ts
->u
.derived
->ts
.is_iso_c
== 1))
1998 /* C_PTR and C_FUNPTR have private components which means they can not
1999 be printed. However, if -std=gnu and not -pedantic, allow
2000 the component to be printed to help debugging. */
2001 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
2003 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
2004 ts
->u
.derived
->name
, code
!= NULL
? &(code
->loc
) :
2005 &gfc_current_locus
);
2009 ts
->type
= ts
->u
.derived
->ts
.type
;
2010 ts
->kind
= ts
->u
.derived
->ts
.kind
;
2011 ts
->f90_type
= ts
->u
.derived
->ts
.f90_type
;
2022 arg2
= build_int_cst (NULL_TREE
, kind
);
2023 function
= iocall
[IOCALL_X_INTEGER
];
2027 arg2
= build_int_cst (NULL_TREE
, kind
);
2028 function
= iocall
[IOCALL_X_REAL
];
2032 arg2
= build_int_cst (NULL_TREE
, kind
);
2033 function
= iocall
[IOCALL_X_COMPLEX
];
2037 arg2
= build_int_cst (NULL_TREE
, kind
);
2038 function
= iocall
[IOCALL_X_LOGICAL
];
2044 if (se
->string_length
)
2045 arg2
= se
->string_length
;
2048 tmp
= build_fold_indirect_ref_loc (input_location
,
2050 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2051 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2052 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2054 arg3
= build_int_cst (NULL_TREE
, kind
);
2055 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2056 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2057 tmp
= build_call_expr_loc (input_location
,
2058 function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2059 gfc_add_expr_to_block (&se
->pre
, tmp
);
2060 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2065 if (se
->string_length
)
2066 arg2
= se
->string_length
;
2069 tmp
= build_fold_indirect_ref_loc (input_location
,
2071 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2072 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2074 function
= iocall
[IOCALL_X_CHARACTER
];
2078 /* Recurse into the elements of the derived type. */
2079 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2080 expr
= build_fold_indirect_ref_loc (input_location
,
2083 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
2085 field
= c
->backend_decl
;
2086 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2088 tmp
= fold_build3_loc (UNKNOWN_LOCATION
,
2089 COMPONENT_REF
, TREE_TYPE (field
),
2090 expr
, field
, NULL_TREE
);
2092 if (c
->attr
.dimension
)
2094 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2095 gfc_add_expr_to_block (&se
->pre
, tmp
);
2099 if (!c
->attr
.pointer
)
2100 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2101 transfer_expr (se
, &c
->ts
, tmp
, code
);
2107 internal_error ("Bad IO basetype (%d)", ts
->type
);
2110 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2111 tmp
= build_call_expr_loc (input_location
,
2112 function
, 3, tmp
, addr_expr
, arg2
);
2113 gfc_add_expr_to_block (&se
->pre
, tmp
);
2114 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2119 /* Generate a call to pass an array descriptor to the IO library. The
2120 array should be of one of the intrinsic types. */
2123 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2125 tree tmp
, charlen_arg
, kind_arg
;
2127 if (ts
->type
== BT_CHARACTER
)
2128 charlen_arg
= se
->string_length
;
2130 charlen_arg
= build_int_cst (NULL_TREE
, 0);
2132 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
2134 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2135 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2136 iocall
[IOCALL_X_ARRAY
], 4,
2137 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2138 gfc_add_expr_to_block (&se
->pre
, tmp
);
2139 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2143 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2146 gfc_trans_transfer (gfc_code
* code
)
2148 stmtblock_t block
, body
;
2157 gfc_start_block (&block
);
2158 gfc_init_block (&body
);
2161 ss
= gfc_walk_expr (expr
);
2164 gfc_init_se (&se
, NULL
);
2166 if (ss
== gfc_ss_terminator
)
2168 /* Transfer a scalar value. */
2169 gfc_conv_expr_reference (&se
, expr
);
2170 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2174 /* Transfer an array. If it is an array of an intrinsic
2175 type, pass the descriptor to the library. Otherwise
2176 scalarize the transfer. */
2177 if (expr
->ref
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
2179 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2181 gcc_assert (ref
->type
== REF_ARRAY
);
2184 if (expr
->ts
.type
!= BT_DERIVED
2185 && ref
&& ref
->next
== NULL
2186 && !is_subref_array (expr
))
2188 bool seen_vector
= false;
2190 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2192 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2193 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2197 if (seen_vector
&& last_dt
== READ
)
2199 /* Create a temp, read to that and copy it back. */
2200 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
, false);
2205 /* Get the descriptor. */
2206 gfc_conv_expr_descriptor (&se
, expr
, ss
);
2207 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2210 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2211 goto finish_block_label
;
2214 /* Initialize the scalarizer. */
2215 gfc_init_loopinfo (&loop
);
2216 gfc_add_ss_to_loop (&loop
, ss
);
2218 /* Initialize the loop. */
2219 gfc_conv_ss_startstride (&loop
);
2220 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
2222 /* The main loop body. */
2223 gfc_mark_ss_chain_used (ss
, 1);
2224 gfc_start_scalarized_body (&loop
, &body
);
2226 gfc_copy_loopinfo_to_se (&se
, &loop
);
2229 gfc_conv_expr_reference (&se
, expr
);
2230 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2235 gfc_add_block_to_block (&body
, &se
.pre
);
2236 gfc_add_block_to_block (&body
, &se
.post
);
2239 tmp
= gfc_finish_block (&body
);
2242 gcc_assert (se
.ss
== gfc_ss_terminator
);
2243 gfc_trans_scalarizing_loops (&loop
, &body
);
2245 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2246 tmp
= gfc_finish_block (&loop
.pre
);
2247 gfc_cleanup_loop (&loop
);
2250 gfc_add_expr_to_block (&block
, tmp
);
2252 return gfc_finish_block (&block
);
2255 #include "gt-fortran-trans-io.h"