1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
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. */
67 typedef struct GTY(()) gfc_st_parameter_field
{
70 enum ioparam_type param_type
;
71 enum iofield_type type
;
75 gfc_st_parameter_field
;
77 typedef struct GTY(()) gfc_st_parameter
{
85 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
91 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, (enum ioparam_type
) 0, (enum iofield_type
) 0, NULL
, NULL
}
111 /* Library I/O subroutines */
122 IOCALL_X_CHARACTER_WIDE
,
130 IOCALL_IOLENGTH_DONE
,
136 IOCALL_SET_NML_VAL_DIM
,
141 static GTY(()) tree iocall
[IOCALL_NUM
];
143 /* Variable for keeping track of what the last data transfer statement
144 was. Used for deciding which subroutine to call when the data
145 transfer is complete. */
146 static enum { READ
, WRITE
, IOLENGTH
} last_dt
;
148 /* The data transfer parameter block that should be shared by all
149 data transfer calls belonging to the same read/write/iolength. */
150 static GTY(()) tree dt_parm
;
151 static stmtblock_t
*dt_post_end_block
;
154 gfc_build_st_parameter (enum ioparam_type ptype
, tree
*types
)
157 gfc_st_parameter_field
*p
;
160 tree t
= make_node (RECORD_TYPE
);
162 len
= strlen (st_parameter
[ptype
].name
);
163 gcc_assert (len
<= sizeof (name
) - sizeof ("__st_parameter_"));
164 memcpy (name
, "__st_parameter_", sizeof ("__st_parameter_"));
165 memcpy (name
+ sizeof ("__st_parameter_") - 1, st_parameter
[ptype
].name
,
167 TYPE_NAME (t
) = get_identifier (name
);
169 for (type
= 0, p
= st_parameter_field
; type
< IOPARM_field_num
; type
++, p
++)
170 if (p
->param_type
== ptype
)
173 case IOPARM_type_int4
:
174 case IOPARM_type_intio
:
175 case IOPARM_type_pint4
:
176 case IOPARM_type_pintio
:
177 case IOPARM_type_parray
:
178 case IOPARM_type_pchar
:
179 case IOPARM_type_pad
:
180 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
181 get_identifier (p
->name
),
184 case IOPARM_type_char1
:
185 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
186 get_identifier (p
->name
),
189 case IOPARM_type_char2
:
190 len
= strlen (p
->name
);
191 gcc_assert (len
<= sizeof (name
) - sizeof ("_len"));
192 memcpy (name
, p
->name
, len
);
193 memcpy (name
+ len
, "_len", sizeof ("_len"));
194 p
->field_len
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
195 get_identifier (name
),
196 gfc_charlen_type_node
);
197 if (p
->type
== IOPARM_type_char2
)
198 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
199 get_identifier (p
->name
),
202 case IOPARM_type_common
:
204 = gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
205 get_identifier (p
->name
),
206 st_parameter
[IOPARM_ptype_common
].type
);
208 case IOPARM_type_num
:
213 st_parameter
[ptype
].type
= t
;
217 /* Build code to test an error condition and call generate_error if needed.
218 Note: This builds calls to generate_error in the runtime library function.
219 The function generate_error is dependent on certain parameters in the
220 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
221 Therefore, the code to set these flags must be generated before
222 this function is used. */
225 gfc_trans_io_runtime_check (tree cond
, tree var
, int error_code
,
226 const char * msgid
, stmtblock_t
* pblock
)
231 tree arg1
, arg2
, arg3
;
234 if (integer_zerop (cond
))
237 /* The code to generate the error. */
238 gfc_start_block (&block
);
240 arg1
= gfc_build_addr_expr (NULL_TREE
, var
);
242 arg2
= build_int_cst (integer_type_node
, error_code
),
244 asprintf (&message
, "%s", _(msgid
));
245 arg3
= gfc_build_addr_expr (pchar_type_node
,
246 gfc_build_localized_cstring_const (message
));
249 tmp
= build_call_expr (gfor_fndecl_generate_error
, 3, arg1
, arg2
, arg3
);
251 gfc_add_expr_to_block (&block
, tmp
);
253 body
= gfc_finish_block (&block
);
255 if (integer_onep (cond
))
257 gfc_add_expr_to_block (pblock
, body
);
261 /* Tell the compiler that this isn't likely. */
262 cond
= fold_convert (long_integer_type_node
, cond
);
263 tmp
= build_int_cst (long_integer_type_node
, 0);
264 cond
= build_call_expr (built_in_decls
[BUILT_IN_EXPECT
], 2, cond
, tmp
);
265 cond
= fold_convert (boolean_type_node
, cond
);
267 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt ());
268 gfc_add_expr_to_block (pblock
, tmp
);
273 /* Create function decls for IO library functions. */
276 gfc_build_io_library_fndecls (void)
278 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
279 tree gfc_intio_type_node
;
280 tree parm_type
, dt_parm_type
;
281 HOST_WIDE_INT pad_size
;
284 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
285 types
[IOPARM_type_intio
] = gfc_intio_type_node
286 = gfc_get_int_type (gfc_intio_kind
);
287 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
288 types
[IOPARM_type_pintio
]
289 = build_pointer_type (gfc_intio_type_node
);
290 types
[IOPARM_type_parray
] = pchar_type_node
;
291 types
[IOPARM_type_pchar
] = pchar_type_node
;
292 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
293 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
294 pad_idx
= build_index_type (build_int_cst (NULL_TREE
, pad_size
- 1));
295 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
297 /* pad actually contains pointers and integers so it needs to have an
298 alignment that is at least as large as the needed alignment for those
299 types. See the st_parameter_dt structure in libgfortran/io/io.h for
300 what really goes into this space. */
301 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
302 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind
)));
304 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
305 gfc_build_st_parameter ((enum ioparam_type
) ptype
, types
);
307 /* Define the transfer functions. */
309 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
311 iocall
[IOCALL_X_INTEGER
] =
312 gfc_build_library_function_decl (get_identifier
313 (PREFIX("transfer_integer")),
314 void_type_node
, 3, dt_parm_type
,
315 pvoid_type_node
, gfc_int4_type_node
);
317 iocall
[IOCALL_X_LOGICAL
] =
318 gfc_build_library_function_decl (get_identifier
319 (PREFIX("transfer_logical")),
320 void_type_node
, 3, dt_parm_type
,
321 pvoid_type_node
, gfc_int4_type_node
);
323 iocall
[IOCALL_X_CHARACTER
] =
324 gfc_build_library_function_decl (get_identifier
325 (PREFIX("transfer_character")),
326 void_type_node
, 3, dt_parm_type
,
327 pvoid_type_node
, gfc_int4_type_node
);
329 iocall
[IOCALL_X_CHARACTER_WIDE
] =
330 gfc_build_library_function_decl (get_identifier
331 (PREFIX("transfer_character_wide")),
332 void_type_node
, 4, dt_parm_type
,
333 pvoid_type_node
, gfc_charlen_type_node
,
336 iocall
[IOCALL_X_REAL
] =
337 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
338 void_type_node
, 3, dt_parm_type
,
339 pvoid_type_node
, gfc_int4_type_node
);
341 iocall
[IOCALL_X_COMPLEX
] =
342 gfc_build_library_function_decl (get_identifier
343 (PREFIX("transfer_complex")),
344 void_type_node
, 3, dt_parm_type
,
345 pvoid_type_node
, gfc_int4_type_node
);
347 iocall
[IOCALL_X_ARRAY
] =
348 gfc_build_library_function_decl (get_identifier
349 (PREFIX("transfer_array")),
350 void_type_node
, 4, dt_parm_type
,
351 pvoid_type_node
, integer_type_node
,
352 gfc_charlen_type_node
);
354 /* Library entry points */
356 iocall
[IOCALL_READ
] =
357 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
358 void_type_node
, 1, dt_parm_type
);
360 iocall
[IOCALL_WRITE
] =
361 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
362 void_type_node
, 1, dt_parm_type
);
364 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
365 iocall
[IOCALL_OPEN
] =
366 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
367 void_type_node
, 1, parm_type
);
370 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
371 iocall
[IOCALL_CLOSE
] =
372 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
373 void_type_node
, 1, parm_type
);
375 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
376 iocall
[IOCALL_INQUIRE
] =
377 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
378 gfc_int4_type_node
, 1, parm_type
);
380 iocall
[IOCALL_IOLENGTH
] =
381 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
382 void_type_node
, 1, dt_parm_type
);
384 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_wait
].type
);
385 iocall
[IOCALL_WAIT
] =
386 gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")),
387 gfc_int4_type_node
, 1, parm_type
);
389 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
390 iocall
[IOCALL_REWIND
] =
391 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
392 gfc_int4_type_node
, 1, parm_type
);
394 iocall
[IOCALL_BACKSPACE
] =
395 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
396 gfc_int4_type_node
, 1, parm_type
);
398 iocall
[IOCALL_ENDFILE
] =
399 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
400 gfc_int4_type_node
, 1, parm_type
);
402 iocall
[IOCALL_FLUSH
] =
403 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
404 gfc_int4_type_node
, 1, parm_type
);
406 /* Library helpers */
408 iocall
[IOCALL_READ_DONE
] =
409 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
410 gfc_int4_type_node
, 1, dt_parm_type
);
412 iocall
[IOCALL_WRITE_DONE
] =
413 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
414 gfc_int4_type_node
, 1, dt_parm_type
);
416 iocall
[IOCALL_IOLENGTH_DONE
] =
417 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
418 gfc_int4_type_node
, 1, dt_parm_type
);
421 iocall
[IOCALL_SET_NML_VAL
] =
422 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
423 void_type_node
, 6, dt_parm_type
,
424 pvoid_type_node
, pvoid_type_node
,
425 gfc_int4_type_node
, gfc_charlen_type_node
,
428 iocall
[IOCALL_SET_NML_VAL_DIM
] =
429 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
430 void_type_node
, 5, dt_parm_type
,
431 gfc_int4_type_node
, gfc_array_index_type
,
432 gfc_array_index_type
, gfc_array_index_type
);
436 /* Generate code to store an integer constant into the
437 st_parameter_XXX structure. */
440 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
444 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
446 if (p
->param_type
== IOPARM_ptype_common
)
447 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
448 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
449 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
451 gfc_add_modify (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
456 /* Generate code to store a non-string I/O parameter into the
457 st_parameter_XXX structure. This is a pass by value. */
460 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
465 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
466 tree dest_type
= TREE_TYPE (p
->field
);
468 gfc_init_se (&se
, NULL
);
469 gfc_conv_expr_val (&se
, e
);
471 /* If we're storing a UNIT number, we need to check it first. */
472 if (type
== IOPARM_common_unit
&& e
->ts
.kind
!= 4)
477 /* Don't evaluate the UNIT number multiple times. */
478 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
480 /* UNIT numbers should be nonnegative. */
481 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, se
.expr
,
482 build_int_cst (TREE_TYPE (se
.expr
),0));
483 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
484 "Negative unit number in I/O statement",
487 /* UNIT numbers should be less than the max. */
488 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
489 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
490 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, se
.expr
,
491 fold_convert (TREE_TYPE (se
.expr
), max
));
492 gfc_trans_io_runtime_check (cond
, var
, LIBERROR_BAD_UNIT
,
493 "Unit number in I/O statement too large",
498 se
.expr
= convert (dest_type
, se
.expr
);
499 gfc_add_block_to_block (block
, &se
.pre
);
501 if (p
->param_type
== IOPARM_ptype_common
)
502 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
503 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
505 tmp
= fold_build3 (COMPONENT_REF
, dest_type
, var
, p
->field
, NULL_TREE
);
506 gfc_add_modify (block
, tmp
, se
.expr
);
511 /* Generate code to store a non-string I/O parameter into the
512 st_parameter_XXX structure. This is pass by reference. */
515 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
516 tree var
, enum iofield type
, gfc_expr
*e
)
520 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
522 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
523 gfc_init_se (&se
, NULL
);
524 gfc_conv_expr_lhs (&se
, e
);
526 gfc_add_block_to_block (block
, &se
.pre
);
528 if (TYPE_MODE (TREE_TYPE (se
.expr
))
529 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
531 addr
= convert (TREE_TYPE (p
->field
), gfc_build_addr_expr (NULL_TREE
, se
.expr
));
533 /* If this is for the iostat variable initialize the
534 user variable to LIBERROR_OK which is zero. */
535 if (type
== IOPARM_common_iostat
)
536 gfc_add_modify (block
, se
.expr
,
537 build_int_cst (TREE_TYPE (se
.expr
), LIBERROR_OK
));
541 /* The type used by the library has different size
542 from the type of the variable supplied by the user.
543 Need to use a temporary. */
544 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
545 st_parameter_field
[type
].name
);
547 /* If this is for the iostat variable, initialize the
548 user variable to LIBERROR_OK which is zero. */
549 if (type
== IOPARM_common_iostat
)
550 gfc_add_modify (block
, tmpvar
,
551 build_int_cst (TREE_TYPE (tmpvar
), LIBERROR_OK
));
553 addr
= gfc_build_addr_expr (NULL_TREE
, tmpvar
);
554 /* After the I/O operation, we set the variable from the temporary. */
555 tmp
= convert (TREE_TYPE (se
.expr
), tmpvar
);
556 gfc_add_modify (postblock
, se
.expr
, tmp
);
559 if (p
->param_type
== IOPARM_ptype_common
)
560 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
561 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
562 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
563 var
, p
->field
, NULL_TREE
);
564 gfc_add_modify (block
, tmp
, addr
);
568 /* Given an array expr, find its address and length to get a string. If the
569 array is full, the string's address is the address of array's first element
570 and the length is the size of the whole array. If it is an element, the
571 string's address is the element's address and the length is the rest size of
575 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
581 tree type
, array
, tmp
;
585 /* If it is an element, we need its address and size of the rest. */
586 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
587 gcc_assert (e
->ref
->u
.ar
.type
== AR_ELEMENT
);
588 sym
= e
->symtree
->n
.sym
;
589 rank
= sym
->as
->rank
- 1;
590 gfc_conv_expr (se
, e
);
592 array
= sym
->backend_decl
;
593 type
= TREE_TYPE (array
);
595 if (GFC_ARRAY_TYPE_P (type
))
596 size
= GFC_TYPE_ARRAY_SIZE (type
);
599 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
600 size
= gfc_conv_array_stride (array
, rank
);
601 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
602 gfc_conv_array_ubound (array
, rank
),
603 gfc_conv_array_lbound (array
, rank
));
604 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
606 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
610 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
611 TREE_OPERAND (se
->expr
, 1));
612 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
613 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
614 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
615 fold_convert (gfc_array_index_type
, tmp
));
616 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
620 gfc_conv_array_parameter (se
, e
, gfc_walk_expr (e
), 1, NULL
, NULL
, &size
);
621 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
625 /* Generate code to store a string and its length into the
626 st_parameter_XXX structure. */
629 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
630 enum iofield type
, gfc_expr
* e
)
636 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
638 gfc_init_se (&se
, NULL
);
640 if (p
->param_type
== IOPARM_ptype_common
)
641 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
642 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
643 io
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
644 var
, p
->field
, NULL_TREE
);
645 len
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
),
646 var
, p
->field_len
, NULL_TREE
);
648 /* Integer variable assigned a format label. */
649 if (e
->ts
.type
== BT_INTEGER
651 && e
->symtree
->n
.sym
->attr
.assign
== 1)
656 gfc_conv_label_variable (&se
, e
);
657 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
658 cond
= fold_build2 (LT_EXPR
, boolean_type_node
,
659 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
661 asprintf(&msg
, "Label assigned to variable '%s' (%%ld) is not a format "
662 "label", e
->symtree
->name
);
663 gfc_trans_runtime_check (true, false, cond
, &se
.pre
, &e
->where
, msg
,
664 fold_convert (long_integer_type_node
, tmp
));
667 gfc_add_modify (&se
.pre
, io
,
668 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
669 gfc_add_modify (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
673 /* General character. */
674 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
675 gfc_conv_expr (&se
, e
);
676 /* Array assigned Hollerith constant or character array. */
677 else if (e
->rank
> 0 || (e
->symtree
&& e
->symtree
->n
.sym
->as
->rank
> 0))
678 gfc_convert_array_to_string (&se
, e
);
682 gfc_conv_string_parameter (&se
);
683 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
684 gfc_add_modify (&se
.pre
, len
, se
.string_length
);
687 gfc_add_block_to_block (block
, &se
.pre
);
688 gfc_add_block_to_block (postblock
, &se
.post
);
693 /* Generate code to store the character (array) and the character length
694 for an internal unit. */
697 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
698 tree var
, gfc_expr
* e
)
705 gfc_st_parameter_field
*p
;
708 gfc_init_se (&se
, NULL
);
710 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
712 io
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
713 var
, p
->field
, NULL_TREE
);
714 len
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
),
715 var
, p
->field_len
, NULL_TREE
);
716 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
717 desc
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
718 var
, p
->field
, NULL_TREE
);
720 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
722 /* Character scalars. */
725 gfc_conv_expr (&se
, e
);
726 gfc_conv_string_parameter (&se
);
728 se
.expr
= build_int_cst (pchar_type_node
, 0);
731 /* Character array. */
732 else if (e
->rank
> 0)
734 se
.ss
= gfc_walk_expr (e
);
736 if (is_subref_array (e
))
738 /* Use a temporary for components of arrays of derived types
739 or substring array references. */
740 gfc_conv_subref_array_arg (&se
, e
, 0,
741 last_dt
== READ
? INTENT_IN
: INTENT_OUT
);
742 tmp
= build_fold_indirect_ref (se
.expr
);
743 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
744 tmp
= gfc_conv_descriptor_data_get (tmp
);
748 /* Return the data pointer and rank from the descriptor. */
749 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
750 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
751 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
757 /* The cast is needed for character substrings and the descriptor
759 gfc_add_modify (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
760 gfc_add_modify (&se
.pre
, len
,
761 fold_convert (TREE_TYPE (len
), se
.string_length
));
762 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
764 gfc_add_block_to_block (block
, &se
.pre
);
765 gfc_add_block_to_block (post_block
, &se
.post
);
769 /* Add a case to a IO-result switch. */
772 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
777 return; /* No label, no case */
779 value
= build_int_cst (NULL_TREE
, label_value
);
781 /* Make a backend label for this case. */
782 tmp
= gfc_build_label_decl (NULL_TREE
);
784 /* And the case itself. */
785 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
786 gfc_add_expr_to_block (body
, tmp
);
788 /* Jump to the label. */
789 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
790 gfc_add_expr_to_block (body
, tmp
);
794 /* Generate a switch statement that branches to the correct I/O
795 result label. The last statement of an I/O call stores the
796 result into a variable because there is often cleanup that
797 must be done before the switch, so a temporary would have to
798 be created anyway. */
801 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
802 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
806 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
808 /* If no labels are specified, ignore the result instead
809 of building an empty switch. */
810 if (err_label
== NULL
812 && eor_label
== NULL
)
815 /* Build a switch statement. */
816 gfc_start_block (&body
);
818 /* The label values here must be the same as the values
819 in the library_return enum in the runtime library */
820 add_case (1, err_label
, &body
);
821 add_case (2, end_label
, &body
);
822 add_case (3, eor_label
, &body
);
824 tmp
= gfc_finish_block (&body
);
826 var
= fold_build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
827 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
828 rc
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
829 var
, p
->field
, NULL_TREE
);
830 rc
= fold_build2 (BIT_AND_EXPR
, TREE_TYPE (rc
),
831 rc
, build_int_cst (TREE_TYPE (rc
),
832 IOPARM_common_libreturn_mask
));
834 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
836 gfc_add_expr_to_block (block
, tmp
);
840 /* Store the current file and line number to variables so that if a
841 library call goes awry, we can tell the user where the problem is. */
844 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
847 tree str
, locus_file
;
849 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
851 locus_file
= fold_build3 (COMPONENT_REF
,
852 st_parameter
[IOPARM_ptype_common
].type
,
853 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
854 locus_file
= fold_build3 (COMPONENT_REF
, TREE_TYPE (p
->field
),
855 locus_file
, p
->field
, NULL_TREE
);
857 str
= gfc_build_cstring_const (f
->filename
);
859 str
= gfc_build_addr_expr (pchar_type_node
, str
);
860 gfc_add_modify (block
, locus_file
, str
);
862 line
= LOCATION_LINE (where
->lb
->location
);
863 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
867 /* Translate an OPEN statement. */
870 gfc_trans_open (gfc_code
* code
)
872 stmtblock_t block
, post_block
;
875 unsigned int mask
= 0;
877 gfc_start_block (&block
);
878 gfc_init_block (&post_block
);
880 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
882 set_error_locus (&block
, var
, &code
->loc
);
886 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
890 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
894 mask
|= IOPARM_common_err
;
897 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
900 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
904 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
908 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
911 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
914 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
918 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
922 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
926 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
930 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
933 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_decimal
,
937 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_encoding
,
941 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_round
, p
->round
);
944 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_sign
, p
->sign
);
947 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_asynchronous
,
951 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
954 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
957 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
959 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
961 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
962 tmp
= build_call_expr (iocall
[IOCALL_OPEN
], 1, tmp
);
963 gfc_add_expr_to_block (&block
, tmp
);
965 gfc_add_block_to_block (&block
, &post_block
);
967 io_result (&block
, var
, p
->err
, NULL
, NULL
);
969 return gfc_finish_block (&block
);
973 /* Translate a CLOSE statement. */
976 gfc_trans_close (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_close
].type
, "close_parm");
988 set_error_locus (&block
, var
, &code
->loc
);
992 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
996 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1000 mask
|= IOPARM_common_err
;
1003 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
1006 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1009 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1011 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1013 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1014 tmp
= build_call_expr (iocall
[IOCALL_CLOSE
], 1, tmp
);
1015 gfc_add_expr_to_block (&block
, tmp
);
1017 gfc_add_block_to_block (&block
, &post_block
);
1019 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1021 return gfc_finish_block (&block
);
1025 /* Common subroutine for building a file positioning statement. */
1028 build_filepos (tree function
, gfc_code
* code
)
1030 stmtblock_t block
, post_block
;
1033 unsigned int mask
= 0;
1035 p
= code
->ext
.filepos
;
1037 gfc_start_block (&block
);
1038 gfc_init_block (&post_block
);
1040 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1043 set_error_locus (&block
, var
, &code
->loc
);
1046 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1050 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1054 mask
|= IOPARM_common_err
;
1056 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1059 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1061 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1063 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1064 tmp
= build_call_expr (function
, 1, tmp
);
1065 gfc_add_expr_to_block (&block
, tmp
);
1067 gfc_add_block_to_block (&block
, &post_block
);
1069 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1071 return gfc_finish_block (&block
);
1075 /* Translate a BACKSPACE statement. */
1078 gfc_trans_backspace (gfc_code
* code
)
1080 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1084 /* Translate an ENDFILE statement. */
1087 gfc_trans_endfile (gfc_code
* code
)
1089 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1093 /* Translate a REWIND statement. */
1096 gfc_trans_rewind (gfc_code
* code
)
1098 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1102 /* Translate a FLUSH statement. */
1105 gfc_trans_flush (gfc_code
* code
)
1107 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1111 /* Create a dummy iostat variable to catch any error due to bad unit. */
1114 create_dummy_iostat (void)
1119 gfc_get_ha_sym_tree ("@iostat", &st
);
1120 st
->n
.sym
->ts
.type
= BT_INTEGER
;
1121 st
->n
.sym
->ts
.kind
= gfc_default_integer_kind
;
1122 gfc_set_sym_referenced (st
->n
.sym
);
1123 gfc_commit_symbol (st
->n
.sym
);
1124 st
->n
.sym
->backend_decl
1125 = gfc_create_var (gfc_get_int_type (st
->n
.sym
->ts
.kind
),
1128 e
= gfc_get_expr ();
1129 e
->expr_type
= EXPR_VARIABLE
;
1131 e
->ts
.type
= BT_INTEGER
;
1132 e
->ts
.kind
= st
->n
.sym
->ts
.kind
;
1138 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1141 gfc_trans_inquire (gfc_code
* code
)
1143 stmtblock_t block
, post_block
;
1146 unsigned int mask
= 0, mask2
= 0;
1148 gfc_start_block (&block
);
1149 gfc_init_block (&post_block
);
1151 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1154 set_error_locus (&block
, var
, &code
->loc
);
1155 p
= code
->ext
.inquire
;
1158 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1162 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1166 mask
|= IOPARM_common_err
;
1169 if (p
->unit
&& p
->file
)
1170 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1173 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1178 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1181 if (p
->unit
&& !p
->iostat
)
1183 p
->iostat
= create_dummy_iostat ();
1184 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1185 IOPARM_common_iostat
, p
->iostat
);
1190 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1194 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1198 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1202 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1206 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1210 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1214 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1218 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1222 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1226 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1230 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1231 IOPARM_inquire_recl_out
, p
->recl
);
1234 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1235 IOPARM_inquire_nextrec
, p
->nextrec
);
1238 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1242 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1246 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1250 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1254 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1258 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1262 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1266 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1270 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1274 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1275 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1277 /* The second series of flags. */
1278 if (p
->asynchronous
)
1279 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_asynchronous
,
1283 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_decimal
,
1287 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_encoding
,
1291 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_round
,
1295 mask2
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sign
,
1299 mask2
|= set_parameter_ref (&block
, &post_block
, var
,
1300 IOPARM_inquire_pending
, p
->pending
);
1303 mask2
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_size
,
1307 mask2
|= set_parameter_ref (&block
, &post_block
,var
, IOPARM_inquire_id
,
1311 mask
|= set_parameter_const (&block
, var
, IOPARM_inquire_flags2
, mask2
);
1313 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1316 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1318 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1320 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1321 tmp
= build_call_expr (iocall
[IOCALL_INQUIRE
], 1, tmp
);
1322 gfc_add_expr_to_block (&block
, tmp
);
1324 gfc_add_block_to_block (&block
, &post_block
);
1326 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1328 return gfc_finish_block (&block
);
1333 gfc_trans_wait (gfc_code
* code
)
1335 stmtblock_t block
, post_block
;
1338 unsigned int mask
= 0;
1340 gfc_start_block (&block
);
1341 gfc_init_block (&post_block
);
1343 var
= gfc_create_var (st_parameter
[IOPARM_ptype_wait
].type
,
1346 set_error_locus (&block
, var
, &code
->loc
);
1349 /* Set parameters here. */
1351 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1355 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1359 mask
|= IOPARM_common_err
;
1362 mask
|= set_parameter_value (&block
, var
, IOPARM_wait_id
, p
->id
);
1364 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1367 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1369 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1370 tmp
= build_call_expr (iocall
[IOCALL_WAIT
], 1, tmp
);
1371 gfc_add_expr_to_block (&block
, tmp
);
1373 gfc_add_block_to_block (&block
, &post_block
);
1375 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1377 return gfc_finish_block (&block
);
1382 gfc_new_nml_name_expr (const char * name
)
1384 gfc_expr
* nml_name
;
1386 nml_name
= gfc_get_expr();
1387 nml_name
->ref
= NULL
;
1388 nml_name
->expr_type
= EXPR_CONSTANT
;
1389 nml_name
->ts
.kind
= gfc_default_character_kind
;
1390 nml_name
->ts
.type
= BT_CHARACTER
;
1391 nml_name
->value
.character
.length
= strlen(name
);
1392 nml_name
->value
.character
.string
= gfc_char_to_widechar (name
);
1397 /* nml_full_name builds up the fully qualified name of a
1398 derived type component. */
1401 nml_full_name (const char* var_name
, const char* cmp_name
)
1403 int full_name_length
;
1406 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1407 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1408 strcpy (full_name
, var_name
);
1409 full_name
= strcat (full_name
, "%");
1410 full_name
= strcat (full_name
, cmp_name
);
1414 /* nml_get_addr_expr builds an address expression from the
1415 gfc_symbol or gfc_component backend_decl's. An offset is
1416 provided so that the address of an element of an array of
1417 derived types is returned. This is used in the runtime to
1418 determine that span of the derived type. */
1421 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1424 tree decl
= NULL_TREE
;
1428 int dummy_arg_flagged
;
1432 sym
->attr
.referenced
= 1;
1433 decl
= gfc_get_symbol_decl (sym
);
1435 /* If this is the enclosing function declaration, use
1436 the fake result instead. */
1437 if (decl
== current_function_decl
)
1438 decl
= gfc_get_fake_result_decl (sym
, 0);
1439 else if (decl
== DECL_CONTEXT (current_function_decl
))
1440 decl
= gfc_get_fake_result_decl (sym
, 1);
1443 decl
= c
->backend_decl
;
1445 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1446 || TREE_CODE (decl
) == VAR_DECL
1447 || TREE_CODE (decl
) == PARM_DECL
)
1448 || TREE_CODE (decl
) == COMPONENT_REF
));
1452 /* Build indirect reference, if dummy argument. */
1454 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1456 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref (tmp
) : tmp
;
1458 /* If an array, set flag and use indirect ref. if built. */
1460 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1461 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1466 /* Treat the component of a derived type, using base_addr for
1467 the derived type. */
1469 if (TREE_CODE (decl
) == FIELD_DECL
)
1470 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1471 base_addr
, tmp
, NULL_TREE
);
1473 /* If we have a derived type component, a reference to the first
1474 element of the array is built. This is done so that base_addr,
1475 used in the build of the component reference, always points to
1479 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
, NULL
);
1481 /* Now build the address expression. */
1483 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1485 /* If scalar dummy, resolve indirect reference now. */
1487 if (dummy_arg_flagged
&& !array_flagged
)
1488 tmp
= build_fold_indirect_ref (tmp
);
1490 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1495 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1496 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1497 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1499 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1502 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1503 gfc_symbol
* sym
, gfc_component
* c
,
1506 gfc_typespec
* ts
= NULL
;
1507 gfc_array_spec
* as
= NULL
;
1508 tree addr_expr
= NULL
;
1518 gcc_assert (sym
|| c
);
1520 /* Build the namelist object name. */
1522 string
= gfc_build_cstring_const (var_name
);
1523 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1525 /* Build ts, as and data address using symbol or component. */
1527 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1528 as
= (sym
) ? sym
->as
: c
->as
;
1530 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1537 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1538 dtype
= gfc_get_dtype (dt
);
1542 itype
= GFC_DTYPE_UNKNOWN
;
1548 itype
= GFC_DTYPE_INTEGER
;
1551 itype
= GFC_DTYPE_LOGICAL
;
1554 itype
= GFC_DTYPE_REAL
;
1557 itype
= GFC_DTYPE_COMPLEX
;
1560 itype
= GFC_DTYPE_DERIVED
;
1563 itype
= GFC_DTYPE_CHARACTER
;
1569 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1572 /* Build up the arguments for the transfer call.
1573 The call for the scalar part transfers:
1574 (address, name, type, kind or string_length, dtype) */
1576 dt_parm_addr
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1578 if (ts
->type
== BT_CHARACTER
)
1579 tmp
= ts
->cl
->backend_decl
;
1581 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1582 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL
], 6,
1583 dt_parm_addr
, addr_expr
, string
,
1584 IARG (ts
->kind
), tmp
, dtype
);
1585 gfc_add_expr_to_block (block
, tmp
);
1587 /* If the object is an array, transfer rank times:
1588 (null pointer, name, stride, lbound, ubound) */
1590 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1592 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1595 GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
),
1596 GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
),
1597 GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1598 gfc_add_expr_to_block (block
, tmp
);
1601 if (ts
->type
== BT_DERIVED
)
1605 /* Provide the RECORD_TYPE to build component references. */
1607 tree expr
= build_fold_indirect_ref (addr_expr
);
1609 for (cmp
= ts
->derived
->components
; cmp
; cmp
= cmp
->next
)
1611 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1612 transfer_namelist_element (block
,
1615 gfc_free (full_name
);
1622 /* Create a data transfer statement. Not all of the fields are valid
1623 for both reading and writing, but improper use has been filtered
1627 build_dt (tree function
, gfc_code
* code
)
1629 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1634 unsigned int mask
= 0;
1636 gfc_start_block (&block
);
1637 gfc_init_block (&post_block
);
1638 gfc_init_block (&post_end_block
);
1639 gfc_init_block (&post_iu_block
);
1641 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1643 set_error_locus (&block
, var
, &code
->loc
);
1645 if (last_dt
== IOLENGTH
)
1649 inq
= code
->ext
.inquire
;
1651 /* First check that preconditions are met. */
1652 gcc_assert (inq
!= NULL
);
1653 gcc_assert (inq
->iolength
!= NULL
);
1655 /* Connect to the iolength variable. */
1656 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1657 IOPARM_dt_iolength
, inq
->iolength
);
1663 gcc_assert (dt
!= NULL
);
1666 if (dt
&& dt
->io_unit
)
1668 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1670 mask
|= set_internal_unit (&block
, &post_iu_block
,
1672 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1676 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1681 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1685 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1686 IOPARM_common_iostat
, dt
->iostat
);
1689 mask
|= IOPARM_common_err
;
1692 mask
|= IOPARM_common_eor
;
1695 mask
|= IOPARM_common_end
;
1698 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1699 IOPARM_dt_id
, dt
->id
);
1702 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_pos
, dt
->pos
);
1704 if (dt
->asynchronous
)
1705 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_asynchronous
,
1709 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_blank
,
1713 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_decimal
,
1717 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_delim
,
1721 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_pad
,
1725 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_round
,
1729 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_sign
,
1733 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1736 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1739 if (dt
->format_expr
)
1740 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1743 if (dt
->format_label
)
1745 if (dt
->format_label
== &format_asterisk
)
1746 mask
|= IOPARM_dt_list_format
;
1748 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1749 dt
->format_label
->format
);
1753 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1754 IOPARM_dt_size
, dt
->size
);
1758 if (dt
->format_expr
|| dt
->format_label
)
1759 gfc_internal_error ("build_dt: format with namelist");
1761 nmlname
= gfc_new_nml_name_expr (dt
->namelist
->name
);
1763 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1766 if (last_dt
== READ
)
1767 mask
|= IOPARM_dt_namelist_read_mode
;
1769 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1773 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1774 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1778 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1780 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1781 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1784 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1786 tmp
= gfc_build_addr_expr (NULL_TREE
, var
);
1787 tmp
= build_call_expr (function
, 1, tmp
);
1788 gfc_add_expr_to_block (&block
, tmp
);
1790 gfc_add_block_to_block (&block
, &post_block
);
1793 dt_post_end_block
= &post_end_block
;
1795 gfc_add_expr_to_block (&block
, gfc_trans_code (code
->block
->next
));
1797 gfc_add_block_to_block (&block
, &post_iu_block
);
1800 dt_post_end_block
= NULL
;
1802 return gfc_finish_block (&block
);
1806 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1807 this as a third sort of data transfer statement, except that
1808 lengths are summed instead of actually transferring any data. */
1811 gfc_trans_iolength (gfc_code
* code
)
1814 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1818 /* Translate a READ statement. */
1821 gfc_trans_read (gfc_code
* code
)
1824 return build_dt (iocall
[IOCALL_READ
], code
);
1828 /* Translate a WRITE statement */
1831 gfc_trans_write (gfc_code
* code
)
1834 return build_dt (iocall
[IOCALL_WRITE
], code
);
1838 /* Finish a data transfer statement. */
1841 gfc_trans_dt_end (gfc_code
* code
)
1846 gfc_init_block (&block
);
1851 function
= iocall
[IOCALL_READ_DONE
];
1855 function
= iocall
[IOCALL_WRITE_DONE
];
1859 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1866 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
1867 tmp
= build_call_expr (function
, 1, tmp
);
1868 gfc_add_expr_to_block (&block
, tmp
);
1869 gfc_add_block_to_block (&block
, dt_post_end_block
);
1870 gfc_init_block (dt_post_end_block
);
1872 if (last_dt
!= IOLENGTH
)
1874 gcc_assert (code
->ext
.dt
!= NULL
);
1875 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1876 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1879 return gfc_finish_block (&block
);
1883 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1885 /* Given an array field in a derived type variable, generate the code
1886 for the loop that iterates over array elements, and the code that
1887 accesses those array elements. Use transfer_expr to generate code
1888 for transferring that element. Because elements may also be
1889 derived types, transfer_expr and transfer_array_component are mutually
1893 transfer_array_component (tree expr
, gfc_component
* cm
, locus
* where
)
1903 gfc_start_block (&block
);
1904 gfc_init_se (&se
, NULL
);
1906 /* Create and initialize Scalarization Status. Unlike in
1907 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1908 care of this task, because we don't have a gfc_expr at hand.
1909 Build one manually, as in gfc_trans_subarray_assign. */
1912 ss
->type
= GFC_SS_COMPONENT
;
1914 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1915 ss
->next
= gfc_ss_terminator
;
1916 ss
->data
.info
.dimen
= cm
->as
->rank
;
1917 ss
->data
.info
.descriptor
= expr
;
1918 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1919 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1920 for (n
= 0; n
< cm
->as
->rank
; n
++)
1922 ss
->data
.info
.dim
[n
] = n
;
1923 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1924 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1926 mpz_init (ss
->shape
[n
]);
1927 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1928 cm
->as
->lower
[n
]->value
.integer
);
1929 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1932 /* Once we got ss, we use scalarizer to create the loop. */
1934 gfc_init_loopinfo (&loop
);
1935 gfc_add_ss_to_loop (&loop
, ss
);
1936 gfc_conv_ss_startstride (&loop
);
1937 gfc_conv_loop_setup (&loop
, where
);
1938 gfc_mark_ss_chain_used (ss
, 1);
1939 gfc_start_scalarized_body (&loop
, &body
);
1941 gfc_copy_loopinfo_to_se (&se
, &loop
);
1944 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1946 gfc_conv_tmp_array_ref (&se
);
1948 /* Now se.expr contains an element of the array. Take the address and pass
1949 it to the IO routines. */
1950 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
1951 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1953 /* We are done now with the loop body. Wrap up the scalarizer and
1956 gfc_add_block_to_block (&body
, &se
.pre
);
1957 gfc_add_block_to_block (&body
, &se
.post
);
1959 gfc_trans_scalarizing_loops (&loop
, &body
);
1961 gfc_add_block_to_block (&block
, &loop
.pre
);
1962 gfc_add_block_to_block (&block
, &loop
.post
);
1964 for (n
= 0; n
< cm
->as
->rank
; n
++)
1965 mpz_clear (ss
->shape
[n
]);
1966 gfc_free (ss
->shape
);
1968 gfc_cleanup_loop (&loop
);
1970 return gfc_finish_block (&block
);
1973 /* Generate the call for a scalar transfer node. */
1976 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
1978 tree tmp
, function
, arg2
, arg3
, field
, expr
;
1982 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
1983 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
1984 We need to translate the expression to a constant if it's either
1985 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
1986 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
1987 BT_DERIVED (could have been changed by gfc_conv_expr). */
1988 if ((ts
->type
== BT_DERIVED
&& ts
->is_iso_c
== 1 && ts
->derived
!= NULL
)
1989 || (ts
->derived
!= NULL
&& ts
->derived
->ts
.is_iso_c
== 1))
1991 /* C_PTR and C_FUNPTR have private components which means they can not
1992 be printed. However, if -std=gnu and not -pedantic, allow
1993 the component to be printed to help debugging. */
1994 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
1996 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
1997 ts
->derived
->name
, code
!= NULL
? &(code
->loc
) :
1998 &gfc_current_locus
);
2002 ts
->type
= ts
->derived
->ts
.type
;
2003 ts
->kind
= ts
->derived
->ts
.kind
;
2004 ts
->f90_type
= ts
->derived
->ts
.f90_type
;
2015 arg2
= build_int_cst (NULL_TREE
, kind
);
2016 function
= iocall
[IOCALL_X_INTEGER
];
2020 arg2
= build_int_cst (NULL_TREE
, kind
);
2021 function
= iocall
[IOCALL_X_REAL
];
2025 arg2
= build_int_cst (NULL_TREE
, kind
);
2026 function
= iocall
[IOCALL_X_COMPLEX
];
2030 arg2
= build_int_cst (NULL_TREE
, kind
);
2031 function
= iocall
[IOCALL_X_LOGICAL
];
2037 if (se
->string_length
)
2038 arg2
= se
->string_length
;
2041 tmp
= build_fold_indirect_ref (addr_expr
);
2042 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2043 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2044 arg2
= fold_convert (gfc_charlen_type_node
, arg2
);
2046 arg3
= build_int_cst (NULL_TREE
, kind
);
2047 function
= iocall
[IOCALL_X_CHARACTER_WIDE
];
2048 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2049 tmp
= build_call_expr (function
, 4, tmp
, addr_expr
, arg2
, arg3
);
2050 gfc_add_expr_to_block (&se
->pre
, tmp
);
2051 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2056 if (se
->string_length
)
2057 arg2
= se
->string_length
;
2060 tmp
= build_fold_indirect_ref (addr_expr
);
2061 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
2062 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
2064 function
= iocall
[IOCALL_X_CHARACTER
];
2068 /* Recurse into the elements of the derived type. */
2069 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
2070 expr
= build_fold_indirect_ref (expr
);
2072 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2074 field
= c
->backend_decl
;
2075 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2077 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
2078 expr
, field
, NULL_TREE
);
2080 if (c
->attr
.dimension
)
2082 tmp
= transfer_array_component (tmp
, c
, & code
->loc
);
2083 gfc_add_expr_to_block (&se
->pre
, tmp
);
2087 if (!c
->attr
.pointer
)
2088 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2089 transfer_expr (se
, &c
->ts
, tmp
, code
);
2095 internal_error ("Bad IO basetype (%d)", ts
->type
);
2098 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2099 tmp
= build_call_expr (function
, 3, tmp
, addr_expr
, arg2
);
2100 gfc_add_expr_to_block (&se
->pre
, tmp
);
2101 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2106 /* Generate a call to pass an array descriptor to the IO library. The
2107 array should be of one of the intrinsic types. */
2110 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
2112 tree tmp
, charlen_arg
, kind_arg
;
2114 if (ts
->type
== BT_CHARACTER
)
2115 charlen_arg
= se
->string_length
;
2117 charlen_arg
= build_int_cst (NULL_TREE
, 0);
2119 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
2121 tmp
= gfc_build_addr_expr (NULL_TREE
, dt_parm
);
2122 tmp
= build_call_expr (iocall
[IOCALL_X_ARRAY
], 4,
2123 tmp
, addr_expr
, kind_arg
, charlen_arg
);
2124 gfc_add_expr_to_block (&se
->pre
, tmp
);
2125 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2129 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2132 gfc_trans_transfer (gfc_code
* code
)
2134 stmtblock_t block
, body
;
2143 gfc_start_block (&block
);
2144 gfc_init_block (&body
);
2147 ss
= gfc_walk_expr (expr
);
2150 gfc_init_se (&se
, NULL
);
2152 if (ss
== gfc_ss_terminator
)
2154 /* Transfer a scalar value. */
2155 gfc_conv_expr_reference (&se
, expr
);
2156 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2160 /* Transfer an array. If it is an array of an intrinsic
2161 type, pass the descriptor to the library. Otherwise
2162 scalarize the transfer. */
2165 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
2167 gcc_assert (ref
->type
== REF_ARRAY
);
2170 if (expr
->ts
.type
!= BT_DERIVED
2171 && ref
&& ref
->next
== NULL
2172 && !is_subref_array (expr
))
2174 bool seen_vector
= false;
2176 if (ref
&& ref
->u
.ar
.type
== AR_SECTION
)
2178 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2179 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2183 if (seen_vector
&& last_dt
== READ
)
2185 /* Create a temp, read to that and copy it back. */
2186 gfc_conv_subref_array_arg (&se
, expr
, 0, INTENT_OUT
);
2191 /* Get the descriptor. */
2192 gfc_conv_expr_descriptor (&se
, expr
, ss
);
2193 tmp
= gfc_build_addr_expr (NULL_TREE
, se
.expr
);
2196 transfer_array_desc (&se
, &expr
->ts
, tmp
);
2197 goto finish_block_label
;
2200 /* Initialize the scalarizer. */
2201 gfc_init_loopinfo (&loop
);
2202 gfc_add_ss_to_loop (&loop
, ss
);
2204 /* Initialize the loop. */
2205 gfc_conv_ss_startstride (&loop
);
2206 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
2208 /* The main loop body. */
2209 gfc_mark_ss_chain_used (ss
, 1);
2210 gfc_start_scalarized_body (&loop
, &body
);
2212 gfc_copy_loopinfo_to_se (&se
, &loop
);
2215 gfc_conv_expr_reference (&se
, expr
);
2216 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2221 gfc_add_block_to_block (&body
, &se
.pre
);
2222 gfc_add_block_to_block (&body
, &se
.post
);
2225 tmp
= gfc_finish_block (&body
);
2228 gcc_assert (se
.ss
== gfc_ss_terminator
);
2229 gfc_trans_scalarizing_loops (&loop
, &body
);
2231 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2232 tmp
= gfc_finish_block (&loop
.pre
);
2233 gfc_cleanup_loop (&loop
);
2236 gfc_add_expr_to_block (&block
, tmp
);
2238 return gfc_finish_block (&block
);
2241 #include "gt-fortran-trans-io.h"