1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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
), 1, 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 gfc_new_nml_name_expr (const char * name
)
1397 gfc_expr
* nml_name
;
1399 nml_name
= gfc_get_expr();
1400 nml_name
->ref
= NULL
;
1401 nml_name
->expr_type
= EXPR_CONSTANT
;
1402 nml_name
->ts
.kind
= gfc_default_character_kind
;
1403 nml_name
->ts
.type
= BT_CHARACTER
;
1404 nml_name
->value
.character
.length
= strlen(name
);
1405 nml_name
->value
.character
.string
= gfc_char_to_widechar (name
);
1410 /* nml_full_name builds up the fully qualified name of a
1411 derived type component. */
1414 nml_full_name (const char* var_name
, const char* cmp_name
)
1416 int full_name_length
;
1419 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1420 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1421 strcpy (full_name
, var_name
);
1422 full_name
= strcat (full_name
, "%");
1423 full_name
= strcat (full_name
, cmp_name
);
1427 /* nml_get_addr_expr builds an address expression from the
1428 gfc_symbol or gfc_component backend_decl's. An offset is
1429 provided so that the address of an element of an array of
1430 derived types is returned. This is used in the runtime to
1431 determine that span of the derived type. */
1434 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1437 tree decl
= NULL_TREE
;
1441 int dummy_arg_flagged
;
1445 sym
->attr
.referenced
= 1;
1446 decl
= gfc_get_symbol_decl (sym
);
1448 /* If this is the enclosing function declaration, use
1449 the fake result instead. */
1450 if (decl
== current_function_decl
)
1451 decl
= gfc_get_fake_result_decl (sym
, 0);
1452 else if (decl
== DECL_CONTEXT (current_function_decl
))
1453 decl
= gfc_get_fake_result_decl (sym
, 1);
1456 decl
= c
->backend_decl
;
1458 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1459 || TREE_CODE (decl
) == VAR_DECL
1460 || TREE_CODE (decl
) == PARM_DECL
)
1461 || TREE_CODE (decl
) == COMPONENT_REF
));
1465 /* Build indirect reference, if dummy argument. */
1467 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1469 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref_loc (input_location
,
1472 /* If an array, set flag and use indirect ref. if built. */
1474 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1475 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1480 /* Treat the component of a derived type, using base_addr for
1481 the derived type. */
1483 if (TREE_CODE (decl
) == FIELD_DECL
)
1484 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1485 base_addr
, tmp
, NULL_TREE
);
1487 /* If we have a derived type component, a reference to the first
1488 element of the array is built. This is done so that base_addr,
1489 used in the build of the component reference, always points to
1493 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1495 /* Now build the address expression. */
1497 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1499 /* If scalar dummy, resolve indirect reference now. */
1501 if (dummy_arg_flagged
&& !array_flagged
)
1502 tmp
= build_fold_indirect_ref_loc (input_location
,
1505 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1510 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1511 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1512 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1514 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1517 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1518 gfc_symbol
* sym
, gfc_component
* c
,
1521 gfc_typespec
* ts
= NULL
;
1522 gfc_array_spec
* as
= NULL
;
1523 tree addr_expr
= NULL
;
1533 gcc_assert (sym
|| c
);
1535 /* Build the namelist object name. */
1537 string
= gfc_build_cstring_const (var_name
);
1538 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1540 /* Build ts, as and data address using symbol or component. */
1542 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1543 as
= (sym
) ? sym
->as
: c
->as
;
1545 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1552 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1553 dtype
= gfc_get_dtype (dt
);
1557 itype
= GFC_DTYPE_UNKNOWN
;
1563 itype
= GFC_DTYPE_INTEGER
;
1566 itype
= GFC_DTYPE_LOGICAL
;
1569 itype
= GFC_DTYPE_REAL
;
1572 itype
= GFC_DTYPE_COMPLEX
;
1575 itype
= GFC_DTYPE_DERIVED
;
1578 itype
= GFC_DTYPE_CHARACTER
;
1584 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1587 /* Build up the arguments for the transfer call.
1588 The call for the scalar part transfers:
1589 (address, name, type, kind or string_length, dtype) */
1591 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1593 if (ts
->type
== BT_CHARACTER
)
1594 tmp
= ts
->u
.cl
->backend_decl
;
1596 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1597 tmp
= build_call_expr_loc (input_location
,
1598 iocall
[IOCALL_SET_NML_VAL
], 6,
1599 dt_parm_addr
, addr_expr
, string
,
1600 IARG (ts
->kind
), tmp
, dtype
);
1601 gfc_add_expr_to_block (block
, tmp
);
1603 /* If the object is an array, transfer rank times:
1604 (null pointer, name, stride, lbound, ubound) */
1606 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1608 tmp
= build_call_expr_loc (input_location
,
1609 iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1612 GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
),
1613 GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
),
1614 GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1615 gfc_add_expr_to_block (block
, tmp
);
1618 if (ts
->type
== BT_DERIVED
)
1622 /* Provide the RECORD_TYPE to build component references. */
1624 tree expr
= build_fold_indirect_ref_loc (input_location
,
1627 for (cmp
= ts
->u
.derived
->components
; cmp
; cmp
= cmp
->next
)
1629 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1630 transfer_namelist_element (block
,
1633 gfc_free (full_name
);
1640 /* Create a data transfer statement. Not all of the fields are valid
1641 for both reading and writing, but improper use has been filtered
1645 build_dt (tree function
, gfc_code
* code
)
1647 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1652 unsigned int mask
= 0;
1654 gfc_start_block (&block
);
1655 gfc_init_block (&post_block
);
1656 gfc_init_block (&post_end_block
);
1657 gfc_init_block (&post_iu_block
);
1659 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1661 set_error_locus (&block
, var
, &code
->loc
);
1663 if (last_dt
== IOLENGTH
)
1667 inq
= code
->ext
.inquire
;
1669 /* First check that preconditions are met. */
1670 gcc_assert (inq
!= NULL
);
1671 gcc_assert (inq
->iolength
!= NULL
);
1673 /* Connect to the iolength variable. */
1674 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1675 IOPARM_dt_iolength
, inq
->iolength
);
1681 gcc_assert (dt
!= NULL
);
1684 if (dt
&& dt
->io_unit
)
1686 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1688 mask
|= set_internal_unit (&block
, &post_iu_block
,
1690 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1694 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1699 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1703 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1704 IOPARM_common_iostat
, dt
->iostat
);
1707 mask
|= IOPARM_common_err
;
1710 mask
|= IOPARM_common_eor
;
1713 mask
|= IOPARM_common_end
;
1716 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1717 IOPARM_dt_id
, dt
->id
);
1720 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1722 if (dt
->asynchronous
)
1723 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_asynchronous
,
1727 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1731 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1735 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1739 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1743 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1747 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1751 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1754 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1757 if (dt
->format_expr
)
1758 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1761 if (dt
->format_label
)
1763 if (dt
->format_label
== &format_asterisk
)
1764 mask
|= IOPARM_dt_list_format
;
1766 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1767 dt
->format_label
->format
);
1771 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1772 IOPARM_dt_size
, dt
->size
);
1776 if (dt
->format_expr
|| dt
->format_label
)
1777 gfc_internal_error ("build_dt: format with namelist");
1779 nmlname
= gfc_new_nml_name_expr (dt
->namelist
->name
);
1781 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1784 if (last_dt
== READ
)
1785 mask
|= IOPARM_dt_namelist_read_mode
;
1787 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1791 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1792 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1796 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1798 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1799 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1802 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1804 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1805 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
1807 gfc_add_expr_to_block (&block
, tmp
);
1809 gfc_add_block_to_block (&block
, &post_block
);
1812 dt_post_end_block
= &post_end_block
;
1814 gfc_add_expr_to_block (&block
, gfc_trans_code (code
->block
->next
));
1816 gfc_add_block_to_block (&block
, &post_iu_block
);
1819 dt_post_end_block
= NULL
;
1821 return gfc_finish_block (&block
);
1825 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1826 this as a third sort of data transfer statement, except that
1827 lengths are summed instead of actually transferring any data. */
1830 gfc_trans_iolength (gfc_code
* code
)
1833 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1837 /* Translate a READ statement. */
1840 gfc_trans_read (gfc_code
* code
)
1843 return build_dt (iocall
[IOCALL_READ
], code
);
1847 /* Translate a WRITE statement */
1850 gfc_trans_write (gfc_code
* code
)
1853 return build_dt (iocall
[IOCALL_WRITE
], code
);
1857 /* Finish a data transfer statement. */
1860 gfc_trans_dt_end (gfc_code
* code
)
1865 gfc_init_block (&block
);
1870 function
= iocall
[IOCALL_READ_DONE
];
1874 function
= iocall
[IOCALL_WRITE_DONE
];
1878 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1885 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1886 tmp
= build_call_expr_loc (input_location
,
1888 gfc_add_expr_to_block (&block
, tmp
);
1889 gfc_add_block_to_block (&block
, dt_post_end_block
);
1890 gfc_init_block (dt_post_end_block
);
1892 if (last_dt
!= IOLENGTH
)
1894 gcc_assert (code
->ext
.dt
!= NULL
);
1895 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1896 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1899 return gfc_finish_block (&block
);
1903 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1905 /* Given an array field in a derived type variable, generate the code
1906 for the loop that iterates over array elements, and the code that
1907 accesses those array elements. Use transfer_expr to generate code
1908 for transferring that element. Because elements may also be
1909 derived types, transfer_expr and transfer_array_component are mutually
1913 transfer_array_component (tree expr
, gfc_component
* cm
, locus
* where
)
1923 gfc_start_block (&block
);
1924 gfc_init_se (&se
, NULL
);
1926 /* Create and initialize Scalarization Status. Unlike in
1927 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1928 care of this task, because we don't have a gfc_expr at hand.
1929 Build one manually, as in gfc_trans_subarray_assign. */
1932 ss
->type
= GFC_SS_COMPONENT
;
1934 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1935 ss
->next
= gfc_ss_terminator
;
1936 ss
->data
.info
.dimen
= cm
->as
->rank
;
1937 ss
->data
.info
.descriptor
= expr
;
1938 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1939 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1940 for (n
= 0; n
< cm
->as
->rank
; n
++)
1942 ss
->data
.info
.dim
[n
] = n
;
1943 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1944 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1946 mpz_init (ss
->shape
[n
]);
1947 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1948 cm
->as
->lower
[n
]->value
.integer
);
1949 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1952 /* Once we got ss, we use scalarizer to create the loop. */
1954 gfc_init_loopinfo (&loop
);
1955 gfc_add_ss_to_loop (&loop
, ss
);
1956 gfc_conv_ss_startstride (&loop
);
1957 gfc_conv_loop_setup (&loop
, where
);
1958 gfc_mark_ss_chain_used (ss
, 1);
1959 gfc_start_scalarized_body (&loop
, &body
);
1961 gfc_copy_loopinfo_to_se (&se
, &loop
);
1964 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1966 gfc_conv_tmp_array_ref (&se
);
1968 /* Now se.expr contains an element of the array. Take the address and pass
1969 it to the IO routines. */
1970 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
1971 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1973 /* We are done now with the loop body. Wrap up the scalarizer and
1976 gfc_add_block_to_block (&body
, &se
.pre
);
1977 gfc_add_block_to_block (&body
, &se
.post
);
1979 gfc_trans_scalarizing_loops (&loop
, &body
);
1981 gfc_add_block_to_block (&block
, &loop
.pre
);
1982 gfc_add_block_to_block (&block
, &loop
.post
);
1984 for (n
= 0; n
< cm
->as
->rank
; n
++)
1985 mpz_clear (ss
->shape
[n
]);
1986 gfc_free (ss
->shape
);
1988 gfc_cleanup_loop (&loop
);
1990 return gfc_finish_block (&block
);
1993 /* Generate the call for a scalar transfer node. */
1996 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
1998 tree tmp
, function
, arg2
, arg3
, field
, expr
;
2002 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2003 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2004 We need to translate the expression to a constant if it's either
2005 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2006 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2007 BT_DERIVED (could have been changed by gfc_conv_expr). */
2008 if ((ts
->type
== BT_DERIVED
|| ts
->type
== BT_INTEGER
)
2009 && ts
->u
.derived
!= NULL
2010 && (ts
->is_iso_c
== 1 || ts
->u
.derived
->ts
.is_iso_c
== 1))
2012 /* C_PTR and C_FUNPTR have private components which means they can not
2013 be printed. However, if -std=gnu and not -pedantic, allow
2014 the component to be printed to help debugging. */
2015 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
2017 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
2018 ts
->u
.derived
->name
, code
!= NULL
? &(code
->loc
) :
2019 &gfc_current_locus
);
2023 ts
->type
= ts
->u
.derived
->ts
.type
;
2024 ts
->kind
= ts
->u
.derived
->ts
.kind
;
2025 ts
->f90_type
= ts
->u
.derived
->ts
.f90_type
;
2036 arg2
= build_int_cst (NULL_TREE
, kind
);
2037 function
= iocall
[IOCALL_X_INTEGER
];
2041 arg2
= build_int_cst (NULL_TREE
, kind
);
2042 function
= iocall
[IOCALL_X_REAL
];
2046 arg2
= build_int_cst (NULL_TREE
, kind
);
2047 function
= iocall
[IOCALL_X_COMPLEX
];
2051 arg2
= build_int_cst (NULL_TREE
, kind
);
2052 function
= iocall
[IOCALL_X_LOGICAL
];
2058 if (se
->string_length
)
2059 arg2
= se
->string_length
;
2062 tmp
= build_fold_indirect_ref_loc (input_location
,
2064 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2065 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2066 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2068 arg3
= build_int_cst (NULL_TREE
, kind
);
2069 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2070 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2071 tmp
= build_call_expr_loc (input_location
,
2072 function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2073 gfc_add_expr_to_block (&se
->pre
, tmp
);
2074 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2079 if (se
->string_length
)
2080 arg2
= se
->string_length
;
2083 tmp
= build_fold_indirect_ref_loc (input_location
,
2085 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2086 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2088 function
= iocall
[IOCALL_X_CHARACTER
];
2092 /* Recurse into the elements of the derived type. */
2093 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2094 expr
= build_fold_indirect_ref_loc (input_location
,
2097 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
2099 field
= c
->backend_decl
;
2100 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2102 tmp
= fold_build3_loc (UNKNOWN_LOCATION
,
2103 COMPONENT_REF
, TREE_TYPE (field
),
2104 expr
, field
, NULL_TREE
);
2106 if (c
->attr
.dimension
)
2108 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2109 gfc_add_expr_to_block (&se
->pre
, tmp
);
2113 if (!c
->attr
.pointer
)
2114 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2115 transfer_expr (se
, &c
->ts
, tmp
, code
);
2121 internal_error ("Bad IO basetype (%d)", ts
->type
);
2124 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2125 tmp
= build_call_expr_loc (input_location
,
2126 function
, 3, tmp
, addr_expr
, arg2
);
2127 gfc_add_expr_to_block (&se
->pre
, tmp
);
2128 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2133 /* Generate a call to pass an array descriptor to the IO library. The
2134 array should be of one of the intrinsic types. */
2137 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2139 tree tmp
, charlen_arg
, kind_arg
;
2141 if (ts
->type
== BT_CHARACTER
)
2142 charlen_arg
= se
->string_length
;
2144 charlen_arg
= build_int_cst (NULL_TREE
, 0);
2146 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
2148 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2149 tmp
= build_call_expr_loc (UNKNOWN_LOCATION
,
2150 iocall
[IOCALL_X_ARRAY
], 4,
2151 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2152 gfc_add_expr_to_block (&se
->pre
, tmp
);
2153 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2157 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2160 gfc_trans_transfer (gfc_code
* code
)
2162 stmtblock_t block
, body
;
2171 gfc_start_block (&block
);
2172 gfc_init_block (&body
);
2175 ss
= gfc_walk_expr (expr
);
2178 gfc_init_se (&se
, NULL
);
2180 if (ss
== gfc_ss_terminator
)
2182 /* Transfer a scalar value. */
2183 gfc_conv_expr_reference (&se
, expr
);
2184 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2188 /* Transfer an array. If it is an array of an intrinsic
2189 type, pass the descriptor to the library. Otherwise
2190 scalarize the transfer. */
2191 if (expr
->ref
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
2193 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2195 gcc_assert (ref
->type
== REF_ARRAY
);
2198 if (expr
->ts
.type
!= BT_DERIVED
2199 && ref
&& ref
->next
== NULL
2200 && !is_subref_array (expr
))
2202 bool seen_vector
= false;
2204 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2206 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2207 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2211 if (seen_vector
&& last_dt
== READ
)
2213 /* Create a temp, read to that and copy it back. */
2214 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
, false);
2219 /* Get the descriptor. */
2220 gfc_conv_expr_descriptor (&se
, expr
, ss
);
2221 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2224 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2225 goto finish_block_label
;
2228 /* Initialize the scalarizer. */
2229 gfc_init_loopinfo (&loop
);
2230 gfc_add_ss_to_loop (&loop
, ss
);
2232 /* Initialize the loop. */
2233 gfc_conv_ss_startstride (&loop
);
2234 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
2236 /* The main loop body. */
2237 gfc_mark_ss_chain_used (ss
, 1);
2238 gfc_start_scalarized_body (&loop
, &body
);
2240 gfc_copy_loopinfo_to_se (&se
, &loop
);
2243 gfc_conv_expr_reference (&se
, expr
);
2244 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2249 gfc_add_block_to_block (&body
, &se
.pre
);
2250 gfc_add_block_to_block (&body
, &se
.post
);
2253 tmp
= gfc_finish_block (&body
);
2256 gcc_assert (se
.ss
== gfc_ss_terminator
);
2257 gfc_trans_scalarizing_loops (&loop
, &body
);
2259 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2260 tmp
= gfc_finish_block (&loop
.pre
);
2261 gfc_cleanup_loop (&loop
);
2264 gfc_add_expr_to_block (&block
, tmp
);
2266 return gfc_finish_block (&block
);
2269 #include "gt-fortran-trans-io.h"