1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
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"
39 /* Members of the ioparm structure. */
65 typedef struct gfc_st_parameter_field
GTY(())
69 enum ioparam_type param_type
;
70 enum iofield_type type
;
74 gfc_st_parameter_field
;
76 typedef struct gfc_st_parameter
GTY(())
85 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
91 static GTY(()) gfc_st_parameter st_parameter
[] =
101 static GTY(()) gfc_st_parameter_field st_parameter_field
[] =
103 #define IOPARM(param_type, name, mask, type) \
104 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
105 #include "ioparm.def"
107 { NULL
, 0, 0, 0, NULL
, NULL
}
110 /* Library I/O subroutines */
128 IOCALL_IOLENGTH_DONE
,
134 IOCALL_SET_NML_VAL_DIM
,
138 static GTY(()) tree iocall
[IOCALL_NUM
];
140 /* Variable for keeping track of what the last data transfer statement
141 was. Used for deciding which subroutine to call when the data
142 transfer is complete. */
143 static enum { READ
, WRITE
, IOLENGTH
} last_dt
;
145 /* The data transfer parameter block that should be shared by all
146 data transfer calls belonging to the same read/write/iolength. */
147 static GTY(()) tree dt_parm
;
148 static stmtblock_t
*dt_post_end_block
;
151 gfc_build_st_parameter (enum ioparam_type ptype
, tree
*types
)
154 gfc_st_parameter_field
*p
;
157 tree t
= make_node (RECORD_TYPE
);
159 len
= strlen (st_parameter
[ptype
].name
);
160 gcc_assert (len
<= sizeof (name
) - sizeof ("__st_parameter_"));
161 memcpy (name
, "__st_parameter_", sizeof ("__st_parameter_"));
162 memcpy (name
+ sizeof ("__st_parameter_") - 1, st_parameter
[ptype
].name
,
164 TYPE_NAME (t
) = get_identifier (name
);
166 for (type
= 0, p
= st_parameter_field
; type
< IOPARM_field_num
; type
++, p
++)
167 if (p
->param_type
== ptype
)
170 case IOPARM_type_int4
:
171 case IOPARM_type_pint4
:
172 case IOPARM_type_parray
:
173 case IOPARM_type_pchar
:
174 case IOPARM_type_pad
:
175 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
176 get_identifier (p
->name
),
179 case IOPARM_type_char1
:
180 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
181 get_identifier (p
->name
),
184 case IOPARM_type_char2
:
185 len
= strlen (p
->name
);
186 gcc_assert (len
<= sizeof (name
) - sizeof ("_len"));
187 memcpy (name
, p
->name
, len
);
188 memcpy (name
+ len
, "_len", sizeof ("_len"));
189 p
->field_len
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
190 get_identifier (name
),
191 gfc_charlen_type_node
);
192 if (p
->type
== IOPARM_type_char2
)
193 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
194 get_identifier (p
->name
),
197 case IOPARM_type_common
:
199 = gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
200 get_identifier (p
->name
),
201 st_parameter
[IOPARM_ptype_common
].type
);
203 case IOPARM_type_num
:
208 st_parameter
[ptype
].type
= t
;
211 /* Create function decls for IO library functions. */
214 gfc_build_io_library_fndecls (void)
216 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
217 tree parm_type
, dt_parm_type
;
218 tree gfc_c_int_type_node
;
219 HOST_WIDE_INT pad_size
;
220 enum ioparam_type ptype
;
222 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
223 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
224 types
[IOPARM_type_parray
] = pchar_type_node
;
225 types
[IOPARM_type_pchar
] = pchar_type_node
;
226 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
227 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
228 pad_idx
= build_index_type (build_int_cst (NULL_TREE
, pad_size
));
229 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
231 /* pad actually contains pointers and integers so it needs to have an
232 alignment that is at least as large as the needed alignment for those
233 types. See the st_parameter_dt structure in libgfortran/io/io.h for
234 what really goes into this space. */
235 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
236 TYPE_ALIGN (gfc_get_int_type (gfc_max_integer_kind
)));
238 gfc_c_int_type_node
= gfc_get_int_type (gfc_c_int_kind
);
240 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
241 gfc_build_st_parameter (ptype
, types
);
243 /* Define the transfer functions. */
245 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
247 iocall
[IOCALL_X_INTEGER
] =
248 gfc_build_library_function_decl (get_identifier
249 (PREFIX("transfer_integer")),
250 void_type_node
, 3, dt_parm_type
,
251 pvoid_type_node
, gfc_int4_type_node
);
253 iocall
[IOCALL_X_LOGICAL
] =
254 gfc_build_library_function_decl (get_identifier
255 (PREFIX("transfer_logical")),
256 void_type_node
, 3, dt_parm_type
,
257 pvoid_type_node
, gfc_int4_type_node
);
259 iocall
[IOCALL_X_CHARACTER
] =
260 gfc_build_library_function_decl (get_identifier
261 (PREFIX("transfer_character")),
262 void_type_node
, 3, dt_parm_type
,
263 pvoid_type_node
, gfc_int4_type_node
);
265 iocall
[IOCALL_X_REAL
] =
266 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
267 void_type_node
, 3, dt_parm_type
,
268 pvoid_type_node
, gfc_int4_type_node
);
270 iocall
[IOCALL_X_COMPLEX
] =
271 gfc_build_library_function_decl (get_identifier
272 (PREFIX("transfer_complex")),
273 void_type_node
, 3, dt_parm_type
,
274 pvoid_type_node
, gfc_int4_type_node
);
276 iocall
[IOCALL_X_ARRAY
] =
277 gfc_build_library_function_decl (get_identifier
278 (PREFIX("transfer_array")),
279 void_type_node
, 4, dt_parm_type
,
280 pvoid_type_node
, gfc_c_int_type_node
,
281 gfc_charlen_type_node
);
283 /* Library entry points */
285 iocall
[IOCALL_READ
] =
286 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
287 void_type_node
, 1, dt_parm_type
);
289 iocall
[IOCALL_WRITE
] =
290 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
291 void_type_node
, 1, dt_parm_type
);
293 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
294 iocall
[IOCALL_OPEN
] =
295 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
296 void_type_node
, 1, parm_type
);
299 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
300 iocall
[IOCALL_CLOSE
] =
301 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
302 void_type_node
, 1, parm_type
);
304 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
305 iocall
[IOCALL_INQUIRE
] =
306 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
307 gfc_int4_type_node
, 1, parm_type
);
309 iocall
[IOCALL_IOLENGTH
] =
310 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
311 void_type_node
, 1, dt_parm_type
);
313 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
314 iocall
[IOCALL_REWIND
] =
315 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
316 gfc_int4_type_node
, 1, parm_type
);
318 iocall
[IOCALL_BACKSPACE
] =
319 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
320 gfc_int4_type_node
, 1, parm_type
);
322 iocall
[IOCALL_ENDFILE
] =
323 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
324 gfc_int4_type_node
, 1, parm_type
);
326 iocall
[IOCALL_FLUSH
] =
327 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
328 gfc_int4_type_node
, 1, parm_type
);
330 /* Library helpers */
332 iocall
[IOCALL_READ_DONE
] =
333 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
334 gfc_int4_type_node
, 1, dt_parm_type
);
336 iocall
[IOCALL_WRITE_DONE
] =
337 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
338 gfc_int4_type_node
, 1, dt_parm_type
);
340 iocall
[IOCALL_IOLENGTH_DONE
] =
341 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
342 gfc_int4_type_node
, 1, dt_parm_type
);
345 iocall
[IOCALL_SET_NML_VAL
] =
346 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
347 void_type_node
, 6, dt_parm_type
,
348 pvoid_type_node
, pvoid_type_node
,
349 gfc_int4_type_node
, gfc_charlen_type_node
,
352 iocall
[IOCALL_SET_NML_VAL_DIM
] =
353 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
354 void_type_node
, 5, dt_parm_type
,
355 gfc_int4_type_node
, gfc_int4_type_node
,
356 gfc_int4_type_node
, gfc_int4_type_node
);
360 /* Generate code to store an integer constant into the
361 st_parameter_XXX structure. */
364 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
368 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
370 if (p
->param_type
== IOPARM_ptype_common
)
371 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
372 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
373 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
375 gfc_add_modify_expr (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
380 /* Generate code to store a non-string I/O parameter into the
381 st_parameter_XXX structure. This is a pass by value. */
384 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
389 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
391 gfc_init_se (&se
, NULL
);
392 gfc_conv_expr_type (&se
, e
, TREE_TYPE (p
->field
));
393 gfc_add_block_to_block (block
, &se
.pre
);
395 if (p
->param_type
== IOPARM_ptype_common
)
396 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
397 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
398 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
400 gfc_add_modify_expr (block
, tmp
, se
.expr
);
405 /* Generate code to store a non-string I/O parameter into the
406 st_parameter_XXX structure. This is pass by reference. */
409 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
410 tree var
, enum iofield type
, gfc_expr
*e
)
414 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
416 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
417 gfc_init_se (&se
, NULL
);
418 gfc_conv_expr_lhs (&se
, e
);
420 gfc_add_block_to_block (block
, &se
.pre
);
422 if (TYPE_MODE (TREE_TYPE (se
.expr
))
423 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
424 addr
= convert (TREE_TYPE (p
->field
),
425 build_fold_addr_expr (se
.expr
));
428 /* The type used by the library has different size
429 from the type of the variable supplied by the user.
430 Need to use a temporary. */
432 = gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
433 st_parameter_field
[type
].name
);
434 addr
= build_fold_addr_expr (tmpvar
);
435 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
436 gfc_add_modify_expr (postblock
, se
.expr
, tmp
);
439 if (p
->param_type
== IOPARM_ptype_common
)
440 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
441 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
442 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
444 gfc_add_modify_expr (block
, tmp
, addr
);
448 /* Given an array expr, find its address and length to get a string. If the
449 array is full, the string's address is the address of array's first element
450 and the length is the size of the whole array. If it is an element, the
451 string's address is the element's address and the length is the rest size of
456 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
465 sym
= e
->symtree
->n
.sym
;
466 rank
= sym
->as
->rank
- 1;
468 if (e
->ref
->u
.ar
.type
== AR_FULL
)
470 se
->expr
= gfc_get_symbol_decl (sym
);
471 se
->expr
= gfc_conv_array_data (se
->expr
);
475 gfc_conv_expr (se
, e
);
478 array
= sym
->backend_decl
;
479 type
= TREE_TYPE (array
);
481 if (GFC_ARRAY_TYPE_P (type
))
482 size
= GFC_TYPE_ARRAY_SIZE (type
);
485 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
486 size
= gfc_conv_array_stride (array
, rank
);
487 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
488 gfc_conv_array_ubound (array
, rank
),
489 gfc_conv_array_lbound (array
, rank
));
490 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
492 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
497 /* If it is an element, we need the its address and size of the rest. */
498 if (e
->ref
->u
.ar
.type
== AR_ELEMENT
)
500 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
501 TREE_OPERAND (se
->expr
, 1));
502 se
->expr
= build_fold_addr_expr (se
->expr
);
505 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
506 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
508 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
512 /* Generate code to store a string and its length into the
513 st_parameter_XXX structure. */
516 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
517 enum iofield type
, gfc_expr
* e
)
524 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
526 gfc_init_se (&se
, NULL
);
528 if (p
->param_type
== IOPARM_ptype_common
)
529 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
530 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
531 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
533 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
536 /* Integer variable assigned a format label. */
537 if (e
->ts
.type
== BT_INTEGER
&& e
->symtree
->n
.sym
->attr
.assign
== 1)
539 gfc_conv_label_variable (&se
, e
);
541 gfc_build_cstring_const ("Assigned label is not a format label");
542 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
543 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
,
544 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
545 gfc_trans_runtime_check (tmp
, msg
, &se
.pre
);
546 gfc_add_modify_expr (&se
.pre
, io
,
547 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
548 gfc_add_modify_expr (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
552 /* General character. */
553 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
554 gfc_conv_expr (&se
, e
);
555 /* Array assigned Hollerith constant or character array. */
556 else if (e
->symtree
&& (e
->symtree
->n
.sym
->as
->rank
> 0))
557 gfc_convert_array_to_string (&se
, e
);
561 gfc_conv_string_parameter (&se
);
562 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
563 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
566 gfc_add_block_to_block (block
, &se
.pre
);
567 gfc_add_block_to_block (postblock
, &se
.post
);
572 /* Generate code to store the character (array) and the character length
573 for an internal unit. */
576 set_internal_unit (stmtblock_t
* block
, tree var
, gfc_expr
* e
)
583 gfc_st_parameter_field
*p
;
586 gfc_init_se (&se
, NULL
);
588 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
590 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
592 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
594 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
595 desc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
598 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
600 /* Character scalars. */
603 gfc_conv_expr (&se
, e
);
604 gfc_conv_string_parameter (&se
);
606 se
.expr
= fold_convert (pchar_type_node
, integer_zero_node
);
609 /* Character array. */
610 else if (e
->rank
> 0)
612 se
.ss
= gfc_walk_expr (e
);
614 /* Return the data pointer and rank from the descriptor. */
615 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
616 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
617 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
622 /* The cast is needed for character substrings and the descriptor
624 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
625 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
626 gfc_add_modify_expr (&se
.pre
, desc
, se
.expr
);
628 gfc_add_block_to_block (block
, &se
.pre
);
632 /* Add a case to a IO-result switch. */
635 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
640 return; /* No label, no case */
642 value
= build_int_cst (NULL_TREE
, label_value
);
644 /* Make a backend label for this case. */
645 tmp
= gfc_build_label_decl (NULL_TREE
);
647 /* And the case itself. */
648 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
649 gfc_add_expr_to_block (body
, tmp
);
651 /* Jump to the label. */
652 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
653 gfc_add_expr_to_block (body
, tmp
);
657 /* Generate a switch statement that branches to the correct I/O
658 result label. The last statement of an I/O call stores the
659 result into a variable because there is often cleanup that
660 must be done before the switch, so a temporary would have to
661 be created anyway. */
664 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
665 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
669 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
671 /* If no labels are specified, ignore the result instead
672 of building an empty switch. */
673 if (err_label
== NULL
675 && eor_label
== NULL
)
678 /* Build a switch statement. */
679 gfc_start_block (&body
);
681 /* The label values here must be the same as the values
682 in the library_return enum in the runtime library */
683 add_case (1, err_label
, &body
);
684 add_case (2, end_label
, &body
);
685 add_case (3, eor_label
, &body
);
687 tmp
= gfc_finish_block (&body
);
689 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
690 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
691 rc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
693 rc
= build2 (BIT_AND_EXPR
, TREE_TYPE (rc
), rc
,
694 build_int_cst (TREE_TYPE (rc
), IOPARM_common_libreturn_mask
));
696 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
698 gfc_add_expr_to_block (block
, tmp
);
702 /* Store the current file and line number to variables so that if a
703 library call goes awry, we can tell the user where the problem is. */
706 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
709 tree str
, locus_file
;
711 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
713 locus_file
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
714 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
715 locus_file
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), locus_file
,
716 p
->field
, NULL_TREE
);
718 str
= gfc_build_cstring_const (f
->filename
);
720 str
= gfc_build_addr_expr (pchar_type_node
, str
);
721 gfc_add_modify_expr (block
, locus_file
, str
);
723 #ifdef USE_MAPPED_LOCATION
724 line
= LOCATION_LINE (where
->lb
->location
);
726 line
= where
->lb
->linenum
;
728 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
732 /* Translate an OPEN statement. */
735 gfc_trans_open (gfc_code
* code
)
737 stmtblock_t block
, post_block
;
740 unsigned int mask
= 0;
742 gfc_start_block (&block
);
743 gfc_init_block (&post_block
);
745 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
747 set_error_locus (&block
, var
, &code
->loc
);
751 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
753 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
756 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
759 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
763 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
767 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
770 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
773 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
777 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
781 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
785 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
789 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
792 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
796 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
800 mask
|= IOPARM_common_err
;
803 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
806 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
808 tmp
= build_fold_addr_expr (var
);
809 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
810 tmp
= build_function_call_expr (iocall
[IOCALL_OPEN
], tmp
);
811 gfc_add_expr_to_block (&block
, tmp
);
813 gfc_add_block_to_block (&block
, &post_block
);
815 io_result (&block
, var
, p
->err
, NULL
, NULL
);
817 return gfc_finish_block (&block
);
821 /* Translate a CLOSE statement. */
824 gfc_trans_close (gfc_code
* code
)
826 stmtblock_t block
, post_block
;
829 unsigned int mask
= 0;
831 gfc_start_block (&block
);
832 gfc_init_block (&post_block
);
834 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
836 set_error_locus (&block
, var
, &code
->loc
);
840 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
842 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
845 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
849 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
853 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
857 mask
|= IOPARM_common_err
;
859 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
861 tmp
= build_fold_addr_expr (var
);
862 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
863 tmp
= build_function_call_expr (iocall
[IOCALL_CLOSE
], tmp
);
864 gfc_add_expr_to_block (&block
, tmp
);
866 gfc_add_block_to_block (&block
, &post_block
);
868 io_result (&block
, var
, p
->err
, NULL
, NULL
);
870 return gfc_finish_block (&block
);
874 /* Common subroutine for building a file positioning statement. */
877 build_filepos (tree function
, gfc_code
* code
)
879 stmtblock_t block
, post_block
;
882 unsigned int mask
= 0;
884 p
= code
->ext
.filepos
;
886 gfc_start_block (&block
);
887 gfc_init_block (&post_block
);
889 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
892 set_error_locus (&block
, var
, &code
->loc
);
895 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
897 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
900 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
904 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
908 mask
|= IOPARM_common_err
;
910 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
912 tmp
= build_fold_addr_expr (var
);
913 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
914 tmp
= build_function_call_expr (function
, tmp
);
915 gfc_add_expr_to_block (&block
, tmp
);
917 gfc_add_block_to_block (&block
, &post_block
);
919 io_result (&block
, var
, p
->err
, NULL
, NULL
);
921 return gfc_finish_block (&block
);
925 /* Translate a BACKSPACE statement. */
928 gfc_trans_backspace (gfc_code
* code
)
930 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
934 /* Translate an ENDFILE statement. */
937 gfc_trans_endfile (gfc_code
* code
)
939 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
943 /* Translate a REWIND statement. */
946 gfc_trans_rewind (gfc_code
* code
)
948 return build_filepos (iocall
[IOCALL_REWIND
], code
);
952 /* Translate a FLUSH statement. */
955 gfc_trans_flush (gfc_code
* code
)
957 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
961 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
964 gfc_trans_inquire (gfc_code
* code
)
966 stmtblock_t block
, post_block
;
969 unsigned int mask
= 0;
971 gfc_start_block (&block
);
972 gfc_init_block (&post_block
);
974 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
977 set_error_locus (&block
, var
, &code
->loc
);
978 p
= code
->ext
.inquire
;
981 if (p
->unit
&& p
->file
)
982 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers.", &code
->loc
);
985 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
987 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
990 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
994 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
998 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1002 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1006 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1010 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1014 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1018 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1022 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1026 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1030 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1034 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1038 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1042 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1046 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1047 IOPARM_inquire_recl_out
, p
->recl
);
1050 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1051 IOPARM_inquire_nextrec
, p
->nextrec
);
1054 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1058 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1062 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1066 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1070 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1074 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1078 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1082 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1086 mask
|= IOPARM_common_err
;
1089 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1092 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1094 tmp
= build_fold_addr_expr (var
);
1095 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1096 tmp
= build_function_call_expr (iocall
[IOCALL_INQUIRE
], tmp
);
1097 gfc_add_expr_to_block (&block
, tmp
);
1099 gfc_add_block_to_block (&block
, &post_block
);
1101 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1103 return gfc_finish_block (&block
);
1107 gfc_new_nml_name_expr (const char * name
)
1109 gfc_expr
* nml_name
;
1111 nml_name
= gfc_get_expr();
1112 nml_name
->ref
= NULL
;
1113 nml_name
->expr_type
= EXPR_CONSTANT
;
1114 nml_name
->ts
.kind
= gfc_default_character_kind
;
1115 nml_name
->ts
.type
= BT_CHARACTER
;
1116 nml_name
->value
.character
.length
= strlen(name
);
1117 nml_name
->value
.character
.string
= gfc_getmem (strlen (name
) + 1);
1118 strcpy (nml_name
->value
.character
.string
, name
);
1123 /* nml_full_name builds up the fully qualified name of a
1124 derived type component. */
1127 nml_full_name (const char* var_name
, const char* cmp_name
)
1129 int full_name_length
;
1132 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1133 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1134 strcpy (full_name
, var_name
);
1135 full_name
= strcat (full_name
, "%");
1136 full_name
= strcat (full_name
, cmp_name
);
1140 /* nml_get_addr_expr builds an address expression from the
1141 gfc_symbol or gfc_component backend_decl's. An offset is
1142 provided so that the address of an element of an array of
1143 derived types is returned. This is used in the runtime to
1144 determine that span of the derived type. */
1147 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1150 tree decl
= NULL_TREE
;
1154 int dummy_arg_flagged
;
1158 sym
->attr
.referenced
= 1;
1159 decl
= gfc_get_symbol_decl (sym
);
1162 decl
= c
->backend_decl
;
1164 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1165 || TREE_CODE (decl
) == VAR_DECL
1166 || TREE_CODE (decl
) == PARM_DECL
)
1167 || TREE_CODE (decl
) == COMPONENT_REF
));
1171 /* Build indirect reference, if dummy argument. */
1173 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1175 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref (tmp
) : tmp
;
1177 /* If an array, set flag and use indirect ref. if built. */
1179 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1180 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1185 /* Treat the component of a derived type, using base_addr for
1186 the derived type. */
1188 if (TREE_CODE (decl
) == FIELD_DECL
)
1189 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1190 base_addr
, tmp
, NULL_TREE
);
1192 /* If we have a derived type component, a reference to the first
1193 element of the array is built. This is done so that base_addr,
1194 used in the build of the component reference, always points to
1198 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
);
1200 /* Now build the address expression. */
1202 tmp
= build_fold_addr_expr (tmp
);
1204 /* If scalar dummy, resolve indirect reference now. */
1206 if (dummy_arg_flagged
&& !array_flagged
)
1207 tmp
= build_fold_indirect_ref (tmp
);
1209 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1214 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1215 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1216 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1218 #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
1219 #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
1220 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1223 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1224 gfc_symbol
* sym
, gfc_component
* c
,
1227 gfc_typespec
* ts
= NULL
;
1228 gfc_array_spec
* as
= NULL
;
1229 tree addr_expr
= NULL
;
1240 gcc_assert (sym
|| c
);
1242 /* Build the namelist object name. */
1244 string
= gfc_build_cstring_const (var_name
);
1245 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1247 /* Build ts, as and data address using symbol or component. */
1249 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1250 as
= (sym
) ? sym
->as
: c
->as
;
1252 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1259 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1260 dtype
= gfc_get_dtype (dt
);
1264 itype
= GFC_DTYPE_UNKNOWN
;
1270 itype
= GFC_DTYPE_INTEGER
;
1273 itype
= GFC_DTYPE_LOGICAL
;
1276 itype
= GFC_DTYPE_REAL
;
1279 itype
= GFC_DTYPE_COMPLEX
;
1282 itype
= GFC_DTYPE_DERIVED
;
1285 itype
= GFC_DTYPE_CHARACTER
;
1291 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1294 /* Build up the arguments for the transfer call.
1295 The call for the scalar part transfers:
1296 (address, name, type, kind or string_length, dtype) */
1298 dt_parm_addr
= build_fold_addr_expr (dt_parm
);
1299 NML_FIRST_ARG (dt_parm_addr
);
1300 NML_ADD_ARG (addr_expr
);
1301 NML_ADD_ARG (string
);
1302 NML_ADD_ARG (IARG (ts
->kind
));
1304 if (ts
->type
== BT_CHARACTER
)
1305 NML_ADD_ARG (ts
->cl
->backend_decl
);
1307 NML_ADD_ARG (convert (gfc_charlen_type_node
, integer_zero_node
));
1309 NML_ADD_ARG (dtype
);
1310 tmp
= build_function_call_expr (iocall
[IOCALL_SET_NML_VAL
], args
);
1311 gfc_add_expr_to_block (block
, tmp
);
1313 /* If the object is an array, transfer rank times:
1314 (null pointer, name, stride, lbound, ubound) */
1316 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1318 NML_FIRST_ARG (dt_parm_addr
);
1319 NML_ADD_ARG (IARG (n_dim
));
1320 NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
));
1321 NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
));
1322 NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1323 tmp
= build_function_call_expr (iocall
[IOCALL_SET_NML_VAL_DIM
], args
);
1324 gfc_add_expr_to_block (block
, tmp
);
1327 if (ts
->type
== BT_DERIVED
)
1331 /* Provide the RECORD_TYPE to build component references. */
1333 tree expr
= build_fold_indirect_ref (addr_expr
);
1335 for (cmp
= ts
->derived
->components
; cmp
; cmp
= cmp
->next
)
1337 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1338 transfer_namelist_element (block
,
1341 gfc_free (full_name
);
1348 #undef NML_FIRST_ARG
1350 /* Create a data transfer statement. Not all of the fields are valid
1351 for both reading and writing, but improper use has been filtered
1355 build_dt (tree function
, gfc_code
* code
)
1357 stmtblock_t block
, post_block
, post_end_block
;
1362 unsigned int mask
= 0;
1364 gfc_start_block (&block
);
1365 gfc_init_block (&post_block
);
1366 gfc_init_block (&post_end_block
);
1368 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1370 set_error_locus (&block
, var
, &code
->loc
);
1372 if (last_dt
== IOLENGTH
)
1376 inq
= code
->ext
.inquire
;
1378 /* First check that preconditions are met. */
1379 gcc_assert (inq
!= NULL
);
1380 gcc_assert (inq
->iolength
!= NULL
);
1382 /* Connect to the iolength variable. */
1383 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1384 IOPARM_dt_iolength
, inq
->iolength
);
1390 gcc_assert (dt
!= NULL
);
1393 if (dt
&& dt
->io_unit
)
1395 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1397 mask
|= set_internal_unit (&block
, var
, dt
->io_unit
);
1398 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1401 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1404 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1409 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1412 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1415 if (dt
->format_expr
)
1416 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1419 if (dt
->format_label
)
1421 if (dt
->format_label
== &format_asterisk
)
1422 mask
|= IOPARM_dt_list_format
;
1424 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1425 dt
->format_label
->format
);
1429 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1433 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1434 IOPARM_common_iostat
, dt
->iostat
);
1437 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1438 IOPARM_dt_size
, dt
->size
);
1441 mask
|= IOPARM_common_err
;
1444 mask
|= IOPARM_common_eor
;
1447 mask
|= IOPARM_common_end
;
1451 if (dt
->format_expr
|| dt
->format_label
)
1452 gfc_internal_error ("build_dt: format with namelist");
1454 nmlname
= gfc_new_nml_name_expr (dt
->namelist
->name
);
1456 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1459 if (last_dt
== READ
)
1460 mask
|= IOPARM_dt_namelist_read_mode
;
1462 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1466 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1467 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1471 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1474 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1476 tmp
= build_fold_addr_expr (var
);
1477 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1478 tmp
= build_function_call_expr (function
, tmp
);
1479 gfc_add_expr_to_block (&block
, tmp
);
1481 gfc_add_block_to_block (&block
, &post_block
);
1484 dt_post_end_block
= &post_end_block
;
1486 gfc_add_expr_to_block (&block
, gfc_trans_code (code
->block
->next
));
1489 dt_post_end_block
= NULL
;
1491 return gfc_finish_block (&block
);
1495 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1496 this as a third sort of data transfer statement, except that
1497 lengths are summed instead of actually transferring any data. */
1500 gfc_trans_iolength (gfc_code
* code
)
1503 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1507 /* Translate a READ statement. */
1510 gfc_trans_read (gfc_code
* code
)
1513 return build_dt (iocall
[IOCALL_READ
], code
);
1517 /* Translate a WRITE statement */
1520 gfc_trans_write (gfc_code
* code
)
1523 return build_dt (iocall
[IOCALL_WRITE
], code
);
1527 /* Finish a data transfer statement. */
1530 gfc_trans_dt_end (gfc_code
* code
)
1535 gfc_init_block (&block
);
1540 function
= iocall
[IOCALL_READ_DONE
];
1544 function
= iocall
[IOCALL_WRITE_DONE
];
1548 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1555 tmp
= build_fold_addr_expr (dt_parm
);
1556 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1557 tmp
= build_function_call_expr (function
, tmp
);
1558 gfc_add_expr_to_block (&block
, tmp
);
1559 gfc_add_block_to_block (&block
, dt_post_end_block
);
1560 gfc_init_block (dt_post_end_block
);
1562 if (last_dt
!= IOLENGTH
)
1564 gcc_assert (code
->ext
.dt
!= NULL
);
1565 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1566 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1569 return gfc_finish_block (&block
);
1573 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
);
1575 /* Given an array field in a derived type variable, generate the code
1576 for the loop that iterates over array elements, and the code that
1577 accesses those array elements. Use transfer_expr to generate code
1578 for transferring that element. Because elements may also be
1579 derived types, transfer_expr and transfer_array_component are mutually
1583 transfer_array_component (tree expr
, gfc_component
* cm
)
1593 gfc_start_block (&block
);
1594 gfc_init_se (&se
, NULL
);
1596 /* Create and initialize Scalarization Status. Unlike in
1597 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1598 care of this task, because we don't have a gfc_expr at hand.
1599 Build one manually, as in gfc_trans_subarray_assign. */
1602 ss
->type
= GFC_SS_COMPONENT
;
1604 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1605 ss
->next
= gfc_ss_terminator
;
1606 ss
->data
.info
.dimen
= cm
->as
->rank
;
1607 ss
->data
.info
.descriptor
= expr
;
1608 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1609 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1610 for (n
= 0; n
< cm
->as
->rank
; n
++)
1612 ss
->data
.info
.dim
[n
] = n
;
1613 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1614 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1616 mpz_init (ss
->shape
[n
]);
1617 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1618 cm
->as
->lower
[n
]->value
.integer
);
1619 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1622 /* Once we got ss, we use scalarizer to create the loop. */
1624 gfc_init_loopinfo (&loop
);
1625 gfc_add_ss_to_loop (&loop
, ss
);
1626 gfc_conv_ss_startstride (&loop
);
1627 gfc_conv_loop_setup (&loop
);
1628 gfc_mark_ss_chain_used (ss
, 1);
1629 gfc_start_scalarized_body (&loop
, &body
);
1631 gfc_copy_loopinfo_to_se (&se
, &loop
);
1634 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1636 gfc_conv_tmp_array_ref (&se
);
1638 /* Now se.expr contains an element of the array. Take the address and pass
1639 it to the IO routines. */
1640 tmp
= build_fold_addr_expr (se
.expr
);
1641 transfer_expr (&se
, &cm
->ts
, tmp
);
1643 /* We are done now with the loop body. Wrap up the scalarizer and
1646 gfc_add_block_to_block (&body
, &se
.pre
);
1647 gfc_add_block_to_block (&body
, &se
.post
);
1649 gfc_trans_scalarizing_loops (&loop
, &body
);
1651 gfc_add_block_to_block (&block
, &loop
.pre
);
1652 gfc_add_block_to_block (&block
, &loop
.post
);
1654 for (n
= 0; n
< cm
->as
->rank
; n
++)
1655 mpz_clear (ss
->shape
[n
]);
1656 gfc_free (ss
->shape
);
1658 gfc_cleanup_loop (&loop
);
1660 return gfc_finish_block (&block
);
1663 /* Generate the call for a scalar transfer node. */
1666 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1668 tree args
, tmp
, function
, arg2
, field
, expr
;
1679 arg2
= build_int_cst (NULL_TREE
, kind
);
1680 function
= iocall
[IOCALL_X_INTEGER
];
1684 arg2
= build_int_cst (NULL_TREE
, kind
);
1685 function
= iocall
[IOCALL_X_REAL
];
1689 arg2
= build_int_cst (NULL_TREE
, kind
);
1690 function
= iocall
[IOCALL_X_COMPLEX
];
1694 arg2
= build_int_cst (NULL_TREE
, kind
);
1695 function
= iocall
[IOCALL_X_LOGICAL
];
1699 if (se
->string_length
)
1700 arg2
= se
->string_length
;
1703 tmp
= build_fold_indirect_ref (addr_expr
);
1704 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
1705 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
1707 function
= iocall
[IOCALL_X_CHARACTER
];
1711 /* Recurse into the elements of the derived type. */
1712 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
1713 expr
= build_fold_indirect_ref (expr
);
1715 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1717 field
= c
->backend_decl
;
1718 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
1720 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), expr
, field
,
1725 tmp
= transfer_array_component (tmp
, c
);
1726 gfc_add_expr_to_block (&se
->pre
, tmp
);
1731 tmp
= build_fold_addr_expr (tmp
);
1732 transfer_expr (se
, &c
->ts
, tmp
);
1738 internal_error ("Bad IO basetype (%d)", ts
->type
);
1741 tmp
= build_fold_addr_expr (dt_parm
);
1742 args
= gfc_chainon_list (NULL_TREE
, tmp
);
1743 args
= gfc_chainon_list (args
, addr_expr
);
1744 args
= gfc_chainon_list (args
, arg2
);
1746 tmp
= build_function_call_expr (function
, args
);
1747 gfc_add_expr_to_block (&se
->pre
, tmp
);
1748 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1753 /* Generate a call to pass an array descriptor to the IO library. The
1754 array should be of one of the intrinsic types. */
1757 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1759 tree args
, tmp
, charlen_arg
, kind_arg
;
1761 if (ts
->type
== BT_CHARACTER
)
1762 charlen_arg
= se
->string_length
;
1764 charlen_arg
= build_int_cstu (NULL_TREE
, 0);
1766 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
1768 tmp
= build_fold_addr_expr (dt_parm
);
1769 args
= gfc_chainon_list (NULL_TREE
, tmp
);
1770 args
= gfc_chainon_list (args
, addr_expr
);
1771 args
= gfc_chainon_list (args
, kind_arg
);
1772 args
= gfc_chainon_list (args
, charlen_arg
);
1773 tmp
= build_function_call_expr (iocall
[IOCALL_X_ARRAY
], args
);
1774 gfc_add_expr_to_block (&se
->pre
, tmp
);
1775 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1779 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1782 gfc_trans_transfer (gfc_code
* code
)
1784 stmtblock_t block
, body
;
1792 gfc_start_block (&block
);
1793 gfc_init_block (&body
);
1796 ss
= gfc_walk_expr (expr
);
1799 gfc_init_se (&se
, NULL
);
1801 if (ss
== gfc_ss_terminator
)
1803 /* Transfer a scalar value. */
1804 gfc_conv_expr_reference (&se
, expr
);
1805 transfer_expr (&se
, &expr
->ts
, se
.expr
);
1809 /* Transfer an array. If it is an array of an intrinsic
1810 type, pass the descriptor to the library. Otherwise
1811 scalarize the transfer. */
1814 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
1816 gcc_assert (ref
->type
== REF_ARRAY
);
1819 if (expr
->ts
.type
!= BT_DERIVED
&& ref
&& ref
->next
== NULL
)
1821 /* Get the descriptor. */
1822 gfc_conv_expr_descriptor (&se
, expr
, ss
);
1823 tmp
= build_fold_addr_expr (se
.expr
);
1824 transfer_array_desc (&se
, &expr
->ts
, tmp
);
1825 goto finish_block_label
;
1828 /* Initialize the scalarizer. */
1829 gfc_init_loopinfo (&loop
);
1830 gfc_add_ss_to_loop (&loop
, ss
);
1832 /* Initialize the loop. */
1833 gfc_conv_ss_startstride (&loop
);
1834 gfc_conv_loop_setup (&loop
);
1836 /* The main loop body. */
1837 gfc_mark_ss_chain_used (ss
, 1);
1838 gfc_start_scalarized_body (&loop
, &body
);
1840 gfc_copy_loopinfo_to_se (&se
, &loop
);
1843 gfc_conv_expr_reference (&se
, expr
);
1844 transfer_expr (&se
, &expr
->ts
, se
.expr
);
1849 gfc_add_block_to_block (&body
, &se
.pre
);
1850 gfc_add_block_to_block (&body
, &se
.post
);
1853 tmp
= gfc_finish_block (&body
);
1856 gcc_assert (se
.ss
== gfc_ss_terminator
);
1857 gfc_trans_scalarizing_loops (&loop
, &body
);
1859 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1860 tmp
= gfc_finish_block (&loop
.pre
);
1861 gfc_cleanup_loop (&loop
);
1864 gfc_add_expr_to_block (&block
, tmp
);
1866 return gfc_finish_block (&block
);
1869 #include "gt-fortran-trans-io.h"