1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
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, 0, 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 (gfor_fndecl_generate_error
, 3, arg1
, arg2
, arg3
);
251 gfc_add_expr_to_block (&block
, tmp
);
253 body
= gfc_finish_block (&block
);
255 if (integer_onep (cond
))
257 gfc_add_expr_to_block (pblock
, body
);
261 /* Tell the compiler that this isn't likely. */
262 cond
= fold_convert (long_integer_type_node
, cond
);
263 tmp
= build_int_cst (long_integer_type_node
, 0);
264 cond
= build_call_expr (built_in_decls
[BUILT_IN_EXPECT
], 2, cond
, tmp
);
265 cond
= fold_convert (boolean_type_node
, cond
);
267 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt ());
268 gfc_add_expr_to_block (pblock
, tmp
);
273 /* Create function decls for IO library functions. */
276 gfc_build_io_library_fndecls (void)
278 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
279 tree gfc_intio_type_node
;
280 tree parm_type
, dt_parm_type
;
281 HOST_WIDE_INT pad_size
;
282 enum ioparam_type ptype
;
284 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
285 types
[IOPARM_type_intio
] = gfc_intio_type_node
286 = gfc_get_int_type (gfc_intio_kind
);
287 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
288 types
[IOPARM_type_pintio
]
289 = build_pointer_type (gfc_intio_type_node
);
290 types
[IOPARM_type_parray
] = pchar_type_node
;
291 types
[IOPARM_type_pchar
] = pchar_type_node
;
292 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
293 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
294 pad_idx
= build_index_type (build_int_cst (NULL_TREE
, pad_size
- 1));
295 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
297 /* pad actually contains pointers and integers so it needs to have an
298 alignment that is at least as large as the needed alignment for those
299 types. See the st_parameter_dt structure in libgfortran/io/io.h for
300 what really goes into this space. */
301 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
302 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind
)));
304 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
305 gfc_build_st_parameter (ptype
, types
);
307 /* Define the transfer functions. */
309 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
311 iocall
[IOCALL_X_INTEGER
] =
312 gfc_build_library_function_decl (get_identifier
313 (PREFIX("transfer_integer")),
314 void_type_node
, 3, dt_parm_type
,
315 pvoid_type_node
, gfc_int4_type_node
);
317 iocall
[IOCALL_X_LOGICAL
] =
318 gfc_build_library_function_decl (get_identifier
319 (PREFIX("transfer_logical")),
320 void_type_node
, 3, dt_parm_type
,
321 pvoid_type_node
, gfc_int4_type_node
);
323 iocall
[IOCALL_X_CHARACTER
] =
324 gfc_build_library_function_decl (get_identifier
325 (PREFIX("transfer_character")),
326 void_type_node
, 3, dt_parm_type
,
327 pvoid_type_node
, gfc_int4_type_node
);
329 iocall
[IOCALL_X_CHARACTER_WIDE
] =
330 gfc_build_library_function_decl (get_identifier
331 (PREFIX("transfer_character_wide")),
332 void_type_node
, 4, dt_parm_type
,
333 pvoid_type_node
, gfc_charlen_type_node
,
336 iocall
[IOCALL_X_REAL
] =
337 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
338 void_type_node
, 3, dt_parm_type
,
339 pvoid_type_node
, gfc_int4_type_node
);
341 iocall
[IOCALL_X_COMPLEX
] =
342 gfc_build_library_function_decl (get_identifier
343 (PREFIX("transfer_complex")),
344 void_type_node
, 3, dt_parm_type
,
345 pvoid_type_node
, gfc_int4_type_node
);
347 iocall
[IOCALL_X_ARRAY
] =
348 gfc_build_library_function_decl (get_identifier
349 (PREFIX("transfer_array")),
350 void_type_node
, 4, dt_parm_type
,
351 pvoid_type_node
, integer_type_node
,
352 gfc_charlen_type_node
);
354 /* Library entry points */
356 iocall
[IOCALL_READ
] =
357 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
358 void_type_node
, 1, dt_parm_type
);
360 iocall
[IOCALL_WRITE
] =
361 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
362 void_type_node
, 1, dt_parm_type
);
364 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
365 iocall
[IOCALL_OPEN
] =
366 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
367 void_type_node
, 1, parm_type
);
370 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
371 iocall
[IOCALL_CLOSE
] =
372 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
373 void_type_node
, 1, parm_type
);
375 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
376 iocall
[IOCALL_INQUIRE
] =
377 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
378 gfc_int4_type_node
, 1, parm_type
);
380 iocall
[IOCALL_IOLENGTH
] =
381 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
382 void_type_node
, 1, dt_parm_type
);
384 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_wait
].type
);
385 iocall
[IOCALL_WAIT
] =
386 gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")),
387 gfc_int4_type_node
, 1, parm_type
);
389 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
390 iocall
[IOCALL_REWIND
] =
391 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
392 gfc_int4_type_node
, 1, parm_type
);
394 iocall
[IOCALL_BACKSPACE
] =
395 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
396 gfc_int4_type_node
, 1, parm_type
);
398 iocall
[IOCALL_ENDFILE
] =
399 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
400 gfc_int4_type_node
, 1, parm_type
);
402 iocall
[IOCALL_FLUSH
] =
403 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
404 gfc_int4_type_node
, 1, parm_type
);
406 /* Library helpers */
408 iocall
[IOCALL_READ_DONE
] =
409 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
410 gfc_int4_type_node
, 1, dt_parm_type
);
412 iocall
[IOCALL_WRITE_DONE
] =
413 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
414 gfc_int4_type_node
, 1, dt_parm_type
);
416 iocall
[IOCALL_IOLENGTH_DONE
] =
417 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
418 gfc_int4_type_node
, 1, dt_parm_type
);
421 iocall
[IOCALL_SET_NML_VAL
] =
422 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
423 void_type_node
, 6, dt_parm_type
,
424 pvoid_type_node
, pvoid_type_node
,
425 gfc_int4_type_node
, gfc_charlen_type_node
,
428 iocall
[IOCALL_SET_NML_VAL_DIM
] =
429 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
430 void_type_node
, 5, dt_parm_type
,
431 gfc_int4_type_node
, gfc_array_index_type
,
432 gfc_array_index_type
, gfc_array_index_type
);
436 /* Generate code to store an integer constant into the
437 st_parameter_XXX structure. */
440 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
444 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
446 if (p
->param_type
== IOPARM_ptype_common
)
447 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
448 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
449 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
451 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
456 /* Generate code to store a non-string I/O parameter into the
457 st_parameter_XXX structure. This is a pass by value. */
460 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
465 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
466 tree dest_type
= TREE_TYPE (p
->field
);
468 gfc_init_se (&se
, NULL
);
469 gfc_conv_expr_val (&se
, e
);
471 /* If we're storing a UNIT number, we need to check it first. */
472 if (type
== IOPARM_common_unit
&& e
->ts
.kind
!= 4)
477 /* Don't evaluate the UNIT number multiple times. */
478 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
480 /* UNIT numbers should be nonnegative. */
481 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, se
.expr
,
482 build_int_cst (TREE_TYPE (se
.expr
),0));
483 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
484 "Negative unit number in I/O statement",
487 /* UNIT numbers should be less than the max. */
488 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
489 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
490 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, se
.expr
,
491 fold_convert (TREE_TYPE (se
.expr
), max
));
492 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
493 "Unit number in I/O statement too large",
498 se
.expr
= convert (dest_type
, se
.expr
);
499 gfc_add_block_to_block (block
, &se
.pre
);
501 if (p
->param_type
== IOPARM_ptype_common
)
502 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
503 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
505 tmp
= fold_build3 (COMPONENT_REF
, dest_type
, var
, p
->field
, NULL_TREE
);
506 gfc_add_modify (block
, tmp
, se
.expr
);
511 /* Generate code to store a non-string I/O parameter into the
512 st_parameter_XXX structure. This is pass by reference. */
515 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
516 tree var
, enum iofield type
, gfc_expr
*e
)
520 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
522 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
523 gfc_init_se (&se
, NULL
);
524 gfc_conv_expr_lhs (&se
, e
);
526 gfc_add_block_to_block (block
, &se
.pre
);
528 if (TYPE_MODE (TREE_TYPE (se
.expr
))
529 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
531 addr
= convert (TREE_TYPE (p
->field
), gfc_build_addr_expr (NULL_TREE
, se
.expr
));
533 /* If this is for the iostat variable initialize the
534 user variable to LIBERROR_OK which is zero. */
535 if (type
== IOPARM_common_iostat
)
536 gfc_add_modify (block
, se
.expr
,
537 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
541 /* The type used by the library has different size
542 from the type of the variable supplied by the user.
543 Need to use a temporary. */
544 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
545 st_parameter_field
[type
].name
);
547 /* If this is for the iostat variable, initialize the
548 user variable to LIBERROR_OK which is zero. */
549 if (type
== IOPARM_common_iostat
)
550 gfc_add_modify (block
, tmpvar
,
551 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
553 addr
= gfc_build_addr_expr (NULL_TREE
, tmpvar
);
554 /* After the I/O operation, we set the variable from the temporary. */
555 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
556 gfc_add_modify (postblock
, se
.expr
, tmp
);
559 if (p
->param_type
== IOPARM_ptype_common
)
560 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
561 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
562 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
563 var
, p
->field
, NULL_TREE
);
564 gfc_add_modify (block
, tmp
, addr
);
568 /* Given an array expr, find its address and length to get a string. If the
569 array is full, the string's address is the address of array's first element
570 and the length is the size of the whole array. If it is an element, the
571 string's address is the element's address and the length is the rest size of
576 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
585 sym
= e
->symtree
->n
.sym
;
586 rank
= sym
->as
->rank
- 1;
588 if (e
->ref
->u
.ar
.type
== AR_FULL
)
590 se
->expr
= gfc_get_symbol_decl (sym
);
591 se
->expr
= gfc_conv_array_data (se
->expr
);
595 gfc_conv_expr (se
, e
);
598 array
= sym
->backend_decl
;
599 type
= TREE_TYPE (array
);
601 if (GFC_ARRAY_TYPE_P (type
))
602 size
= GFC_TYPE_ARRAY_SIZE (type
);
605 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
606 size
= gfc_conv_array_stride (array
, rank
);
607 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
608 gfc_conv_array_ubound (array
, rank
),
609 gfc_conv_array_lbound (array
, rank
));
610 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
612 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
617 /* If it is an element, we need the its address and size of the rest. */
618 if (e
->ref
->u
.ar
.type
== AR_ELEMENT
)
620 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
621 TREE_OPERAND (se
->expr
, 1));
622 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
625 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
626 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
627 fold_convert (gfc_array_index_type
, tmp
));
629 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
633 /* Generate code to store a string and its length into the
634 st_parameter_XXX structure. */
637 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
638 enum iofield type
, gfc_expr
* e
)
644 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
646 gfc_init_se (&se
, NULL
);
648 if (p
->param_type
== IOPARM_ptype_common
)
649 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
650 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
651 io
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
652 var
, p
->field
, NULL_TREE
);
653 len
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
),
654 var
, p
->field_len
, NULL_TREE
);
656 /* Integer variable assigned a format label. */
657 if (e
->ts
.type
== BT_INTEGER
&& e
->symtree
->n
.sym
->attr
.assign
== 1)
662 gfc_conv_label_variable (&se
, e
);
663 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
664 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
665 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
667 asprintf(&msg
, "Label assigned to variable '%s' (%%ld) is not a format "
668 "label", e
->symtree
->name
);
669 gfc_trans_runtime_check (true, false, cond
, &se
.pre
, &e
->where
, msg
,
670 fold_convert (long_integer_type_node
, tmp
));
673 gfc_add_modify (&se
.pre
, io
,
674 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
675 gfc_add_modify (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
679 /* General character. */
680 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
681 gfc_conv_expr (&se
, e
);
682 /* Array assigned Hollerith constant or character array. */
683 else if (e
->symtree
&& (e
->symtree
->n
.sym
->as
->rank
> 0))
684 gfc_convert_array_to_string (&se
, e
);
688 gfc_conv_string_parameter (&se
);
689 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
690 gfc_add_modify (&se
.pre
, len
, se
.string_length
);
693 gfc_add_block_to_block (block
, &se
.pre
);
694 gfc_add_block_to_block (postblock
, &se
.post
);
699 /* Generate code to store the character (array) and the character length
700 for an internal unit. */
703 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
704 tree var
, gfc_expr
* e
)
711 gfc_st_parameter_field
*p
;
714 gfc_init_se (&se
, NULL
);
716 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
718 io
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
719 var
, p
->field
, NULL_TREE
);
720 len
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
),
721 var
, p
->field_len
, NULL_TREE
);
722 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
723 desc
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
724 var
, p
->field
, NULL_TREE
);
726 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
728 /* Character scalars. */
731 gfc_conv_expr (&se
, e
);
732 gfc_conv_string_parameter (&se
);
734 se
.expr
= build_int_cst (pchar_type_node
, 0);
737 /* Character array. */
738 else if (e
->rank
> 0)
740 se
.ss
= gfc_walk_expr (e
);
742 if (is_subref_array (e
))
744 /* Use a temporary for components of arrays of derived types
745 or substring array references. */
746 gfc_conv_subref_array_arg (&se
, e
, 0,
747 last_dt
== READ
? INTENT_IN
: INTENT_OUT
);
748 tmp
= build_fold_indirect_ref (se
.expr
);
749 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
750 tmp
= gfc_conv_descriptor_data_get (tmp
);
754 /* Return the data pointer and rank from the descriptor. */
755 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
756 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
757 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
763 /* The cast is needed for character substrings and the descriptor
765 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
766 gfc_add_modify (&se
.pre
, len
,
767 fold_convert (TREE_TYPE (len
), se
.string_length
));
768 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
770 gfc_add_block_to_block (block
, &se
.pre
);
771 gfc_add_block_to_block (post_block
, &se
.post
);
775 /* Add a case to a IO-result switch. */
778 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
783 return; /* No label, no case */
785 value
= build_int_cst (NULL_TREE
, label_value
);
787 /* Make a backend label for this case. */
788 tmp
= gfc_build_label_decl (NULL_TREE
);
790 /* And the case itself. */
791 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
792 gfc_add_expr_to_block (body
, tmp
);
794 /* Jump to the label. */
795 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
796 gfc_add_expr_to_block (body
, tmp
);
800 /* Generate a switch statement that branches to the correct I/O
801 result label. The last statement of an I/O call stores the
802 result into a variable because there is often cleanup that
803 must be done before the switch, so a temporary would have to
804 be created anyway. */
807 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
808 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
812 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
814 /* If no labels are specified, ignore the result instead
815 of building an empty switch. */
816 if (err_label
== NULL
818 && eor_label
== NULL
)
821 /* Build a switch statement. */
822 gfc_start_block (&body
);
824 /* The label values here must be the same as the values
825 in the library_return enum in the runtime library */
826 add_case (1, err_label
, &body
);
827 add_case (2, end_label
, &body
);
828 add_case (3, eor_label
, &body
);
830 tmp
= gfc_finish_block (&body
);
832 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
833 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
834 rc
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
835 var
, p
->field
, NULL_TREE
);
836 rc
= fold_build2 (BIT_AND_EXPR
, TREE_TYPE (rc
),
837 rc
, build_int_cst (TREE_TYPE (rc
),
838 IOPARM_common_libreturn_mask
));
840 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
842 gfc_add_expr_to_block (block
, tmp
);
846 /* Store the current file and line number to variables so that if a
847 library call goes awry, we can tell the user where the problem is. */
850 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
853 tree str
, locus_file
;
855 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
857 locus_file
= fold_build3 (COMPONENT_REF
,
858 st_parameter
[IOPARM_ptype_common
].type
,
859 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
860 locus_file
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
861 locus_file
, p
->field
, NULL_TREE
);
863 str
= gfc_build_cstring_const (f
->filename
);
865 str
= gfc_build_addr_expr (pchar_type_node
, str
);
866 gfc_add_modify (block
, locus_file
, str
);
868 line
= LOCATION_LINE (where
->lb
->location
);
869 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
873 /* Translate an OPEN statement. */
876 gfc_trans_open (gfc_code
* code
)
878 stmtblock_t block
, post_block
;
881 unsigned int mask
= 0;
883 gfc_start_block (&block
);
884 gfc_init_block (&post_block
);
886 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
888 set_error_locus (&block
, var
, &code
->loc
);
892 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
896 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
900 mask
|= IOPARM_common_err
;
903 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
906 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
910 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
914 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
917 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
920 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
924 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
928 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
932 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
936 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
939 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
943 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
947 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
950 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
953 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
957 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
960 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
963 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
965 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
967 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
968 tmp
= build_call_expr (iocall
[IOCALL_OPEN
], 1, tmp
);
969 gfc_add_expr_to_block (&block
, tmp
);
971 gfc_add_block_to_block (&block
, &post_block
);
973 io_result (&block
, var
, p
->err
, NULL
, NULL
);
975 return gfc_finish_block (&block
);
979 /* Translate a CLOSE statement. */
982 gfc_trans_close (gfc_code
* code
)
984 stmtblock_t block
, post_block
;
987 unsigned int mask
= 0;
989 gfc_start_block (&block
);
990 gfc_init_block (&post_block
);
992 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
994 set_error_locus (&block
, var
, &code
->loc
);
998 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1002 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1006 mask
|= IOPARM_common_err
;
1009 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
1012 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1015 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1017 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1019 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1020 tmp
= build_call_expr (iocall
[IOCALL_CLOSE
], 1, tmp
);
1021 gfc_add_expr_to_block (&block
, tmp
);
1023 gfc_add_block_to_block (&block
, &post_block
);
1025 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1027 return gfc_finish_block (&block
);
1031 /* Common subroutine for building a file positioning statement. */
1034 build_filepos (tree function
, gfc_code
* code
)
1036 stmtblock_t block
, post_block
;
1039 unsigned int mask
= 0;
1041 p
= code
->ext
.filepos
;
1043 gfc_start_block (&block
);
1044 gfc_init_block (&post_block
);
1046 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1049 set_error_locus (&block
, var
, &code
->loc
);
1052 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1056 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1060 mask
|= IOPARM_common_err
;
1062 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1065 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1067 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1069 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1070 tmp
= build_call_expr (function
, 1, tmp
);
1071 gfc_add_expr_to_block (&block
, tmp
);
1073 gfc_add_block_to_block (&block
, &post_block
);
1075 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1077 return gfc_finish_block (&block
);
1081 /* Translate a BACKSPACE statement. */
1084 gfc_trans_backspace (gfc_code
* code
)
1086 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1090 /* Translate an ENDFILE statement. */
1093 gfc_trans_endfile (gfc_code
* code
)
1095 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1099 /* Translate a REWIND statement. */
1102 gfc_trans_rewind (gfc_code
* code
)
1104 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1108 /* Translate a FLUSH statement. */
1111 gfc_trans_flush (gfc_code
* code
)
1113 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1117 /* Create a dummy iostat variable to catch any error due to bad unit. */
1120 create_dummy_iostat (void)
1125 gfc_get_ha_sym_tree ("@iostat", &st
);
1126 st
->n
.sym
->ts
.type
= BT_INTEGER
;
1127 st
->n
.sym
->ts
.kind
= gfc_default_integer_kind
;
1128 gfc_set_sym_referenced (st
->n
.sym
);
1129 gfc_commit_symbol (st
->n
.sym
);
1130 st
->n
.sym
->backend_decl
1131 = gfc_create_var (gfc_get_int_type (st
->n
.sym
->ts
.kind
),
1134 e
= gfc_get_expr ();
1135 e
->expr_type
= EXPR_VARIABLE
;
1137 e
->ts
.type
= BT_INTEGER
;
1138 e
->ts
.kind
= st
->n
.sym
->ts
.kind
;
1144 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1147 gfc_trans_inquire (gfc_code
* code
)
1149 stmtblock_t block
, post_block
;
1152 unsigned int mask
= 0, mask2
= 0;
1154 gfc_start_block (&block
);
1155 gfc_init_block (&post_block
);
1157 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1160 set_error_locus (&block
, var
, &code
->loc
);
1161 p
= code
->ext
.inquire
;
1164 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1168 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1172 mask
|= IOPARM_common_err
;
1175 if (p
->unit
&& p
->file
)
1176 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1179 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1184 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1187 if (p
->unit
&& !p
->iostat
)
1189 p
->iostat
= create_dummy_iostat ();
1190 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1191 IOPARM_common_iostat
, p
->iostat
);
1196 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1200 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1204 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1208 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1212 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1216 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1220 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1224 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1228 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1232 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1236 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1237 IOPARM_inquire_recl_out
, p
->recl
);
1240 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1241 IOPARM_inquire_nextrec
, p
->nextrec
);
1244 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1248 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1252 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1256 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1260 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1264 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1268 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1272 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1276 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1280 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1281 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1283 /* The second series of flags. */
1284 if (p
->asynchronous
)
1285 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1289 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1293 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1297 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1301 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1305 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1306 IOPARM_inquire_pending
, p
->pending
);
1309 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1313 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1317 mask
|= set_parameter_const (&block
, var
, IOPARM_inquire_flags2
, mask2
);
1319 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1322 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1324 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1326 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1327 tmp
= build_call_expr (iocall
[IOCALL_INQUIRE
], 1, tmp
);
1328 gfc_add_expr_to_block (&block
, tmp
);
1330 gfc_add_block_to_block (&block
, &post_block
);
1332 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1334 return gfc_finish_block (&block
);
1339 gfc_trans_wait (gfc_code
* code
)
1341 stmtblock_t block
, post_block
;
1344 unsigned int mask
= 0;
1346 gfc_start_block (&block
);
1347 gfc_init_block (&post_block
);
1349 var
= gfc_create_var (st_parameter
[IOPARM_ptype_wait
].type
,
1352 set_error_locus (&block
, var
, &code
->loc
);
1355 /* Set parameters here. */
1357 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1361 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1365 mask
|= IOPARM_common_err
;
1368 mask
|= set_parameter_value (&block
, var
, IOPARM_wait_id
, p
->id
);
1370 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1373 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1375 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1376 tmp
= build_call_expr (iocall
[IOCALL_WAIT
], 1, tmp
);
1377 gfc_add_expr_to_block (&block
, tmp
);
1379 gfc_add_block_to_block (&block
, &post_block
);
1381 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1383 return gfc_finish_block (&block
);
1388 gfc_new_nml_name_expr (const char * name
)
1390 gfc_expr
* nml_name
;
1392 nml_name
= gfc_get_expr();
1393 nml_name
->ref
= NULL
;
1394 nml_name
->expr_type
= EXPR_CONSTANT
;
1395 nml_name
->ts
.kind
= gfc_default_character_kind
;
1396 nml_name
->ts
.type
= BT_CHARACTER
;
1397 nml_name
->value
.character
.length
= strlen(name
);
1398 nml_name
->value
.character
.string
= gfc_char_to_widechar (name
);
1403 /* nml_full_name builds up the fully qualified name of a
1404 derived type component. */
1407 nml_full_name (const char* var_name
, const char* cmp_name
)
1409 int full_name_length
;
1412 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1413 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1414 strcpy (full_name
, var_name
);
1415 full_name
= strcat (full_name
, "%");
1416 full_name
= strcat (full_name
, cmp_name
);
1420 /* nml_get_addr_expr builds an address expression from the
1421 gfc_symbol or gfc_component backend_decl's. An offset is
1422 provided so that the address of an element of an array of
1423 derived types is returned. This is used in the runtime to
1424 determine that span of the derived type. */
1427 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1430 tree decl
= NULL_TREE
;
1434 int dummy_arg_flagged
;
1438 sym
->attr
.referenced
= 1;
1439 decl
= gfc_get_symbol_decl (sym
);
1441 /* If this is the enclosing function declaration, use
1442 the fake result instead. */
1443 if (decl
== current_function_decl
)
1444 decl
= gfc_get_fake_result_decl (sym
, 0);
1445 else if (decl
== DECL_CONTEXT (current_function_decl
))
1446 decl
= gfc_get_fake_result_decl (sym
, 1);
1449 decl
= c
->backend_decl
;
1451 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1452 || TREE_CODE (decl
) == VAR_DECL
1453 || TREE_CODE (decl
) == PARM_DECL
)
1454 || TREE_CODE (decl
) == COMPONENT_REF
));
1458 /* Build indirect reference, if dummy argument. */
1460 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1462 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref (tmp
) : tmp
;
1464 /* If an array, set flag and use indirect ref. if built. */
1466 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1467 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1472 /* Treat the component of a derived type, using base_addr for
1473 the derived type. */
1475 if (TREE_CODE (decl
) == FIELD_DECL
)
1476 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1477 base_addr
, tmp
, NULL_TREE
);
1479 /* If we have a derived type component, a reference to the first
1480 element of the array is built. This is done so that base_addr,
1481 used in the build of the component reference, always points to
1485 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1487 /* Now build the address expression. */
1489 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1491 /* If scalar dummy, resolve indirect reference now. */
1493 if (dummy_arg_flagged
&& !array_flagged
)
1494 tmp
= build_fold_indirect_ref (tmp
);
1496 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1501 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1502 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1503 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1505 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1508 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1509 gfc_symbol
* sym
, gfc_component
* c
,
1512 gfc_typespec
* ts
= NULL
;
1513 gfc_array_spec
* as
= NULL
;
1514 tree addr_expr
= NULL
;
1524 gcc_assert (sym
|| c
);
1526 /* Build the namelist object name. */
1528 string
= gfc_build_cstring_const (var_name
);
1529 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1531 /* Build ts, as and data address using symbol or component. */
1533 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1534 as
= (sym
) ? sym
->as
: c
->as
;
1536 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1543 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1544 dtype
= gfc_get_dtype (dt
);
1548 itype
= GFC_DTYPE_UNKNOWN
;
1554 itype
= GFC_DTYPE_INTEGER
;
1557 itype
= GFC_DTYPE_LOGICAL
;
1560 itype
= GFC_DTYPE_REAL
;
1563 itype
= GFC_DTYPE_COMPLEX
;
1566 itype
= GFC_DTYPE_DERIVED
;
1569 itype
= GFC_DTYPE_CHARACTER
;
1575 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1578 /* Build up the arguments for the transfer call.
1579 The call for the scalar part transfers:
1580 (address, name, type, kind or string_length, dtype) */
1582 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1584 if (ts
->type
== BT_CHARACTER
)
1585 tmp
= ts
->cl
->backend_decl
;
1587 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1588 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL
], 6,
1589 dt_parm_addr
, addr_expr
, string
,
1590 IARG (ts
->kind
), tmp
, dtype
);
1591 gfc_add_expr_to_block (block
, tmp
);
1593 /* If the object is an array, transfer rank times:
1594 (null pointer, name, stride, lbound, ubound) */
1596 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1598 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1601 GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
),
1602 GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
),
1603 GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1604 gfc_add_expr_to_block (block
, tmp
);
1607 if (ts
->type
== BT_DERIVED
)
1611 /* Provide the RECORD_TYPE to build component references. */
1613 tree expr
= build_fold_indirect_ref (addr_expr
);
1615 for (cmp
= ts
->derived
->components
; cmp
; cmp
= cmp
->next
)
1617 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1618 transfer_namelist_element (block
,
1621 gfc_free (full_name
);
1628 /* Create a data transfer statement. Not all of the fields are valid
1629 for both reading and writing, but improper use has been filtered
1633 build_dt (tree function
, gfc_code
* code
)
1635 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1640 unsigned int mask
= 0;
1642 gfc_start_block (&block
);
1643 gfc_init_block (&post_block
);
1644 gfc_init_block (&post_end_block
);
1645 gfc_init_block (&post_iu_block
);
1647 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1649 set_error_locus (&block
, var
, &code
->loc
);
1651 if (last_dt
== IOLENGTH
)
1655 inq
= code
->ext
.inquire
;
1657 /* First check that preconditions are met. */
1658 gcc_assert (inq
!= NULL
);
1659 gcc_assert (inq
->iolength
!= NULL
);
1661 /* Connect to the iolength variable. */
1662 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1663 IOPARM_dt_iolength
, inq
->iolength
);
1669 gcc_assert (dt
!= NULL
);
1672 if (dt
&& dt
->io_unit
)
1674 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1676 mask
|= set_internal_unit (&block
, &post_iu_block
,
1678 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1682 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1687 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1691 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1692 IOPARM_common_iostat
, dt
->iostat
);
1695 mask
|= IOPARM_common_err
;
1698 mask
|= IOPARM_common_eor
;
1701 mask
|= IOPARM_common_end
;
1704 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1705 IOPARM_dt_id
, dt
->id
);
1708 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1710 if (dt
->asynchronous
)
1711 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_asynchronous
,
1715 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1719 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1723 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1727 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1731 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1735 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1739 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1742 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1745 if (dt
->format_expr
)
1746 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1749 if (dt
->format_label
)
1751 if (dt
->format_label
== &format_asterisk
)
1752 mask
|= IOPARM_dt_list_format
;
1754 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1755 dt
->format_label
->format
);
1759 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1760 IOPARM_dt_size
, dt
->size
);
1764 if (dt
->format_expr
|| dt
->format_label
)
1765 gfc_internal_error ("build_dt: format with namelist");
1767 nmlname
= gfc_new_nml_name_expr (dt
->namelist
->name
);
1769 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1772 if (last_dt
== READ
)
1773 mask
|= IOPARM_dt_namelist_read_mode
;
1775 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1779 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1780 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1784 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1786 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1787 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1790 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1792 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1793 tmp
= build_call_expr (function
, 1, tmp
);
1794 gfc_add_expr_to_block (&block
, tmp
);
1796 gfc_add_block_to_block (&block
, &post_block
);
1799 dt_post_end_block
= &post_end_block
;
1801 gfc_add_expr_to_block (&block
, gfc_trans_code (code
->block
->next
));
1803 gfc_add_block_to_block (&block
, &post_iu_block
);
1806 dt_post_end_block
= NULL
;
1808 return gfc_finish_block (&block
);
1812 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1813 this as a third sort of data transfer statement, except that
1814 lengths are summed instead of actually transferring any data. */
1817 gfc_trans_iolength (gfc_code
* code
)
1820 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1824 /* Translate a READ statement. */
1827 gfc_trans_read (gfc_code
* code
)
1830 return build_dt (iocall
[IOCALL_READ
], code
);
1834 /* Translate a WRITE statement */
1837 gfc_trans_write (gfc_code
* code
)
1840 return build_dt (iocall
[IOCALL_WRITE
], code
);
1844 /* Finish a data transfer statement. */
1847 gfc_trans_dt_end (gfc_code
* code
)
1852 gfc_init_block (&block
);
1857 function
= iocall
[IOCALL_READ_DONE
];
1861 function
= iocall
[IOCALL_WRITE_DONE
];
1865 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1872 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1873 tmp
= build_call_expr (function
, 1, tmp
);
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
->is_iso_c
== 1 && ts
->derived
!= NULL
)
1995 || (ts
->derived
!= NULL
&& ts
->derived
->ts
.is_iso_c
== 1))
1997 /* C_PTR and C_FUNPTR have private components which means they can not
1998 be printed. However, if -std=gnu and not -pedantic, allow
1999 the component to be printed to help debugging. */
2000 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
2002 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
2003 ts
->derived
->name
, code
!= NULL
? &(code
->loc
) :
2004 &gfc_current_locus
);
2008 ts
->type
= ts
->derived
->ts
.type
;
2009 ts
->kind
= ts
->derived
->ts
.kind
;
2010 ts
->f90_type
= ts
->derived
->ts
.f90_type
;
2021 arg2
= build_int_cst (NULL_TREE
, kind
);
2022 function
= iocall
[IOCALL_X_INTEGER
];
2026 arg2
= build_int_cst (NULL_TREE
, kind
);
2027 function
= iocall
[IOCALL_X_REAL
];
2031 arg2
= build_int_cst (NULL_TREE
, kind
);
2032 function
= iocall
[IOCALL_X_COMPLEX
];
2036 arg2
= build_int_cst (NULL_TREE
, kind
);
2037 function
= iocall
[IOCALL_X_LOGICAL
];
2043 if (se
->string_length
)
2044 arg2
= se
->string_length
;
2047 tmp
= build_fold_indirect_ref (addr_expr
);
2048 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2049 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2050 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2052 arg3
= build_int_cst (NULL_TREE
, kind
);
2053 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2054 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2055 tmp
= build_call_expr (function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2056 gfc_add_expr_to_block (&se
->pre
, tmp
);
2057 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2062 if (se
->string_length
)
2063 arg2
= se
->string_length
;
2066 tmp
= build_fold_indirect_ref (addr_expr
);
2067 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2068 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2070 function
= iocall
[IOCALL_X_CHARACTER
];
2074 /* Recurse into the elements of the derived type. */
2075 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2076 expr
= build_fold_indirect_ref (expr
);
2078 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2080 field
= c
->backend_decl
;
2081 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2083 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
2084 expr
, field
, NULL_TREE
);
2086 if (c
->attr
.dimension
)
2088 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2089 gfc_add_expr_to_block (&se
->pre
, tmp
);
2093 if (!c
->attr
.pointer
)
2094 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2095 transfer_expr (se
, &c
->ts
, tmp
, code
);
2101 internal_error ("Bad IO basetype (%d)", ts
->type
);
2104 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2105 tmp
= build_call_expr (function
, 3, tmp
, addr_expr
, arg2
);
2106 gfc_add_expr_to_block (&se
->pre
, tmp
);
2107 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2112 /* Generate a call to pass an array descriptor to the IO library. The
2113 array should be of one of the intrinsic types. */
2116 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2118 tree tmp
, charlen_arg
, kind_arg
;
2120 if (ts
->type
== BT_CHARACTER
)
2121 charlen_arg
= se
->string_length
;
2123 charlen_arg
= build_int_cst (NULL_TREE
, 0);
2125 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
2127 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2128 tmp
= build_call_expr (iocall
[IOCALL_X_ARRAY
], 4,
2129 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2130 gfc_add_expr_to_block (&se
->pre
, tmp
);
2131 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2135 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2138 gfc_trans_transfer (gfc_code
* code
)
2140 stmtblock_t block
, body
;
2149 gfc_start_block (&block
);
2150 gfc_init_block (&body
);
2153 ss
= gfc_walk_expr (expr
);
2156 gfc_init_se (&se
, NULL
);
2158 if (ss
== gfc_ss_terminator
)
2160 /* Transfer a scalar value. */
2161 gfc_conv_expr_reference (&se
, expr
);
2162 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2166 /* Transfer an array. If it is an array of an intrinsic
2167 type, pass the descriptor to the library. Otherwise
2168 scalarize the transfer. */
2171 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2173 gcc_assert (ref
->type
== REF_ARRAY
);
2176 if (expr
->ts
.type
!= BT_DERIVED
2177 && ref
&& ref
->next
== NULL
2178 && !is_subref_array (expr
))
2180 bool seen_vector
= false;
2182 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2184 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2185 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2189 if (seen_vector
&& last_dt
== READ
)
2191 /* Create a temp, read to that and copy it back. */
2192 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
);
2197 /* Get the descriptor. */
2198 gfc_conv_expr_descriptor (&se
, expr
, ss
);
2199 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2202 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2203 goto finish_block_label
;
2206 /* Initialize the scalarizer. */
2207 gfc_init_loopinfo (&loop
);
2208 gfc_add_ss_to_loop (&loop
, ss
);
2210 /* Initialize the loop. */
2211 gfc_conv_ss_startstride (&loop
);
2212 gfc_conv_loop_setup (&loop
, &code
->expr
->where
);
2214 /* The main loop body. */
2215 gfc_mark_ss_chain_used (ss
, 1);
2216 gfc_start_scalarized_body (&loop
, &body
);
2218 gfc_copy_loopinfo_to_se (&se
, &loop
);
2221 gfc_conv_expr_reference (&se
, expr
);
2222 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2227 gfc_add_block_to_block (&body
, &se
.pre
);
2228 gfc_add_block_to_block (&body
, &se
.post
);
2231 tmp
= gfc_finish_block (&body
);
2234 gcc_assert (se
.ss
== gfc_ss_terminator
);
2235 gfc_trans_scalarizing_loops (&loop
, &body
);
2237 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2238 tmp
= gfc_finish_block (&loop
.pre
);
2239 gfc_cleanup_loop (&loop
);
2242 gfc_add_expr_to_block (&block
, tmp
);
2244 return gfc_finish_block (&block
);
2247 #include "gt-fortran-trans-io.h"