1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
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"
27 #include "tree-gimple.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. */
66 typedef struct gfc_st_parameter_field
GTY(())
70 enum ioparam_type param_type
;
71 enum iofield_type type
;
75 gfc_st_parameter_field
;
77 typedef struct gfc_st_parameter
GTY(())
86 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
92 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 */
129 IOCALL_IOLENGTH_DONE
,
135 IOCALL_SET_NML_VAL_DIM
,
139 static GTY(()) tree iocall
[IOCALL_NUM
];
141 /* Variable for keeping track of what the last data transfer statement
142 was. Used for deciding which subroutine to call when the data
143 transfer is complete. */
144 static enum { READ
, WRITE
, IOLENGTH
} last_dt
;
146 /* The data transfer parameter block that should be shared by all
147 data transfer calls belonging to the same read/write/iolength. */
148 static GTY(()) tree dt_parm
;
149 static stmtblock_t
*dt_post_end_block
;
152 gfc_build_st_parameter (enum ioparam_type ptype
, tree
*types
)
155 gfc_st_parameter_field
*p
;
158 tree t
= make_node (RECORD_TYPE
);
160 len
= strlen (st_parameter
[ptype
].name
);
161 gcc_assert (len
<= sizeof (name
) - sizeof ("__st_parameter_"));
162 memcpy (name
, "__st_parameter_", sizeof ("__st_parameter_"));
163 memcpy (name
+ sizeof ("__st_parameter_") - 1, st_parameter
[ptype
].name
,
165 TYPE_NAME (t
) = get_identifier (name
);
167 for (type
= 0, p
= st_parameter_field
; type
< IOPARM_field_num
; type
++, p
++)
168 if (p
->param_type
== ptype
)
171 case IOPARM_type_int4
:
172 case IOPARM_type_intio
:
173 case IOPARM_type_pint4
:
174 case IOPARM_type_pintio
:
175 case IOPARM_type_parray
:
176 case IOPARM_type_pchar
:
177 case IOPARM_type_pad
:
178 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
179 get_identifier (p
->name
),
182 case IOPARM_type_char1
:
183 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
184 get_identifier (p
->name
),
187 case IOPARM_type_char2
:
188 len
= strlen (p
->name
);
189 gcc_assert (len
<= sizeof (name
) - sizeof ("_len"));
190 memcpy (name
, p
->name
, len
);
191 memcpy (name
+ len
, "_len", sizeof ("_len"));
192 p
->field_len
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
193 get_identifier (name
),
194 gfc_charlen_type_node
);
195 if (p
->type
== IOPARM_type_char2
)
196 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
197 get_identifier (p
->name
),
200 case IOPARM_type_common
:
202 = gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
203 get_identifier (p
->name
),
204 st_parameter
[IOPARM_ptype_common
].type
);
206 case IOPARM_type_num
:
211 st_parameter
[ptype
].type
= t
;
215 /* Build code to test an error condition and call generate_error if needed.
216 Note: This builds calls to generate_error in the runtime library function.
217 The function generate_error is dependent on certain parameters in the
218 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
219 Therefore, the code to set these flags must be generated before
220 this function is used. */
223 gfc_trans_io_runtime_check (tree cond
, tree var
, int error_code
,
224 const char * msgid
, stmtblock_t
* pblock
)
229 tree arg1
, arg2
, arg3
;
232 if (integer_zerop (cond
))
235 /* The code to generate the error. */
236 gfc_start_block (&block
);
238 arg1
= build_fold_addr_expr (var
);
240 arg2
= build_int_cst (integer_type_node
, error_code
),
242 asprintf (&message
, "%s", _(msgid
));
243 arg3
= gfc_build_addr_expr (pchar_type_node
, gfc_build_cstring_const(message
));
246 tmp
= build_call_expr (gfor_fndecl_generate_error
, 3, arg1
, arg2
, arg3
);
248 gfc_add_expr_to_block (&block
, tmp
);
250 body
= gfc_finish_block (&block
);
252 if (integer_onep (cond
))
254 gfc_add_expr_to_block (pblock
, body
);
258 /* Tell the compiler that this isn't likely. */
259 cond
= fold_convert (long_integer_type_node
, cond
);
260 tmp
= build_int_cst (long_integer_type_node
, 0);
261 cond
= build_call_expr (built_in_decls
[BUILT_IN_EXPECT
], 2, cond
, tmp
);
262 cond
= fold_convert (boolean_type_node
, cond
);
264 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt ());
265 gfc_add_expr_to_block (pblock
, tmp
);
270 /* Create function decls for IO library functions. */
273 gfc_build_io_library_fndecls (void)
275 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
276 tree gfc_intio_type_node
;
277 tree parm_type
, dt_parm_type
;
278 HOST_WIDE_INT pad_size
;
279 enum ioparam_type ptype
;
281 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
282 types
[IOPARM_type_intio
] = gfc_intio_type_node
283 = gfc_get_int_type (gfc_intio_kind
);
284 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
285 types
[IOPARM_type_pintio
]
286 = build_pointer_type (gfc_intio_type_node
);
287 types
[IOPARM_type_parray
] = pchar_type_node
;
288 types
[IOPARM_type_pchar
] = pchar_type_node
;
289 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
290 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
291 pad_idx
= build_index_type (build_int_cst (NULL_TREE
, pad_size
));
292 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
294 /* pad actually contains pointers and integers so it needs to have an
295 alignment that is at least as large as the needed alignment for those
296 types. See the st_parameter_dt structure in libgfortran/io/io.h for
297 what really goes into this space. */
298 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
299 TYPE_ALIGN (gfc_get_int_type (gfc_max_integer_kind
)));
301 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
302 gfc_build_st_parameter (ptype
, types
);
304 /* Define the transfer functions. */
306 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
308 iocall
[IOCALL_X_INTEGER
] =
309 gfc_build_library_function_decl (get_identifier
310 (PREFIX("transfer_integer")),
311 void_type_node
, 3, dt_parm_type
,
312 pvoid_type_node
, gfc_int4_type_node
);
314 iocall
[IOCALL_X_LOGICAL
] =
315 gfc_build_library_function_decl (get_identifier
316 (PREFIX("transfer_logical")),
317 void_type_node
, 3, dt_parm_type
,
318 pvoid_type_node
, gfc_int4_type_node
);
320 iocall
[IOCALL_X_CHARACTER
] =
321 gfc_build_library_function_decl (get_identifier
322 (PREFIX("transfer_character")),
323 void_type_node
, 3, dt_parm_type
,
324 pvoid_type_node
, gfc_int4_type_node
);
326 iocall
[IOCALL_X_REAL
] =
327 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
328 void_type_node
, 3, dt_parm_type
,
329 pvoid_type_node
, gfc_int4_type_node
);
331 iocall
[IOCALL_X_COMPLEX
] =
332 gfc_build_library_function_decl (get_identifier
333 (PREFIX("transfer_complex")),
334 void_type_node
, 3, dt_parm_type
,
335 pvoid_type_node
, gfc_int4_type_node
);
337 iocall
[IOCALL_X_ARRAY
] =
338 gfc_build_library_function_decl (get_identifier
339 (PREFIX("transfer_array")),
340 void_type_node
, 4, dt_parm_type
,
341 pvoid_type_node
, integer_type_node
,
342 gfc_charlen_type_node
);
344 /* Library entry points */
346 iocall
[IOCALL_READ
] =
347 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
348 void_type_node
, 1, dt_parm_type
);
350 iocall
[IOCALL_WRITE
] =
351 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
352 void_type_node
, 1, dt_parm_type
);
354 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
355 iocall
[IOCALL_OPEN
] =
356 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
357 void_type_node
, 1, parm_type
);
360 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
361 iocall
[IOCALL_CLOSE
] =
362 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
363 void_type_node
, 1, parm_type
);
365 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
366 iocall
[IOCALL_INQUIRE
] =
367 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
368 gfc_int4_type_node
, 1, parm_type
);
370 iocall
[IOCALL_IOLENGTH
] =
371 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
372 void_type_node
, 1, dt_parm_type
);
374 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
375 iocall
[IOCALL_REWIND
] =
376 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
377 gfc_int4_type_node
, 1, parm_type
);
379 iocall
[IOCALL_BACKSPACE
] =
380 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
381 gfc_int4_type_node
, 1, parm_type
);
383 iocall
[IOCALL_ENDFILE
] =
384 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
385 gfc_int4_type_node
, 1, parm_type
);
387 iocall
[IOCALL_FLUSH
] =
388 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
389 gfc_int4_type_node
, 1, parm_type
);
391 /* Library helpers */
393 iocall
[IOCALL_READ_DONE
] =
394 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
395 gfc_int4_type_node
, 1, dt_parm_type
);
397 iocall
[IOCALL_WRITE_DONE
] =
398 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
399 gfc_int4_type_node
, 1, dt_parm_type
);
401 iocall
[IOCALL_IOLENGTH_DONE
] =
402 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
403 gfc_int4_type_node
, 1, dt_parm_type
);
406 iocall
[IOCALL_SET_NML_VAL
] =
407 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
408 void_type_node
, 6, dt_parm_type
,
409 pvoid_type_node
, pvoid_type_node
,
410 gfc_int4_type_node
, gfc_charlen_type_node
,
413 iocall
[IOCALL_SET_NML_VAL_DIM
] =
414 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
415 void_type_node
, 5, dt_parm_type
,
416 gfc_int4_type_node
, gfc_array_index_type
,
417 gfc_array_index_type
, gfc_array_index_type
);
421 /* Generate code to store an integer constant into the
422 st_parameter_XXX structure. */
425 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
429 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
431 if (p
->param_type
== IOPARM_ptype_common
)
432 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
433 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
434 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
436 gfc_add_modify_expr (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
441 /* Generate code to store a non-string I/O parameter into the
442 st_parameter_XXX structure. This is a pass by value. */
445 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
450 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
451 tree dest_type
= TREE_TYPE (p
->field
);
453 gfc_init_se (&se
, NULL
);
454 gfc_conv_expr_val (&se
, e
);
456 /* If we're storing a UNIT number, we need to check it first. */
457 if (type
== IOPARM_common_unit
&& e
->ts
.kind
!= 4)
462 /* Don't evaluate the UNIT number multiple times. */
463 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
465 /* UNIT numbers should be nonnegative. */
466 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, se
.expr
,
467 build_int_cst (TREE_TYPE (se
.expr
),0));
468 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
469 "Negative unit number in I/O statement",
472 /* UNIT numbers should be less than the max. */
473 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
474 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
475 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, se
.expr
,
476 fold_convert (TREE_TYPE (se
.expr
), max
));
477 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
478 "Unit number in I/O statement too large",
483 se
.expr
= convert (dest_type
, se
.expr
);
484 gfc_add_block_to_block (block
, &se
.pre
);
486 if (p
->param_type
== IOPARM_ptype_common
)
487 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
488 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
490 tmp
= build3 (COMPONENT_REF
, dest_type
, var
, p
->field
, NULL_TREE
);
491 gfc_add_modify_expr (block
, tmp
, se
.expr
);
496 /* Generate code to store a non-string I/O parameter into the
497 st_parameter_XXX structure. This is pass by reference. */
500 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
501 tree var
, enum iofield type
, gfc_expr
*e
)
505 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
507 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
508 gfc_init_se (&se
, NULL
);
509 gfc_conv_expr_lhs (&se
, e
);
511 gfc_add_block_to_block (block
, &se
.pre
);
513 if (TYPE_MODE (TREE_TYPE (se
.expr
))
514 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
516 addr
= convert (TREE_TYPE (p
->field
), build_fold_addr_expr (se
.expr
));
518 /* If this is for the iostat variable initialize the
519 user variable to LIBERROR_OK which is zero. */
520 if (type
== IOPARM_common_iostat
)
521 gfc_add_modify_expr (block
, se
.expr
,
522 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
526 /* The type used by the library has different size
527 from the type of the variable supplied by the user.
528 Need to use a temporary. */
529 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
530 st_parameter_field
[type
].name
);
532 /* If this is for the iostat variable, initialize the
533 user variable to LIBERROR_OK which is zero. */
534 if (type
== IOPARM_common_iostat
)
535 gfc_add_modify_expr (block
, tmpvar
,
536 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
538 addr
= build_fold_addr_expr (tmpvar
);
539 /* After the I/O operation, we set the variable from the temporary. */
540 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
541 gfc_add_modify_expr (postblock
, se
.expr
, tmp
);
544 if (p
->param_type
== IOPARM_ptype_common
)
545 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
546 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
547 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
549 gfc_add_modify_expr (block
, tmp
, addr
);
553 /* Given an array expr, find its address and length to get a string. If the
554 array is full, the string's address is the address of array's first element
555 and the length is the size of the whole array. If it is an element, the
556 string's address is the element's address and the length is the rest size of
561 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
570 sym
= e
->symtree
->n
.sym
;
571 rank
= sym
->as
->rank
- 1;
573 if (e
->ref
->u
.ar
.type
== AR_FULL
)
575 se
->expr
= gfc_get_symbol_decl (sym
);
576 se
->expr
= gfc_conv_array_data (se
->expr
);
580 gfc_conv_expr (se
, e
);
583 array
= sym
->backend_decl
;
584 type
= TREE_TYPE (array
);
586 if (GFC_ARRAY_TYPE_P (type
))
587 size
= GFC_TYPE_ARRAY_SIZE (type
);
590 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
591 size
= gfc_conv_array_stride (array
, rank
);
592 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
593 gfc_conv_array_ubound (array
, rank
),
594 gfc_conv_array_lbound (array
, rank
));
595 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
597 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
602 /* If it is an element, we need the its address and size of the rest. */
603 if (e
->ref
->u
.ar
.type
== AR_ELEMENT
)
605 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
606 TREE_OPERAND (se
->expr
, 1));
607 se
->expr
= build_fold_addr_expr (se
->expr
);
610 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
611 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
612 fold_convert (gfc_array_index_type
, tmp
));
614 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
618 /* Generate code to store a string and its length into the
619 st_parameter_XXX structure. */
622 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
623 enum iofield type
, gfc_expr
* e
)
629 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
631 gfc_init_se (&se
, NULL
);
633 if (p
->param_type
== IOPARM_ptype_common
)
634 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
635 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
636 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
638 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
641 /* Integer variable assigned a format label. */
642 if (e
->ts
.type
== BT_INTEGER
&& e
->symtree
->n
.sym
->attr
.assign
== 1)
647 gfc_conv_label_variable (&se
, e
);
648 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
649 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
650 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
652 asprintf(&msg
, "Label assigned to variable '%s' (%%ld) is not a format "
653 "label", e
->symtree
->name
);
654 gfc_trans_runtime_check (cond
, &se
.pre
, &e
->where
, msg
,
655 fold_convert (long_integer_type_node
, tmp
));
658 gfc_add_modify_expr (&se
.pre
, io
,
659 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
660 gfc_add_modify_expr (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
664 /* General character. */
665 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
666 gfc_conv_expr (&se
, e
);
667 /* Array assigned Hollerith constant or character array. */
668 else if (e
->symtree
&& (e
->symtree
->n
.sym
->as
->rank
> 0))
669 gfc_convert_array_to_string (&se
, e
);
673 gfc_conv_string_parameter (&se
);
674 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
675 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
678 gfc_add_block_to_block (block
, &se
.pre
);
679 gfc_add_block_to_block (postblock
, &se
.post
);
684 /* Generate code to store the character (array) and the character length
685 for an internal unit. */
688 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
689 tree var
, gfc_expr
* e
)
696 gfc_st_parameter_field
*p
;
699 gfc_init_se (&se
, NULL
);
701 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
703 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
705 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
707 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
708 desc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
711 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
713 /* Character scalars. */
716 gfc_conv_expr (&se
, e
);
717 gfc_conv_string_parameter (&se
);
719 se
.expr
= build_int_cst (pchar_type_node
, 0);
722 /* Character array. */
723 else if (e
->rank
> 0)
725 se
.ss
= gfc_walk_expr (e
);
727 if (is_subref_array (e
))
729 /* Use a temporary for components of arrays of derived types
730 or substring array references. */
731 gfc_conv_subref_array_arg (&se
, e
, 0,
732 last_dt
== READ
? INTENT_IN
: INTENT_OUT
);
733 tmp
= build_fold_indirect_ref (se
.expr
);
734 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
735 tmp
= gfc_conv_descriptor_data_get (tmp
);
739 /* Return the data pointer and rank from the descriptor. */
740 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
741 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
742 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
748 /* The cast is needed for character substrings and the descriptor
750 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
751 gfc_add_modify_expr (&se
.pre
, len
,
752 fold_convert (TREE_TYPE (len
), se
.string_length
));
753 gfc_add_modify_expr (&se
.pre
, desc
, se
.expr
);
755 gfc_add_block_to_block (block
, &se
.pre
);
756 gfc_add_block_to_block (post_block
, &se
.post
);
760 /* Add a case to a IO-result switch. */
763 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
768 return; /* No label, no case */
770 value
= build_int_cst (NULL_TREE
, label_value
);
772 /* Make a backend label for this case. */
773 tmp
= gfc_build_label_decl (NULL_TREE
);
775 /* And the case itself. */
776 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
777 gfc_add_expr_to_block (body
, tmp
);
779 /* Jump to the label. */
780 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
781 gfc_add_expr_to_block (body
, tmp
);
785 /* Generate a switch statement that branches to the correct I/O
786 result label. The last statement of an I/O call stores the
787 result into a variable because there is often cleanup that
788 must be done before the switch, so a temporary would have to
789 be created anyway. */
792 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
793 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
797 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
799 /* If no labels are specified, ignore the result instead
800 of building an empty switch. */
801 if (err_label
== NULL
803 && eor_label
== NULL
)
806 /* Build a switch statement. */
807 gfc_start_block (&body
);
809 /* The label values here must be the same as the values
810 in the library_return enum in the runtime library */
811 add_case (1, err_label
, &body
);
812 add_case (2, end_label
, &body
);
813 add_case (3, eor_label
, &body
);
815 tmp
= gfc_finish_block (&body
);
817 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
818 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
819 rc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
821 rc
= build2 (BIT_AND_EXPR
, TREE_TYPE (rc
), rc
,
822 build_int_cst (TREE_TYPE (rc
), IOPARM_common_libreturn_mask
));
824 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
826 gfc_add_expr_to_block (block
, tmp
);
830 /* Store the current file and line number to variables so that if a
831 library call goes awry, we can tell the user where the problem is. */
834 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
837 tree str
, locus_file
;
839 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
841 locus_file
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
842 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
843 locus_file
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), locus_file
,
844 p
->field
, NULL_TREE
);
846 str
= gfc_build_cstring_const (f
->filename
);
848 str
= gfc_build_addr_expr (pchar_type_node
, str
);
849 gfc_add_modify_expr (block
, locus_file
, str
);
851 #ifdef USE_MAPPED_LOCATION
852 line
= LOCATION_LINE (where
->lb
->location
);
854 line
= where
->lb
->linenum
;
856 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
860 /* Translate an OPEN statement. */
863 gfc_trans_open (gfc_code
* code
)
865 stmtblock_t block
, post_block
;
868 unsigned int mask
= 0;
870 gfc_start_block (&block
);
871 gfc_init_block (&post_block
);
873 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
875 set_error_locus (&block
, var
, &code
->loc
);
879 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
883 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
887 mask
|= IOPARM_common_err
;
890 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
893 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
897 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
901 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
904 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
907 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
911 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
915 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
919 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
923 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
926 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
929 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
932 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
934 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
936 tmp
= build_fold_addr_expr (var
);
937 tmp
= build_call_expr (iocall
[IOCALL_OPEN
], 1, tmp
);
938 gfc_add_expr_to_block (&block
, tmp
);
940 gfc_add_block_to_block (&block
, &post_block
);
942 io_result (&block
, var
, p
->err
, NULL
, NULL
);
944 return gfc_finish_block (&block
);
948 /* Translate a CLOSE statement. */
951 gfc_trans_close (gfc_code
* code
)
953 stmtblock_t block
, post_block
;
956 unsigned int mask
= 0;
958 gfc_start_block (&block
);
959 gfc_init_block (&post_block
);
961 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
963 set_error_locus (&block
, var
, &code
->loc
);
967 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
971 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
975 mask
|= IOPARM_common_err
;
978 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
981 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
984 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
986 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
988 tmp
= build_fold_addr_expr (var
);
989 tmp
= build_call_expr (iocall
[IOCALL_CLOSE
], 1, tmp
);
990 gfc_add_expr_to_block (&block
, tmp
);
992 gfc_add_block_to_block (&block
, &post_block
);
994 io_result (&block
, var
, p
->err
, NULL
, NULL
);
996 return gfc_finish_block (&block
);
1000 /* Common subroutine for building a file positioning statement. */
1003 build_filepos (tree function
, gfc_code
* code
)
1005 stmtblock_t block
, post_block
;
1008 unsigned int mask
= 0;
1010 p
= code
->ext
.filepos
;
1012 gfc_start_block (&block
);
1013 gfc_init_block (&post_block
);
1015 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1018 set_error_locus (&block
, var
, &code
->loc
);
1021 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1025 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1029 mask
|= IOPARM_common_err
;
1031 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1034 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1036 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1038 tmp
= build_fold_addr_expr (var
);
1039 tmp
= build_call_expr (function
, 1, tmp
);
1040 gfc_add_expr_to_block (&block
, tmp
);
1042 gfc_add_block_to_block (&block
, &post_block
);
1044 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1046 return gfc_finish_block (&block
);
1050 /* Translate a BACKSPACE statement. */
1053 gfc_trans_backspace (gfc_code
* code
)
1055 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1059 /* Translate an ENDFILE statement. */
1062 gfc_trans_endfile (gfc_code
* code
)
1064 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1068 /* Translate a REWIND statement. */
1071 gfc_trans_rewind (gfc_code
* code
)
1073 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1077 /* Translate a FLUSH statement. */
1080 gfc_trans_flush (gfc_code
* code
)
1082 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1086 /* Create a dummy iostat variable to catch any error due to bad unit. */
1089 create_dummy_iostat (void)
1094 gfc_get_ha_sym_tree ("@iostat", &st
);
1095 st
->n
.sym
->ts
.type
= BT_INTEGER
;
1096 st
->n
.sym
->ts
.kind
= gfc_default_integer_kind
;
1097 gfc_set_sym_referenced (st
->n
.sym
);
1098 st
->n
.sym
->backend_decl
1099 = gfc_create_var (gfc_get_int_type (st
->n
.sym
->ts
.kind
),
1102 e
= gfc_get_expr ();
1103 e
->expr_type
= EXPR_VARIABLE
;
1105 e
->ts
.type
= BT_INTEGER
;
1106 e
->ts
.kind
= st
->n
.sym
->ts
.kind
;
1112 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1115 gfc_trans_inquire (gfc_code
* code
)
1117 stmtblock_t block
, post_block
;
1120 unsigned int mask
= 0;
1122 gfc_start_block (&block
);
1123 gfc_init_block (&post_block
);
1125 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1128 set_error_locus (&block
, var
, &code
->loc
);
1129 p
= code
->ext
.inquire
;
1132 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1136 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1140 mask
|= IOPARM_common_err
;
1143 if (p
->unit
&& p
->file
)
1144 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1147 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1152 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1155 if (p
->unit
&& !p
->iostat
)
1157 p
->iostat
= create_dummy_iostat ();
1158 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1159 IOPARM_common_iostat
, p
->iostat
);
1164 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1168 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1172 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1176 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1180 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1184 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1188 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1192 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1196 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1200 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1204 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1205 IOPARM_inquire_recl_out
, p
->recl
);
1208 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1209 IOPARM_inquire_nextrec
, p
->nextrec
);
1212 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1216 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1220 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1224 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1228 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1232 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1236 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1240 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1244 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1248 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1249 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1251 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1254 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1256 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1258 tmp
= build_fold_addr_expr (var
);
1259 tmp
= build_call_expr (iocall
[IOCALL_INQUIRE
], 1, tmp
);
1260 gfc_add_expr_to_block (&block
, tmp
);
1262 gfc_add_block_to_block (&block
, &post_block
);
1264 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1266 return gfc_finish_block (&block
);
1270 gfc_new_nml_name_expr (const char * name
)
1272 gfc_expr
* nml_name
;
1274 nml_name
= gfc_get_expr();
1275 nml_name
->ref
= NULL
;
1276 nml_name
->expr_type
= EXPR_CONSTANT
;
1277 nml_name
->ts
.kind
= gfc_default_character_kind
;
1278 nml_name
->ts
.type
= BT_CHARACTER
;
1279 nml_name
->value
.character
.length
= strlen(name
);
1280 nml_name
->value
.character
.string
= gfc_getmem (strlen (name
) + 1);
1281 strcpy (nml_name
->value
.character
.string
, name
);
1286 /* nml_full_name builds up the fully qualified name of a
1287 derived type component. */
1290 nml_full_name (const char* var_name
, const char* cmp_name
)
1292 int full_name_length
;
1295 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1296 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1297 strcpy (full_name
, var_name
);
1298 full_name
= strcat (full_name
, "%");
1299 full_name
= strcat (full_name
, cmp_name
);
1303 /* nml_get_addr_expr builds an address expression from the
1304 gfc_symbol or gfc_component backend_decl's. An offset is
1305 provided so that the address of an element of an array of
1306 derived types is returned. This is used in the runtime to
1307 determine that span of the derived type. */
1310 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1313 tree decl
= NULL_TREE
;
1317 int dummy_arg_flagged
;
1321 sym
->attr
.referenced
= 1;
1322 decl
= gfc_get_symbol_decl (sym
);
1324 /* If this is the enclosing function declaration, use
1325 the fake result instead. */
1326 if (decl
== current_function_decl
)
1327 decl
= gfc_get_fake_result_decl (sym
, 0);
1328 else if (decl
== DECL_CONTEXT (current_function_decl
))
1329 decl
= gfc_get_fake_result_decl (sym
, 1);
1332 decl
= c
->backend_decl
;
1334 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1335 || TREE_CODE (decl
) == VAR_DECL
1336 || TREE_CODE (decl
) == PARM_DECL
)
1337 || TREE_CODE (decl
) == COMPONENT_REF
));
1341 /* Build indirect reference, if dummy argument. */
1343 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1345 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref (tmp
) : tmp
;
1347 /* If an array, set flag and use indirect ref. if built. */
1349 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1350 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1355 /* Treat the component of a derived type, using base_addr for
1356 the derived type. */
1358 if (TREE_CODE (decl
) == FIELD_DECL
)
1359 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1360 base_addr
, tmp
, NULL_TREE
);
1362 /* If we have a derived type component, a reference to the first
1363 element of the array is built. This is done so that base_addr,
1364 used in the build of the component reference, always points to
1368 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1370 /* Now build the address expression. */
1372 tmp
= build_fold_addr_expr (tmp
);
1374 /* If scalar dummy, resolve indirect reference now. */
1376 if (dummy_arg_flagged
&& !array_flagged
)
1377 tmp
= build_fold_indirect_ref (tmp
);
1379 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1384 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1385 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1386 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1388 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1391 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1392 gfc_symbol
* sym
, gfc_component
* c
,
1395 gfc_typespec
* ts
= NULL
;
1396 gfc_array_spec
* as
= NULL
;
1397 tree addr_expr
= NULL
;
1407 gcc_assert (sym
|| c
);
1409 /* Build the namelist object name. */
1411 string
= gfc_build_cstring_const (var_name
);
1412 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1414 /* Build ts, as and data address using symbol or component. */
1416 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1417 as
= (sym
) ? sym
->as
: c
->as
;
1419 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1426 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1427 dtype
= gfc_get_dtype (dt
);
1431 itype
= GFC_DTYPE_UNKNOWN
;
1437 itype
= GFC_DTYPE_INTEGER
;
1440 itype
= GFC_DTYPE_LOGICAL
;
1443 itype
= GFC_DTYPE_REAL
;
1446 itype
= GFC_DTYPE_COMPLEX
;
1449 itype
= GFC_DTYPE_DERIVED
;
1452 itype
= GFC_DTYPE_CHARACTER
;
1458 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1461 /* Build up the arguments for the transfer call.
1462 The call for the scalar part transfers:
1463 (address, name, type, kind or string_length, dtype) */
1465 dt_parm_addr
= build_fold_addr_expr (dt_parm
);
1467 if (ts
->type
== BT_CHARACTER
)
1468 tmp
= ts
->cl
->backend_decl
;
1470 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1471 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL
], 6,
1472 dt_parm_addr
, addr_expr
, string
,
1473 IARG (ts
->kind
), tmp
, dtype
);
1474 gfc_add_expr_to_block (block
, tmp
);
1476 /* If the object is an array, transfer rank times:
1477 (null pointer, name, stride, lbound, ubound) */
1479 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1481 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1484 GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
),
1485 GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
),
1486 GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1487 gfc_add_expr_to_block (block
, tmp
);
1490 if (ts
->type
== BT_DERIVED
)
1494 /* Provide the RECORD_TYPE to build component references. */
1496 tree expr
= build_fold_indirect_ref (addr_expr
);
1498 for (cmp
= ts
->derived
->components
; cmp
; cmp
= cmp
->next
)
1500 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1501 transfer_namelist_element (block
,
1504 gfc_free (full_name
);
1511 /* Create a data transfer statement. Not all of the fields are valid
1512 for both reading and writing, but improper use has been filtered
1516 build_dt (tree function
, gfc_code
* code
)
1518 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1523 unsigned int mask
= 0;
1525 gfc_start_block (&block
);
1526 gfc_init_block (&post_block
);
1527 gfc_init_block (&post_end_block
);
1528 gfc_init_block (&post_iu_block
);
1530 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1532 set_error_locus (&block
, var
, &code
->loc
);
1534 if (last_dt
== IOLENGTH
)
1538 inq
= code
->ext
.inquire
;
1540 /* First check that preconditions are met. */
1541 gcc_assert (inq
!= NULL
);
1542 gcc_assert (inq
->iolength
!= NULL
);
1544 /* Connect to the iolength variable. */
1545 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1546 IOPARM_dt_iolength
, inq
->iolength
);
1552 gcc_assert (dt
!= NULL
);
1555 if (dt
&& dt
->io_unit
)
1557 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1559 mask
|= set_internal_unit (&block
, &post_iu_block
,
1561 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1565 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1570 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1574 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1575 IOPARM_common_iostat
, dt
->iostat
);
1578 mask
|= IOPARM_common_err
;
1581 mask
|= IOPARM_common_eor
;
1584 mask
|= IOPARM_common_end
;
1587 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1590 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1593 if (dt
->format_expr
)
1594 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1597 if (dt
->format_label
)
1599 if (dt
->format_label
== &format_asterisk
)
1600 mask
|= IOPARM_dt_list_format
;
1602 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1603 dt
->format_label
->format
);
1607 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1608 IOPARM_dt_size
, dt
->size
);
1612 if (dt
->format_expr
|| dt
->format_label
)
1613 gfc_internal_error ("build_dt: format with namelist");
1615 nmlname
= gfc_new_nml_name_expr (dt
->namelist
->name
);
1617 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1620 if (last_dt
== READ
)
1621 mask
|= IOPARM_dt_namelist_read_mode
;
1623 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1627 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1628 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1632 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1634 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1635 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1638 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1640 tmp
= build_fold_addr_expr (var
);
1641 tmp
= build_call_expr (function
, 1, tmp
);
1642 gfc_add_expr_to_block (&block
, tmp
);
1644 gfc_add_block_to_block (&block
, &post_block
);
1647 dt_post_end_block
= &post_end_block
;
1649 gfc_add_expr_to_block (&block
, gfc_trans_code (code
->block
->next
));
1651 gfc_add_block_to_block (&block
, &post_iu_block
);
1654 dt_post_end_block
= NULL
;
1656 return gfc_finish_block (&block
);
1660 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1661 this as a third sort of data transfer statement, except that
1662 lengths are summed instead of actually transferring any data. */
1665 gfc_trans_iolength (gfc_code
* code
)
1668 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1672 /* Translate a READ statement. */
1675 gfc_trans_read (gfc_code
* code
)
1678 return build_dt (iocall
[IOCALL_READ
], code
);
1682 /* Translate a WRITE statement */
1685 gfc_trans_write (gfc_code
* code
)
1688 return build_dt (iocall
[IOCALL_WRITE
], code
);
1692 /* Finish a data transfer statement. */
1695 gfc_trans_dt_end (gfc_code
* code
)
1700 gfc_init_block (&block
);
1705 function
= iocall
[IOCALL_READ_DONE
];
1709 function
= iocall
[IOCALL_WRITE_DONE
];
1713 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1720 tmp
= build_fold_addr_expr (dt_parm
);
1721 tmp
= build_call_expr (function
, 1, tmp
);
1722 gfc_add_expr_to_block (&block
, tmp
);
1723 gfc_add_block_to_block (&block
, dt_post_end_block
);
1724 gfc_init_block (dt_post_end_block
);
1726 if (last_dt
!= IOLENGTH
)
1728 gcc_assert (code
->ext
.dt
!= NULL
);
1729 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1730 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1733 return gfc_finish_block (&block
);
1737 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1739 /* Given an array field in a derived type variable, generate the code
1740 for the loop that iterates over array elements, and the code that
1741 accesses those array elements. Use transfer_expr to generate code
1742 for transferring that element. Because elements may also be
1743 derived types, transfer_expr and transfer_array_component are mutually
1747 transfer_array_component (tree expr
, gfc_component
* cm
)
1757 gfc_start_block (&block
);
1758 gfc_init_se (&se
, NULL
);
1760 /* Create and initialize Scalarization Status. Unlike in
1761 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1762 care of this task, because we don't have a gfc_expr at hand.
1763 Build one manually, as in gfc_trans_subarray_assign. */
1766 ss
->type
= GFC_SS_COMPONENT
;
1768 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1769 ss
->next
= gfc_ss_terminator
;
1770 ss
->data
.info
.dimen
= cm
->as
->rank
;
1771 ss
->data
.info
.descriptor
= expr
;
1772 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1773 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1774 for (n
= 0; n
< cm
->as
->rank
; n
++)
1776 ss
->data
.info
.dim
[n
] = n
;
1777 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1778 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1780 mpz_init (ss
->shape
[n
]);
1781 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1782 cm
->as
->lower
[n
]->value
.integer
);
1783 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1786 /* Once we got ss, we use scalarizer to create the loop. */
1788 gfc_init_loopinfo (&loop
);
1789 gfc_add_ss_to_loop (&loop
, ss
);
1790 gfc_conv_ss_startstride (&loop
);
1791 gfc_conv_loop_setup (&loop
);
1792 gfc_mark_ss_chain_used (ss
, 1);
1793 gfc_start_scalarized_body (&loop
, &body
);
1795 gfc_copy_loopinfo_to_se (&se
, &loop
);
1798 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1800 gfc_conv_tmp_array_ref (&se
);
1802 /* Now se.expr contains an element of the array. Take the address and pass
1803 it to the IO routines. */
1804 tmp
= build_fold_addr_expr (se
.expr
);
1805 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1807 /* We are done now with the loop body. Wrap up the scalarizer and
1810 gfc_add_block_to_block (&body
, &se
.pre
);
1811 gfc_add_block_to_block (&body
, &se
.post
);
1813 gfc_trans_scalarizing_loops (&loop
, &body
);
1815 gfc_add_block_to_block (&block
, &loop
.pre
);
1816 gfc_add_block_to_block (&block
, &loop
.post
);
1818 for (n
= 0; n
< cm
->as
->rank
; n
++)
1819 mpz_clear (ss
->shape
[n
]);
1820 gfc_free (ss
->shape
);
1822 gfc_cleanup_loop (&loop
);
1824 return gfc_finish_block (&block
);
1827 /* Generate the call for a scalar transfer node. */
1830 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
1832 tree tmp
, function
, arg2
, field
, expr
;
1836 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
1837 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
1838 We need to translate the expression to a constant if it's either
1839 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
1840 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
1841 BT_DERIVED (could have been changed by gfc_conv_expr). */
1842 if ((ts
->type
== BT_DERIVED
&& ts
->is_iso_c
== 1 && ts
->derived
!= NULL
)
1843 || (ts
->derived
!= NULL
&& ts
->derived
->ts
.is_iso_c
== 1))
1845 /* C_PTR and C_FUNPTR have private components which means they can not
1846 be printed. However, if -std=gnu and not -pedantic, allow
1847 the component to be printed to help debugging. */
1848 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
1850 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
1851 ts
->derived
->name
, code
!= NULL
? &(code
->loc
) :
1852 &gfc_current_locus
);
1856 ts
->type
= ts
->derived
->ts
.type
;
1857 ts
->kind
= ts
->derived
->ts
.kind
;
1858 ts
->f90_type
= ts
->derived
->ts
.f90_type
;
1868 arg2
= build_int_cst (NULL_TREE
, kind
);
1869 function
= iocall
[IOCALL_X_INTEGER
];
1873 arg2
= build_int_cst (NULL_TREE
, kind
);
1874 function
= iocall
[IOCALL_X_REAL
];
1878 arg2
= build_int_cst (NULL_TREE
, kind
);
1879 function
= iocall
[IOCALL_X_COMPLEX
];
1883 arg2
= build_int_cst (NULL_TREE
, kind
);
1884 function
= iocall
[IOCALL_X_LOGICAL
];
1889 if (se
->string_length
)
1890 arg2
= se
->string_length
;
1893 tmp
= build_fold_indirect_ref (addr_expr
);
1894 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
1895 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
1897 function
= iocall
[IOCALL_X_CHARACTER
];
1901 /* Recurse into the elements of the derived type. */
1902 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
1903 expr
= build_fold_indirect_ref (expr
);
1905 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1907 field
= c
->backend_decl
;
1908 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
1910 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), expr
, field
,
1915 tmp
= transfer_array_component (tmp
, c
);
1916 gfc_add_expr_to_block (&se
->pre
, tmp
);
1921 tmp
= build_fold_addr_expr (tmp
);
1922 transfer_expr (se
, &c
->ts
, tmp
, code
);
1928 internal_error ("Bad IO basetype (%d)", ts
->type
);
1931 tmp
= build_fold_addr_expr (dt_parm
);
1932 tmp
= build_call_expr (function
, 3, tmp
, addr_expr
, arg2
);
1933 gfc_add_expr_to_block (&se
->pre
, tmp
);
1934 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1939 /* Generate a call to pass an array descriptor to the IO library. The
1940 array should be of one of the intrinsic types. */
1943 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1945 tree tmp
, charlen_arg
, kind_arg
;
1947 if (ts
->type
== BT_CHARACTER
)
1948 charlen_arg
= se
->string_length
;
1950 charlen_arg
= build_int_cst (NULL_TREE
, 0);
1952 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
1954 tmp
= build_fold_addr_expr (dt_parm
);
1955 tmp
= build_call_expr (iocall
[IOCALL_X_ARRAY
], 4,
1956 tmp
, addr_expr
, kind_arg
, charlen_arg
);
1957 gfc_add_expr_to_block (&se
->pre
, tmp
);
1958 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1962 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1965 gfc_trans_transfer (gfc_code
* code
)
1967 stmtblock_t block
, body
;
1975 gfc_start_block (&block
);
1976 gfc_init_block (&body
);
1979 ss
= gfc_walk_expr (expr
);
1982 gfc_init_se (&se
, NULL
);
1984 if (ss
== gfc_ss_terminator
)
1986 /* Transfer a scalar value. */
1987 gfc_conv_expr_reference (&se
, expr
);
1988 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
1992 /* Transfer an array. If it is an array of an intrinsic
1993 type, pass the descriptor to the library. Otherwise
1994 scalarize the transfer. */
1997 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
1999 gcc_assert (ref
->type
== REF_ARRAY
);
2002 if (expr
->ts
.type
!= BT_DERIVED
2003 && ref
&& ref
->next
== NULL
2004 && !is_subref_array (expr
))
2006 /* Get the descriptor. */
2007 gfc_conv_expr_descriptor (&se
, expr
, ss
);
2008 tmp
= build_fold_addr_expr (se
.expr
);
2009 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2010 goto finish_block_label
;
2013 /* Initialize the scalarizer. */
2014 gfc_init_loopinfo (&loop
);
2015 gfc_add_ss_to_loop (&loop
, ss
);
2017 /* Initialize the loop. */
2018 gfc_conv_ss_startstride (&loop
);
2019 gfc_conv_loop_setup (&loop
);
2021 /* The main loop body. */
2022 gfc_mark_ss_chain_used (ss
, 1);
2023 gfc_start_scalarized_body (&loop
, &body
);
2025 gfc_copy_loopinfo_to_se (&se
, &loop
);
2028 gfc_conv_expr_reference (&se
, expr
);
2029 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2034 gfc_add_block_to_block (&body
, &se
.pre
);
2035 gfc_add_block_to_block (&body
, &se
.post
);
2038 tmp
= gfc_finish_block (&body
);
2041 gcc_assert (se
.ss
== gfc_ss_terminator
);
2042 gfc_trans_scalarizing_loops (&loop
, &body
);
2044 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2045 tmp
= gfc_finish_block (&loop
.pre
);
2046 gfc_cleanup_loop (&loop
);
2049 gfc_add_expr_to_block (&block
, tmp
);
2051 return gfc_finish_block (&block
);
2054 #include "gt-fortran-trans-io.h"