1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
26 #include "coretypes.h"
28 #include "tree-gimple.h"
34 #include "trans-stmt.h"
35 #include "trans-array.h"
36 #include "trans-types.h"
37 #include "trans-const.h"
39 /* Members of the ioparm structure. */
67 typedef struct gfc_st_parameter_field
GTY(())
71 enum ioparam_type param_type
;
72 enum iofield_type type
;
76 gfc_st_parameter_field
;
78 typedef struct gfc_st_parameter
GTY(())
87 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
93 static GTY(()) gfc_st_parameter st_parameter
[] =
103 static GTY(()) gfc_st_parameter_field st_parameter_field
[] =
105 #define IOPARM(param_type, name, mask, type) \
106 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
107 #include "ioparm.def"
109 { NULL
, 0, 0, 0, NULL
, NULL
}
112 /* Library I/O subroutines */
130 IOCALL_IOLENGTH_DONE
,
136 IOCALL_SET_NML_VAL_DIM
,
140 static GTY(()) tree iocall
[IOCALL_NUM
];
142 /* Variable for keeping track of what the last data transfer statement
143 was. Used for deciding which subroutine to call when the data
144 transfer is complete. */
145 static enum { READ
, WRITE
, IOLENGTH
} last_dt
;
147 /* The data transfer parameter block that should be shared by all
148 data transfer calls belonging to the same read/write/iolength. */
149 static GTY(()) tree dt_parm
;
150 static stmtblock_t
*dt_post_end_block
;
153 gfc_build_st_parameter (enum ioparam_type ptype
, tree
*types
)
156 gfc_st_parameter_field
*p
;
159 tree t
= make_node (RECORD_TYPE
);
161 len
= strlen (st_parameter
[ptype
].name
);
162 gcc_assert (len
<= sizeof (name
) - sizeof ("__st_parameter_"));
163 memcpy (name
, "__st_parameter_", sizeof ("__st_parameter_"));
164 memcpy (name
+ sizeof ("__st_parameter_") - 1, st_parameter
[ptype
].name
,
166 TYPE_NAME (t
) = get_identifier (name
);
168 for (type
= 0, p
= st_parameter_field
; type
< IOPARM_field_num
; type
++, p
++)
169 if (p
->param_type
== ptype
)
172 case IOPARM_type_int4
:
173 case IOPARM_type_intio
:
174 case IOPARM_type_pint4
:
175 case IOPARM_type_pintio
:
176 case IOPARM_type_parray
:
177 case IOPARM_type_pchar
:
178 case IOPARM_type_pad
:
179 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
180 get_identifier (p
->name
),
183 case IOPARM_type_char1
:
184 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
185 get_identifier (p
->name
),
188 case IOPARM_type_char2
:
189 len
= strlen (p
->name
);
190 gcc_assert (len
<= sizeof (name
) - sizeof ("_len"));
191 memcpy (name
, p
->name
, len
);
192 memcpy (name
+ len
, "_len", sizeof ("_len"));
193 p
->field_len
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
194 get_identifier (name
),
195 gfc_charlen_type_node
);
196 if (p
->type
== IOPARM_type_char2
)
197 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
198 get_identifier (p
->name
),
201 case IOPARM_type_common
:
203 = gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
204 get_identifier (p
->name
),
205 st_parameter
[IOPARM_ptype_common
].type
);
207 case IOPARM_type_num
:
212 st_parameter
[ptype
].type
= t
;
215 /* Create function decls for IO library functions. */
218 gfc_build_io_library_fndecls (void)
220 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
221 tree gfc_intio_type_node
;
222 tree parm_type
, dt_parm_type
;
223 tree gfc_c_int_type_node
;
224 HOST_WIDE_INT pad_size
;
225 enum ioparam_type ptype
;
227 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
228 types
[IOPARM_type_intio
] = gfc_intio_type_node
229 = gfc_get_int_type (gfc_intio_kind
);
230 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
231 types
[IOPARM_type_pintio
]
232 = build_pointer_type (gfc_intio_type_node
);
233 types
[IOPARM_type_parray
] = pchar_type_node
;
234 types
[IOPARM_type_pchar
] = pchar_type_node
;
235 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
236 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
237 pad_idx
= build_index_type (build_int_cst (NULL_TREE
, pad_size
));
238 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
240 /* pad actually contains pointers and integers so it needs to have an
241 alignment that is at least as large as the needed alignment for those
242 types. See the st_parameter_dt structure in libgfortran/io/io.h for
243 what really goes into this space. */
244 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
245 TYPE_ALIGN (gfc_get_int_type (gfc_max_integer_kind
)));
247 gfc_c_int_type_node
= gfc_get_int_type (gfc_c_int_kind
);
249 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
250 gfc_build_st_parameter (ptype
, types
);
252 /* Define the transfer functions. */
254 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
256 iocall
[IOCALL_X_INTEGER
] =
257 gfc_build_library_function_decl (get_identifier
258 (PREFIX("transfer_integer")),
259 void_type_node
, 3, dt_parm_type
,
260 pvoid_type_node
, gfc_int4_type_node
);
262 iocall
[IOCALL_X_LOGICAL
] =
263 gfc_build_library_function_decl (get_identifier
264 (PREFIX("transfer_logical")),
265 void_type_node
, 3, dt_parm_type
,
266 pvoid_type_node
, gfc_int4_type_node
);
268 iocall
[IOCALL_X_CHARACTER
] =
269 gfc_build_library_function_decl (get_identifier
270 (PREFIX("transfer_character")),
271 void_type_node
, 3, dt_parm_type
,
272 pvoid_type_node
, gfc_int4_type_node
);
274 iocall
[IOCALL_X_REAL
] =
275 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
276 void_type_node
, 3, dt_parm_type
,
277 pvoid_type_node
, gfc_int4_type_node
);
279 iocall
[IOCALL_X_COMPLEX
] =
280 gfc_build_library_function_decl (get_identifier
281 (PREFIX("transfer_complex")),
282 void_type_node
, 3, dt_parm_type
,
283 pvoid_type_node
, gfc_int4_type_node
);
285 iocall
[IOCALL_X_ARRAY
] =
286 gfc_build_library_function_decl (get_identifier
287 (PREFIX("transfer_array")),
288 void_type_node
, 4, dt_parm_type
,
289 pvoid_type_node
, gfc_c_int_type_node
,
290 gfc_charlen_type_node
);
292 /* Library entry points */
294 iocall
[IOCALL_READ
] =
295 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
296 void_type_node
, 1, dt_parm_type
);
298 iocall
[IOCALL_WRITE
] =
299 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
300 void_type_node
, 1, dt_parm_type
);
302 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
303 iocall
[IOCALL_OPEN
] =
304 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
305 void_type_node
, 1, parm_type
);
308 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
309 iocall
[IOCALL_CLOSE
] =
310 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
311 void_type_node
, 1, parm_type
);
313 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
314 iocall
[IOCALL_INQUIRE
] =
315 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
316 gfc_int4_type_node
, 1, parm_type
);
318 iocall
[IOCALL_IOLENGTH
] =
319 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
320 void_type_node
, 1, dt_parm_type
);
322 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
323 iocall
[IOCALL_REWIND
] =
324 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
325 gfc_int4_type_node
, 1, parm_type
);
327 iocall
[IOCALL_BACKSPACE
] =
328 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
329 gfc_int4_type_node
, 1, parm_type
);
331 iocall
[IOCALL_ENDFILE
] =
332 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
333 gfc_int4_type_node
, 1, parm_type
);
335 iocall
[IOCALL_FLUSH
] =
336 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
337 gfc_int4_type_node
, 1, parm_type
);
339 /* Library helpers */
341 iocall
[IOCALL_READ_DONE
] =
342 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
343 gfc_int4_type_node
, 1, dt_parm_type
);
345 iocall
[IOCALL_WRITE_DONE
] =
346 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
347 gfc_int4_type_node
, 1, dt_parm_type
);
349 iocall
[IOCALL_IOLENGTH_DONE
] =
350 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
351 gfc_int4_type_node
, 1, dt_parm_type
);
354 iocall
[IOCALL_SET_NML_VAL
] =
355 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
356 void_type_node
, 6, dt_parm_type
,
357 pvoid_type_node
, pvoid_type_node
,
358 gfc_int4_type_node
, gfc_charlen_type_node
,
361 iocall
[IOCALL_SET_NML_VAL_DIM
] =
362 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
363 void_type_node
, 5, dt_parm_type
,
364 gfc_int4_type_node
, gfc_int4_type_node
,
365 gfc_int4_type_node
, gfc_int4_type_node
);
369 /* Generate code to store an integer constant into the
370 st_parameter_XXX structure. */
373 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
377 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
379 if (p
->param_type
== IOPARM_ptype_common
)
380 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
381 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
382 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
384 gfc_add_modify_expr (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
389 /* Generate code to store a non-string I/O parameter into the
390 st_parameter_XXX structure. This is a pass by value. */
393 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
398 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
400 gfc_init_se (&se
, NULL
);
401 gfc_conv_expr_type (&se
, e
, TREE_TYPE (p
->field
));
402 gfc_add_block_to_block (block
, &se
.pre
);
404 if (p
->param_type
== IOPARM_ptype_common
)
405 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
406 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
407 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
409 gfc_add_modify_expr (block
, tmp
, se
.expr
);
414 /* Generate code to store a non-string I/O parameter into the
415 st_parameter_XXX structure. This is pass by reference. */
418 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
419 tree var
, enum iofield type
, gfc_expr
*e
)
423 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
425 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
426 gfc_init_se (&se
, NULL
);
427 gfc_conv_expr_lhs (&se
, e
);
429 gfc_add_block_to_block (block
, &se
.pre
);
431 if (TYPE_MODE (TREE_TYPE (se
.expr
))
432 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
433 addr
= convert (TREE_TYPE (p
->field
),
434 build_fold_addr_expr (se
.expr
));
437 /* The type used by the library has different size
438 from the type of the variable supplied by the user.
439 Need to use a temporary. */
441 = gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
442 st_parameter_field
[type
].name
);
443 addr
= build_fold_addr_expr (tmpvar
);
444 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
445 gfc_add_modify_expr (postblock
, se
.expr
, tmp
);
448 if (p
->param_type
== IOPARM_ptype_common
)
449 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
450 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
451 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
453 gfc_add_modify_expr (block
, tmp
, addr
);
457 /* Given an array expr, find its address and length to get a string. If the
458 array is full, the string's address is the address of array's first element
459 and the length is the size of the whole array. If it is an element, the
460 string's address is the element's address and the length is the rest size of
465 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
474 sym
= e
->symtree
->n
.sym
;
475 rank
= sym
->as
->rank
- 1;
477 if (e
->ref
->u
.ar
.type
== AR_FULL
)
479 se
->expr
= gfc_get_symbol_decl (sym
);
480 se
->expr
= gfc_conv_array_data (se
->expr
);
484 gfc_conv_expr (se
, e
);
487 array
= sym
->backend_decl
;
488 type
= TREE_TYPE (array
);
490 if (GFC_ARRAY_TYPE_P (type
))
491 size
= GFC_TYPE_ARRAY_SIZE (type
);
494 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
495 size
= gfc_conv_array_stride (array
, rank
);
496 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
497 gfc_conv_array_ubound (array
, rank
),
498 gfc_conv_array_lbound (array
, rank
));
499 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
501 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
506 /* If it is an element, we need the its address and size of the rest. */
507 if (e
->ref
->u
.ar
.type
== AR_ELEMENT
)
509 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
510 TREE_OPERAND (se
->expr
, 1));
511 se
->expr
= build_fold_addr_expr (se
->expr
);
514 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
515 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
517 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
521 /* Generate code to store a string and its length into the
522 st_parameter_XXX structure. */
525 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
526 enum iofield type
, gfc_expr
* e
)
532 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
534 gfc_init_se (&se
, NULL
);
536 if (p
->param_type
== IOPARM_ptype_common
)
537 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
538 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
539 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
541 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
544 /* Integer variable assigned a format label. */
545 if (e
->ts
.type
== BT_INTEGER
&& e
->symtree
->n
.sym
->attr
.assign
== 1)
549 gfc_conv_label_variable (&se
, e
);
550 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
551 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
,
552 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
554 asprintf(&msg
, "Label assigned to variable '%s' is not a format label",
556 gfc_trans_runtime_check (tmp
, msg
, &se
.pre
, &e
->where
);
559 gfc_add_modify_expr (&se
.pre
, io
,
560 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
561 gfc_add_modify_expr (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
565 /* General character. */
566 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
567 gfc_conv_expr (&se
, e
);
568 /* Array assigned Hollerith constant or character array. */
569 else if (e
->symtree
&& (e
->symtree
->n
.sym
->as
->rank
> 0))
570 gfc_convert_array_to_string (&se
, e
);
574 gfc_conv_string_parameter (&se
);
575 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
576 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
579 gfc_add_block_to_block (block
, &se
.pre
);
580 gfc_add_block_to_block (postblock
, &se
.post
);
585 /* Generate code to store the character (array) and the character length
586 for an internal unit. */
589 set_internal_unit (stmtblock_t
* block
, tree var
, gfc_expr
* e
)
596 gfc_st_parameter_field
*p
;
599 gfc_init_se (&se
, NULL
);
601 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
603 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
605 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
607 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
608 desc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
611 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
613 /* Character scalars. */
616 gfc_conv_expr (&se
, e
);
617 gfc_conv_string_parameter (&se
);
619 se
.expr
= build_int_cst (pchar_type_node
, 0);
622 /* Character array. */
623 else if (e
->rank
> 0)
625 se
.ss
= gfc_walk_expr (e
);
627 /* Return the data pointer and rank from the descriptor. */
628 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
629 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
630 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
635 /* The cast is needed for character substrings and the descriptor
637 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
638 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
639 gfc_add_modify_expr (&se
.pre
, desc
, se
.expr
);
641 gfc_add_block_to_block (block
, &se
.pre
);
645 /* Add a case to a IO-result switch. */
648 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
653 return; /* No label, no case */
655 value
= build_int_cst (NULL_TREE
, label_value
);
657 /* Make a backend label for this case. */
658 tmp
= gfc_build_label_decl (NULL_TREE
);
660 /* And the case itself. */
661 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
662 gfc_add_expr_to_block (body
, tmp
);
664 /* Jump to the label. */
665 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
666 gfc_add_expr_to_block (body
, tmp
);
670 /* Generate a switch statement that branches to the correct I/O
671 result label. The last statement of an I/O call stores the
672 result into a variable because there is often cleanup that
673 must be done before the switch, so a temporary would have to
674 be created anyway. */
677 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
678 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
682 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
684 /* If no labels are specified, ignore the result instead
685 of building an empty switch. */
686 if (err_label
== NULL
688 && eor_label
== NULL
)
691 /* Build a switch statement. */
692 gfc_start_block (&body
);
694 /* The label values here must be the same as the values
695 in the library_return enum in the runtime library */
696 add_case (1, err_label
, &body
);
697 add_case (2, end_label
, &body
);
698 add_case (3, eor_label
, &body
);
700 tmp
= gfc_finish_block (&body
);
702 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
703 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
704 rc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
706 rc
= build2 (BIT_AND_EXPR
, TREE_TYPE (rc
), rc
,
707 build_int_cst (TREE_TYPE (rc
), IOPARM_common_libreturn_mask
));
709 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
711 gfc_add_expr_to_block (block
, tmp
);
715 /* Store the current file and line number to variables so that if a
716 library call goes awry, we can tell the user where the problem is. */
719 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
722 tree str
, locus_file
;
724 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
726 locus_file
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
727 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
728 locus_file
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), locus_file
,
729 p
->field
, NULL_TREE
);
731 str
= gfc_build_cstring_const (f
->filename
);
733 str
= gfc_build_addr_expr (pchar_type_node
, str
);
734 gfc_add_modify_expr (block
, locus_file
, str
);
736 #ifdef USE_MAPPED_LOCATION
737 line
= LOCATION_LINE (where
->lb
->location
);
739 line
= where
->lb
->linenum
;
741 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
745 /* Translate an OPEN statement. */
748 gfc_trans_open (gfc_code
* code
)
750 stmtblock_t block
, post_block
;
753 unsigned int mask
= 0;
755 gfc_start_block (&block
);
756 gfc_init_block (&post_block
);
758 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
760 set_error_locus (&block
, var
, &code
->loc
);
764 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
766 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
769 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
772 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
776 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
780 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
783 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
786 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
790 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
794 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
798 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
802 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
805 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
809 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
813 mask
|= IOPARM_common_err
;
816 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
819 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
821 tmp
= build_fold_addr_expr (var
);
822 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
823 tmp
= build_function_call_expr (iocall
[IOCALL_OPEN
], tmp
);
824 gfc_add_expr_to_block (&block
, tmp
);
826 gfc_add_block_to_block (&block
, &post_block
);
828 io_result (&block
, var
, p
->err
, NULL
, NULL
);
830 return gfc_finish_block (&block
);
834 /* Translate a CLOSE statement. */
837 gfc_trans_close (gfc_code
* code
)
839 stmtblock_t block
, post_block
;
842 unsigned int mask
= 0;
844 gfc_start_block (&block
);
845 gfc_init_block (&post_block
);
847 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
849 set_error_locus (&block
, var
, &code
->loc
);
853 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
855 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
858 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
862 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
866 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
870 mask
|= IOPARM_common_err
;
872 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
874 tmp
= build_fold_addr_expr (var
);
875 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
876 tmp
= build_function_call_expr (iocall
[IOCALL_CLOSE
], tmp
);
877 gfc_add_expr_to_block (&block
, tmp
);
879 gfc_add_block_to_block (&block
, &post_block
);
881 io_result (&block
, var
, p
->err
, NULL
, NULL
);
883 return gfc_finish_block (&block
);
887 /* Common subroutine for building a file positioning statement. */
890 build_filepos (tree function
, gfc_code
* code
)
892 stmtblock_t block
, post_block
;
895 unsigned int mask
= 0;
897 p
= code
->ext
.filepos
;
899 gfc_start_block (&block
);
900 gfc_init_block (&post_block
);
902 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
905 set_error_locus (&block
, var
, &code
->loc
);
908 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
910 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
913 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
917 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
921 mask
|= IOPARM_common_err
;
923 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
925 tmp
= build_fold_addr_expr (var
);
926 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
927 tmp
= build_function_call_expr (function
, tmp
);
928 gfc_add_expr_to_block (&block
, tmp
);
930 gfc_add_block_to_block (&block
, &post_block
);
932 io_result (&block
, var
, p
->err
, NULL
, NULL
);
934 return gfc_finish_block (&block
);
938 /* Translate a BACKSPACE statement. */
941 gfc_trans_backspace (gfc_code
* code
)
943 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
947 /* Translate an ENDFILE statement. */
950 gfc_trans_endfile (gfc_code
* code
)
952 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
956 /* Translate a REWIND statement. */
959 gfc_trans_rewind (gfc_code
* code
)
961 return build_filepos (iocall
[IOCALL_REWIND
], code
);
965 /* Translate a FLUSH statement. */
968 gfc_trans_flush (gfc_code
* code
)
970 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
974 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
977 gfc_trans_inquire (gfc_code
* code
)
979 stmtblock_t block
, post_block
;
982 unsigned int mask
= 0;
984 gfc_start_block (&block
);
985 gfc_init_block (&post_block
);
987 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
990 set_error_locus (&block
, var
, &code
->loc
);
991 p
= code
->ext
.inquire
;
994 if (p
->unit
&& p
->file
)
995 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
998 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1000 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1003 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1007 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1011 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1015 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1019 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1023 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1027 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1031 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1035 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1039 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1043 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1047 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1051 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1055 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1059 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1060 IOPARM_inquire_recl_out
, p
->recl
);
1063 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1064 IOPARM_inquire_nextrec
, p
->nextrec
);
1067 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1071 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1075 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1079 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1083 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1087 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1091 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1095 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1099 mask
|= IOPARM_common_err
;
1102 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1106 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1107 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1109 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1111 tmp
= build_fold_addr_expr (var
);
1112 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1113 tmp
= build_function_call_expr (iocall
[IOCALL_INQUIRE
], tmp
);
1114 gfc_add_expr_to_block (&block
, tmp
);
1116 gfc_add_block_to_block (&block
, &post_block
);
1118 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1120 return gfc_finish_block (&block
);
1124 gfc_new_nml_name_expr (const char * name
)
1126 gfc_expr
* nml_name
;
1128 nml_name
= gfc_get_expr();
1129 nml_name
->ref
= NULL
;
1130 nml_name
->expr_type
= EXPR_CONSTANT
;
1131 nml_name
->ts
.kind
= gfc_default_character_kind
;
1132 nml_name
->ts
.type
= BT_CHARACTER
;
1133 nml_name
->value
.character
.length
= strlen(name
);
1134 nml_name
->value
.character
.string
= gfc_getmem (strlen (name
) + 1);
1135 strcpy (nml_name
->value
.character
.string
, name
);
1140 /* nml_full_name builds up the fully qualified name of a
1141 derived type component. */
1144 nml_full_name (const char* var_name
, const char* cmp_name
)
1146 int full_name_length
;
1149 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1150 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1151 strcpy (full_name
, var_name
);
1152 full_name
= strcat (full_name
, "%");
1153 full_name
= strcat (full_name
, cmp_name
);
1157 /* nml_get_addr_expr builds an address expression from the
1158 gfc_symbol or gfc_component backend_decl's. An offset is
1159 provided so that the address of an element of an array of
1160 derived types is returned. This is used in the runtime to
1161 determine that span of the derived type. */
1164 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1167 tree decl
= NULL_TREE
;
1171 int dummy_arg_flagged
;
1175 sym
->attr
.referenced
= 1;
1176 decl
= gfc_get_symbol_decl (sym
);
1179 decl
= c
->backend_decl
;
1181 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1182 || TREE_CODE (decl
) == VAR_DECL
1183 || TREE_CODE (decl
) == PARM_DECL
)
1184 || TREE_CODE (decl
) == COMPONENT_REF
));
1188 /* Build indirect reference, if dummy argument. */
1190 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1192 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref (tmp
) : tmp
;
1194 /* If an array, set flag and use indirect ref. if built. */
1196 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1197 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1202 /* Treat the component of a derived type, using base_addr for
1203 the derived type. */
1205 if (TREE_CODE (decl
) == FIELD_DECL
)
1206 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1207 base_addr
, tmp
, NULL_TREE
);
1209 /* If we have a derived type component, a reference to the first
1210 element of the array is built. This is done so that base_addr,
1211 used in the build of the component reference, always points to
1215 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
);
1217 /* Now build the address expression. */
1219 tmp
= build_fold_addr_expr (tmp
);
1221 /* If scalar dummy, resolve indirect reference now. */
1223 if (dummy_arg_flagged
&& !array_flagged
)
1224 tmp
= build_fold_indirect_ref (tmp
);
1226 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1231 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1232 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1233 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1235 #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
1236 #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
1237 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1240 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1241 gfc_symbol
* sym
, gfc_component
* c
,
1244 gfc_typespec
* ts
= NULL
;
1245 gfc_array_spec
* as
= NULL
;
1246 tree addr_expr
= NULL
;
1257 gcc_assert (sym
|| c
);
1259 /* Build the namelist object name. */
1261 string
= gfc_build_cstring_const (var_name
);
1262 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1264 /* Build ts, as and data address using symbol or component. */
1266 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1267 as
= (sym
) ? sym
->as
: c
->as
;
1269 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1276 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1277 dtype
= gfc_get_dtype (dt
);
1281 itype
= GFC_DTYPE_UNKNOWN
;
1287 itype
= GFC_DTYPE_INTEGER
;
1290 itype
= GFC_DTYPE_LOGICAL
;
1293 itype
= GFC_DTYPE_REAL
;
1296 itype
= GFC_DTYPE_COMPLEX
;
1299 itype
= GFC_DTYPE_DERIVED
;
1302 itype
= GFC_DTYPE_CHARACTER
;
1308 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1311 /* Build up the arguments for the transfer call.
1312 The call for the scalar part transfers:
1313 (address, name, type, kind or string_length, dtype) */
1315 dt_parm_addr
= build_fold_addr_expr (dt_parm
);
1316 NML_FIRST_ARG (dt_parm_addr
);
1317 NML_ADD_ARG (addr_expr
);
1318 NML_ADD_ARG (string
);
1319 NML_ADD_ARG (IARG (ts
->kind
));
1321 if (ts
->type
== BT_CHARACTER
)
1322 NML_ADD_ARG (ts
->cl
->backend_decl
);
1324 NML_ADD_ARG (build_int_cst (gfc_charlen_type_node
, 0));
1326 NML_ADD_ARG (dtype
);
1327 tmp
= build_function_call_expr (iocall
[IOCALL_SET_NML_VAL
], args
);
1328 gfc_add_expr_to_block (block
, tmp
);
1330 /* If the object is an array, transfer rank times:
1331 (null pointer, name, stride, lbound, ubound) */
1333 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1335 NML_FIRST_ARG (dt_parm_addr
);
1336 NML_ADD_ARG (IARG (n_dim
));
1337 NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
));
1338 NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
));
1339 NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1340 tmp
= build_function_call_expr (iocall
[IOCALL_SET_NML_VAL_DIM
], args
);
1341 gfc_add_expr_to_block (block
, tmp
);
1344 if (ts
->type
== BT_DERIVED
)
1348 /* Provide the RECORD_TYPE to build component references. */
1350 tree expr
= build_fold_indirect_ref (addr_expr
);
1352 for (cmp
= ts
->derived
->components
; cmp
; cmp
= cmp
->next
)
1354 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1355 transfer_namelist_element (block
,
1358 gfc_free (full_name
);
1365 #undef NML_FIRST_ARG
1367 /* Create a data transfer statement. Not all of the fields are valid
1368 for both reading and writing, but improper use has been filtered
1372 build_dt (tree function
, gfc_code
* code
)
1374 stmtblock_t block
, post_block
, post_end_block
;
1379 unsigned int mask
= 0;
1381 gfc_start_block (&block
);
1382 gfc_init_block (&post_block
);
1383 gfc_init_block (&post_end_block
);
1385 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1387 set_error_locus (&block
, var
, &code
->loc
);
1389 if (last_dt
== IOLENGTH
)
1393 inq
= code
->ext
.inquire
;
1395 /* First check that preconditions are met. */
1396 gcc_assert (inq
!= NULL
);
1397 gcc_assert (inq
->iolength
!= NULL
);
1399 /* Connect to the iolength variable. */
1400 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1401 IOPARM_dt_iolength
, inq
->iolength
);
1407 gcc_assert (dt
!= NULL
);
1410 if (dt
&& dt
->io_unit
)
1412 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1414 mask
|= set_internal_unit (&block
, var
, dt
->io_unit
);
1415 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1418 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1421 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1426 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1429 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1432 if (dt
->format_expr
)
1433 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1436 if (dt
->format_label
)
1438 if (dt
->format_label
== &format_asterisk
)
1439 mask
|= IOPARM_dt_list_format
;
1441 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1442 dt
->format_label
->format
);
1446 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1450 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1451 IOPARM_common_iostat
, dt
->iostat
);
1454 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1455 IOPARM_dt_size
, dt
->size
);
1458 mask
|= IOPARM_common_err
;
1461 mask
|= IOPARM_common_eor
;
1464 mask
|= IOPARM_common_end
;
1468 if (dt
->format_expr
|| dt
->format_label
)
1469 gfc_internal_error ("build_dt: format with namelist");
1471 nmlname
= gfc_new_nml_name_expr (dt
->namelist
->name
);
1473 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1476 if (last_dt
== READ
)
1477 mask
|= IOPARM_dt_namelist_read_mode
;
1479 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1483 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1484 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1488 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1491 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1493 tmp
= build_fold_addr_expr (var
);
1494 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1495 tmp
= build_function_call_expr (function
, tmp
);
1496 gfc_add_expr_to_block (&block
, tmp
);
1498 gfc_add_block_to_block (&block
, &post_block
);
1501 dt_post_end_block
= &post_end_block
;
1503 gfc_add_expr_to_block (&block
, gfc_trans_code (code
->block
->next
));
1506 dt_post_end_block
= NULL
;
1508 return gfc_finish_block (&block
);
1512 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1513 this as a third sort of data transfer statement, except that
1514 lengths are summed instead of actually transferring any data. */
1517 gfc_trans_iolength (gfc_code
* code
)
1520 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1524 /* Translate a READ statement. */
1527 gfc_trans_read (gfc_code
* code
)
1530 return build_dt (iocall
[IOCALL_READ
], code
);
1534 /* Translate a WRITE statement */
1537 gfc_trans_write (gfc_code
* code
)
1540 return build_dt (iocall
[IOCALL_WRITE
], code
);
1544 /* Finish a data transfer statement. */
1547 gfc_trans_dt_end (gfc_code
* code
)
1552 gfc_init_block (&block
);
1557 function
= iocall
[IOCALL_READ_DONE
];
1561 function
= iocall
[IOCALL_WRITE_DONE
];
1565 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1572 tmp
= build_fold_addr_expr (dt_parm
);
1573 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1574 tmp
= build_function_call_expr (function
, tmp
);
1575 gfc_add_expr_to_block (&block
, tmp
);
1576 gfc_add_block_to_block (&block
, dt_post_end_block
);
1577 gfc_init_block (dt_post_end_block
);
1579 if (last_dt
!= IOLENGTH
)
1581 gcc_assert (code
->ext
.dt
!= NULL
);
1582 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1583 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1586 return gfc_finish_block (&block
);
1590 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
);
1592 /* Given an array field in a derived type variable, generate the code
1593 for the loop that iterates over array elements, and the code that
1594 accesses those array elements. Use transfer_expr to generate code
1595 for transferring that element. Because elements may also be
1596 derived types, transfer_expr and transfer_array_component are mutually
1600 transfer_array_component (tree expr
, gfc_component
* cm
)
1610 gfc_start_block (&block
);
1611 gfc_init_se (&se
, NULL
);
1613 /* Create and initialize Scalarization Status. Unlike in
1614 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1615 care of this task, because we don't have a gfc_expr at hand.
1616 Build one manually, as in gfc_trans_subarray_assign. */
1619 ss
->type
= GFC_SS_COMPONENT
;
1621 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1622 ss
->next
= gfc_ss_terminator
;
1623 ss
->data
.info
.dimen
= cm
->as
->rank
;
1624 ss
->data
.info
.descriptor
= expr
;
1625 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1626 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1627 for (n
= 0; n
< cm
->as
->rank
; n
++)
1629 ss
->data
.info
.dim
[n
] = n
;
1630 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1631 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1633 mpz_init (ss
->shape
[n
]);
1634 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1635 cm
->as
->lower
[n
]->value
.integer
);
1636 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1639 /* Once we got ss, we use scalarizer to create the loop. */
1641 gfc_init_loopinfo (&loop
);
1642 gfc_add_ss_to_loop (&loop
, ss
);
1643 gfc_conv_ss_startstride (&loop
);
1644 gfc_conv_loop_setup (&loop
);
1645 gfc_mark_ss_chain_used (ss
, 1);
1646 gfc_start_scalarized_body (&loop
, &body
);
1648 gfc_copy_loopinfo_to_se (&se
, &loop
);
1651 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1653 gfc_conv_tmp_array_ref (&se
);
1655 /* Now se.expr contains an element of the array. Take the address and pass
1656 it to the IO routines. */
1657 tmp
= build_fold_addr_expr (se
.expr
);
1658 transfer_expr (&se
, &cm
->ts
, tmp
);
1660 /* We are done now with the loop body. Wrap up the scalarizer and
1663 gfc_add_block_to_block (&body
, &se
.pre
);
1664 gfc_add_block_to_block (&body
, &se
.post
);
1666 gfc_trans_scalarizing_loops (&loop
, &body
);
1668 gfc_add_block_to_block (&block
, &loop
.pre
);
1669 gfc_add_block_to_block (&block
, &loop
.post
);
1671 for (n
= 0; n
< cm
->as
->rank
; n
++)
1672 mpz_clear (ss
->shape
[n
]);
1673 gfc_free (ss
->shape
);
1675 gfc_cleanup_loop (&loop
);
1677 return gfc_finish_block (&block
);
1680 /* Generate the call for a scalar transfer node. */
1683 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1685 tree args
, tmp
, function
, arg2
, field
, expr
;
1696 arg2
= build_int_cst (NULL_TREE
, kind
);
1697 function
= iocall
[IOCALL_X_INTEGER
];
1701 arg2
= build_int_cst (NULL_TREE
, kind
);
1702 function
= iocall
[IOCALL_X_REAL
];
1706 arg2
= build_int_cst (NULL_TREE
, kind
);
1707 function
= iocall
[IOCALL_X_COMPLEX
];
1711 arg2
= build_int_cst (NULL_TREE
, kind
);
1712 function
= iocall
[IOCALL_X_LOGICAL
];
1717 if (se
->string_length
)
1718 arg2
= se
->string_length
;
1721 tmp
= build_fold_indirect_ref (addr_expr
);
1722 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
1723 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
1725 function
= iocall
[IOCALL_X_CHARACTER
];
1729 /* Recurse into the elements of the derived type. */
1730 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
1731 expr
= build_fold_indirect_ref (expr
);
1733 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1735 field
= c
->backend_decl
;
1736 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
1738 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), expr
, field
,
1743 tmp
= transfer_array_component (tmp
, c
);
1744 gfc_add_expr_to_block (&se
->pre
, tmp
);
1749 tmp
= build_fold_addr_expr (tmp
);
1750 transfer_expr (se
, &c
->ts
, tmp
);
1756 internal_error ("Bad IO basetype (%d)", ts
->type
);
1759 tmp
= build_fold_addr_expr (dt_parm
);
1760 args
= gfc_chainon_list (NULL_TREE
, tmp
);
1761 args
= gfc_chainon_list (args
, addr_expr
);
1762 args
= gfc_chainon_list (args
, arg2
);
1764 tmp
= build_function_call_expr (function
, args
);
1765 gfc_add_expr_to_block (&se
->pre
, tmp
);
1766 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1771 /* Generate a call to pass an array descriptor to the IO library. The
1772 array should be of one of the intrinsic types. */
1775 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1777 tree args
, tmp
, charlen_arg
, kind_arg
;
1779 if (ts
->type
== BT_CHARACTER
)
1780 charlen_arg
= se
->string_length
;
1782 charlen_arg
= build_int_cstu (NULL_TREE
, 0);
1784 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
1786 tmp
= build_fold_addr_expr (dt_parm
);
1787 args
= gfc_chainon_list (NULL_TREE
, tmp
);
1788 args
= gfc_chainon_list (args
, addr_expr
);
1789 args
= gfc_chainon_list (args
, kind_arg
);
1790 args
= gfc_chainon_list (args
, charlen_arg
);
1791 tmp
= build_function_call_expr (iocall
[IOCALL_X_ARRAY
], args
);
1792 gfc_add_expr_to_block (&se
->pre
, tmp
);
1793 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1797 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1800 gfc_trans_transfer (gfc_code
* code
)
1802 stmtblock_t block
, body
;
1810 gfc_start_block (&block
);
1811 gfc_init_block (&body
);
1814 ss
= gfc_walk_expr (expr
);
1817 gfc_init_se (&se
, NULL
);
1819 if (ss
== gfc_ss_terminator
)
1821 /* Transfer a scalar value. */
1822 gfc_conv_expr_reference (&se
, expr
);
1823 transfer_expr (&se
, &expr
->ts
, se
.expr
);
1827 /* Transfer an array. If it is an array of an intrinsic
1828 type, pass the descriptor to the library. Otherwise
1829 scalarize the transfer. */
1832 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
1834 gcc_assert (ref
->type
== REF_ARRAY
);
1837 if (expr
->ts
.type
!= BT_DERIVED
&& ref
&& ref
->next
== NULL
)
1839 /* Get the descriptor. */
1840 gfc_conv_expr_descriptor (&se
, expr
, ss
);
1841 tmp
= build_fold_addr_expr (se
.expr
);
1842 transfer_array_desc (&se
, &expr
->ts
, tmp
);
1843 goto finish_block_label
;
1846 /* Initialize the scalarizer. */
1847 gfc_init_loopinfo (&loop
);
1848 gfc_add_ss_to_loop (&loop
, ss
);
1850 /* Initialize the loop. */
1851 gfc_conv_ss_startstride (&loop
);
1852 gfc_conv_loop_setup (&loop
);
1854 /* The main loop body. */
1855 gfc_mark_ss_chain_used (ss
, 1);
1856 gfc_start_scalarized_body (&loop
, &body
);
1858 gfc_copy_loopinfo_to_se (&se
, &loop
);
1861 gfc_conv_expr_reference (&se
, expr
);
1862 transfer_expr (&se
, &expr
->ts
, se
.expr
);
1867 gfc_add_block_to_block (&body
, &se
.pre
);
1868 gfc_add_block_to_block (&body
, &se
.post
);
1871 tmp
= gfc_finish_block (&body
);
1874 gcc_assert (se
.ss
== gfc_ss_terminator
);
1875 gfc_trans_scalarizing_loops (&loop
, &body
);
1877 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1878 tmp
= gfc_finish_block (&loop
.pre
);
1879 gfc_cleanup_loop (&loop
);
1882 gfc_add_expr_to_block (&block
, tmp
);
1884 return gfc_finish_block (&block
);
1887 #include "gt-fortran-trans-io.h"