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_aliased_array (e
))
729 /* Use a temporary for components of arrays of derived types
730 or substring array references. */
731 gfc_conv_aliased_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 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1089 gfc_trans_inquire (gfc_code
* code
)
1091 stmtblock_t block
, post_block
;
1094 unsigned int mask
= 0;
1096 gfc_start_block (&block
);
1097 gfc_init_block (&post_block
);
1099 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1102 set_error_locus (&block
, var
, &code
->loc
);
1103 p
= code
->ext
.inquire
;
1106 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1110 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1114 mask
|= IOPARM_common_err
;
1117 if (p
->unit
&& p
->file
)
1118 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1121 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1125 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1129 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1133 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1137 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1141 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1145 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1149 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1153 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1157 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1161 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1165 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1169 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1170 IOPARM_inquire_recl_out
, p
->recl
);
1173 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1174 IOPARM_inquire_nextrec
, p
->nextrec
);
1177 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1181 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1185 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1189 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1193 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1197 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1201 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1205 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1209 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1213 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1214 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1216 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1219 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1221 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1223 tmp
= build_fold_addr_expr (var
);
1224 tmp
= build_call_expr (iocall
[IOCALL_INQUIRE
], 1, tmp
);
1225 gfc_add_expr_to_block (&block
, tmp
);
1227 gfc_add_block_to_block (&block
, &post_block
);
1229 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1231 return gfc_finish_block (&block
);
1235 gfc_new_nml_name_expr (const char * name
)
1237 gfc_expr
* nml_name
;
1239 nml_name
= gfc_get_expr();
1240 nml_name
->ref
= NULL
;
1241 nml_name
->expr_type
= EXPR_CONSTANT
;
1242 nml_name
->ts
.kind
= gfc_default_character_kind
;
1243 nml_name
->ts
.type
= BT_CHARACTER
;
1244 nml_name
->value
.character
.length
= strlen(name
);
1245 nml_name
->value
.character
.string
= gfc_getmem (strlen (name
) + 1);
1246 strcpy (nml_name
->value
.character
.string
, name
);
1251 /* nml_full_name builds up the fully qualified name of a
1252 derived type component. */
1255 nml_full_name (const char* var_name
, const char* cmp_name
)
1257 int full_name_length
;
1260 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1261 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1262 strcpy (full_name
, var_name
);
1263 full_name
= strcat (full_name
, "%");
1264 full_name
= strcat (full_name
, cmp_name
);
1268 /* nml_get_addr_expr builds an address expression from the
1269 gfc_symbol or gfc_component backend_decl's. An offset is
1270 provided so that the address of an element of an array of
1271 derived types is returned. This is used in the runtime to
1272 determine that span of the derived type. */
1275 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1278 tree decl
= NULL_TREE
;
1282 int dummy_arg_flagged
;
1286 sym
->attr
.referenced
= 1;
1287 decl
= gfc_get_symbol_decl (sym
);
1289 /* If this is the enclosing function declaration, use
1290 the fake result instead. */
1291 if (decl
== current_function_decl
)
1292 decl
= gfc_get_fake_result_decl (sym
, 0);
1293 else if (decl
== DECL_CONTEXT (current_function_decl
))
1294 decl
= gfc_get_fake_result_decl (sym
, 1);
1297 decl
= c
->backend_decl
;
1299 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1300 || TREE_CODE (decl
) == VAR_DECL
1301 || TREE_CODE (decl
) == PARM_DECL
)
1302 || TREE_CODE (decl
) == COMPONENT_REF
));
1306 /* Build indirect reference, if dummy argument. */
1308 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1310 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref (tmp
) : tmp
;
1312 /* If an array, set flag and use indirect ref. if built. */
1314 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1315 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1320 /* Treat the component of a derived type, using base_addr for
1321 the derived type. */
1323 if (TREE_CODE (decl
) == FIELD_DECL
)
1324 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1325 base_addr
, tmp
, NULL_TREE
);
1327 /* If we have a derived type component, a reference to the first
1328 element of the array is built. This is done so that base_addr,
1329 used in the build of the component reference, always points to
1333 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
);
1335 /* Now build the address expression. */
1337 tmp
= build_fold_addr_expr (tmp
);
1339 /* If scalar dummy, resolve indirect reference now. */
1341 if (dummy_arg_flagged
&& !array_flagged
)
1342 tmp
= build_fold_indirect_ref (tmp
);
1344 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1349 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1350 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1351 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1353 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1356 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1357 gfc_symbol
* sym
, gfc_component
* c
,
1360 gfc_typespec
* ts
= NULL
;
1361 gfc_array_spec
* as
= NULL
;
1362 tree addr_expr
= NULL
;
1372 gcc_assert (sym
|| c
);
1374 /* Build the namelist object name. */
1376 string
= gfc_build_cstring_const (var_name
);
1377 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1379 /* Build ts, as and data address using symbol or component. */
1381 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1382 as
= (sym
) ? sym
->as
: c
->as
;
1384 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1391 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1392 dtype
= gfc_get_dtype (dt
);
1396 itype
= GFC_DTYPE_UNKNOWN
;
1402 itype
= GFC_DTYPE_INTEGER
;
1405 itype
= GFC_DTYPE_LOGICAL
;
1408 itype
= GFC_DTYPE_REAL
;
1411 itype
= GFC_DTYPE_COMPLEX
;
1414 itype
= GFC_DTYPE_DERIVED
;
1417 itype
= GFC_DTYPE_CHARACTER
;
1423 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1426 /* Build up the arguments for the transfer call.
1427 The call for the scalar part transfers:
1428 (address, name, type, kind or string_length, dtype) */
1430 dt_parm_addr
= build_fold_addr_expr (dt_parm
);
1432 if (ts
->type
== BT_CHARACTER
)
1433 tmp
= ts
->cl
->backend_decl
;
1435 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1436 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL
], 6,
1437 dt_parm_addr
, addr_expr
, string
,
1438 IARG (ts
->kind
), tmp
, dtype
);
1439 gfc_add_expr_to_block (block
, tmp
);
1441 /* If the object is an array, transfer rank times:
1442 (null pointer, name, stride, lbound, ubound) */
1444 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1446 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1449 GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
),
1450 GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
),
1451 GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1452 gfc_add_expr_to_block (block
, tmp
);
1455 if (ts
->type
== BT_DERIVED
)
1459 /* Provide the RECORD_TYPE to build component references. */
1461 tree expr
= build_fold_indirect_ref (addr_expr
);
1463 for (cmp
= ts
->derived
->components
; cmp
; cmp
= cmp
->next
)
1465 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1466 transfer_namelist_element (block
,
1469 gfc_free (full_name
);
1476 /* Create a data transfer statement. Not all of the fields are valid
1477 for both reading and writing, but improper use has been filtered
1481 build_dt (tree function
, gfc_code
* code
)
1483 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1488 unsigned int mask
= 0;
1490 gfc_start_block (&block
);
1491 gfc_init_block (&post_block
);
1492 gfc_init_block (&post_end_block
);
1493 gfc_init_block (&post_iu_block
);
1495 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1497 set_error_locus (&block
, var
, &code
->loc
);
1499 if (last_dt
== IOLENGTH
)
1503 inq
= code
->ext
.inquire
;
1505 /* First check that preconditions are met. */
1506 gcc_assert (inq
!= NULL
);
1507 gcc_assert (inq
->iolength
!= NULL
);
1509 /* Connect to the iolength variable. */
1510 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1511 IOPARM_dt_iolength
, inq
->iolength
);
1517 gcc_assert (dt
!= NULL
);
1520 if (dt
&& dt
->io_unit
)
1522 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1524 mask
|= set_internal_unit (&block
, &post_iu_block
,
1526 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1530 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1535 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1539 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1540 IOPARM_common_iostat
, dt
->iostat
);
1543 mask
|= IOPARM_common_err
;
1546 mask
|= IOPARM_common_eor
;
1549 mask
|= IOPARM_common_end
;
1552 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1555 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1558 if (dt
->format_expr
)
1559 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1562 if (dt
->format_label
)
1564 if (dt
->format_label
== &format_asterisk
)
1565 mask
|= IOPARM_dt_list_format
;
1567 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1568 dt
->format_label
->format
);
1572 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1573 IOPARM_dt_size
, dt
->size
);
1577 if (dt
->format_expr
|| dt
->format_label
)
1578 gfc_internal_error ("build_dt: format with namelist");
1580 nmlname
= gfc_new_nml_name_expr (dt
->namelist
->name
);
1582 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1585 if (last_dt
== READ
)
1586 mask
|= IOPARM_dt_namelist_read_mode
;
1588 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1592 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1593 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1597 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1599 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1600 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1603 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1605 tmp
= build_fold_addr_expr (var
);
1606 tmp
= build_call_expr (function
, 1, tmp
);
1607 gfc_add_expr_to_block (&block
, tmp
);
1609 gfc_add_block_to_block (&block
, &post_block
);
1612 dt_post_end_block
= &post_end_block
;
1614 gfc_add_expr_to_block (&block
, gfc_trans_code (code
->block
->next
));
1616 gfc_add_block_to_block (&block
, &post_iu_block
);
1619 dt_post_end_block
= NULL
;
1621 return gfc_finish_block (&block
);
1625 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1626 this as a third sort of data transfer statement, except that
1627 lengths are summed instead of actually transferring any data. */
1630 gfc_trans_iolength (gfc_code
* code
)
1633 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1637 /* Translate a READ statement. */
1640 gfc_trans_read (gfc_code
* code
)
1643 return build_dt (iocall
[IOCALL_READ
], code
);
1647 /* Translate a WRITE statement */
1650 gfc_trans_write (gfc_code
* code
)
1653 return build_dt (iocall
[IOCALL_WRITE
], code
);
1657 /* Finish a data transfer statement. */
1660 gfc_trans_dt_end (gfc_code
* code
)
1665 gfc_init_block (&block
);
1670 function
= iocall
[IOCALL_READ_DONE
];
1674 function
= iocall
[IOCALL_WRITE_DONE
];
1678 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1685 tmp
= build_fold_addr_expr (dt_parm
);
1686 tmp
= build_call_expr (function
, 1, tmp
);
1687 gfc_add_expr_to_block (&block
, tmp
);
1688 gfc_add_block_to_block (&block
, dt_post_end_block
);
1689 gfc_init_block (dt_post_end_block
);
1691 if (last_dt
!= IOLENGTH
)
1693 gcc_assert (code
->ext
.dt
!= NULL
);
1694 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1695 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1698 return gfc_finish_block (&block
);
1702 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1704 /* Given an array field in a derived type variable, generate the code
1705 for the loop that iterates over array elements, and the code that
1706 accesses those array elements. Use transfer_expr to generate code
1707 for transferring that element. Because elements may also be
1708 derived types, transfer_expr and transfer_array_component are mutually
1712 transfer_array_component (tree expr
, gfc_component
* cm
)
1722 gfc_start_block (&block
);
1723 gfc_init_se (&se
, NULL
);
1725 /* Create and initialize Scalarization Status. Unlike in
1726 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1727 care of this task, because we don't have a gfc_expr at hand.
1728 Build one manually, as in gfc_trans_subarray_assign. */
1731 ss
->type
= GFC_SS_COMPONENT
;
1733 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1734 ss
->next
= gfc_ss_terminator
;
1735 ss
->data
.info
.dimen
= cm
->as
->rank
;
1736 ss
->data
.info
.descriptor
= expr
;
1737 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1738 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1739 for (n
= 0; n
< cm
->as
->rank
; n
++)
1741 ss
->data
.info
.dim
[n
] = n
;
1742 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1743 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1745 mpz_init (ss
->shape
[n
]);
1746 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1747 cm
->as
->lower
[n
]->value
.integer
);
1748 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1751 /* Once we got ss, we use scalarizer to create the loop. */
1753 gfc_init_loopinfo (&loop
);
1754 gfc_add_ss_to_loop (&loop
, ss
);
1755 gfc_conv_ss_startstride (&loop
);
1756 gfc_conv_loop_setup (&loop
);
1757 gfc_mark_ss_chain_used (ss
, 1);
1758 gfc_start_scalarized_body (&loop
, &body
);
1760 gfc_copy_loopinfo_to_se (&se
, &loop
);
1763 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1765 gfc_conv_tmp_array_ref (&se
);
1767 /* Now se.expr contains an element of the array. Take the address and pass
1768 it to the IO routines. */
1769 tmp
= build_fold_addr_expr (se
.expr
);
1770 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1772 /* We are done now with the loop body. Wrap up the scalarizer and
1775 gfc_add_block_to_block (&body
, &se
.pre
);
1776 gfc_add_block_to_block (&body
, &se
.post
);
1778 gfc_trans_scalarizing_loops (&loop
, &body
);
1780 gfc_add_block_to_block (&block
, &loop
.pre
);
1781 gfc_add_block_to_block (&block
, &loop
.post
);
1783 for (n
= 0; n
< cm
->as
->rank
; n
++)
1784 mpz_clear (ss
->shape
[n
]);
1785 gfc_free (ss
->shape
);
1787 gfc_cleanup_loop (&loop
);
1789 return gfc_finish_block (&block
);
1792 /* Generate the call for a scalar transfer node. */
1795 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
1797 tree tmp
, function
, arg2
, field
, expr
;
1801 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
1802 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
1803 We need to translate the expression to a constant if it's either
1804 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
1805 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
1806 BT_DERIVED (could have been changed by gfc_conv_expr). */
1807 if ((ts
->type
== BT_DERIVED
&& ts
->is_iso_c
== 1 && ts
->derived
!= NULL
)
1808 || (ts
->derived
!= NULL
&& ts
->derived
->ts
.is_iso_c
== 1))
1810 /* C_PTR and C_FUNPTR have private components which means they can not
1811 be printed. However, if -std=gnu and not -pedantic, allow
1812 the component to be printed to help debugging. */
1813 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
1815 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
1816 ts
->derived
->name
, code
!= NULL
? &(code
->loc
) :
1817 &gfc_current_locus
);
1821 ts
->type
= ts
->derived
->ts
.type
;
1822 ts
->kind
= ts
->derived
->ts
.kind
;
1823 ts
->f90_type
= ts
->derived
->ts
.f90_type
;
1833 arg2
= build_int_cst (NULL_TREE
, kind
);
1834 function
= iocall
[IOCALL_X_INTEGER
];
1838 arg2
= build_int_cst (NULL_TREE
, kind
);
1839 function
= iocall
[IOCALL_X_REAL
];
1843 arg2
= build_int_cst (NULL_TREE
, kind
);
1844 function
= iocall
[IOCALL_X_COMPLEX
];
1848 arg2
= build_int_cst (NULL_TREE
, kind
);
1849 function
= iocall
[IOCALL_X_LOGICAL
];
1854 if (se
->string_length
)
1855 arg2
= se
->string_length
;
1858 tmp
= build_fold_indirect_ref (addr_expr
);
1859 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
1860 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
1862 function
= iocall
[IOCALL_X_CHARACTER
];
1866 /* Recurse into the elements of the derived type. */
1867 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
1868 expr
= build_fold_indirect_ref (expr
);
1870 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1872 field
= c
->backend_decl
;
1873 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
1875 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), expr
, field
,
1880 tmp
= transfer_array_component (tmp
, c
);
1881 gfc_add_expr_to_block (&se
->pre
, tmp
);
1886 tmp
= build_fold_addr_expr (tmp
);
1887 transfer_expr (se
, &c
->ts
, tmp
, code
);
1893 internal_error ("Bad IO basetype (%d)", ts
->type
);
1896 tmp
= build_fold_addr_expr (dt_parm
);
1897 tmp
= build_call_expr (function
, 3, tmp
, addr_expr
, arg2
);
1898 gfc_add_expr_to_block (&se
->pre
, tmp
);
1899 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1904 /* Generate a call to pass an array descriptor to the IO library. The
1905 array should be of one of the intrinsic types. */
1908 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1910 tree tmp
, charlen_arg
, kind_arg
;
1912 if (ts
->type
== BT_CHARACTER
)
1913 charlen_arg
= se
->string_length
;
1915 charlen_arg
= build_int_cst (NULL_TREE
, 0);
1917 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
1919 tmp
= build_fold_addr_expr (dt_parm
);
1920 tmp
= build_call_expr (iocall
[IOCALL_X_ARRAY
], 4,
1921 tmp
, addr_expr
, kind_arg
, charlen_arg
);
1922 gfc_add_expr_to_block (&se
->pre
, tmp
);
1923 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1927 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1930 gfc_trans_transfer (gfc_code
* code
)
1932 stmtblock_t block
, body
;
1940 gfc_start_block (&block
);
1941 gfc_init_block (&body
);
1944 ss
= gfc_walk_expr (expr
);
1947 gfc_init_se (&se
, NULL
);
1949 if (ss
== gfc_ss_terminator
)
1951 /* Transfer a scalar value. */
1952 gfc_conv_expr_reference (&se
, expr
);
1953 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
1957 /* Transfer an array. If it is an array of an intrinsic
1958 type, pass the descriptor to the library. Otherwise
1959 scalarize the transfer. */
1962 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
1964 gcc_assert (ref
->type
== REF_ARRAY
);
1967 if (expr
->ts
.type
!= BT_DERIVED
&& ref
&& ref
->next
== NULL
)
1969 /* Get the descriptor. */
1970 gfc_conv_expr_descriptor (&se
, expr
, ss
);
1971 tmp
= build_fold_addr_expr (se
.expr
);
1972 transfer_array_desc (&se
, &expr
->ts
, tmp
);
1973 goto finish_block_label
;
1976 /* Initialize the scalarizer. */
1977 gfc_init_loopinfo (&loop
);
1978 gfc_add_ss_to_loop (&loop
, ss
);
1980 /* Initialize the loop. */
1981 gfc_conv_ss_startstride (&loop
);
1982 gfc_conv_loop_setup (&loop
);
1984 /* The main loop body. */
1985 gfc_mark_ss_chain_used (ss
, 1);
1986 gfc_start_scalarized_body (&loop
, &body
);
1988 gfc_copy_loopinfo_to_se (&se
, &loop
);
1991 gfc_conv_expr_reference (&se
, expr
);
1992 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
1997 gfc_add_block_to_block (&body
, &se
.pre
);
1998 gfc_add_block_to_block (&body
, &se
.post
);
2001 tmp
= gfc_finish_block (&body
);
2004 gcc_assert (se
.ss
== gfc_ss_terminator
);
2005 gfc_trans_scalarizing_loops (&loop
, &body
);
2007 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2008 tmp
= gfc_finish_block (&loop
.pre
);
2009 gfc_cleanup_loop (&loop
);
2012 gfc_add_expr_to_block (&block
, tmp
);
2014 return gfc_finish_block (&block
);
2017 #include "gt-fortran-trans-io.h"