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)
460 ioerror_codes bad_unit
;
463 bad_unit
= IOERROR_BAD_UNIT
;
465 /* Don't evaluate the UNIT number multiple times. */
466 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
468 /* UNIT numbers should be nonnegative. */
469 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, se
.expr
,
470 build_int_cst (TREE_TYPE (se
.expr
),0));
471 gfc_trans_io_runtime_check (cond
, var
, bad_unit
,
472 "Negative unit number in I/O statement",
475 /* UNIT numbers should be less than the max. */
476 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
477 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
478 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, se
.expr
,
479 fold_convert (TREE_TYPE (se
.expr
), max
));
480 gfc_trans_io_runtime_check (cond
, var
, bad_unit
,
481 "Unit number in I/O statement too large",
486 se
.expr
= convert (dest_type
, se
.expr
);
487 gfc_add_block_to_block (block
, &se
.pre
);
489 if (p
->param_type
== IOPARM_ptype_common
)
490 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
491 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
493 tmp
= build3 (COMPONENT_REF
, dest_type
, var
, p
->field
, NULL_TREE
);
494 gfc_add_modify_expr (block
, tmp
, se
.expr
);
499 /* Generate code to store a non-string I/O parameter into the
500 st_parameter_XXX structure. This is pass by reference. */
503 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
504 tree var
, enum iofield type
, gfc_expr
*e
)
508 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
510 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
511 gfc_init_se (&se
, NULL
);
512 gfc_conv_expr_lhs (&se
, e
);
514 gfc_add_block_to_block (block
, &se
.pre
);
516 if (TYPE_MODE (TREE_TYPE (se
.expr
))
517 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
519 addr
= convert (TREE_TYPE (p
->field
), build_fold_addr_expr (se
.expr
));
521 /* If this is for the iostat variable initialize the
522 user variable to IOERROR_OK which is zero. */
523 if (type
== IOPARM_common_iostat
)
527 gfc_add_modify_expr (block
, se
.expr
,
528 build_int_cst (TREE_TYPE (se
.expr
), ok
));
533 /* The type used by the library has different size
534 from the type of the variable supplied by the user.
535 Need to use a temporary. */
536 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
537 st_parameter_field
[type
].name
);
539 /* If this is for the iostat variable, initialize the
540 user variable to IOERROR_OK which is zero. */
541 if (type
== IOPARM_common_iostat
)
545 gfc_add_modify_expr (block
, tmpvar
,
546 build_int_cst (TREE_TYPE (tmpvar
), ok
));
549 addr
= build_fold_addr_expr (tmpvar
);
550 /* After the I/O operation, we set the variable from the temporary. */
551 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
552 gfc_add_modify_expr (postblock
, se
.expr
, tmp
);
555 if (p
->param_type
== IOPARM_ptype_common
)
556 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
557 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
558 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
560 gfc_add_modify_expr (block
, tmp
, addr
);
564 /* Given an array expr, find its address and length to get a string. If the
565 array is full, the string's address is the address of array's first element
566 and the length is the size of the whole array. If it is an element, the
567 string's address is the element's address and the length is the rest size of
572 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
581 sym
= e
->symtree
->n
.sym
;
582 rank
= sym
->as
->rank
- 1;
584 if (e
->ref
->u
.ar
.type
== AR_FULL
)
586 se
->expr
= gfc_get_symbol_decl (sym
);
587 se
->expr
= gfc_conv_array_data (se
->expr
);
591 gfc_conv_expr (se
, e
);
594 array
= sym
->backend_decl
;
595 type
= TREE_TYPE (array
);
597 if (GFC_ARRAY_TYPE_P (type
))
598 size
= GFC_TYPE_ARRAY_SIZE (type
);
601 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
602 size
= gfc_conv_array_stride (array
, rank
);
603 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
604 gfc_conv_array_ubound (array
, rank
),
605 gfc_conv_array_lbound (array
, rank
));
606 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
608 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
613 /* If it is an element, we need the its address and size of the rest. */
614 if (e
->ref
->u
.ar
.type
== AR_ELEMENT
)
616 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
617 TREE_OPERAND (se
->expr
, 1));
618 se
->expr
= build_fold_addr_expr (se
->expr
);
621 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
622 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
623 fold_convert (gfc_array_index_type
, tmp
));
625 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
629 /* Generate code to store a string and its length into the
630 st_parameter_XXX structure. */
633 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
634 enum iofield type
, gfc_expr
* e
)
640 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
642 gfc_init_se (&se
, NULL
);
644 if (p
->param_type
== IOPARM_ptype_common
)
645 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
646 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
647 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
649 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
652 /* Integer variable assigned a format label. */
653 if (e
->ts
.type
== BT_INTEGER
&& e
->symtree
->n
.sym
->attr
.assign
== 1)
658 gfc_conv_label_variable (&se
, e
);
659 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
660 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
661 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
663 asprintf(&msg
, "Label assigned to variable '%s' (%%ld) is not a format "
664 "label", e
->symtree
->name
);
665 gfc_trans_runtime_check (cond
, &se
.pre
, &e
->where
, msg
,
666 fold_convert (long_integer_type_node
, tmp
));
669 gfc_add_modify_expr (&se
.pre
, io
,
670 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
671 gfc_add_modify_expr (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
675 /* General character. */
676 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
677 gfc_conv_expr (&se
, e
);
678 /* Array assigned Hollerith constant or character array. */
679 else if (e
->symtree
&& (e
->symtree
->n
.sym
->as
->rank
> 0))
680 gfc_convert_array_to_string (&se
, e
);
684 gfc_conv_string_parameter (&se
);
685 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
686 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
689 gfc_add_block_to_block (block
, &se
.pre
);
690 gfc_add_block_to_block (postblock
, &se
.post
);
695 /* Generate code to store the character (array) and the character length
696 for an internal unit. */
699 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
700 tree var
, gfc_expr
* e
)
707 gfc_st_parameter_field
*p
;
710 gfc_init_se (&se
, NULL
);
712 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
714 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
716 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
718 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
719 desc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
722 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
724 /* Character scalars. */
727 gfc_conv_expr (&se
, e
);
728 gfc_conv_string_parameter (&se
);
730 se
.expr
= build_int_cst (pchar_type_node
, 0);
733 /* Character array. */
734 else if (e
->rank
> 0)
736 se
.ss
= gfc_walk_expr (e
);
738 if (is_aliased_array (e
))
740 /* Use a temporary for components of arrays of derived types
741 or substring array references. */
742 gfc_conv_aliased_arg (&se
, e
, 0,
743 last_dt
== READ
? INTENT_IN
: INTENT_OUT
);
744 tmp
= build_fold_indirect_ref (se
.expr
);
745 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
746 tmp
= gfc_conv_descriptor_data_get (tmp
);
750 /* Return the data pointer and rank from the descriptor. */
751 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
752 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
753 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
759 /* The cast is needed for character substrings and the descriptor
761 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
762 gfc_add_modify_expr (&se
.pre
, len
,
763 fold_convert (TREE_TYPE (len
), se
.string_length
));
764 gfc_add_modify_expr (&se
.pre
, desc
, se
.expr
);
766 gfc_add_block_to_block (block
, &se
.pre
);
767 gfc_add_block_to_block (post_block
, &se
.post
);
771 /* Add a case to a IO-result switch. */
774 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
779 return; /* No label, no case */
781 value
= build_int_cst (NULL_TREE
, label_value
);
783 /* Make a backend label for this case. */
784 tmp
= gfc_build_label_decl (NULL_TREE
);
786 /* And the case itself. */
787 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
788 gfc_add_expr_to_block (body
, tmp
);
790 /* Jump to the label. */
791 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
792 gfc_add_expr_to_block (body
, tmp
);
796 /* Generate a switch statement that branches to the correct I/O
797 result label. The last statement of an I/O call stores the
798 result into a variable because there is often cleanup that
799 must be done before the switch, so a temporary would have to
800 be created anyway. */
803 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
804 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
808 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
810 /* If no labels are specified, ignore the result instead
811 of building an empty switch. */
812 if (err_label
== NULL
814 && eor_label
== NULL
)
817 /* Build a switch statement. */
818 gfc_start_block (&body
);
820 /* The label values here must be the same as the values
821 in the library_return enum in the runtime library */
822 add_case (1, err_label
, &body
);
823 add_case (2, end_label
, &body
);
824 add_case (3, eor_label
, &body
);
826 tmp
= gfc_finish_block (&body
);
828 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
829 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
830 rc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
832 rc
= build2 (BIT_AND_EXPR
, TREE_TYPE (rc
), rc
,
833 build_int_cst (TREE_TYPE (rc
), IOPARM_common_libreturn_mask
));
835 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
837 gfc_add_expr_to_block (block
, tmp
);
841 /* Store the current file and line number to variables so that if a
842 library call goes awry, we can tell the user where the problem is. */
845 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
848 tree str
, locus_file
;
850 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
852 locus_file
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
853 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
854 locus_file
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), locus_file
,
855 p
->field
, NULL_TREE
);
857 str
= gfc_build_cstring_const (f
->filename
);
859 str
= gfc_build_addr_expr (pchar_type_node
, str
);
860 gfc_add_modify_expr (block
, locus_file
, str
);
862 #ifdef USE_MAPPED_LOCATION
863 line
= LOCATION_LINE (where
->lb
->location
);
865 line
= where
->lb
->linenum
;
867 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
871 /* Translate an OPEN statement. */
874 gfc_trans_open (gfc_code
* code
)
876 stmtblock_t block
, post_block
;
879 unsigned int mask
= 0;
881 gfc_start_block (&block
);
882 gfc_init_block (&post_block
);
884 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
886 set_error_locus (&block
, var
, &code
->loc
);
890 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
894 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
898 mask
|= IOPARM_common_err
;
901 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
904 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
908 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
912 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
915 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
918 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
922 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
926 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
930 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
934 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
937 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
940 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
943 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
945 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
947 tmp
= build_fold_addr_expr (var
);
948 tmp
= build_call_expr (iocall
[IOCALL_OPEN
], 1, tmp
);
949 gfc_add_expr_to_block (&block
, tmp
);
951 gfc_add_block_to_block (&block
, &post_block
);
953 io_result (&block
, var
, p
->err
, NULL
, NULL
);
955 return gfc_finish_block (&block
);
959 /* Translate a CLOSE statement. */
962 gfc_trans_close (gfc_code
* code
)
964 stmtblock_t block
, post_block
;
967 unsigned int mask
= 0;
969 gfc_start_block (&block
);
970 gfc_init_block (&post_block
);
972 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
974 set_error_locus (&block
, var
, &code
->loc
);
978 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
982 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
986 mask
|= IOPARM_common_err
;
989 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
992 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
995 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
997 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
999 tmp
= build_fold_addr_expr (var
);
1000 tmp
= build_call_expr (iocall
[IOCALL_CLOSE
], 1, tmp
);
1001 gfc_add_expr_to_block (&block
, tmp
);
1003 gfc_add_block_to_block (&block
, &post_block
);
1005 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1007 return gfc_finish_block (&block
);
1011 /* Common subroutine for building a file positioning statement. */
1014 build_filepos (tree function
, gfc_code
* code
)
1016 stmtblock_t block
, post_block
;
1019 unsigned int mask
= 0;
1021 p
= code
->ext
.filepos
;
1023 gfc_start_block (&block
);
1024 gfc_init_block (&post_block
);
1026 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1029 set_error_locus (&block
, var
, &code
->loc
);
1032 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1036 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1040 mask
|= IOPARM_common_err
;
1042 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1045 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1047 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1049 tmp
= build_fold_addr_expr (var
);
1050 tmp
= build_call_expr (function
, 1, tmp
);
1051 gfc_add_expr_to_block (&block
, tmp
);
1053 gfc_add_block_to_block (&block
, &post_block
);
1055 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1057 return gfc_finish_block (&block
);
1061 /* Translate a BACKSPACE statement. */
1064 gfc_trans_backspace (gfc_code
* code
)
1066 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1070 /* Translate an ENDFILE statement. */
1073 gfc_trans_endfile (gfc_code
* code
)
1075 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1079 /* Translate a REWIND statement. */
1082 gfc_trans_rewind (gfc_code
* code
)
1084 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1088 /* Translate a FLUSH statement. */
1091 gfc_trans_flush (gfc_code
* code
)
1093 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1097 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1100 gfc_trans_inquire (gfc_code
* code
)
1102 stmtblock_t block
, post_block
;
1105 unsigned int mask
= 0;
1107 gfc_start_block (&block
);
1108 gfc_init_block (&post_block
);
1110 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1113 set_error_locus (&block
, var
, &code
->loc
);
1114 p
= code
->ext
.inquire
;
1117 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1121 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1125 mask
|= IOPARM_common_err
;
1128 if (p
->unit
&& p
->file
)
1129 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1132 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1136 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1140 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1144 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1148 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1152 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1156 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1160 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1164 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1168 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1172 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1176 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1180 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1181 IOPARM_inquire_recl_out
, p
->recl
);
1184 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1185 IOPARM_inquire_nextrec
, p
->nextrec
);
1188 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1192 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1196 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1200 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1204 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1208 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1212 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1216 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1220 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1224 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1225 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1227 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1230 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1232 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1234 tmp
= build_fold_addr_expr (var
);
1235 tmp
= build_call_expr (iocall
[IOCALL_INQUIRE
], 1, tmp
);
1236 gfc_add_expr_to_block (&block
, tmp
);
1238 gfc_add_block_to_block (&block
, &post_block
);
1240 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1242 return gfc_finish_block (&block
);
1246 gfc_new_nml_name_expr (const char * name
)
1248 gfc_expr
* nml_name
;
1250 nml_name
= gfc_get_expr();
1251 nml_name
->ref
= NULL
;
1252 nml_name
->expr_type
= EXPR_CONSTANT
;
1253 nml_name
->ts
.kind
= gfc_default_character_kind
;
1254 nml_name
->ts
.type
= BT_CHARACTER
;
1255 nml_name
->value
.character
.length
= strlen(name
);
1256 nml_name
->value
.character
.string
= gfc_getmem (strlen (name
) + 1);
1257 strcpy (nml_name
->value
.character
.string
, name
);
1262 /* nml_full_name builds up the fully qualified name of a
1263 derived type component. */
1266 nml_full_name (const char* var_name
, const char* cmp_name
)
1268 int full_name_length
;
1271 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1272 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1273 strcpy (full_name
, var_name
);
1274 full_name
= strcat (full_name
, "%");
1275 full_name
= strcat (full_name
, cmp_name
);
1279 /* nml_get_addr_expr builds an address expression from the
1280 gfc_symbol or gfc_component backend_decl's. An offset is
1281 provided so that the address of an element of an array of
1282 derived types is returned. This is used in the runtime to
1283 determine that span of the derived type. */
1286 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1289 tree decl
= NULL_TREE
;
1293 int dummy_arg_flagged
;
1297 sym
->attr
.referenced
= 1;
1298 decl
= gfc_get_symbol_decl (sym
);
1300 /* If this is the enclosing function declaration, use
1301 the fake result instead. */
1302 if (decl
== current_function_decl
)
1303 decl
= gfc_get_fake_result_decl (sym
, 0);
1304 else if (decl
== DECL_CONTEXT (current_function_decl
))
1305 decl
= gfc_get_fake_result_decl (sym
, 1);
1308 decl
= c
->backend_decl
;
1310 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1311 || TREE_CODE (decl
) == VAR_DECL
1312 || TREE_CODE (decl
) == PARM_DECL
)
1313 || TREE_CODE (decl
) == COMPONENT_REF
));
1317 /* Build indirect reference, if dummy argument. */
1319 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1321 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref (tmp
) : tmp
;
1323 /* If an array, set flag and use indirect ref. if built. */
1325 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1326 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1331 /* Treat the component of a derived type, using base_addr for
1332 the derived type. */
1334 if (TREE_CODE (decl
) == FIELD_DECL
)
1335 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1336 base_addr
, tmp
, NULL_TREE
);
1338 /* If we have a derived type component, a reference to the first
1339 element of the array is built. This is done so that base_addr,
1340 used in the build of the component reference, always points to
1344 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
);
1346 /* Now build the address expression. */
1348 tmp
= build_fold_addr_expr (tmp
);
1350 /* If scalar dummy, resolve indirect reference now. */
1352 if (dummy_arg_flagged
&& !array_flagged
)
1353 tmp
= build_fold_indirect_ref (tmp
);
1355 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1360 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1361 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1362 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1364 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1367 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1368 gfc_symbol
* sym
, gfc_component
* c
,
1371 gfc_typespec
* ts
= NULL
;
1372 gfc_array_spec
* as
= NULL
;
1373 tree addr_expr
= NULL
;
1383 gcc_assert (sym
|| c
);
1385 /* Build the namelist object name. */
1387 string
= gfc_build_cstring_const (var_name
);
1388 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1390 /* Build ts, as and data address using symbol or component. */
1392 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1393 as
= (sym
) ? sym
->as
: c
->as
;
1395 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1402 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1403 dtype
= gfc_get_dtype (dt
);
1407 itype
= GFC_DTYPE_UNKNOWN
;
1413 itype
= GFC_DTYPE_INTEGER
;
1416 itype
= GFC_DTYPE_LOGICAL
;
1419 itype
= GFC_DTYPE_REAL
;
1422 itype
= GFC_DTYPE_COMPLEX
;
1425 itype
= GFC_DTYPE_DERIVED
;
1428 itype
= GFC_DTYPE_CHARACTER
;
1434 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1437 /* Build up the arguments for the transfer call.
1438 The call for the scalar part transfers:
1439 (address, name, type, kind or string_length, dtype) */
1441 dt_parm_addr
= build_fold_addr_expr (dt_parm
);
1443 if (ts
->type
== BT_CHARACTER
)
1444 tmp
= ts
->cl
->backend_decl
;
1446 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1447 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL
], 6,
1448 dt_parm_addr
, addr_expr
, string
,
1449 IARG (ts
->kind
), tmp
, dtype
);
1450 gfc_add_expr_to_block (block
, tmp
);
1452 /* If the object is an array, transfer rank times:
1453 (null pointer, name, stride, lbound, ubound) */
1455 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1457 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1460 GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
),
1461 GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
),
1462 GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1463 gfc_add_expr_to_block (block
, tmp
);
1466 if (ts
->type
== BT_DERIVED
)
1470 /* Provide the RECORD_TYPE to build component references. */
1472 tree expr
= build_fold_indirect_ref (addr_expr
);
1474 for (cmp
= ts
->derived
->components
; cmp
; cmp
= cmp
->next
)
1476 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1477 transfer_namelist_element (block
,
1480 gfc_free (full_name
);
1487 /* Create a data transfer statement. Not all of the fields are valid
1488 for both reading and writing, but improper use has been filtered
1492 build_dt (tree function
, gfc_code
* code
)
1494 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1499 unsigned int mask
= 0;
1501 gfc_start_block (&block
);
1502 gfc_init_block (&post_block
);
1503 gfc_init_block (&post_end_block
);
1504 gfc_init_block (&post_iu_block
);
1506 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1508 set_error_locus (&block
, var
, &code
->loc
);
1510 if (last_dt
== IOLENGTH
)
1514 inq
= code
->ext
.inquire
;
1516 /* First check that preconditions are met. */
1517 gcc_assert (inq
!= NULL
);
1518 gcc_assert (inq
->iolength
!= NULL
);
1520 /* Connect to the iolength variable. */
1521 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1522 IOPARM_dt_iolength
, inq
->iolength
);
1528 gcc_assert (dt
!= NULL
);
1531 if (dt
&& dt
->io_unit
)
1533 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1535 mask
|= set_internal_unit (&block
, &post_iu_block
,
1537 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1541 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1546 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1550 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1551 IOPARM_common_iostat
, dt
->iostat
);
1554 mask
|= IOPARM_common_err
;
1557 mask
|= IOPARM_common_eor
;
1560 mask
|= IOPARM_common_end
;
1563 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1566 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1569 if (dt
->format_expr
)
1570 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1573 if (dt
->format_label
)
1575 if (dt
->format_label
== &format_asterisk
)
1576 mask
|= IOPARM_dt_list_format
;
1578 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1579 dt
->format_label
->format
);
1583 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1584 IOPARM_dt_size
, dt
->size
);
1588 if (dt
->format_expr
|| dt
->format_label
)
1589 gfc_internal_error ("build_dt: format with namelist");
1591 nmlname
= gfc_new_nml_name_expr (dt
->namelist
->name
);
1593 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1596 if (last_dt
== READ
)
1597 mask
|= IOPARM_dt_namelist_read_mode
;
1599 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1603 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1604 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1608 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1610 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1611 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1614 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1616 tmp
= build_fold_addr_expr (var
);
1617 tmp
= build_call_expr (function
, 1, tmp
);
1618 gfc_add_expr_to_block (&block
, tmp
);
1620 gfc_add_block_to_block (&block
, &post_block
);
1623 dt_post_end_block
= &post_end_block
;
1625 gfc_add_expr_to_block (&block
, gfc_trans_code (code
->block
->next
));
1627 gfc_add_block_to_block (&block
, &post_iu_block
);
1630 dt_post_end_block
= NULL
;
1632 return gfc_finish_block (&block
);
1636 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1637 this as a third sort of data transfer statement, except that
1638 lengths are summed instead of actually transferring any data. */
1641 gfc_trans_iolength (gfc_code
* code
)
1644 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1648 /* Translate a READ statement. */
1651 gfc_trans_read (gfc_code
* code
)
1654 return build_dt (iocall
[IOCALL_READ
], code
);
1658 /* Translate a WRITE statement */
1661 gfc_trans_write (gfc_code
* code
)
1664 return build_dt (iocall
[IOCALL_WRITE
], code
);
1668 /* Finish a data transfer statement. */
1671 gfc_trans_dt_end (gfc_code
* code
)
1676 gfc_init_block (&block
);
1681 function
= iocall
[IOCALL_READ_DONE
];
1685 function
= iocall
[IOCALL_WRITE_DONE
];
1689 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1696 tmp
= build_fold_addr_expr (dt_parm
);
1697 tmp
= build_call_expr (function
, 1, tmp
);
1698 gfc_add_expr_to_block (&block
, tmp
);
1699 gfc_add_block_to_block (&block
, dt_post_end_block
);
1700 gfc_init_block (dt_post_end_block
);
1702 if (last_dt
!= IOLENGTH
)
1704 gcc_assert (code
->ext
.dt
!= NULL
);
1705 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1706 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1709 return gfc_finish_block (&block
);
1713 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1715 /* Given an array field in a derived type variable, generate the code
1716 for the loop that iterates over array elements, and the code that
1717 accesses those array elements. Use transfer_expr to generate code
1718 for transferring that element. Because elements may also be
1719 derived types, transfer_expr and transfer_array_component are mutually
1723 transfer_array_component (tree expr
, gfc_component
* cm
)
1733 gfc_start_block (&block
);
1734 gfc_init_se (&se
, NULL
);
1736 /* Create and initialize Scalarization Status. Unlike in
1737 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1738 care of this task, because we don't have a gfc_expr at hand.
1739 Build one manually, as in gfc_trans_subarray_assign. */
1742 ss
->type
= GFC_SS_COMPONENT
;
1744 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1745 ss
->next
= gfc_ss_terminator
;
1746 ss
->data
.info
.dimen
= cm
->as
->rank
;
1747 ss
->data
.info
.descriptor
= expr
;
1748 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1749 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1750 for (n
= 0; n
< cm
->as
->rank
; n
++)
1752 ss
->data
.info
.dim
[n
] = n
;
1753 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1754 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1756 mpz_init (ss
->shape
[n
]);
1757 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1758 cm
->as
->lower
[n
]->value
.integer
);
1759 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1762 /* Once we got ss, we use scalarizer to create the loop. */
1764 gfc_init_loopinfo (&loop
);
1765 gfc_add_ss_to_loop (&loop
, ss
);
1766 gfc_conv_ss_startstride (&loop
);
1767 gfc_conv_loop_setup (&loop
);
1768 gfc_mark_ss_chain_used (ss
, 1);
1769 gfc_start_scalarized_body (&loop
, &body
);
1771 gfc_copy_loopinfo_to_se (&se
, &loop
);
1774 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1776 gfc_conv_tmp_array_ref (&se
);
1778 /* Now se.expr contains an element of the array. Take the address and pass
1779 it to the IO routines. */
1780 tmp
= build_fold_addr_expr (se
.expr
);
1781 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1783 /* We are done now with the loop body. Wrap up the scalarizer and
1786 gfc_add_block_to_block (&body
, &se
.pre
);
1787 gfc_add_block_to_block (&body
, &se
.post
);
1789 gfc_trans_scalarizing_loops (&loop
, &body
);
1791 gfc_add_block_to_block (&block
, &loop
.pre
);
1792 gfc_add_block_to_block (&block
, &loop
.post
);
1794 for (n
= 0; n
< cm
->as
->rank
; n
++)
1795 mpz_clear (ss
->shape
[n
]);
1796 gfc_free (ss
->shape
);
1798 gfc_cleanup_loop (&loop
);
1800 return gfc_finish_block (&block
);
1803 /* Generate the call for a scalar transfer node. */
1806 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
1808 tree tmp
, function
, arg2
, field
, expr
;
1812 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
1813 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
1814 We need to translate the expression to a constant if it's either
1815 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
1816 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
1817 BT_DERIVED (could have been changed by gfc_conv_expr). */
1818 if ((ts
->type
== BT_DERIVED
&& ts
->is_iso_c
== 1 && ts
->derived
!= NULL
)
1819 || (ts
->derived
!= NULL
&& ts
->derived
->ts
.is_iso_c
== 1))
1821 /* C_PTR and C_FUNPTR have private components which means they can not
1822 be printed. However, if -std=gnu and not -pedantic, allow
1823 the component to be printed to help debugging. */
1824 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
1826 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
1827 ts
->derived
->name
, code
!= NULL
? &(code
->loc
) :
1828 &gfc_current_locus
);
1832 ts
->type
= ts
->derived
->ts
.type
;
1833 ts
->kind
= ts
->derived
->ts
.kind
;
1834 ts
->f90_type
= ts
->derived
->ts
.f90_type
;
1844 arg2
= build_int_cst (NULL_TREE
, kind
);
1845 function
= iocall
[IOCALL_X_INTEGER
];
1849 arg2
= build_int_cst (NULL_TREE
, kind
);
1850 function
= iocall
[IOCALL_X_REAL
];
1854 arg2
= build_int_cst (NULL_TREE
, kind
);
1855 function
= iocall
[IOCALL_X_COMPLEX
];
1859 arg2
= build_int_cst (NULL_TREE
, kind
);
1860 function
= iocall
[IOCALL_X_LOGICAL
];
1865 if (se
->string_length
)
1866 arg2
= se
->string_length
;
1869 tmp
= build_fold_indirect_ref (addr_expr
);
1870 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
1871 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
1873 function
= iocall
[IOCALL_X_CHARACTER
];
1877 /* Recurse into the elements of the derived type. */
1878 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
1879 expr
= build_fold_indirect_ref (expr
);
1881 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1883 field
= c
->backend_decl
;
1884 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
1886 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), expr
, field
,
1891 tmp
= transfer_array_component (tmp
, c
);
1892 gfc_add_expr_to_block (&se
->pre
, tmp
);
1897 tmp
= build_fold_addr_expr (tmp
);
1898 transfer_expr (se
, &c
->ts
, tmp
, code
);
1904 internal_error ("Bad IO basetype (%d)", ts
->type
);
1907 tmp
= build_fold_addr_expr (dt_parm
);
1908 tmp
= build_call_expr (function
, 3, tmp
, addr_expr
, arg2
);
1909 gfc_add_expr_to_block (&se
->pre
, tmp
);
1910 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1915 /* Generate a call to pass an array descriptor to the IO library. The
1916 array should be of one of the intrinsic types. */
1919 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1921 tree tmp
, charlen_arg
, kind_arg
;
1923 if (ts
->type
== BT_CHARACTER
)
1924 charlen_arg
= se
->string_length
;
1926 charlen_arg
= build_int_cst (NULL_TREE
, 0);
1928 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
1930 tmp
= build_fold_addr_expr (dt_parm
);
1931 tmp
= build_call_expr (iocall
[IOCALL_X_ARRAY
], 4,
1932 tmp
, addr_expr
, kind_arg
, charlen_arg
);
1933 gfc_add_expr_to_block (&se
->pre
, tmp
);
1934 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1938 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1941 gfc_trans_transfer (gfc_code
* code
)
1943 stmtblock_t block
, body
;
1951 gfc_start_block (&block
);
1952 gfc_init_block (&body
);
1955 ss
= gfc_walk_expr (expr
);
1958 gfc_init_se (&se
, NULL
);
1960 if (ss
== gfc_ss_terminator
)
1962 /* Transfer a scalar value. */
1963 gfc_conv_expr_reference (&se
, expr
);
1964 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
1968 /* Transfer an array. If it is an array of an intrinsic
1969 type, pass the descriptor to the library. Otherwise
1970 scalarize the transfer. */
1973 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
1975 gcc_assert (ref
->type
== REF_ARRAY
);
1978 if (expr
->ts
.type
!= BT_DERIVED
&& ref
&& ref
->next
== NULL
)
1980 /* Get the descriptor. */
1981 gfc_conv_expr_descriptor (&se
, expr
, ss
);
1982 tmp
= build_fold_addr_expr (se
.expr
);
1983 transfer_array_desc (&se
, &expr
->ts
, tmp
);
1984 goto finish_block_label
;
1987 /* Initialize the scalarizer. */
1988 gfc_init_loopinfo (&loop
);
1989 gfc_add_ss_to_loop (&loop
, ss
);
1991 /* Initialize the loop. */
1992 gfc_conv_ss_startstride (&loop
);
1993 gfc_conv_loop_setup (&loop
);
1995 /* The main loop body. */
1996 gfc_mark_ss_chain_used (ss
, 1);
1997 gfc_start_scalarized_body (&loop
, &body
);
1999 gfc_copy_loopinfo_to_se (&se
, &loop
);
2002 gfc_conv_expr_reference (&se
, expr
);
2003 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2008 gfc_add_block_to_block (&body
, &se
.pre
);
2009 gfc_add_block_to_block (&body
, &se
.post
);
2012 tmp
= gfc_finish_block (&body
);
2015 gcc_assert (se
.ss
== gfc_ss_terminator
);
2016 gfc_trans_scalarizing_loops (&loop
, &body
);
2018 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2019 tmp
= gfc_finish_block (&loop
.pre
);
2020 gfc_cleanup_loop (&loop
);
2023 gfc_add_expr_to_block (&block
, tmp
);
2025 return gfc_finish_block (&block
);
2028 #include "gt-fortran-trans-io.h"