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
);
230 gfc_c_int_type_node
= gfc_get_int_type (gfc_c_int_kind
);
232 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
233 gfc_build_st_parameter (ptype
, types
);
235 /* Define the transfer functions. */
237 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
239 iocall
[IOCALL_X_INTEGER
] =
240 gfc_build_library_function_decl (get_identifier
241 (PREFIX("transfer_integer")),
242 void_type_node
, 3, dt_parm_type
,
243 pvoid_type_node
, gfc_int4_type_node
);
245 iocall
[IOCALL_X_LOGICAL
] =
246 gfc_build_library_function_decl (get_identifier
247 (PREFIX("transfer_logical")),
248 void_type_node
, 3, dt_parm_type
,
249 pvoid_type_node
, gfc_int4_type_node
);
251 iocall
[IOCALL_X_CHARACTER
] =
252 gfc_build_library_function_decl (get_identifier
253 (PREFIX("transfer_character")),
254 void_type_node
, 3, dt_parm_type
,
255 pvoid_type_node
, gfc_int4_type_node
);
257 iocall
[IOCALL_X_REAL
] =
258 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
259 void_type_node
, 3, dt_parm_type
,
260 pvoid_type_node
, gfc_int4_type_node
);
262 iocall
[IOCALL_X_COMPLEX
] =
263 gfc_build_library_function_decl (get_identifier
264 (PREFIX("transfer_complex")),
265 void_type_node
, 3, dt_parm_type
,
266 pvoid_type_node
, gfc_int4_type_node
);
268 iocall
[IOCALL_X_ARRAY
] =
269 gfc_build_library_function_decl (get_identifier
270 (PREFIX("transfer_array")),
271 void_type_node
, 4, dt_parm_type
,
272 pvoid_type_node
, gfc_c_int_type_node
,
273 gfc_charlen_type_node
);
275 /* Library entry points */
277 iocall
[IOCALL_READ
] =
278 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
279 void_type_node
, 1, dt_parm_type
);
281 iocall
[IOCALL_WRITE
] =
282 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
283 void_type_node
, 1, dt_parm_type
);
285 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
286 iocall
[IOCALL_OPEN
] =
287 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
288 void_type_node
, 1, parm_type
);
291 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
292 iocall
[IOCALL_CLOSE
] =
293 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
294 void_type_node
, 1, parm_type
);
296 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
297 iocall
[IOCALL_INQUIRE
] =
298 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
299 gfc_int4_type_node
, 1, parm_type
);
301 iocall
[IOCALL_IOLENGTH
] =
302 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
303 void_type_node
, 1, dt_parm_type
);
305 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
306 iocall
[IOCALL_REWIND
] =
307 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
308 gfc_int4_type_node
, 1, parm_type
);
310 iocall
[IOCALL_BACKSPACE
] =
311 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
312 gfc_int4_type_node
, 1, parm_type
);
314 iocall
[IOCALL_ENDFILE
] =
315 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
316 gfc_int4_type_node
, 1, parm_type
);
318 iocall
[IOCALL_FLUSH
] =
319 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
320 gfc_int4_type_node
, 1, parm_type
);
322 /* Library helpers */
324 iocall
[IOCALL_READ_DONE
] =
325 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
326 gfc_int4_type_node
, 1, dt_parm_type
);
328 iocall
[IOCALL_WRITE_DONE
] =
329 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
330 gfc_int4_type_node
, 1, dt_parm_type
);
332 iocall
[IOCALL_IOLENGTH_DONE
] =
333 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
334 gfc_int4_type_node
, 1, dt_parm_type
);
337 iocall
[IOCALL_SET_NML_VAL
] =
338 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
339 void_type_node
, 6, dt_parm_type
,
340 pvoid_type_node
, pvoid_type_node
,
341 gfc_int4_type_node
, gfc_charlen_type_node
,
344 iocall
[IOCALL_SET_NML_VAL_DIM
] =
345 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
346 void_type_node
, 5, dt_parm_type
,
347 gfc_int4_type_node
, gfc_int4_type_node
,
348 gfc_int4_type_node
, gfc_int4_type_node
);
352 /* Generate code to store an integer constant into the
353 st_parameter_XXX structure. */
356 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
360 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
362 if (p
->param_type
== IOPARM_ptype_common
)
363 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
364 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
365 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
367 gfc_add_modify_expr (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
372 /* Generate code to store a non-string I/O parameter into the
373 st_parameter_XXX structure. This is a pass by value. */
376 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
381 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
383 gfc_init_se (&se
, NULL
);
384 gfc_conv_expr_type (&se
, e
, TREE_TYPE (p
->field
));
385 gfc_add_block_to_block (block
, &se
.pre
);
387 if (p
->param_type
== IOPARM_ptype_common
)
388 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
389 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
390 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
392 gfc_add_modify_expr (block
, tmp
, se
.expr
);
397 /* Generate code to store a non-string I/O parameter into the
398 st_parameter_XXX structure. This is pass by reference. */
401 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
402 tree var
, enum iofield type
, gfc_expr
*e
)
406 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
408 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
409 gfc_init_se (&se
, NULL
);
410 gfc_conv_expr_lhs (&se
, e
);
412 gfc_add_block_to_block (block
, &se
.pre
);
414 if (TYPE_MODE (TREE_TYPE (se
.expr
))
415 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
416 addr
= convert (TREE_TYPE (p
->field
),
417 build_fold_addr_expr (se
.expr
));
420 /* The type used by the library has different size
421 from the type of the variable supplied by the user.
422 Need to use a temporary. */
424 = gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
425 st_parameter_field
[type
].name
);
426 addr
= build_fold_addr_expr (tmpvar
);
427 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
428 gfc_add_modify_expr (postblock
, se
.expr
, tmp
);
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
, addr
);
440 /* Given an array expr, find its address and length to get a string. If the
441 array is full, the string's address is the address of array's first element
442 and the length is the size of the whole array. If it is an element, the
443 string's address is the element's address and the length is the rest size of
448 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
457 sym
= e
->symtree
->n
.sym
;
458 rank
= sym
->as
->rank
- 1;
460 if (e
->ref
->u
.ar
.type
== AR_FULL
)
462 se
->expr
= gfc_get_symbol_decl (sym
);
463 se
->expr
= gfc_conv_array_data (se
->expr
);
467 gfc_conv_expr (se
, e
);
470 array
= sym
->backend_decl
;
471 type
= TREE_TYPE (array
);
473 if (GFC_ARRAY_TYPE_P (type
))
474 size
= GFC_TYPE_ARRAY_SIZE (type
);
477 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
478 size
= gfc_conv_array_stride (array
, rank
);
479 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
480 gfc_conv_array_ubound (array
, rank
),
481 gfc_conv_array_lbound (array
, rank
));
482 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
484 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
489 /* If it is an element, we need the its address and size of the rest. */
490 if (e
->ref
->u
.ar
.type
== AR_ELEMENT
)
492 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
493 TREE_OPERAND (se
->expr
, 1));
494 se
->expr
= build_fold_addr_expr (se
->expr
);
497 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
498 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
500 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
504 /* Generate code to store a string and its length into the
505 st_parameter_XXX structure. */
508 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
509 enum iofield type
, gfc_expr
* e
)
516 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
518 gfc_init_se (&se
, NULL
);
520 if (p
->param_type
== IOPARM_ptype_common
)
521 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
522 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
523 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
525 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
528 /* Integer variable assigned a format label. */
529 if (e
->ts
.type
== BT_INTEGER
&& e
->symtree
->n
.sym
->attr
.assign
== 1)
531 gfc_conv_label_variable (&se
, e
);
533 gfc_build_cstring_const ("Assigned label is not a format label");
534 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
535 tmp
= build2 (LE_EXPR
, boolean_type_node
,
536 tmp
, convert (TREE_TYPE (tmp
), integer_minus_one_node
));
537 gfc_trans_runtime_check (tmp
, msg
, &se
.pre
);
538 gfc_add_modify_expr (&se
.pre
, io
,
539 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
540 gfc_add_modify_expr (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
544 /* General character. */
545 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
546 gfc_conv_expr (&se
, e
);
547 /* Array assigned Hollerith constant or character array. */
548 else if (e
->symtree
&& (e
->symtree
->n
.sym
->as
->rank
> 0))
549 gfc_convert_array_to_string (&se
, e
);
553 gfc_conv_string_parameter (&se
);
554 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
555 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
558 gfc_add_block_to_block (block
, &se
.pre
);
559 gfc_add_block_to_block (postblock
, &se
.post
);
564 /* Generate code to store the character (array) and the character length
565 for an internal unit. */
568 set_internal_unit (stmtblock_t
* block
, tree var
, gfc_expr
* e
)
575 gfc_st_parameter_field
*p
;
578 gfc_init_se (&se
, NULL
);
580 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
582 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
584 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
586 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
587 desc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
590 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
592 /* Character scalars. */
595 gfc_conv_expr (&se
, e
);
596 gfc_conv_string_parameter (&se
);
598 se
.expr
= fold_convert (pchar_type_node
, integer_zero_node
);
601 /* Character array. */
602 else if (e
->rank
> 0)
604 se
.ss
= gfc_walk_expr (e
);
606 /* Return the data pointer and rank from the descriptor. */
607 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
608 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
609 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
614 /* The cast is needed for character substrings and the descriptor
616 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
617 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
618 gfc_add_modify_expr (&se
.pre
, desc
, se
.expr
);
620 gfc_add_block_to_block (block
, &se
.pre
);
624 /* Add a case to a IO-result switch. */
627 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
632 return; /* No label, no case */
634 value
= build_int_cst (NULL_TREE
, label_value
);
636 /* Make a backend label for this case. */
637 tmp
= gfc_build_label_decl (NULL_TREE
);
639 /* And the case itself. */
640 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
641 gfc_add_expr_to_block (body
, tmp
);
643 /* Jump to the label. */
644 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
645 gfc_add_expr_to_block (body
, tmp
);
649 /* Generate a switch statement that branches to the correct I/O
650 result label. The last statement of an I/O call stores the
651 result into a variable because there is often cleanup that
652 must be done before the switch, so a temporary would have to
653 be created anyway. */
656 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
657 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
661 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
663 /* If no labels are specified, ignore the result instead
664 of building an empty switch. */
665 if (err_label
== NULL
667 && eor_label
== NULL
)
670 /* Build a switch statement. */
671 gfc_start_block (&body
);
673 /* The label values here must be the same as the values
674 in the library_return enum in the runtime library */
675 add_case (1, err_label
, &body
);
676 add_case (2, end_label
, &body
);
677 add_case (3, eor_label
, &body
);
679 tmp
= gfc_finish_block (&body
);
681 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
682 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
683 rc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
685 rc
= build2 (BIT_AND_EXPR
, TREE_TYPE (rc
), rc
,
686 build_int_cst (TREE_TYPE (rc
), IOPARM_common_libreturn_mask
));
688 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
690 gfc_add_expr_to_block (block
, tmp
);
694 /* Store the current file and line number to variables so that if a
695 library call goes awry, we can tell the user where the problem is. */
698 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
701 tree str
, locus_file
;
703 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
705 locus_file
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
706 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
707 locus_file
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), locus_file
,
708 p
->field
, NULL_TREE
);
710 str
= gfc_build_cstring_const (f
->filename
);
712 str
= gfc_build_addr_expr (pchar_type_node
, str
);
713 gfc_add_modify_expr (block
, locus_file
, str
);
715 #ifdef USE_MAPPED_LOCATION
716 line
= LOCATION_LINE (where
->lb
->location
);
718 line
= where
->lb
->linenum
;
720 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
724 /* Translate an OPEN statement. */
727 gfc_trans_open (gfc_code
* code
)
729 stmtblock_t block
, post_block
;
732 unsigned int mask
= 0;
734 gfc_start_block (&block
);
735 gfc_init_block (&post_block
);
737 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
739 set_error_locus (&block
, var
, &code
->loc
);
743 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
745 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
748 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
751 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
755 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
759 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
762 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
765 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
769 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
773 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
777 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
781 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
784 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
788 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
792 mask
|= IOPARM_common_err
;
795 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
798 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
800 tmp
= build_fold_addr_expr (var
);
801 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
802 tmp
= build_function_call_expr (iocall
[IOCALL_OPEN
], tmp
);
803 gfc_add_expr_to_block (&block
, tmp
);
805 gfc_add_block_to_block (&block
, &post_block
);
807 io_result (&block
, var
, p
->err
, NULL
, NULL
);
809 return gfc_finish_block (&block
);
813 /* Translate a CLOSE statement. */
816 gfc_trans_close (gfc_code
* code
)
818 stmtblock_t block
, post_block
;
821 unsigned int mask
= 0;
823 gfc_start_block (&block
);
824 gfc_init_block (&post_block
);
826 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
828 set_error_locus (&block
, var
, &code
->loc
);
832 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
834 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
837 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
841 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
845 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
849 mask
|= IOPARM_common_err
;
851 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
853 tmp
= build_fold_addr_expr (var
);
854 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
855 tmp
= build_function_call_expr (iocall
[IOCALL_CLOSE
], tmp
);
856 gfc_add_expr_to_block (&block
, tmp
);
858 gfc_add_block_to_block (&block
, &post_block
);
860 io_result (&block
, var
, p
->err
, NULL
, NULL
);
862 return gfc_finish_block (&block
);
866 /* Common subroutine for building a file positioning statement. */
869 build_filepos (tree function
, gfc_code
* code
)
871 stmtblock_t block
, post_block
;
874 unsigned int mask
= 0;
876 p
= code
->ext
.filepos
;
878 gfc_start_block (&block
);
879 gfc_init_block (&post_block
);
881 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
884 set_error_locus (&block
, var
, &code
->loc
);
887 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
889 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
892 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
896 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
900 mask
|= IOPARM_common_err
;
902 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
904 tmp
= build_fold_addr_expr (var
);
905 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
906 tmp
= build_function_call_expr (function
, tmp
);
907 gfc_add_expr_to_block (&block
, tmp
);
909 gfc_add_block_to_block (&block
, &post_block
);
911 io_result (&block
, var
, p
->err
, NULL
, NULL
);
913 return gfc_finish_block (&block
);
917 /* Translate a BACKSPACE statement. */
920 gfc_trans_backspace (gfc_code
* code
)
922 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
926 /* Translate an ENDFILE statement. */
929 gfc_trans_endfile (gfc_code
* code
)
931 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
935 /* Translate a REWIND statement. */
938 gfc_trans_rewind (gfc_code
* code
)
940 return build_filepos (iocall
[IOCALL_REWIND
], code
);
944 /* Translate a FLUSH statement. */
947 gfc_trans_flush (gfc_code
* code
)
949 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
953 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
956 gfc_trans_inquire (gfc_code
* code
)
958 stmtblock_t block
, post_block
;
961 unsigned int mask
= 0;
963 gfc_start_block (&block
);
964 gfc_init_block (&post_block
);
966 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
969 set_error_locus (&block
, var
, &code
->loc
);
970 p
= code
->ext
.inquire
;
973 if (p
->unit
&& p
->file
)
974 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers.", &code
->loc
);
977 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
979 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
982 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
986 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
990 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
994 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
998 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1002 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1006 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1010 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1014 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1018 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1022 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1026 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1030 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1034 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1038 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1039 IOPARM_inquire_recl_out
, p
->recl
);
1042 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1043 IOPARM_inquire_nextrec
, p
->nextrec
);
1046 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1050 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1054 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1058 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1062 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1066 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1070 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1074 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1078 mask
|= IOPARM_common_err
;
1081 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1084 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1086 tmp
= build_fold_addr_expr (var
);
1087 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1088 tmp
= build_function_call_expr (iocall
[IOCALL_INQUIRE
], tmp
);
1089 gfc_add_expr_to_block (&block
, tmp
);
1091 gfc_add_block_to_block (&block
, &post_block
);
1093 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1095 return gfc_finish_block (&block
);
1099 gfc_new_nml_name_expr (const char * name
)
1101 gfc_expr
* nml_name
;
1103 nml_name
= gfc_get_expr();
1104 nml_name
->ref
= NULL
;
1105 nml_name
->expr_type
= EXPR_CONSTANT
;
1106 nml_name
->ts
.kind
= gfc_default_character_kind
;
1107 nml_name
->ts
.type
= BT_CHARACTER
;
1108 nml_name
->value
.character
.length
= strlen(name
);
1109 nml_name
->value
.character
.string
= gfc_getmem (strlen (name
) + 1);
1110 strcpy (nml_name
->value
.character
.string
, name
);
1115 /* nml_full_name builds up the fully qualified name of a
1116 derived type component. */
1119 nml_full_name (const char* var_name
, const char* cmp_name
)
1121 int full_name_length
;
1124 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1125 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1126 strcpy (full_name
, var_name
);
1127 full_name
= strcat (full_name
, "%");
1128 full_name
= strcat (full_name
, cmp_name
);
1132 /* nml_get_addr_expr builds an address expression from the
1133 gfc_symbol or gfc_component backend_decl's. An offset is
1134 provided so that the address of an element of an array of
1135 derived types is returned. This is used in the runtime to
1136 determine that span of the derived type. */
1139 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1142 tree decl
= NULL_TREE
;
1146 int dummy_arg_flagged
;
1150 sym
->attr
.referenced
= 1;
1151 decl
= gfc_get_symbol_decl (sym
);
1154 decl
= c
->backend_decl
;
1156 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1157 || TREE_CODE (decl
) == VAR_DECL
1158 || TREE_CODE (decl
) == PARM_DECL
)
1159 || TREE_CODE (decl
) == COMPONENT_REF
));
1163 /* Build indirect reference, if dummy argument. */
1165 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1167 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref (tmp
) : tmp
;
1169 /* If an array, set flag and use indirect ref. if built. */
1171 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1172 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1177 /* Treat the component of a derived type, using base_addr for
1178 the derived type. */
1180 if (TREE_CODE (decl
) == FIELD_DECL
)
1181 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1182 base_addr
, tmp
, NULL_TREE
);
1184 /* If we have a derived type component, a reference to the first
1185 element of the array is built. This is done so that base_addr,
1186 used in the build of the component reference, always points to
1190 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
);
1192 /* Now build the address expression. */
1194 tmp
= build_fold_addr_expr (tmp
);
1196 /* If scalar dummy, resolve indirect reference now. */
1198 if (dummy_arg_flagged
&& !array_flagged
)
1199 tmp
= build_fold_indirect_ref (tmp
);
1201 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1206 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1207 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1208 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1210 #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
1211 #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
1212 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1215 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1216 gfc_symbol
* sym
, gfc_component
* c
,
1219 gfc_typespec
* ts
= NULL
;
1220 gfc_array_spec
* as
= NULL
;
1221 tree addr_expr
= NULL
;
1232 gcc_assert (sym
|| c
);
1234 /* Build the namelist object name. */
1236 string
= gfc_build_cstring_const (var_name
);
1237 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1239 /* Build ts, as and data address using symbol or component. */
1241 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1242 as
= (sym
) ? sym
->as
: c
->as
;
1244 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1251 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1252 dtype
= gfc_get_dtype (dt
);
1256 itype
= GFC_DTYPE_UNKNOWN
;
1262 itype
= GFC_DTYPE_INTEGER
;
1265 itype
= GFC_DTYPE_LOGICAL
;
1268 itype
= GFC_DTYPE_REAL
;
1271 itype
= GFC_DTYPE_COMPLEX
;
1274 itype
= GFC_DTYPE_DERIVED
;
1277 itype
= GFC_DTYPE_CHARACTER
;
1283 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1286 /* Build up the arguments for the transfer call.
1287 The call for the scalar part transfers:
1288 (address, name, type, kind or string_length, dtype) */
1290 dt_parm_addr
= build_fold_addr_expr (dt_parm
);
1291 NML_FIRST_ARG (dt_parm_addr
);
1292 NML_ADD_ARG (addr_expr
);
1293 NML_ADD_ARG (string
);
1294 NML_ADD_ARG (IARG (ts
->kind
));
1296 if (ts
->type
== BT_CHARACTER
)
1297 NML_ADD_ARG (ts
->cl
->backend_decl
);
1299 NML_ADD_ARG (convert (gfc_charlen_type_node
, integer_zero_node
));
1301 NML_ADD_ARG (dtype
);
1302 tmp
= build_function_call_expr (iocall
[IOCALL_SET_NML_VAL
], args
);
1303 gfc_add_expr_to_block (block
, tmp
);
1305 /* If the object is an array, transfer rank times:
1306 (null pointer, name, stride, lbound, ubound) */
1308 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1310 NML_FIRST_ARG (dt_parm_addr
);
1311 NML_ADD_ARG (IARG (n_dim
));
1312 NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
));
1313 NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
));
1314 NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1315 tmp
= build_function_call_expr (iocall
[IOCALL_SET_NML_VAL_DIM
], args
);
1316 gfc_add_expr_to_block (block
, tmp
);
1319 if (ts
->type
== BT_DERIVED
)
1323 /* Provide the RECORD_TYPE to build component references. */
1325 tree expr
= build_fold_indirect_ref (addr_expr
);
1327 for (cmp
= ts
->derived
->components
; cmp
; cmp
= cmp
->next
)
1329 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1330 transfer_namelist_element (block
,
1333 gfc_free (full_name
);
1340 #undef NML_FIRST_ARG
1342 /* Create a data transfer statement. Not all of the fields are valid
1343 for both reading and writing, but improper use has been filtered
1347 build_dt (tree function
, gfc_code
* code
)
1349 stmtblock_t block
, post_block
, post_end_block
;
1354 unsigned int mask
= 0;
1356 gfc_start_block (&block
);
1357 gfc_init_block (&post_block
);
1358 gfc_init_block (&post_end_block
);
1360 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1362 set_error_locus (&block
, var
, &code
->loc
);
1364 if (last_dt
== IOLENGTH
)
1368 inq
= code
->ext
.inquire
;
1370 /* First check that preconditions are met. */
1371 gcc_assert (inq
!= NULL
);
1372 gcc_assert (inq
->iolength
!= NULL
);
1374 /* Connect to the iolength variable. */
1375 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1376 IOPARM_dt_iolength
, inq
->iolength
);
1382 gcc_assert (dt
!= NULL
);
1385 if (dt
&& dt
->io_unit
)
1387 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1389 mask
|= set_internal_unit (&block
, var
, dt
->io_unit
);
1390 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1393 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1396 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1401 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1404 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1407 if (dt
->format_expr
)
1408 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1411 if (dt
->format_label
)
1413 if (dt
->format_label
== &format_asterisk
)
1414 mask
|= IOPARM_dt_list_format
;
1416 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1417 dt
->format_label
->format
);
1421 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1425 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1426 IOPARM_common_iostat
, dt
->iostat
);
1429 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1430 IOPARM_dt_size
, dt
->size
);
1433 mask
|= IOPARM_common_err
;
1436 mask
|= IOPARM_common_eor
;
1439 mask
|= IOPARM_common_end
;
1443 if (dt
->format_expr
|| dt
->format_label
)
1444 gfc_internal_error ("build_dt: format with namelist");
1446 nmlname
= gfc_new_nml_name_expr (dt
->namelist
->name
);
1448 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1451 if (last_dt
== READ
)
1452 mask
|= IOPARM_dt_namelist_read_mode
;
1454 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1458 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1459 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1463 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1466 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1468 tmp
= build_fold_addr_expr (var
);
1469 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1470 tmp
= build_function_call_expr (function
, tmp
);
1471 gfc_add_expr_to_block (&block
, tmp
);
1473 gfc_add_block_to_block (&block
, &post_block
);
1476 dt_post_end_block
= &post_end_block
;
1478 gfc_add_expr_to_block (&block
, gfc_trans_code (code
->block
->next
));
1481 dt_post_end_block
= NULL
;
1483 return gfc_finish_block (&block
);
1487 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1488 this as a third sort of data transfer statement, except that
1489 lengths are summed instead of actually transferring any data. */
1492 gfc_trans_iolength (gfc_code
* code
)
1495 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1499 /* Translate a READ statement. */
1502 gfc_trans_read (gfc_code
* code
)
1505 return build_dt (iocall
[IOCALL_READ
], code
);
1509 /* Translate a WRITE statement */
1512 gfc_trans_write (gfc_code
* code
)
1515 return build_dt (iocall
[IOCALL_WRITE
], code
);
1519 /* Finish a data transfer statement. */
1522 gfc_trans_dt_end (gfc_code
* code
)
1527 gfc_init_block (&block
);
1532 function
= iocall
[IOCALL_READ_DONE
];
1536 function
= iocall
[IOCALL_WRITE_DONE
];
1540 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1547 tmp
= build_fold_addr_expr (dt_parm
);
1548 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1549 tmp
= build_function_call_expr (function
, tmp
);
1550 gfc_add_expr_to_block (&block
, tmp
);
1551 gfc_add_block_to_block (&block
, dt_post_end_block
);
1552 gfc_init_block (dt_post_end_block
);
1554 if (last_dt
!= IOLENGTH
)
1556 gcc_assert (code
->ext
.dt
!= NULL
);
1557 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1558 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1561 return gfc_finish_block (&block
);
1565 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
);
1567 /* Given an array field in a derived type variable, generate the code
1568 for the loop that iterates over array elements, and the code that
1569 accesses those array elements. Use transfer_expr to generate code
1570 for transferring that element. Because elements may also be
1571 derived types, transfer_expr and transfer_array_component are mutually
1575 transfer_array_component (tree expr
, gfc_component
* cm
)
1585 gfc_start_block (&block
);
1586 gfc_init_se (&se
, NULL
);
1588 /* Create and initialize Scalarization Status. Unlike in
1589 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1590 care of this task, because we don't have a gfc_expr at hand.
1591 Build one manually, as in gfc_trans_subarray_assign. */
1594 ss
->type
= GFC_SS_COMPONENT
;
1596 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1597 ss
->next
= gfc_ss_terminator
;
1598 ss
->data
.info
.dimen
= cm
->as
->rank
;
1599 ss
->data
.info
.descriptor
= expr
;
1600 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1601 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1602 for (n
= 0; n
< cm
->as
->rank
; n
++)
1604 ss
->data
.info
.dim
[n
] = n
;
1605 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1606 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1608 mpz_init (ss
->shape
[n
]);
1609 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1610 cm
->as
->lower
[n
]->value
.integer
);
1611 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1614 /* Once we got ss, we use scalarizer to create the loop. */
1616 gfc_init_loopinfo (&loop
);
1617 gfc_add_ss_to_loop (&loop
, ss
);
1618 gfc_conv_ss_startstride (&loop
);
1619 gfc_conv_loop_setup (&loop
);
1620 gfc_mark_ss_chain_used (ss
, 1);
1621 gfc_start_scalarized_body (&loop
, &body
);
1623 gfc_copy_loopinfo_to_se (&se
, &loop
);
1626 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1628 gfc_conv_tmp_array_ref (&se
);
1630 /* Now se.expr contains an element of the array. Take the address and pass
1631 it to the IO routines. */
1632 tmp
= build_fold_addr_expr (se
.expr
);
1633 transfer_expr (&se
, &cm
->ts
, tmp
);
1635 /* We are done now with the loop body. Wrap up the scalarizer and
1638 gfc_add_block_to_block (&body
, &se
.pre
);
1639 gfc_add_block_to_block (&body
, &se
.post
);
1641 gfc_trans_scalarizing_loops (&loop
, &body
);
1643 gfc_add_block_to_block (&block
, &loop
.pre
);
1644 gfc_add_block_to_block (&block
, &loop
.post
);
1646 for (n
= 0; n
< cm
->as
->rank
; n
++)
1647 mpz_clear (ss
->shape
[n
]);
1648 gfc_free (ss
->shape
);
1650 gfc_cleanup_loop (&loop
);
1652 return gfc_finish_block (&block
);
1655 /* Generate the call for a scalar transfer node. */
1658 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1660 tree args
, tmp
, function
, arg2
, field
, expr
;
1671 arg2
= build_int_cst (NULL_TREE
, kind
);
1672 function
= iocall
[IOCALL_X_INTEGER
];
1676 arg2
= build_int_cst (NULL_TREE
, kind
);
1677 function
= iocall
[IOCALL_X_REAL
];
1681 arg2
= build_int_cst (NULL_TREE
, kind
);
1682 function
= iocall
[IOCALL_X_COMPLEX
];
1686 arg2
= build_int_cst (NULL_TREE
, kind
);
1687 function
= iocall
[IOCALL_X_LOGICAL
];
1691 if (se
->string_length
)
1692 arg2
= se
->string_length
;
1695 tmp
= build_fold_indirect_ref (addr_expr
);
1696 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
1697 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
1699 function
= iocall
[IOCALL_X_CHARACTER
];
1703 /* Recurse into the elements of the derived type. */
1704 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
1705 expr
= build_fold_indirect_ref (expr
);
1707 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1709 field
= c
->backend_decl
;
1710 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
1712 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), expr
, field
,
1717 tmp
= transfer_array_component (tmp
, c
);
1718 gfc_add_expr_to_block (&se
->pre
, tmp
);
1723 tmp
= build_fold_addr_expr (tmp
);
1724 transfer_expr (se
, &c
->ts
, tmp
);
1730 internal_error ("Bad IO basetype (%d)", ts
->type
);
1733 tmp
= build_fold_addr_expr (dt_parm
);
1734 args
= gfc_chainon_list (NULL_TREE
, tmp
);
1735 args
= gfc_chainon_list (args
, addr_expr
);
1736 args
= gfc_chainon_list (args
, arg2
);
1738 tmp
= build_function_call_expr (function
, args
);
1739 gfc_add_expr_to_block (&se
->pre
, tmp
);
1740 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1745 /* Generate a call to pass an array descriptor to the IO library. The
1746 array should be of one of the intrinsic types. */
1749 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1751 tree args
, tmp
, charlen_arg
, kind_arg
;
1753 if (ts
->type
== BT_CHARACTER
)
1754 charlen_arg
= se
->string_length
;
1756 charlen_arg
= build_int_cstu (NULL_TREE
, 0);
1758 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
1760 tmp
= build_fold_addr_expr (dt_parm
);
1761 args
= gfc_chainon_list (NULL_TREE
, tmp
);
1762 args
= gfc_chainon_list (args
, addr_expr
);
1763 args
= gfc_chainon_list (args
, kind_arg
);
1764 args
= gfc_chainon_list (args
, charlen_arg
);
1765 tmp
= build_function_call_expr (iocall
[IOCALL_X_ARRAY
], args
);
1766 gfc_add_expr_to_block (&se
->pre
, tmp
);
1767 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1771 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1774 gfc_trans_transfer (gfc_code
* code
)
1776 stmtblock_t block
, body
;
1784 gfc_start_block (&block
);
1785 gfc_init_block (&body
);
1788 ss
= gfc_walk_expr (expr
);
1791 gfc_init_se (&se
, NULL
);
1793 if (ss
== gfc_ss_terminator
)
1795 /* Transfer a scalar value. */
1796 gfc_conv_expr_reference (&se
, expr
);
1797 transfer_expr (&se
, &expr
->ts
, se
.expr
);
1801 /* Transfer an array. If it is an array of an intrinsic
1802 type, pass the descriptor to the library. Otherwise
1803 scalarize the transfer. */
1806 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
1808 gcc_assert (ref
->type
== REF_ARRAY
);
1811 if (expr
->ts
.type
!= BT_DERIVED
&& ref
&& ref
->next
== NULL
)
1813 /* Get the descriptor. */
1814 gfc_conv_expr_descriptor (&se
, expr
, ss
);
1815 tmp
= build_fold_addr_expr (se
.expr
);
1816 transfer_array_desc (&se
, &expr
->ts
, tmp
);
1817 goto finish_block_label
;
1820 /* Initialize the scalarizer. */
1821 gfc_init_loopinfo (&loop
);
1822 gfc_add_ss_to_loop (&loop
, ss
);
1824 /* Initialize the loop. */
1825 gfc_conv_ss_startstride (&loop
);
1826 gfc_conv_loop_setup (&loop
);
1828 /* The main loop body. */
1829 gfc_mark_ss_chain_used (ss
, 1);
1830 gfc_start_scalarized_body (&loop
, &body
);
1832 gfc_copy_loopinfo_to_se (&se
, &loop
);
1835 gfc_conv_expr_reference (&se
, expr
);
1836 transfer_expr (&se
, &expr
->ts
, se
.expr
);
1841 gfc_add_block_to_block (&body
, &se
.pre
);
1842 gfc_add_block_to_block (&body
, &se
.post
);
1845 tmp
= gfc_finish_block (&body
);
1848 gcc_assert (se
.ss
== gfc_ss_terminator
);
1849 gfc_trans_scalarizing_loops (&loop
, &body
);
1851 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1852 tmp
= gfc_finish_block (&loop
.pre
);
1853 gfc_cleanup_loop (&loop
);
1856 gfc_add_expr_to_block (&block
, tmp
);
1858 return gfc_finish_block (&block
);
1861 #include "gt-fortran-trans-io.h"