1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
26 #include "coretypes.h"
28 #include "tree-gimple.h"
34 #include "trans-stmt.h"
35 #include "trans-array.h"
36 #include "trans-types.h"
37 #include "trans-const.h"
39 /* Members of the ioparm structure. */
67 typedef struct gfc_st_parameter_field
GTY(())
71 enum ioparam_type param_type
;
72 enum iofield_type type
;
76 gfc_st_parameter_field
;
78 typedef struct gfc_st_parameter
GTY(())
87 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
93 static GTY(()) gfc_st_parameter st_parameter
[] =
103 static GTY(()) gfc_st_parameter_field st_parameter_field
[] =
105 #define IOPARM(param_type, name, mask, type) \
106 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
107 #include "ioparm.def"
109 { NULL
, 0, 0, 0, NULL
, NULL
}
112 /* Library I/O subroutines */
130 IOCALL_IOLENGTH_DONE
,
136 IOCALL_SET_NML_VAL_DIM
,
140 static GTY(()) tree iocall
[IOCALL_NUM
];
142 /* Variable for keeping track of what the last data transfer statement
143 was. Used for deciding which subroutine to call when the data
144 transfer is complete. */
145 static enum { READ
, WRITE
, IOLENGTH
} last_dt
;
147 /* The data transfer parameter block that should be shared by all
148 data transfer calls belonging to the same read/write/iolength. */
149 static GTY(()) tree dt_parm
;
150 static stmtblock_t
*dt_post_end_block
;
153 gfc_build_st_parameter (enum ioparam_type ptype
, tree
*types
)
156 gfc_st_parameter_field
*p
;
159 tree t
= make_node (RECORD_TYPE
);
161 len
= strlen (st_parameter
[ptype
].name
);
162 gcc_assert (len
<= sizeof (name
) - sizeof ("__st_parameter_"));
163 memcpy (name
, "__st_parameter_", sizeof ("__st_parameter_"));
164 memcpy (name
+ sizeof ("__st_parameter_") - 1, st_parameter
[ptype
].name
,
166 TYPE_NAME (t
) = get_identifier (name
);
168 for (type
= 0, p
= st_parameter_field
; type
< IOPARM_field_num
; type
++, p
++)
169 if (p
->param_type
== ptype
)
172 case IOPARM_type_int4
:
173 case IOPARM_type_intio
:
174 case IOPARM_type_pint4
:
175 case IOPARM_type_pintio
:
176 case IOPARM_type_parray
:
177 case IOPARM_type_pchar
:
178 case IOPARM_type_pad
:
179 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
180 get_identifier (p
->name
),
183 case IOPARM_type_char1
:
184 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
185 get_identifier (p
->name
),
188 case IOPARM_type_char2
:
189 len
= strlen (p
->name
);
190 gcc_assert (len
<= sizeof (name
) - sizeof ("_len"));
191 memcpy (name
, p
->name
, len
);
192 memcpy (name
+ len
, "_len", sizeof ("_len"));
193 p
->field_len
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
194 get_identifier (name
),
195 gfc_charlen_type_node
);
196 if (p
->type
== IOPARM_type_char2
)
197 p
->field
= gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
198 get_identifier (p
->name
),
201 case IOPARM_type_common
:
203 = gfc_add_field_to_struct (&TYPE_FIELDS (t
), t
,
204 get_identifier (p
->name
),
205 st_parameter
[IOPARM_ptype_common
].type
);
207 case IOPARM_type_num
:
212 st_parameter
[ptype
].type
= t
;
216 /* Build code to test an error condition and call generate_error if needed.
217 Note: This builds calls to generate_error in the runtime library function.
218 The function generate_error is dependent on certain parameters in the
219 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
220 Therefore, the code to set these flags must be generated before
221 this function is used. */
224 gfc_trans_io_runtime_check (tree cond
, tree var
, int error_code
,
225 const char * msgid
, stmtblock_t
* pblock
)
230 tree arg1
, arg2
, arg3
;
233 if (integer_zerop (cond
))
236 /* The code to generate the error. */
237 gfc_start_block (&block
);
239 arg1
= build_fold_addr_expr (var
);
241 arg2
= build_int_cst (integer_type_node
, error_code
),
243 asprintf (&message
, "%s", _(msgid
));
244 arg3
= gfc_build_addr_expr (pchar_type_node
, gfc_build_cstring_const(message
));
247 tmp
= build_call_expr (gfor_fndecl_generate_error
, 3, arg1
, arg2
, arg3
);
249 gfc_add_expr_to_block (&block
, tmp
);
251 body
= gfc_finish_block (&block
);
253 if (integer_onep (cond
))
255 gfc_add_expr_to_block (pblock
, body
);
259 /* Tell the compiler that this isn't likely. */
260 cond
= fold_convert (long_integer_type_node
, cond
);
261 tmp
= build_int_cst (long_integer_type_node
, 0);
262 cond
= build_call_expr (built_in_decls
[BUILT_IN_EXPECT
], 2, cond
, tmp
);
263 cond
= fold_convert (boolean_type_node
, cond
);
265 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt ());
266 gfc_add_expr_to_block (pblock
, tmp
);
271 /* Create function decls for IO library functions. */
274 gfc_build_io_library_fndecls (void)
276 tree types
[IOPARM_type_num
], pad_idx
, gfc_int4_type_node
;
277 tree gfc_intio_type_node
;
278 tree parm_type
, dt_parm_type
;
279 tree gfc_c_int_type_node
;
280 HOST_WIDE_INT pad_size
;
281 enum ioparam_type ptype
;
283 types
[IOPARM_type_int4
] = gfc_int4_type_node
= gfc_get_int_type (4);
284 types
[IOPARM_type_intio
] = gfc_intio_type_node
285 = gfc_get_int_type (gfc_intio_kind
);
286 types
[IOPARM_type_pint4
] = build_pointer_type (gfc_int4_type_node
);
287 types
[IOPARM_type_pintio
]
288 = build_pointer_type (gfc_intio_type_node
);
289 types
[IOPARM_type_parray
] = pchar_type_node
;
290 types
[IOPARM_type_pchar
] = pchar_type_node
;
291 pad_size
= 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node
));
292 pad_size
+= 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node
));
293 pad_idx
= build_index_type (build_int_cst (NULL_TREE
, pad_size
));
294 types
[IOPARM_type_pad
] = build_array_type (char_type_node
, pad_idx
);
296 /* pad actually contains pointers and integers so it needs to have an
297 alignment that is at least as large as the needed alignment for those
298 types. See the st_parameter_dt structure in libgfortran/io/io.h for
299 what really goes into this space. */
300 TYPE_ALIGN (types
[IOPARM_type_pad
]) = MAX (TYPE_ALIGN (pchar_type_node
),
301 TYPE_ALIGN (gfc_get_int_type (gfc_max_integer_kind
)));
303 gfc_c_int_type_node
= gfc_get_int_type (gfc_c_int_kind
);
305 for (ptype
= IOPARM_ptype_common
; ptype
< IOPARM_ptype_num
; ptype
++)
306 gfc_build_st_parameter (ptype
, types
);
308 /* Define the transfer functions. */
310 dt_parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_dt
].type
);
312 iocall
[IOCALL_X_INTEGER
] =
313 gfc_build_library_function_decl (get_identifier
314 (PREFIX("transfer_integer")),
315 void_type_node
, 3, dt_parm_type
,
316 pvoid_type_node
, gfc_int4_type_node
);
318 iocall
[IOCALL_X_LOGICAL
] =
319 gfc_build_library_function_decl (get_identifier
320 (PREFIX("transfer_logical")),
321 void_type_node
, 3, dt_parm_type
,
322 pvoid_type_node
, gfc_int4_type_node
);
324 iocall
[IOCALL_X_CHARACTER
] =
325 gfc_build_library_function_decl (get_identifier
326 (PREFIX("transfer_character")),
327 void_type_node
, 3, dt_parm_type
,
328 pvoid_type_node
, gfc_int4_type_node
);
330 iocall
[IOCALL_X_REAL
] =
331 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
332 void_type_node
, 3, dt_parm_type
,
333 pvoid_type_node
, gfc_int4_type_node
);
335 iocall
[IOCALL_X_COMPLEX
] =
336 gfc_build_library_function_decl (get_identifier
337 (PREFIX("transfer_complex")),
338 void_type_node
, 3, dt_parm_type
,
339 pvoid_type_node
, gfc_int4_type_node
);
341 iocall
[IOCALL_X_ARRAY
] =
342 gfc_build_library_function_decl (get_identifier
343 (PREFIX("transfer_array")),
344 void_type_node
, 4, dt_parm_type
,
345 pvoid_type_node
, gfc_c_int_type_node
,
346 gfc_charlen_type_node
);
348 /* Library entry points */
350 iocall
[IOCALL_READ
] =
351 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
352 void_type_node
, 1, dt_parm_type
);
354 iocall
[IOCALL_WRITE
] =
355 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
356 void_type_node
, 1, dt_parm_type
);
358 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_open
].type
);
359 iocall
[IOCALL_OPEN
] =
360 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
361 void_type_node
, 1, parm_type
);
364 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_close
].type
);
365 iocall
[IOCALL_CLOSE
] =
366 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
367 void_type_node
, 1, parm_type
);
369 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_inquire
].type
);
370 iocall
[IOCALL_INQUIRE
] =
371 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
372 gfc_int4_type_node
, 1, parm_type
);
374 iocall
[IOCALL_IOLENGTH
] =
375 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
376 void_type_node
, 1, dt_parm_type
);
378 parm_type
= build_pointer_type (st_parameter
[IOPARM_ptype_filepos
].type
);
379 iocall
[IOCALL_REWIND
] =
380 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
381 gfc_int4_type_node
, 1, parm_type
);
383 iocall
[IOCALL_BACKSPACE
] =
384 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
385 gfc_int4_type_node
, 1, parm_type
);
387 iocall
[IOCALL_ENDFILE
] =
388 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
389 gfc_int4_type_node
, 1, parm_type
);
391 iocall
[IOCALL_FLUSH
] =
392 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
393 gfc_int4_type_node
, 1, parm_type
);
395 /* Library helpers */
397 iocall
[IOCALL_READ_DONE
] =
398 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
399 gfc_int4_type_node
, 1, dt_parm_type
);
401 iocall
[IOCALL_WRITE_DONE
] =
402 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
403 gfc_int4_type_node
, 1, dt_parm_type
);
405 iocall
[IOCALL_IOLENGTH_DONE
] =
406 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
407 gfc_int4_type_node
, 1, dt_parm_type
);
410 iocall
[IOCALL_SET_NML_VAL
] =
411 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
412 void_type_node
, 6, dt_parm_type
,
413 pvoid_type_node
, pvoid_type_node
,
414 gfc_int4_type_node
, gfc_charlen_type_node
,
417 iocall
[IOCALL_SET_NML_VAL_DIM
] =
418 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
419 void_type_node
, 5, dt_parm_type
,
420 gfc_int4_type_node
, gfc_int4_type_node
,
421 gfc_int4_type_node
, gfc_int4_type_node
);
425 /* Generate code to store an integer constant into the
426 st_parameter_XXX structure. */
429 set_parameter_const (stmtblock_t
*block
, tree var
, enum iofield type
,
433 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
435 if (p
->param_type
== IOPARM_ptype_common
)
436 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
437 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
438 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
440 gfc_add_modify_expr (block
, tmp
, build_int_cst (TREE_TYPE (p
->field
), val
));
445 /* Generate code to store a non-string I/O parameter into the
446 st_parameter_XXX structure. This is a pass by value. */
449 set_parameter_value (stmtblock_t
*block
, tree var
, enum iofield type
,
454 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
455 tree dest_type
= TREE_TYPE (p
->field
);
457 gfc_init_se (&se
, NULL
);
458 gfc_conv_expr_val (&se
, e
);
460 /* If we're storing a UNIT number, we need to check it first. */
461 if (type
== IOPARM_common_unit
&& e
->ts
.kind
!= 4)
464 ioerror_codes bad_unit
;
467 bad_unit
= IOERROR_BAD_UNIT
;
469 /* Don't evaluate the UNIT number multiple times. */
470 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
472 /* UNIT numbers should be nonnegative. */
473 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, se
.expr
,
474 build_int_cst (TREE_TYPE (se
.expr
),0));
475 gfc_trans_io_runtime_check (cond
, var
, bad_unit
,
476 "Negative unit number in I/O statement",
479 /* UNIT numbers should be less than the max. */
480 i
= gfc_validate_kind (BT_INTEGER
, 4, false);
481 max
= gfc_conv_mpz_to_tree (gfc_integer_kinds
[i
].huge
, 4);
482 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, se
.expr
,
483 fold_convert (TREE_TYPE (se
.expr
), max
));
484 gfc_trans_io_runtime_check (cond
, var
, bad_unit
,
485 "Unit number in I/O statement too large",
490 se
.expr
= convert (dest_type
, se
.expr
);
491 gfc_add_block_to_block (block
, &se
.pre
);
493 if (p
->param_type
== IOPARM_ptype_common
)
494 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
495 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
497 tmp
= build3 (COMPONENT_REF
, dest_type
, var
, p
->field
, NULL_TREE
);
498 gfc_add_modify_expr (block
, tmp
, se
.expr
);
503 /* Generate code to store a non-string I/O parameter into the
504 st_parameter_XXX structure. This is pass by reference. */
507 set_parameter_ref (stmtblock_t
*block
, stmtblock_t
*postblock
,
508 tree var
, enum iofield type
, gfc_expr
*e
)
512 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
514 gcc_assert (e
->ts
.type
== BT_INTEGER
|| e
->ts
.type
== BT_LOGICAL
);
515 gfc_init_se (&se
, NULL
);
516 gfc_conv_expr_lhs (&se
, e
);
518 gfc_add_block_to_block (block
, &se
.pre
);
520 if (TYPE_MODE (TREE_TYPE (se
.expr
))
521 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p
->field
))))
523 addr
= convert (TREE_TYPE (p
->field
), build_fold_addr_expr (se
.expr
));
525 /* If this is for the iostat variable initialize the
526 user variable to IOERROR_OK which is zero. */
527 if (type
== IOPARM_common_iostat
)
531 gfc_add_modify_expr (block
, se
.expr
,
532 build_int_cst (TREE_TYPE (se
.expr
), ok
));
537 /* The type used by the library has different size
538 from the type of the variable supplied by the user.
539 Need to use a temporary. */
540 tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p
->field
)),
541 st_parameter_field
[type
].name
);
543 /* If this is for the iostat variable, initialize the
544 user variable to IOERROR_OK which is zero. */
545 if (type
== IOPARM_common_iostat
)
549 gfc_add_modify_expr (block
, tmpvar
,
550 build_int_cst (TREE_TYPE (tmpvar
), ok
));
553 addr
= build_fold_addr_expr (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_expr (postblock
, se
.expr
, tmp
);
559 if (p
->param_type
== IOPARM_ptype_common
)
560 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
561 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
562 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
564 gfc_add_modify_expr (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
576 gfc_convert_array_to_string (gfc_se
* se
, gfc_expr
* e
)
585 sym
= e
->symtree
->n
.sym
;
586 rank
= sym
->as
->rank
- 1;
588 if (e
->ref
->u
.ar
.type
== AR_FULL
)
590 se
->expr
= gfc_get_symbol_decl (sym
);
591 se
->expr
= gfc_conv_array_data (se
->expr
);
595 gfc_conv_expr (se
, e
);
598 array
= sym
->backend_decl
;
599 type
= TREE_TYPE (array
);
601 if (GFC_ARRAY_TYPE_P (type
))
602 size
= GFC_TYPE_ARRAY_SIZE (type
);
605 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type
));
606 size
= gfc_conv_array_stride (array
, rank
);
607 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
608 gfc_conv_array_ubound (array
, rank
),
609 gfc_conv_array_lbound (array
, rank
));
610 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, tmp
,
612 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, tmp
, size
);
617 /* If it is an element, we need the its address and size of the rest. */
618 if (e
->ref
->u
.ar
.type
== AR_ELEMENT
)
620 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
621 TREE_OPERAND (se
->expr
, 1));
622 se
->expr
= build_fold_addr_expr (se
->expr
);
625 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
626 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
627 fold_convert (gfc_array_index_type
, tmp
));
629 se
->string_length
= fold_convert (gfc_charlen_type_node
, size
);
633 /* Generate code to store a string and its length into the
634 st_parameter_XXX structure. */
637 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
638 enum iofield type
, gfc_expr
* e
)
644 gfc_st_parameter_field
*p
= &st_parameter_field
[type
];
646 gfc_init_se (&se
, NULL
);
648 if (p
->param_type
== IOPARM_ptype_common
)
649 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
650 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
651 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
653 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
656 /* Integer variable assigned a format label. */
657 if (e
->ts
.type
== BT_INTEGER
&& e
->symtree
->n
.sym
->attr
.assign
== 1)
661 gfc_conv_label_variable (&se
, e
);
662 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
663 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
,
664 tmp
, build_int_cst (TREE_TYPE (tmp
), 0));
666 asprintf(&msg
, "Label assigned to variable '%s' is not a format label",
668 gfc_trans_runtime_check (tmp
, msg
, &se
.pre
, &e
->where
);
671 gfc_add_modify_expr (&se
.pre
, io
,
672 fold_convert (TREE_TYPE (io
), GFC_DECL_ASSIGN_ADDR (se
.expr
)));
673 gfc_add_modify_expr (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
677 /* General character. */
678 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
679 gfc_conv_expr (&se
, e
);
680 /* Array assigned Hollerith constant or character array. */
681 else if (e
->symtree
&& (e
->symtree
->n
.sym
->as
->rank
> 0))
682 gfc_convert_array_to_string (&se
, e
);
686 gfc_conv_string_parameter (&se
);
687 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
688 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
691 gfc_add_block_to_block (block
, &se
.pre
);
692 gfc_add_block_to_block (postblock
, &se
.post
);
697 /* Generate code to store the character (array) and the character length
698 for an internal unit. */
701 set_internal_unit (stmtblock_t
* block
, stmtblock_t
* post_block
,
702 tree var
, gfc_expr
* e
)
709 gfc_st_parameter_field
*p
;
712 gfc_init_se (&se
, NULL
);
714 p
= &st_parameter_field
[IOPARM_dt_internal_unit
];
716 io
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
718 len
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field_len
), var
, p
->field_len
,
720 p
= &st_parameter_field
[IOPARM_dt_internal_unit_desc
];
721 desc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
724 gcc_assert (e
->ts
.type
== BT_CHARACTER
);
726 /* Character scalars. */
729 gfc_conv_expr (&se
, e
);
730 gfc_conv_string_parameter (&se
);
732 se
.expr
= build_int_cst (pchar_type_node
, 0);
735 /* Character array. */
736 else if (e
->rank
> 0)
738 se
.ss
= gfc_walk_expr (e
);
740 if (is_aliased_array (e
))
742 /* Use a temporary for components of arrays of derived types
743 or substring array references. */
744 gfc_conv_aliased_arg (&se
, e
, 0,
745 last_dt
== READ
? INTENT_IN
: INTENT_OUT
);
746 tmp
= build_fold_indirect_ref (se
.expr
);
747 se
.expr
= gfc_build_addr_expr (pchar_type_node
, tmp
);
748 tmp
= gfc_conv_descriptor_data_get (tmp
);
752 /* Return the data pointer and rank from the descriptor. */
753 gfc_conv_expr_descriptor (&se
, e
, se
.ss
);
754 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
755 se
.expr
= gfc_build_addr_expr (pchar_type_node
, se
.expr
);
761 /* The cast is needed for character substrings and the descriptor
763 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), tmp
));
764 gfc_add_modify_expr (&se
.pre
, len
,
765 fold_convert (TREE_TYPE (len
), se
.string_length
));
766 gfc_add_modify_expr (&se
.pre
, desc
, se
.expr
);
768 gfc_add_block_to_block (block
, &se
.pre
);
769 gfc_add_block_to_block (post_block
, &se
.post
);
773 /* Add a case to a IO-result switch. */
776 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
781 return; /* No label, no case */
783 value
= build_int_cst (NULL_TREE
, label_value
);
785 /* Make a backend label for this case. */
786 tmp
= gfc_build_label_decl (NULL_TREE
);
788 /* And the case itself. */
789 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
790 gfc_add_expr_to_block (body
, tmp
);
792 /* Jump to the label. */
793 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
794 gfc_add_expr_to_block (body
, tmp
);
798 /* Generate a switch statement that branches to the correct I/O
799 result label. The last statement of an I/O call stores the
800 result into a variable because there is often cleanup that
801 must be done before the switch, so a temporary would have to
802 be created anyway. */
805 io_result (stmtblock_t
* block
, tree var
, gfc_st_label
* err_label
,
806 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
810 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_flags
];
812 /* If no labels are specified, ignore the result instead
813 of building an empty switch. */
814 if (err_label
== NULL
816 && eor_label
== NULL
)
819 /* Build a switch statement. */
820 gfc_start_block (&body
);
822 /* The label values here must be the same as the values
823 in the library_return enum in the runtime library */
824 add_case (1, err_label
, &body
);
825 add_case (2, end_label
, &body
);
826 add_case (3, eor_label
, &body
);
828 tmp
= gfc_finish_block (&body
);
830 var
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
831 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
832 rc
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), var
, p
->field
,
834 rc
= build2 (BIT_AND_EXPR
, TREE_TYPE (rc
), rc
,
835 build_int_cst (TREE_TYPE (rc
), IOPARM_common_libreturn_mask
));
837 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
839 gfc_add_expr_to_block (block
, tmp
);
843 /* Store the current file and line number to variables so that if a
844 library call goes awry, we can tell the user where the problem is. */
847 set_error_locus (stmtblock_t
* block
, tree var
, locus
* where
)
850 tree str
, locus_file
;
852 gfc_st_parameter_field
*p
= &st_parameter_field
[IOPARM_common_filename
];
854 locus_file
= build3 (COMPONENT_REF
, st_parameter
[IOPARM_ptype_common
].type
,
855 var
, TYPE_FIELDS (TREE_TYPE (var
)), NULL_TREE
);
856 locus_file
= build3 (COMPONENT_REF
, TREE_TYPE (p
->field
), locus_file
,
857 p
->field
, NULL_TREE
);
859 str
= gfc_build_cstring_const (f
->filename
);
861 str
= gfc_build_addr_expr (pchar_type_node
, str
);
862 gfc_add_modify_expr (block
, locus_file
, str
);
864 #ifdef USE_MAPPED_LOCATION
865 line
= LOCATION_LINE (where
->lb
->location
);
867 line
= where
->lb
->linenum
;
869 set_parameter_const (block
, var
, IOPARM_common_line
, line
);
873 /* Translate an OPEN statement. */
876 gfc_trans_open (gfc_code
* code
)
878 stmtblock_t block
, post_block
;
881 unsigned int mask
= 0;
883 gfc_start_block (&block
);
884 gfc_init_block (&post_block
);
886 var
= gfc_create_var (st_parameter
[IOPARM_ptype_open
].type
, "open_parm");
888 set_error_locus (&block
, var
, &code
->loc
);
892 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
896 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
900 mask
|= IOPARM_common_err
;
903 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_file
, p
->file
);
906 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_status
,
910 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_access
,
914 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_form
, p
->form
);
917 mask
|= set_parameter_value (&block
, var
, IOPARM_open_recl_in
, p
->recl
);
920 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_blank
,
924 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_position
,
928 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_action
,
932 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_delim
,
936 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_pad
, p
->pad
);
939 mask
|= set_string (&block
, &post_block
, var
, IOPARM_open_convert
,
942 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
945 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
947 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
949 tmp
= build_fold_addr_expr (var
);
950 tmp
= build_call_expr (iocall
[IOCALL_OPEN
], 1, tmp
);
951 gfc_add_expr_to_block (&block
, tmp
);
953 gfc_add_block_to_block (&block
, &post_block
);
955 io_result (&block
, var
, p
->err
, NULL
, NULL
);
957 return gfc_finish_block (&block
);
961 /* Translate a CLOSE statement. */
964 gfc_trans_close (gfc_code
* code
)
966 stmtblock_t block
, post_block
;
969 unsigned int mask
= 0;
971 gfc_start_block (&block
);
972 gfc_init_block (&post_block
);
974 var
= gfc_create_var (st_parameter
[IOPARM_ptype_close
].type
, "close_parm");
976 set_error_locus (&block
, var
, &code
->loc
);
980 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
984 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
988 mask
|= IOPARM_common_err
;
991 mask
|= set_string (&block
, &post_block
, var
, IOPARM_close_status
,
994 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
997 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
999 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1001 tmp
= build_fold_addr_expr (var
);
1002 tmp
= build_call_expr (iocall
[IOCALL_CLOSE
], 1, tmp
);
1003 gfc_add_expr_to_block (&block
, tmp
);
1005 gfc_add_block_to_block (&block
, &post_block
);
1007 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1009 return gfc_finish_block (&block
);
1013 /* Common subroutine for building a file positioning statement. */
1016 build_filepos (tree function
, gfc_code
* code
)
1018 stmtblock_t block
, post_block
;
1021 unsigned int mask
= 0;
1023 p
= code
->ext
.filepos
;
1025 gfc_start_block (&block
);
1026 gfc_init_block (&post_block
);
1028 var
= gfc_create_var (st_parameter
[IOPARM_ptype_filepos
].type
,
1031 set_error_locus (&block
, var
, &code
->loc
);
1034 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1038 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1042 mask
|= IOPARM_common_err
;
1044 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1047 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1049 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1051 tmp
= build_fold_addr_expr (var
);
1052 tmp
= build_call_expr (function
, 1, tmp
);
1053 gfc_add_expr_to_block (&block
, tmp
);
1055 gfc_add_block_to_block (&block
, &post_block
);
1057 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1059 return gfc_finish_block (&block
);
1063 /* Translate a BACKSPACE statement. */
1066 gfc_trans_backspace (gfc_code
* code
)
1068 return build_filepos (iocall
[IOCALL_BACKSPACE
], code
);
1072 /* Translate an ENDFILE statement. */
1075 gfc_trans_endfile (gfc_code
* code
)
1077 return build_filepos (iocall
[IOCALL_ENDFILE
], code
);
1081 /* Translate a REWIND statement. */
1084 gfc_trans_rewind (gfc_code
* code
)
1086 return build_filepos (iocall
[IOCALL_REWIND
], code
);
1090 /* Translate a FLUSH statement. */
1093 gfc_trans_flush (gfc_code
* code
)
1095 return build_filepos (iocall
[IOCALL_FLUSH
], code
);
1099 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1102 gfc_trans_inquire (gfc_code
* code
)
1104 stmtblock_t block
, post_block
;
1107 unsigned int mask
= 0;
1109 gfc_start_block (&block
);
1110 gfc_init_block (&post_block
);
1112 var
= gfc_create_var (st_parameter
[IOPARM_ptype_inquire
].type
,
1115 set_error_locus (&block
, var
, &code
->loc
);
1116 p
= code
->ext
.inquire
;
1119 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1123 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_common_iostat
,
1127 mask
|= IOPARM_common_err
;
1130 if (p
->unit
&& p
->file
)
1131 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code
->loc
);
1134 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_file
,
1138 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_exist
,
1142 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_opened
,
1146 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_number
,
1150 mask
|= set_parameter_ref (&block
, &post_block
, var
, IOPARM_inquire_named
,
1154 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_name
,
1158 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_access
,
1162 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_sequential
,
1166 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_direct
,
1170 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_form
,
1174 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_formatted
,
1178 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_unformatted
,
1182 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1183 IOPARM_inquire_recl_out
, p
->recl
);
1186 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1187 IOPARM_inquire_nextrec
, p
->nextrec
);
1190 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_blank
,
1194 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_position
,
1198 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_action
,
1202 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_read
,
1206 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_write
,
1210 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_readwrite
,
1214 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_delim
,
1218 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_pad
,
1222 mask
|= set_string (&block
, &post_block
, var
, IOPARM_inquire_convert
,
1226 mask
|= set_parameter_ref (&block
, &post_block
, var
,
1227 IOPARM_inquire_strm_pos_out
, p
->strm_pos
);
1229 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1232 set_parameter_value (&block
, var
, IOPARM_common_unit
, p
->unit
);
1234 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1236 tmp
= build_fold_addr_expr (var
);
1237 tmp
= build_call_expr (iocall
[IOCALL_INQUIRE
], 1, tmp
);
1238 gfc_add_expr_to_block (&block
, tmp
);
1240 gfc_add_block_to_block (&block
, &post_block
);
1242 io_result (&block
, var
, p
->err
, NULL
, NULL
);
1244 return gfc_finish_block (&block
);
1248 gfc_new_nml_name_expr (const char * name
)
1250 gfc_expr
* nml_name
;
1252 nml_name
= gfc_get_expr();
1253 nml_name
->ref
= NULL
;
1254 nml_name
->expr_type
= EXPR_CONSTANT
;
1255 nml_name
->ts
.kind
= gfc_default_character_kind
;
1256 nml_name
->ts
.type
= BT_CHARACTER
;
1257 nml_name
->value
.character
.length
= strlen(name
);
1258 nml_name
->value
.character
.string
= gfc_getmem (strlen (name
) + 1);
1259 strcpy (nml_name
->value
.character
.string
, name
);
1264 /* nml_full_name builds up the fully qualified name of a
1265 derived type component. */
1268 nml_full_name (const char* var_name
, const char* cmp_name
)
1270 int full_name_length
;
1273 full_name_length
= strlen (var_name
) + strlen (cmp_name
) + 1;
1274 full_name
= (char*)gfc_getmem (full_name_length
+ 1);
1275 strcpy (full_name
, var_name
);
1276 full_name
= strcat (full_name
, "%");
1277 full_name
= strcat (full_name
, cmp_name
);
1281 /* nml_get_addr_expr builds an address expression from the
1282 gfc_symbol or gfc_component backend_decl's. An offset is
1283 provided so that the address of an element of an array of
1284 derived types is returned. This is used in the runtime to
1285 determine that span of the derived type. */
1288 nml_get_addr_expr (gfc_symbol
* sym
, gfc_component
* c
,
1291 tree decl
= NULL_TREE
;
1295 int dummy_arg_flagged
;
1299 sym
->attr
.referenced
= 1;
1300 decl
= gfc_get_symbol_decl (sym
);
1302 /* If this is the enclosing function declaration, use
1303 the fake result instead. */
1304 if (decl
== current_function_decl
)
1305 decl
= gfc_get_fake_result_decl (sym
, 0);
1306 else if (decl
== DECL_CONTEXT (current_function_decl
))
1307 decl
= gfc_get_fake_result_decl (sym
, 1);
1310 decl
= c
->backend_decl
;
1312 gcc_assert (decl
&& ((TREE_CODE (decl
) == FIELD_DECL
1313 || TREE_CODE (decl
) == VAR_DECL
1314 || TREE_CODE (decl
) == PARM_DECL
)
1315 || TREE_CODE (decl
) == COMPONENT_REF
));
1319 /* Build indirect reference, if dummy argument. */
1321 dummy_arg_flagged
= POINTER_TYPE_P (TREE_TYPE(tmp
));
1323 itmp
= (dummy_arg_flagged
) ? build_fold_indirect_ref (tmp
) : tmp
;
1325 /* If an array, set flag and use indirect ref. if built. */
1327 array_flagged
= (TREE_CODE (TREE_TYPE (itmp
)) == ARRAY_TYPE
1328 && !TYPE_STRING_FLAG (TREE_TYPE (itmp
)));
1333 /* Treat the component of a derived type, using base_addr for
1334 the derived type. */
1336 if (TREE_CODE (decl
) == FIELD_DECL
)
1337 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
1338 base_addr
, tmp
, NULL_TREE
);
1340 /* If we have a derived type component, a reference to the first
1341 element of the array is built. This is done so that base_addr,
1342 used in the build of the component reference, always points to
1346 tmp
= gfc_build_array_ref (tmp
, gfc_index_zero_node
);
1348 /* Now build the address expression. */
1350 tmp
= build_fold_addr_expr (tmp
);
1352 /* If scalar dummy, resolve indirect reference now. */
1354 if (dummy_arg_flagged
&& !array_flagged
)
1355 tmp
= build_fold_indirect_ref (tmp
);
1357 gcc_assert (tmp
&& POINTER_TYPE_P (TREE_TYPE (tmp
)));
1362 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1363 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1364 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1366 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1369 transfer_namelist_element (stmtblock_t
* block
, const char * var_name
,
1370 gfc_symbol
* sym
, gfc_component
* c
,
1373 gfc_typespec
* ts
= NULL
;
1374 gfc_array_spec
* as
= NULL
;
1375 tree addr_expr
= NULL
;
1385 gcc_assert (sym
|| c
);
1387 /* Build the namelist object name. */
1389 string
= gfc_build_cstring_const (var_name
);
1390 string
= gfc_build_addr_expr (pchar_type_node
, string
);
1392 /* Build ts, as and data address using symbol or component. */
1394 ts
= (sym
) ? &sym
->ts
: &c
->ts
;
1395 as
= (sym
) ? sym
->as
: c
->as
;
1397 addr_expr
= nml_get_addr_expr (sym
, c
, base_addr
);
1404 dt
= TREE_TYPE ((sym
) ? sym
->backend_decl
: c
->backend_decl
);
1405 dtype
= gfc_get_dtype (dt
);
1409 itype
= GFC_DTYPE_UNKNOWN
;
1415 itype
= GFC_DTYPE_INTEGER
;
1418 itype
= GFC_DTYPE_LOGICAL
;
1421 itype
= GFC_DTYPE_REAL
;
1424 itype
= GFC_DTYPE_COMPLEX
;
1427 itype
= GFC_DTYPE_DERIVED
;
1430 itype
= GFC_DTYPE_CHARACTER
;
1436 dtype
= IARG (itype
<< GFC_DTYPE_TYPE_SHIFT
);
1439 /* Build up the arguments for the transfer call.
1440 The call for the scalar part transfers:
1441 (address, name, type, kind or string_length, dtype) */
1443 dt_parm_addr
= build_fold_addr_expr (dt_parm
);
1445 if (ts
->type
== BT_CHARACTER
)
1446 tmp
= ts
->cl
->backend_decl
;
1448 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1449 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL
], 6,
1450 dt_parm_addr
, addr_expr
, string
,
1451 IARG (ts
->kind
), tmp
, dtype
);
1452 gfc_add_expr_to_block (block
, tmp
);
1454 /* If the object is an array, transfer rank times:
1455 (null pointer, name, stride, lbound, ubound) */
1457 for ( n_dim
= 0 ; n_dim
< rank
; n_dim
++ )
1459 tmp
= build_call_expr (iocall
[IOCALL_SET_NML_VAL_DIM
], 5,
1462 GFC_TYPE_ARRAY_STRIDE (dt
, n_dim
),
1463 GFC_TYPE_ARRAY_LBOUND (dt
, n_dim
),
1464 GFC_TYPE_ARRAY_UBOUND (dt
, n_dim
));
1465 gfc_add_expr_to_block (block
, tmp
);
1468 if (ts
->type
== BT_DERIVED
)
1472 /* Provide the RECORD_TYPE to build component references. */
1474 tree expr
= build_fold_indirect_ref (addr_expr
);
1476 for (cmp
= ts
->derived
->components
; cmp
; cmp
= cmp
->next
)
1478 char *full_name
= nml_full_name (var_name
, cmp
->name
);
1479 transfer_namelist_element (block
,
1482 gfc_free (full_name
);
1489 /* Create a data transfer statement. Not all of the fields are valid
1490 for both reading and writing, but improper use has been filtered
1494 build_dt (tree function
, gfc_code
* code
)
1496 stmtblock_t block
, post_block
, post_end_block
, post_iu_block
;
1501 unsigned int mask
= 0;
1503 gfc_start_block (&block
);
1504 gfc_init_block (&post_block
);
1505 gfc_init_block (&post_end_block
);
1506 gfc_init_block (&post_iu_block
);
1508 var
= gfc_create_var (st_parameter
[IOPARM_ptype_dt
].type
, "dt_parm");
1510 set_error_locus (&block
, var
, &code
->loc
);
1512 if (last_dt
== IOLENGTH
)
1516 inq
= code
->ext
.inquire
;
1518 /* First check that preconditions are met. */
1519 gcc_assert (inq
!= NULL
);
1520 gcc_assert (inq
->iolength
!= NULL
);
1522 /* Connect to the iolength variable. */
1523 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1524 IOPARM_dt_iolength
, inq
->iolength
);
1530 gcc_assert (dt
!= NULL
);
1533 if (dt
&& dt
->io_unit
)
1535 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
1537 mask
|= set_internal_unit (&block
, &post_iu_block
,
1539 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1543 set_parameter_const (&block
, var
, IOPARM_common_unit
, 0);
1548 mask
|= set_string (&block
, &post_block
, var
, IOPARM_common_iomsg
,
1552 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1553 IOPARM_common_iostat
, dt
->iostat
);
1556 mask
|= IOPARM_common_err
;
1559 mask
|= IOPARM_common_eor
;
1562 mask
|= IOPARM_common_end
;
1565 mask
|= set_parameter_value (&block
, var
, IOPARM_dt_rec
, dt
->rec
);
1568 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_advance
,
1571 if (dt
->format_expr
)
1572 mask
|= set_string (&block
, &post_end_block
, var
, IOPARM_dt_format
,
1575 if (dt
->format_label
)
1577 if (dt
->format_label
== &format_asterisk
)
1578 mask
|= IOPARM_dt_list_format
;
1580 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_format
,
1581 dt
->format_label
->format
);
1585 mask
|= set_parameter_ref (&block
, &post_end_block
, var
,
1586 IOPARM_dt_size
, dt
->size
);
1590 if (dt
->format_expr
|| dt
->format_label
)
1591 gfc_internal_error ("build_dt: format with namelist");
1593 nmlname
= gfc_new_nml_name_expr (dt
->namelist
->name
);
1595 mask
|= set_string (&block
, &post_block
, var
, IOPARM_dt_namelist_name
,
1598 if (last_dt
== READ
)
1599 mask
|= IOPARM_dt_namelist_read_mode
;
1601 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1605 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1606 transfer_namelist_element (&block
, nml
->sym
->name
, nml
->sym
,
1610 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1612 if (dt
->io_unit
&& dt
->io_unit
->ts
.type
== BT_INTEGER
)
1613 set_parameter_value (&block
, var
, IOPARM_common_unit
, dt
->io_unit
);
1616 set_parameter_const (&block
, var
, IOPARM_common_flags
, mask
);
1618 tmp
= build_fold_addr_expr (var
);
1619 tmp
= build_call_expr (function
, 1, tmp
);
1620 gfc_add_expr_to_block (&block
, tmp
);
1622 gfc_add_block_to_block (&block
, &post_block
);
1625 dt_post_end_block
= &post_end_block
;
1627 gfc_add_expr_to_block (&block
, gfc_trans_code (code
->block
->next
));
1629 gfc_add_block_to_block (&block
, &post_iu_block
);
1632 dt_post_end_block
= NULL
;
1634 return gfc_finish_block (&block
);
1638 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1639 this as a third sort of data transfer statement, except that
1640 lengths are summed instead of actually transferring any data. */
1643 gfc_trans_iolength (gfc_code
* code
)
1646 return build_dt (iocall
[IOCALL_IOLENGTH
], code
);
1650 /* Translate a READ statement. */
1653 gfc_trans_read (gfc_code
* code
)
1656 return build_dt (iocall
[IOCALL_READ
], code
);
1660 /* Translate a WRITE statement */
1663 gfc_trans_write (gfc_code
* code
)
1666 return build_dt (iocall
[IOCALL_WRITE
], code
);
1670 /* Finish a data transfer statement. */
1673 gfc_trans_dt_end (gfc_code
* code
)
1678 gfc_init_block (&block
);
1683 function
= iocall
[IOCALL_READ_DONE
];
1687 function
= iocall
[IOCALL_WRITE_DONE
];
1691 function
= iocall
[IOCALL_IOLENGTH_DONE
];
1698 tmp
= build_fold_addr_expr (dt_parm
);
1699 tmp
= build_call_expr (function
, 1, tmp
);
1700 gfc_add_expr_to_block (&block
, tmp
);
1701 gfc_add_block_to_block (&block
, dt_post_end_block
);
1702 gfc_init_block (dt_post_end_block
);
1704 if (last_dt
!= IOLENGTH
)
1706 gcc_assert (code
->ext
.dt
!= NULL
);
1707 io_result (&block
, dt_parm
, code
->ext
.dt
->err
,
1708 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1711 return gfc_finish_block (&block
);
1715 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
);
1717 /* Given an array field in a derived type variable, generate the code
1718 for the loop that iterates over array elements, and the code that
1719 accesses those array elements. Use transfer_expr to generate code
1720 for transferring that element. Because elements may also be
1721 derived types, transfer_expr and transfer_array_component are mutually
1725 transfer_array_component (tree expr
, gfc_component
* cm
)
1735 gfc_start_block (&block
);
1736 gfc_init_se (&se
, NULL
);
1738 /* Create and initialize Scalarization Status. Unlike in
1739 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1740 care of this task, because we don't have a gfc_expr at hand.
1741 Build one manually, as in gfc_trans_subarray_assign. */
1744 ss
->type
= GFC_SS_COMPONENT
;
1746 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1747 ss
->next
= gfc_ss_terminator
;
1748 ss
->data
.info
.dimen
= cm
->as
->rank
;
1749 ss
->data
.info
.descriptor
= expr
;
1750 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1751 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1752 for (n
= 0; n
< cm
->as
->rank
; n
++)
1754 ss
->data
.info
.dim
[n
] = n
;
1755 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1756 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1758 mpz_init (ss
->shape
[n
]);
1759 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1760 cm
->as
->lower
[n
]->value
.integer
);
1761 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1764 /* Once we got ss, we use scalarizer to create the loop. */
1766 gfc_init_loopinfo (&loop
);
1767 gfc_add_ss_to_loop (&loop
, ss
);
1768 gfc_conv_ss_startstride (&loop
);
1769 gfc_conv_loop_setup (&loop
);
1770 gfc_mark_ss_chain_used (ss
, 1);
1771 gfc_start_scalarized_body (&loop
, &body
);
1773 gfc_copy_loopinfo_to_se (&se
, &loop
);
1776 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1778 gfc_conv_tmp_array_ref (&se
);
1780 /* Now se.expr contains an element of the array. Take the address and pass
1781 it to the IO routines. */
1782 tmp
= build_fold_addr_expr (se
.expr
);
1783 transfer_expr (&se
, &cm
->ts
, tmp
, NULL
);
1785 /* We are done now with the loop body. Wrap up the scalarizer and
1788 gfc_add_block_to_block (&body
, &se
.pre
);
1789 gfc_add_block_to_block (&body
, &se
.post
);
1791 gfc_trans_scalarizing_loops (&loop
, &body
);
1793 gfc_add_block_to_block (&block
, &loop
.pre
);
1794 gfc_add_block_to_block (&block
, &loop
.post
);
1796 for (n
= 0; n
< cm
->as
->rank
; n
++)
1797 mpz_clear (ss
->shape
[n
]);
1798 gfc_free (ss
->shape
);
1800 gfc_cleanup_loop (&loop
);
1802 return gfc_finish_block (&block
);
1805 /* Generate the call for a scalar transfer node. */
1808 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
, gfc_code
* code
)
1810 tree tmp
, function
, arg2
, field
, expr
;
1814 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
1815 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
1816 We need to translate the expression to a constant if it's either
1817 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
1818 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
1819 BT_DERIVED (could have been changed by gfc_conv_expr). */
1820 if ((ts
->type
== BT_DERIVED
&& ts
->is_iso_c
== 1 && ts
->derived
!= NULL
)
1821 || (ts
->derived
!= NULL
&& ts
->derived
->ts
.is_iso_c
== 1))
1823 /* C_PTR and C_FUNPTR have private components which means they can not
1824 be printed. However, if -std=gnu and not -pedantic, allow
1825 the component to be printed to help debugging. */
1826 if (gfc_notification_std (GFC_STD_GNU
) != SILENT
)
1828 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
1829 ts
->derived
->name
, code
!= NULL
? &(code
->loc
) :
1830 &gfc_current_locus
);
1834 ts
->type
= ts
->derived
->ts
.type
;
1835 ts
->kind
= ts
->derived
->ts
.kind
;
1836 ts
->f90_type
= ts
->derived
->ts
.f90_type
;
1846 arg2
= build_int_cst (NULL_TREE
, kind
);
1847 function
= iocall
[IOCALL_X_INTEGER
];
1851 arg2
= build_int_cst (NULL_TREE
, kind
);
1852 function
= iocall
[IOCALL_X_REAL
];
1856 arg2
= build_int_cst (NULL_TREE
, kind
);
1857 function
= iocall
[IOCALL_X_COMPLEX
];
1861 arg2
= build_int_cst (NULL_TREE
, kind
);
1862 function
= iocall
[IOCALL_X_LOGICAL
];
1867 if (se
->string_length
)
1868 arg2
= se
->string_length
;
1871 tmp
= build_fold_indirect_ref (addr_expr
);
1872 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
1873 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
1875 function
= iocall
[IOCALL_X_CHARACTER
];
1879 /* Recurse into the elements of the derived type. */
1880 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
1881 expr
= build_fold_indirect_ref (expr
);
1883 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1885 field
= c
->backend_decl
;
1886 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
1888 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), expr
, field
,
1893 tmp
= transfer_array_component (tmp
, c
);
1894 gfc_add_expr_to_block (&se
->pre
, tmp
);
1899 tmp
= build_fold_addr_expr (tmp
);
1900 transfer_expr (se
, &c
->ts
, tmp
, code
);
1906 internal_error ("Bad IO basetype (%d)", ts
->type
);
1909 tmp
= build_fold_addr_expr (dt_parm
);
1910 tmp
= build_call_expr (function
, 3, tmp
, addr_expr
, arg2
);
1911 gfc_add_expr_to_block (&se
->pre
, tmp
);
1912 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1917 /* Generate a call to pass an array descriptor to the IO library. The
1918 array should be of one of the intrinsic types. */
1921 transfer_array_desc (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1923 tree tmp
, charlen_arg
, kind_arg
;
1925 if (ts
->type
== BT_CHARACTER
)
1926 charlen_arg
= se
->string_length
;
1928 charlen_arg
= build_int_cst (NULL_TREE
, 0);
1930 kind_arg
= build_int_cst (NULL_TREE
, ts
->kind
);
1932 tmp
= build_fold_addr_expr (dt_parm
);
1933 tmp
= build_call_expr (iocall
[IOCALL_X_ARRAY
], 4,
1934 tmp
, addr_expr
, kind_arg
, charlen_arg
);
1935 gfc_add_expr_to_block (&se
->pre
, tmp
);
1936 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1940 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1943 gfc_trans_transfer (gfc_code
* code
)
1945 stmtblock_t block
, body
;
1953 gfc_start_block (&block
);
1954 gfc_init_block (&body
);
1957 ss
= gfc_walk_expr (expr
);
1960 gfc_init_se (&se
, NULL
);
1962 if (ss
== gfc_ss_terminator
)
1964 /* Transfer a scalar value. */
1965 gfc_conv_expr_reference (&se
, expr
);
1966 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
1970 /* Transfer an array. If it is an array of an intrinsic
1971 type, pass the descriptor to the library. Otherwise
1972 scalarize the transfer. */
1975 for (ref
= expr
->ref
; ref
&& ref
->type
!= REF_ARRAY
;
1977 gcc_assert (ref
->type
== REF_ARRAY
);
1980 if (expr
->ts
.type
!= BT_DERIVED
&& ref
&& ref
->next
== NULL
)
1982 /* Get the descriptor. */
1983 gfc_conv_expr_descriptor (&se
, expr
, ss
);
1984 tmp
= build_fold_addr_expr (se
.expr
);
1985 transfer_array_desc (&se
, &expr
->ts
, tmp
);
1986 goto finish_block_label
;
1989 /* Initialize the scalarizer. */
1990 gfc_init_loopinfo (&loop
);
1991 gfc_add_ss_to_loop (&loop
, ss
);
1993 /* Initialize the loop. */
1994 gfc_conv_ss_startstride (&loop
);
1995 gfc_conv_loop_setup (&loop
);
1997 /* The main loop body. */
1998 gfc_mark_ss_chain_used (ss
, 1);
1999 gfc_start_scalarized_body (&loop
, &body
);
2001 gfc_copy_loopinfo_to_se (&se
, &loop
);
2004 gfc_conv_expr_reference (&se
, expr
);
2005 transfer_expr (&se
, &expr
->ts
, se
.expr
, code
);
2010 gfc_add_block_to_block (&body
, &se
.pre
);
2011 gfc_add_block_to_block (&body
, &se
.post
);
2014 tmp
= gfc_finish_block (&body
);
2017 gcc_assert (se
.ss
== gfc_ss_terminator
);
2018 gfc_trans_scalarizing_loops (&loop
, &body
);
2020 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
2021 tmp
= gfc_finish_block (&loop
.pre
);
2022 gfc_cleanup_loop (&loop
);
2025 gfc_add_expr_to_block (&block
, tmp
);
2027 return gfc_finish_block (&block
);
2030 #include "gt-fortran-trans-io.h"