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"
38 /* Members of the ioparm structure. */
66 typedef struct gfc_st_parameter_field
GTY(())
70 enum ioparam_type param_type
;
71 enum iofield_type type
;
75 gfc_st_parameter_field
;
77 typedef struct gfc_st_parameter
GTY(())
86 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
92 static GTY(()) gfc_st_parameter st_parameter
[] =
102 static GTY(()) gfc_st_parameter_field st_parameter_field
[] =
104 #define IOPARM(param_type, name, mask, type) \
105 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
106 #include "ioparm.def"
108 { NULL
, 0, 0, 0, NULL
, NULL
}
111 /* Library I/O subroutines */
129 IOCALL_IOLENGTH_DONE
,
135 IOCALL_SET_NML_VAL_DIM
,
139 static GTY(()) tree iocall
[IOCALL_NUM
];
141 /* Variable for keeping track of what the last data transfer statement
142 was. Used for deciding which subroutine to call when the data
143 transfer is complete. */
144 static enum { READ
, WRITE
, IOLENGTH
} last_dt
;
146 /* The data transfer parameter block that should be shared by all
147 data transfer calls belonging to the same read/write/iolength. */
148 static GTY(()) tree dt_parm
;
149 static stmtblock_t
*dt_post_end_block
;
152 gfc_build_st_parameter (enum ioparam_type ptype
, tree
*types
)
155 gfc_st_parameter_field
*p
;
158 tree t
= make_node (RECORD_TYPE
);
160 len
= strlen (st_parameter
[ptype
].name
);
161 gcc_assert (len
<= sizeof (name
) - sizeof ("__st_parameter_"));
162 memcpy (name
, "__st_parameter_", sizeof ("__st_parameter_"));
163 memcpy (name
+ sizeof ("__st_parameter_") - 1, st_parameter
[ptype
].name
,
165 TYPE_NAME (t
) = get_identifier (name
);
167 for (type
= 0, p
= st_parameter_field
; type
< IOPARM_field_num
; type
++, p
++)
168 if (p
->param_type
== ptype
)
171 case IOPARM_type_int4
:
172 case IOPARM_type_intio
:
173 case IOPARM_type_pint4
:
174 case IOPARM_type_pintio
:
175 case IOPARM_type_parray
:
176 case IOPARM_type_pchar
:
177 case IOPARM_type_pad
:
178 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
179 get_identifier (p
->name
),
182 case IOPARM_type_char1
:
183 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
184 get_identifier (p
->name
),
187 case IOPARM_type_char2
:
188 len
= strlen (p
->name
);
189 gcc_assert (len
<= sizeof (name
) - sizeof ("_len"));
190 memcpy (name
, p
->name
, len
);
191 memcpy (name
+ len
, "_len", sizeof ("_len"));
192 p
->field_len
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
193 get_identifier (name
),
194 gfc_charlen_type_node
);
195 if (p
->type
== IOPARM_type_char2
)
196 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
197 get_identifier (p
->name
),
200 case IOPARM_type_common
:
202 = gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
203 get_identifier (p
->name
),
204 st_parameter
[IOPARM_ptype_common
].type
);
206 case IOPARM_type_num
:
211 st_parameter
[ptype
].type
= t
;
214 /* Create function decls for IO library functions. */
217 gfc_build_io_library_fndecls (void)
219 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
220 tree gfc_intio_type_node
;
221 tree parm_type
, dt_parm_type
;
222 tree gfc_c_int_type_node
;
223 HOST_WIDE_INT pad_size
;
224 enum ioparam_type ptype
;
226 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
227 types
[IOPARM_type_intio
] = gfc_intio_type_node
228 = gfc_get_int_type (gfc_intio_kind
);
229 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
230 types
[IOPARM_type_pintio
]
231 = build_pointer_type (gfc_intio_type_node
);
232 types
[IOPARM_type_parray
] = pchar_type_node
;
233 types
[IOPARM_type_pchar
] = pchar_type_node
;
234 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
235 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
236 pad_idx
= build_index_type (build_int_cst (NULL_TREE
, pad_size
));
237 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
239 /* pad actually contains pointers and integers so it needs to have an
240 alignment that is at least as large as the needed alignment for those
241 types. See the st_parameter_dt structure in libgfortran/io/io.h for
242 what really goes into this space. */
243 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
244 TYPE_ALIGN (gfc_get_int_type (gfc_max_integer_kind
)));
246 gfc_c_int_type_node
= gfc_get_int_type (gfc_c_int_kind
);
248 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
249 gfc_build_st_parameter (ptype
, types
);
251 /* Define the transfer functions. */
253 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
255 iocall
[IOCALL_X_INTEGER
] =
256 gfc_build_library_function_decl (get_identifier
257 (PREFIX("transfer_integer")),
258 void_type_node
, 3, dt_parm_type
,
259 pvoid_type_node
, gfc_int4_type_node
);
261 iocall
[IOCALL_X_LOGICAL
] =
262 gfc_build_library_function_decl (get_identifier
263 (PREFIX("transfer_logical")),
264 void_type_node
, 3, dt_parm_type
,
265 pvoid_type_node
, gfc_int4_type_node
);
267 iocall
[IOCALL_X_CHARACTER
] =
268 gfc_build_library_function_decl (get_identifier
269 (PREFIX("transfer_character")),
270 void_type_node
, 3, dt_parm_type
,
271 pvoid_type_node
, gfc_int4_type_node
);
273 iocall
[IOCALL_X_REAL
] =
274 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
275 void_type_node
, 3, dt_parm_type
,
276 pvoid_type_node
, gfc_int4_type_node
);
278 iocall
[IOCALL_X_COMPLEX
] =
279 gfc_build_library_function_decl (get_identifier
280 (PREFIX("transfer_complex")),
281 void_type_node
, 3, dt_parm_type
,
282 pvoid_type_node
, gfc_int4_type_node
);
284 iocall
[IOCALL_X_ARRAY
] =
285 gfc_build_library_function_decl (get_identifier
286 (PREFIX("transfer_array")),
287 void_type_node
, 4, dt_parm_type
,
288 pvoid_type_node
, gfc_c_int_type_node
,
289 gfc_charlen_type_node
);
291 /* Library entry points */
293 iocall
[IOCALL_READ
] =
294 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
295 void_type_node
, 1, dt_parm_type
);
297 iocall
[IOCALL_WRITE
] =
298 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
299 void_type_node
, 1, dt_parm_type
);
301 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
302 iocall
[IOCALL_OPEN
] =
303 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
304 void_type_node
, 1, parm_type
);
307 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
308 iocall
[IOCALL_CLOSE
] =
309 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
310 void_type_node
, 1, parm_type
);
312 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
313 iocall
[IOCALL_INQUIRE
] =
314 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
315 gfc_int4_type_node
, 1, parm_type
);
317 iocall
[IOCALL_IOLENGTH
] =
318 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
319 void_type_node
, 1, dt_parm_type
);
321 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
322 iocall
[IOCALL_REWIND
] =
323 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
324 gfc_int4_type_node
, 1, parm_type
);
326 iocall
[IOCALL_BACKSPACE
] =
327 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
328 gfc_int4_type_node
, 1, parm_type
);
330 iocall
[IOCALL_ENDFILE
] =
331 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
332 gfc_int4_type_node
, 1, parm_type
);
334 iocall
[IOCALL_FLUSH
] =
335 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
336 gfc_int4_type_node
, 1, parm_type
);
338 /* Library helpers */
340 iocall
[IOCALL_READ_DONE
] =
341 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
342 gfc_int4_type_node
, 1, dt_parm_type
);
344 iocall
[IOCALL_WRITE_DONE
] =
345 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
346 gfc_int4_type_node
, 1, dt_parm_type
);
348 iocall
[IOCALL_IOLENGTH_DONE
] =
349 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
350 gfc_int4_type_node
, 1, dt_parm_type
);
353 iocall
[IOCALL_SET_NML_VAL
] =
354 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
355 void_type_node
, 6, dt_parm_type
,
356 pvoid_type_node
, pvoid_type_node
,
357 gfc_int4_type_node
, gfc_charlen_type_node
,
360 iocall
[IOCALL_SET_NML_VAL_DIM
] =
361 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
362 void_type_node
, 5, dt_parm_type
,
363 gfc_int4_type_node
, gfc_int4_type_node
,
364 gfc_int4_type_node
, gfc_int4_type_node
);
368 /* Generate code to store an integer constant into the
369 st_parameter_XXX structure. */
372 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
376 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
378 if (p
->param_type
== IOPARM_ptype_common
)
379 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
380 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
381 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
383 gfc_add_modify_expr (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
388 /* Generate code to store a non-string I/O parameter into the
389 st_parameter_XXX structure. This is a pass by value. */
392 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
397 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
399 gfc_init_se (&se
, NULL
);
400 gfc_conv_expr_type (&se
, e
, TREE_TYPE (p
->field
));
401 gfc_add_block_to_block (block
, &se
.pre
);
403 if (p
->param_type
== IOPARM_ptype_common
)
404 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
405 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
406 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
408 gfc_add_modify_expr (block
, tmp
, se
.expr
);
413 /* Generate code to store a non-string I/O parameter into the
414 st_parameter_XXX structure. This is pass by reference. */
417 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
418 tree var
, enum iofield type
, gfc_expr
*e
)
422 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
424 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
425 gfc_init_se (&se
, NULL
);
426 gfc_conv_expr_lhs (&se
, e
);
428 gfc_add_block_to_block (block
, &se
.pre
);
430 if (TYPE_MODE (TREE_TYPE (se
.expr
))
431 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
432 addr
= convert (TREE_TYPE (p
->field
),
433 build_fold_addr_expr (se
.expr
));
436 /* The type used by the library has different size
437 from the type of the variable supplied by the user.
438 Need to use a temporary. */
440 = gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
441 st_parameter_field
[type
].name
);
442 addr
= build_fold_addr_expr (tmpvar
);
443 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
444 gfc_add_modify_expr (postblock
, se
.expr
, tmp
);
447 if (p
->param_type
== IOPARM_ptype_common
)
448 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
449 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
450 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
452 gfc_add_modify_expr (block
, tmp
, addr
);
456 /* Given an array expr, find its address and length to get a string. If the
457 array is full, the string's address is the address of array's first element
458 and the length is the size of the whole array. If it is an element, the
459 string's address is the element's address and the length is the rest size of
464 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
473 sym
= e
->symtree
->n
.sym
;
474 rank
= sym
->as
->rank
- 1;
476 if (e
->ref
->u
.ar
.type
== AR_FULL
)
478 se
->expr
= gfc_get_symbol_decl (sym
);
479 se
->expr
= gfc_conv_array_data (se
->expr
);
483 gfc_conv_expr (se
, e
);
486 array
= sym
->backend_decl
;
487 type
= TREE_TYPE (array
);
489 if (GFC_ARRAY_TYPE_P (type
))
490 size
= GFC_TYPE_ARRAY_SIZE (type
);
493 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
494 size
= gfc_conv_array_stride (array
, rank
);
495 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
496 gfc_conv_array_ubound (array
, rank
),
497 gfc_conv_array_lbound (array
, rank
));
498 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
500 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
505 /* If it is an element, we need the its address and size of the rest. */
506 if (e
->ref
->u
.ar
.type
== AR_ELEMENT
)
508 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
509 TREE_OPERAND (se
->expr
, 1));
510 se
->expr
= build_fold_addr_expr (se
->expr
);
513 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
514 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
516 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
520 /* Generate code to store a string and its length into the
521 st_parameter_XXX structure. */
524 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
525 enum iofield type
, gfc_expr
* e
)
531 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
533 gfc_init_se (&se
, NULL
);
535 if (p
->param_type
== IOPARM_ptype_common
)
536 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
537 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
538 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
540 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
543 /* Integer variable assigned a format label. */
544 if (e
->ts
.type
== BT_INTEGER
&& e
->symtree
->n
.sym
->attr
.assign
== 1)
548 gfc_conv_label_variable (&se
, e
);
549 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
550 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
,
551 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
553 asprintf(&msg
, "Label assigned to variable '%s' is not a format label",
555 gfc_trans_runtime_check (tmp
, msg
, &se
.pre
, &e
->where
);
558 gfc_add_modify_expr (&se
.pre
, io
,
559 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
560 gfc_add_modify_expr (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
564 /* General character. */
565 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
566 gfc_conv_expr (&se
, e
);
567 /* Array assigned Hollerith constant or character array. */
568 else if (e
->symtree
&& (e
->symtree
->n
.sym
->as
->rank
> 0))
569 gfc_convert_array_to_string (&se
, e
);
573 gfc_conv_string_parameter (&se
);
574 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
575 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
578 gfc_add_block_to_block (block
, &se
.pre
);
579 gfc_add_block_to_block (postblock
, &se
.post
);
584 /* Generate code to store the character (array) and the character length
585 for an internal unit. */
588 set_internal_unit (stmtblock_t
* block
, tree var
, gfc_expr
* e
)
595 gfc_st_parameter_field
*p
;
598 gfc_init_se (&se
, NULL
);
600 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
602 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
604 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
606 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
607 desc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
610 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
612 /* Character scalars. */
615 gfc_conv_expr (&se
, e
);
616 gfc_conv_string_parameter (&se
);
618 se
.expr
= build_int_cst (pchar_type_node
, 0);
621 /* Character array. */
622 else if (e
->rank
> 0)
624 se
.ss
= gfc_walk_expr (e
);
626 /* Return the data pointer and rank from the descriptor. */
627 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
628 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
629 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
634 /* The cast is needed for character substrings and the descriptor
636 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
637 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
638 gfc_add_modify_expr (&se
.pre
, desc
, se
.expr
);
640 gfc_add_block_to_block (block
, &se
.pre
);
644 /* Add a case to a IO-result switch. */
647 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
652 return; /* No label, no case */
654 value
= build_int_cst (NULL_TREE
, label_value
);
656 /* Make a backend label for this case. */
657 tmp
= gfc_build_label_decl (NULL_TREE
);
659 /* And the case itself. */
660 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
661 gfc_add_expr_to_block (body
, tmp
);
663 /* Jump to the label. */
664 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
665 gfc_add_expr_to_block (body
, tmp
);
669 /* Generate a switch statement that branches to the correct I/O
670 result label. The last statement of an I/O call stores the
671 result into a variable because there is often cleanup that
672 must be done before the switch, so a temporary would have to
673 be created anyway. */
676 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
677 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
681 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
683 /* If no labels are specified, ignore the result instead
684 of building an empty switch. */
685 if (err_label
== NULL
687 && eor_label
== NULL
)
690 /* Build a switch statement. */
691 gfc_start_block (&body
);
693 /* The label values here must be the same as the values
694 in the library_return enum in the runtime library */
695 add_case (1, err_label
, &body
);
696 add_case (2, end_label
, &body
);
697 add_case (3, eor_label
, &body
);
699 tmp
= gfc_finish_block (&body
);
701 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
702 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
703 rc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
705 rc
= build2 (BIT_AND_EXPR
, TREE_TYPE (rc
), rc
,
706 build_int_cst (TREE_TYPE (rc
), IOPARM_common_libreturn_mask
));
708 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
710 gfc_add_expr_to_block (block
, tmp
);
714 /* Store the current file and line number to variables so that if a
715 library call goes awry, we can tell the user where the problem is. */
718 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
721 tree str
, locus_file
;
723 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
725 locus_file
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
726 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
727 locus_file
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), locus_file
,
728 p
->field
, NULL_TREE
);
730 str
= gfc_build_cstring_const (f
->filename
);
732 str
= gfc_build_addr_expr (pchar_type_node
, str
);
733 gfc_add_modify_expr (block
, locus_file
, str
);
735 #ifdef USE_MAPPED_LOCATION
736 line
= LOCATION_LINE (where
->lb
->location
);
738 line
= where
->lb
->linenum
;
740 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
744 /* Translate an OPEN statement. */
747 gfc_trans_open (gfc_code
* code
)
749 stmtblock_t block
, post_block
;
752 unsigned int mask
= 0;
754 gfc_start_block (&block
);
755 gfc_init_block (&post_block
);
757 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
759 set_error_locus (&block
, var
, &code
->loc
);
763 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
765 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
768 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
771 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
775 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
779 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
782 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
785 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
789 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
793 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
797 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
801 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
804 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
808 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
812 mask
|= IOPARM_common_err
;
815 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
818 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
820 tmp
= build_fold_addr_expr (var
);
821 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
822 tmp
= build_function_call_expr (iocall
[IOCALL_OPEN
], tmp
);
823 gfc_add_expr_to_block (&block
, tmp
);
825 gfc_add_block_to_block (&block
, &post_block
);
827 io_result (&block
, var
, p
->err
, NULL
, NULL
);
829 return gfc_finish_block (&block
);
833 /* Translate a CLOSE statement. */
836 gfc_trans_close (gfc_code
* code
)
838 stmtblock_t block
, post_block
;
841 unsigned int mask
= 0;
843 gfc_start_block (&block
);
844 gfc_init_block (&post_block
);
846 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
848 set_error_locus (&block
, var
, &code
->loc
);
852 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
854 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
857 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
861 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
865 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
869 mask
|= IOPARM_common_err
;
871 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
873 tmp
= build_fold_addr_expr (var
);
874 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
875 tmp
= build_function_call_expr (iocall
[IOCALL_CLOSE
], tmp
);
876 gfc_add_expr_to_block (&block
, tmp
);
878 gfc_add_block_to_block (&block
, &post_block
);
880 io_result (&block
, var
, p
->err
, NULL
, NULL
);
882 return gfc_finish_block (&block
);
886 /* Common subroutine for building a file positioning statement. */
889 build_filepos (tree function
, gfc_code
* code
)
891 stmtblock_t block
, post_block
;
894 unsigned int mask
= 0;
896 p
= code
->ext
.filepos
;
898 gfc_start_block (&block
);
899 gfc_init_block (&post_block
);
901 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
904 set_error_locus (&block
, var
, &code
->loc
);
907 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
909 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
912 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
916 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
920 mask
|= IOPARM_common_err
;
922 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
924 tmp
= build_fold_addr_expr (var
);
925 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
926 tmp
= build_function_call_expr (function
, tmp
);
927 gfc_add_expr_to_block (&block
, tmp
);
929 gfc_add_block_to_block (&block
, &post_block
);
931 io_result (&block
, var
, p
->err
, NULL
, NULL
);
933 return gfc_finish_block (&block
);
937 /* Translate a BACKSPACE statement. */
940 gfc_trans_backspace (gfc_code
* code
)
942 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
946 /* Translate an ENDFILE statement. */
949 gfc_trans_endfile (gfc_code
* code
)
951 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
955 /* Translate a REWIND statement. */
958 gfc_trans_rewind (gfc_code
* code
)
960 return build_filepos (iocall
[IOCALL_REWIND
], code
);
964 /* Translate a FLUSH statement. */
967 gfc_trans_flush (gfc_code
* code
)
969 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
973 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
976 gfc_trans_inquire (gfc_code
* code
)
978 stmtblock_t block
, post_block
;
981 unsigned int mask
= 0;
983 gfc_start_block (&block
);
984 gfc_init_block (&post_block
);
986 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
989 set_error_locus (&block
, var
, &code
->loc
);
990 p
= code
->ext
.inquire
;
993 if (p
->unit
&& p
->file
)
994 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers.", &code
->loc
);
997 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
999 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1002 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1006 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1010 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1014 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1018 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1022 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1026 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1030 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1034 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1038 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1042 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1046 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1050 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1054 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1058 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1059 IOPARM_inquire_recl_out
, p
->recl
);
1062 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1063 IOPARM_inquire_nextrec
, p
->nextrec
);
1066 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1070 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1074 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1078 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1082 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1086 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1090 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1094 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1098 mask
|= IOPARM_common_err
;
1101 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1105 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1106 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1108 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1110 tmp
= build_fold_addr_expr (var
);
1111 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1112 tmp
= build_function_call_expr (iocall
[IOCALL_INQUIRE
], tmp
);
1113 gfc_add_expr_to_block (&block
, tmp
);
1115 gfc_add_block_to_block (&block
, &post_block
);
1117 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1119 return gfc_finish_block (&block
);
1123 gfc_new_nml_name_expr (const char * name
)
1125 gfc_expr
* nml_name
;
1127 nml_name
= gfc_get_expr();
1128 nml_name
->ref
= NULL
;
1129 nml_name
->expr_type
= EXPR_CONSTANT
;
1130 nml_name
->ts
.kind
= gfc_default_character_kind
;
1131 nml_name
->ts
.type
= BT_CHARACTER
;
1132 nml_name
->value
.character
.length
= strlen(name
);
1133 nml_name
->value
.character
.string
= gfc_getmem (strlen (name
) + 1);
1134 strcpy (nml_name
->value
.character
.string
, name
);
1139 /* nml_full_name builds up the fully qualified name of a
1140 derived type component. */
1143 nml_full_name (const char* var_name
, const char* cmp_name
)
1145 int full_name_length
;
1148 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1149 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1150 strcpy (full_name
, var_name
);
1151 full_name
= strcat (full_name
, "%");
1152 full_name
= strcat (full_name
, cmp_name
);
1156 /* nml_get_addr_expr builds an address expression from the
1157 gfc_symbol or gfc_component backend_decl's. An offset is
1158 provided so that the address of an element of an array of
1159 derived types is returned. This is used in the runtime to
1160 determine that span of the derived type. */
1163 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1166 tree decl
= NULL_TREE
;
1170 int dummy_arg_flagged
;
1174 sym
->attr
.referenced
= 1;
1175 decl
= gfc_get_symbol_decl (sym
);
1178 decl
= c
->backend_decl
;
1180 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1181 || TREE_CODE (decl
) == VAR_DECL
1182 || TREE_CODE (decl
) == PARM_DECL
)
1183 || TREE_CODE (decl
) == COMPONENT_REF
));
1187 /* Build indirect reference, if dummy argument. */
1189 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1191 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref (tmp
) : tmp
;
1193 /* If an array, set flag and use indirect ref. if built. */
1195 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1196 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1201 /* Treat the component of a derived type, using base_addr for
1202 the derived type. */
1204 if (TREE_CODE (decl
) == FIELD_DECL
)
1205 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1206 base_addr
, tmp
, NULL_TREE
);
1208 /* If we have a derived type component, a reference to the first
1209 element of the array is built. This is done so that base_addr,
1210 used in the build of the component reference, always points to
1214 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
);
1216 /* Now build the address expression. */
1218 tmp
= build_fold_addr_expr (tmp
);
1220 /* If scalar dummy, resolve indirect reference now. */
1222 if (dummy_arg_flagged
&& !array_flagged
)
1223 tmp
= build_fold_indirect_ref (tmp
);
1225 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1230 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1231 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1232 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1234 #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
1235 #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
1236 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1239 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1240 gfc_symbol
* sym
, gfc_component
* c
,
1243 gfc_typespec
* ts
= NULL
;
1244 gfc_array_spec
* as
= NULL
;
1245 tree addr_expr
= NULL
;
1256 gcc_assert (sym
|| c
);
1258 /* Build the namelist object name. */
1260 string
= gfc_build_cstring_const (var_name
);
1261 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1263 /* Build ts, as and data address using symbol or component. */
1265 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1266 as
= (sym
) ? sym
->as
: c
->as
;
1268 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1275 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1276 dtype
= gfc_get_dtype (dt
);
1280 itype
= GFC_DTYPE_UNKNOWN
;
1286 itype
= GFC_DTYPE_INTEGER
;
1289 itype
= GFC_DTYPE_LOGICAL
;
1292 itype
= GFC_DTYPE_REAL
;
1295 itype
= GFC_DTYPE_COMPLEX
;
1298 itype
= GFC_DTYPE_DERIVED
;
1301 itype
= GFC_DTYPE_CHARACTER
;
1307 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1310 /* Build up the arguments for the transfer call.
1311 The call for the scalar part transfers:
1312 (address, name, type, kind or string_length, dtype) */
1314 dt_parm_addr
= build_fold_addr_expr (dt_parm
);
1315 NML_FIRST_ARG (dt_parm_addr
);
1316 NML_ADD_ARG (addr_expr
);
1317 NML_ADD_ARG (string
);
1318 NML_ADD_ARG (IARG (ts
->kind
));
1320 if (ts
->type
== BT_CHARACTER
)
1321 NML_ADD_ARG (ts
->cl
->backend_decl
);
1323 NML_ADD_ARG (build_int_cst (gfc_charlen_type_node
, 0));
1325 NML_ADD_ARG (dtype
);
1326 tmp
= build_function_call_expr (iocall
[IOCALL_SET_NML_VAL
], args
);
1327 gfc_add_expr_to_block (block
, tmp
);
1329 /* If the object is an array, transfer rank times:
1330 (null pointer, name, stride, lbound, ubound) */
1332 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1334 NML_FIRST_ARG (dt_parm_addr
);
1335 NML_ADD_ARG (IARG (n_dim
));
1336 NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
));
1337 NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
));
1338 NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1339 tmp
= build_function_call_expr (iocall
[IOCALL_SET_NML_VAL_DIM
], args
);
1340 gfc_add_expr_to_block (block
, tmp
);
1343 if (ts
->type
== BT_DERIVED
)
1347 /* Provide the RECORD_TYPE to build component references. */
1349 tree expr
= build_fold_indirect_ref (addr_expr
);
1351 for (cmp
= ts
->derived
->components
; cmp
; cmp
= cmp
->next
)
1353 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1354 transfer_namelist_element (block
,
1357 gfc_free (full_name
);
1364 #undef NML_FIRST_ARG
1366 /* Create a data transfer statement. Not all of the fields are valid
1367 for both reading and writing, but improper use has been filtered
1371 build_dt (tree function
, gfc_code
* code
)
1373 stmtblock_t block
, post_block
, post_end_block
;
1378 unsigned int mask
= 0;
1380 gfc_start_block (&block
);
1381 gfc_init_block (&post_block
);
1382 gfc_init_block (&post_end_block
);
1384 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1386 set_error_locus (&block
, var
, &code
->loc
);
1388 if (last_dt
== IOLENGTH
)
1392 inq
= code
->ext
.inquire
;
1394 /* First check that preconditions are met. */
1395 gcc_assert (inq
!= NULL
);
1396 gcc_assert (inq
->iolength
!= NULL
);
1398 /* Connect to the iolength variable. */
1399 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1400 IOPARM_dt_iolength
, inq
->iolength
);
1406 gcc_assert (dt
!= NULL
);
1409 if (dt
&& dt
->io_unit
)
1411 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1413 mask
|= set_internal_unit (&block
, var
, dt
->io_unit
);
1414 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1417 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1420 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1425 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1428 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1431 if (dt
->format_expr
)
1432 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1435 if (dt
->format_label
)
1437 if (dt
->format_label
== &format_asterisk
)
1438 mask
|= IOPARM_dt_list_format
;
1440 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1441 dt
->format_label
->format
);
1445 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1449 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1450 IOPARM_common_iostat
, dt
->iostat
);
1453 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1454 IOPARM_dt_size
, dt
->size
);
1457 mask
|= IOPARM_common_err
;
1460 mask
|= IOPARM_common_eor
;
1463 mask
|= IOPARM_common_end
;
1467 if (dt
->format_expr
|| dt
->format_label
)
1468 gfc_internal_error ("build_dt: format with namelist");
1470 nmlname
= gfc_new_nml_name_expr (dt
->namelist
->name
);
1472 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1475 if (last_dt
== READ
)
1476 mask
|= IOPARM_dt_namelist_read_mode
;
1478 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1482 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1483 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1487 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1490 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1492 tmp
= build_fold_addr_expr (var
);
1493 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1494 tmp
= build_function_call_expr (function
, tmp
);
1495 gfc_add_expr_to_block (&block
, tmp
);
1497 gfc_add_block_to_block (&block
, &post_block
);
1500 dt_post_end_block
= &post_end_block
;
1502 gfc_add_expr_to_block (&block
, gfc_trans_code (code
->block
->next
));
1505 dt_post_end_block
= NULL
;
1507 return gfc_finish_block (&block
);
1511 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1512 this as a third sort of data transfer statement, except that
1513 lengths are summed instead of actually transferring any data. */
1516 gfc_trans_iolength (gfc_code
* code
)
1519 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1523 /* Translate a READ statement. */
1526 gfc_trans_read (gfc_code
* code
)
1529 return build_dt (iocall
[IOCALL_READ
], code
);
1533 /* Translate a WRITE statement */
1536 gfc_trans_write (gfc_code
* code
)
1539 return build_dt (iocall
[IOCALL_WRITE
], code
);
1543 /* Finish a data transfer statement. */
1546 gfc_trans_dt_end (gfc_code
* code
)
1551 gfc_init_block (&block
);
1556 function
= iocall
[IOCALL_READ_DONE
];
1560 function
= iocall
[IOCALL_WRITE_DONE
];
1564 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1571 tmp
= build_fold_addr_expr (dt_parm
);
1572 tmp
= gfc_chainon_list (NULL_TREE
, tmp
);
1573 tmp
= build_function_call_expr (function
, tmp
);
1574 gfc_add_expr_to_block (&block
, tmp
);
1575 gfc_add_block_to_block (&block
, dt_post_end_block
);
1576 gfc_init_block (dt_post_end_block
);
1578 if (last_dt
!= IOLENGTH
)
1580 gcc_assert (code
->ext
.dt
!= NULL
);
1581 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1582 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1585 return gfc_finish_block (&block
);
1589 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
);
1591 /* Given an array field in a derived type variable, generate the code
1592 for the loop that iterates over array elements, and the code that
1593 accesses those array elements. Use transfer_expr to generate code
1594 for transferring that element. Because elements may also be
1595 derived types, transfer_expr and transfer_array_component are mutually
1599 transfer_array_component (tree expr
, gfc_component
* cm
)
1609 gfc_start_block (&block
);
1610 gfc_init_se (&se
, NULL
);
1612 /* Create and initialize Scalarization Status. Unlike in
1613 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1614 care of this task, because we don't have a gfc_expr at hand.
1615 Build one manually, as in gfc_trans_subarray_assign. */
1618 ss
->type
= GFC_SS_COMPONENT
;
1620 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1621 ss
->next
= gfc_ss_terminator
;
1622 ss
->data
.info
.dimen
= cm
->as
->rank
;
1623 ss
->data
.info
.descriptor
= expr
;
1624 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1625 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1626 for (n
= 0; n
< cm
->as
->rank
; n
++)
1628 ss
->data
.info
.dim
[n
] = n
;
1629 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1630 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1632 mpz_init (ss
->shape
[n
]);
1633 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1634 cm
->as
->lower
[n
]->value
.integer
);
1635 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1638 /* Once we got ss, we use scalarizer to create the loop. */
1640 gfc_init_loopinfo (&loop
);
1641 gfc_add_ss_to_loop (&loop
, ss
);
1642 gfc_conv_ss_startstride (&loop
);
1643 gfc_conv_loop_setup (&loop
);
1644 gfc_mark_ss_chain_used (ss
, 1);
1645 gfc_start_scalarized_body (&loop
, &body
);
1647 gfc_copy_loopinfo_to_se (&se
, &loop
);
1650 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1652 gfc_conv_tmp_array_ref (&se
);
1654 /* Now se.expr contains an element of the array. Take the address and pass
1655 it to the IO routines. */
1656 tmp
= build_fold_addr_expr (se
.expr
);
1657 transfer_expr (&se
, &cm
->ts
, tmp
);
1659 /* We are done now with the loop body. Wrap up the scalarizer and
1662 gfc_add_block_to_block (&body
, &se
.pre
);
1663 gfc_add_block_to_block (&body
, &se
.post
);
1665 gfc_trans_scalarizing_loops (&loop
, &body
);
1667 gfc_add_block_to_block (&block
, &loop
.pre
);
1668 gfc_add_block_to_block (&block
, &loop
.post
);
1670 for (n
= 0; n
< cm
->as
->rank
; n
++)
1671 mpz_clear (ss
->shape
[n
]);
1672 gfc_free (ss
->shape
);
1674 gfc_cleanup_loop (&loop
);
1676 return gfc_finish_block (&block
);
1679 /* Generate the call for a scalar transfer node. */
1682 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1684 tree args
, tmp
, function
, arg2
, field
, expr
;
1695 arg2
= build_int_cst (NULL_TREE
, kind
);
1696 function
= iocall
[IOCALL_X_INTEGER
];
1700 arg2
= build_int_cst (NULL_TREE
, kind
);
1701 function
= iocall
[IOCALL_X_REAL
];
1705 arg2
= build_int_cst (NULL_TREE
, kind
);
1706 function
= iocall
[IOCALL_X_COMPLEX
];
1710 arg2
= build_int_cst (NULL_TREE
, kind
);
1711 function
= iocall
[IOCALL_X_LOGICAL
];
1716 if (se
->string_length
)
1717 arg2
= se
->string_length
;
1720 tmp
= build_fold_indirect_ref (addr_expr
);
1721 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
1722 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
1724 function
= iocall
[IOCALL_X_CHARACTER
];
1728 /* Recurse into the elements of the derived type. */
1729 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
1730 expr
= build_fold_indirect_ref (expr
);
1732 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1734 field
= c
->backend_decl
;
1735 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
1737 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), expr
, field
,
1742 tmp
= transfer_array_component (tmp
, c
);
1743 gfc_add_expr_to_block (&se
->pre
, tmp
);
1748 tmp
= build_fold_addr_expr (tmp
);
1749 transfer_expr (se
, &c
->ts
, tmp
);
1755 internal_error ("Bad IO basetype (%d)", ts
->type
);
1758 tmp
= build_fold_addr_expr (dt_parm
);
1759 args
= gfc_chainon_list (NULL_TREE
, tmp
);
1760 args
= gfc_chainon_list (args
, addr_expr
);
1761 args
= gfc_chainon_list (args
, arg2
);
1763 tmp
= build_function_call_expr (function
, args
);
1764 gfc_add_expr_to_block (&se
->pre
, tmp
);
1765 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1770 /* Generate a call to pass an array descriptor to the IO library. The
1771 array should be of one of the intrinsic types. */
1774 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1776 tree args
, tmp
, charlen_arg
, kind_arg
;
1778 if (ts
->type
== BT_CHARACTER
)
1779 charlen_arg
= se
->string_length
;
1781 charlen_arg
= build_int_cstu (NULL_TREE
, 0);
1783 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
1785 tmp
= build_fold_addr_expr (dt_parm
);
1786 args
= gfc_chainon_list (NULL_TREE
, tmp
);
1787 args
= gfc_chainon_list (args
, addr_expr
);
1788 args
= gfc_chainon_list (args
, kind_arg
);
1789 args
= gfc_chainon_list (args
, charlen_arg
);
1790 tmp
= build_function_call_expr (iocall
[IOCALL_X_ARRAY
], args
);
1791 gfc_add_expr_to_block (&se
->pre
, tmp
);
1792 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1796 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1799 gfc_trans_transfer (gfc_code
* code
)
1801 stmtblock_t block
, body
;
1809 gfc_start_block (&block
);
1810 gfc_init_block (&body
);
1813 ss
= gfc_walk_expr (expr
);
1816 gfc_init_se (&se
, NULL
);
1818 if (ss
== gfc_ss_terminator
)
1820 /* Transfer a scalar value. */
1821 gfc_conv_expr_reference (&se
, expr
);
1822 transfer_expr (&se
, &expr
->ts
, se
.expr
);
1826 /* Transfer an array. If it is an array of an intrinsic
1827 type, pass the descriptor to the library. Otherwise
1828 scalarize the transfer. */
1831 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
1833 gcc_assert (ref
->type
== REF_ARRAY
);
1836 if (expr
->ts
.type
!= BT_DERIVED
&& ref
&& ref
->next
== NULL
)
1838 /* Get the descriptor. */
1839 gfc_conv_expr_descriptor (&se
, expr
, ss
);
1840 tmp
= build_fold_addr_expr (se
.expr
);
1841 transfer_array_desc (&se
, &expr
->ts
, tmp
);
1842 goto finish_block_label
;
1845 /* Initialize the scalarizer. */
1846 gfc_init_loopinfo (&loop
);
1847 gfc_add_ss_to_loop (&loop
, ss
);
1849 /* Initialize the loop. */
1850 gfc_conv_ss_startstride (&loop
);
1851 gfc_conv_loop_setup (&loop
);
1853 /* The main loop body. */
1854 gfc_mark_ss_chain_used (ss
, 1);
1855 gfc_start_scalarized_body (&loop
, &body
);
1857 gfc_copy_loopinfo_to_se (&se
, &loop
);
1860 gfc_conv_expr_reference (&se
, expr
);
1861 transfer_expr (&se
, &expr
->ts
, se
.expr
);
1866 gfc_add_block_to_block (&body
, &se
.pre
);
1867 gfc_add_block_to_block (&body
, &se
.post
);
1870 tmp
= gfc_finish_block (&body
);
1873 gcc_assert (se
.ss
== gfc_ss_terminator
);
1874 gfc_trans_scalarizing_loops (&loop
, &body
);
1876 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1877 tmp
= gfc_finish_block (&loop
.pre
);
1878 gfc_cleanup_loop (&loop
);
1881 gfc_add_expr_to_block (&block
, tmp
);
1883 return gfc_finish_block (&block
);
1886 #include "gt-fortran-trans-io.h"