1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
25 #include "coretypes.h"
27 #include "tree-gimple.h"
33 #include "trans-stmt.h"
34 #include "trans-array.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
39 /* Members of the ioparm structure. */
41 static GTY(()) tree ioparm_unit
;
42 static GTY(()) tree ioparm_err
;
43 static GTY(()) tree ioparm_end
;
44 static GTY(()) tree ioparm_eor
;
45 static GTY(()) tree ioparm_list_format
;
46 static GTY(()) tree ioparm_library_return
;
47 static GTY(()) tree ioparm_iostat
;
48 static GTY(()) tree ioparm_exist
;
49 static GTY(()) tree ioparm_opened
;
50 static GTY(()) tree ioparm_number
;
51 static GTY(()) tree ioparm_named
;
52 static GTY(()) tree ioparm_rec
;
53 static GTY(()) tree ioparm_nextrec
;
54 static GTY(()) tree ioparm_size
;
55 static GTY(()) tree ioparm_recl_in
;
56 static GTY(()) tree ioparm_recl_out
;
57 static GTY(()) tree ioparm_iolength
;
58 static GTY(()) tree ioparm_file
;
59 static GTY(()) tree ioparm_file_len
;
60 static GTY(()) tree ioparm_status
;
61 static GTY(()) tree ioparm_status_len
;
62 static GTY(()) tree ioparm_access
;
63 static GTY(()) tree ioparm_access_len
;
64 static GTY(()) tree ioparm_form
;
65 static GTY(()) tree ioparm_form_len
;
66 static GTY(()) tree ioparm_blank
;
67 static GTY(()) tree ioparm_blank_len
;
68 static GTY(()) tree ioparm_position
;
69 static GTY(()) tree ioparm_position_len
;
70 static GTY(()) tree ioparm_action
;
71 static GTY(()) tree ioparm_action_len
;
72 static GTY(()) tree ioparm_delim
;
73 static GTY(()) tree ioparm_delim_len
;
74 static GTY(()) tree ioparm_pad
;
75 static GTY(()) tree ioparm_pad_len
;
76 static GTY(()) tree ioparm_format
;
77 static GTY(()) tree ioparm_format_len
;
78 static GTY(()) tree ioparm_advance
;
79 static GTY(()) tree ioparm_advance_len
;
80 static GTY(()) tree ioparm_name
;
81 static GTY(()) tree ioparm_name_len
;
82 static GTY(()) tree ioparm_internal_unit
;
83 static GTY(()) tree ioparm_internal_unit_len
;
84 static GTY(()) tree ioparm_sequential
;
85 static GTY(()) tree ioparm_sequential_len
;
86 static GTY(()) tree ioparm_direct
;
87 static GTY(()) tree ioparm_direct_len
;
88 static GTY(()) tree ioparm_formatted
;
89 static GTY(()) tree ioparm_formatted_len
;
90 static GTY(()) tree ioparm_unformatted
;
91 static GTY(()) tree ioparm_unformatted_len
;
92 static GTY(()) tree ioparm_read
;
93 static GTY(()) tree ioparm_read_len
;
94 static GTY(()) tree ioparm_write
;
95 static GTY(()) tree ioparm_write_len
;
96 static GTY(()) tree ioparm_readwrite
;
97 static GTY(()) tree ioparm_readwrite_len
;
98 static GTY(()) tree ioparm_namelist_name
;
99 static GTY(()) tree ioparm_namelist_name_len
;
100 static GTY(()) tree ioparm_namelist_read_mode
;
102 /* The global I/O variables */
104 static GTY(()) tree ioparm_var
;
105 static GTY(()) tree locus_file
;
106 static GTY(()) tree locus_line
;
109 /* Library I/O subroutines */
111 static GTY(()) tree iocall_read
;
112 static GTY(()) tree iocall_read_done
;
113 static GTY(()) tree iocall_write
;
114 static GTY(()) tree iocall_write_done
;
115 static GTY(()) tree iocall_x_integer
;
116 static GTY(()) tree iocall_x_logical
;
117 static GTY(()) tree iocall_x_character
;
118 static GTY(()) tree iocall_x_real
;
119 static GTY(()) tree iocall_x_complex
;
120 static GTY(()) tree iocall_open
;
121 static GTY(()) tree iocall_close
;
122 static GTY(()) tree iocall_inquire
;
123 static GTY(()) tree iocall_iolength
;
124 static GTY(()) tree iocall_iolength_done
;
125 static GTY(()) tree iocall_rewind
;
126 static GTY(()) tree iocall_backspace
;
127 static GTY(()) tree iocall_endfile
;
128 static GTY(()) tree iocall_set_nml_val_int
;
129 static GTY(()) tree iocall_set_nml_val_float
;
130 static GTY(()) tree iocall_set_nml_val_char
;
131 static GTY(()) tree iocall_set_nml_val_complex
;
132 static GTY(()) tree iocall_set_nml_val_log
;
134 /* Variable for keeping track of what the last data transfer statement
135 was. Used for deciding which subroutine to call when the data
136 transfer is complete. */
137 static enum { READ
, WRITE
, IOLENGTH
} last_dt
;
139 #define ADD_FIELD(name, type) \
140 ioparm_ ## name = gfc_add_field_to_struct \
141 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
142 get_identifier (stringize(name)), type)
144 #define ADD_STRING(name) \
145 ioparm_ ## name = gfc_add_field_to_struct \
146 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
147 get_identifier (stringize(name)), pchar_type_node); \
148 ioparm_ ## name ## _len = gfc_add_field_to_struct \
149 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
150 get_identifier (stringize(name) "_len"), gfc_charlen_type_node)
153 /* Create function decls for IO library functions. */
156 gfc_build_io_library_fndecls (void)
158 tree gfc_int4_type_node
;
159 tree gfc_pint4_type_node
;
162 gfc_int4_type_node
= gfc_get_int_type (4);
163 gfc_pint4_type_node
= build_pointer_type (gfc_int4_type_node
);
165 /* Build the st_parameter structure. Information associated with I/O
166 calls are transferred here. This must match the one defined in the
169 ioparm_type
= make_node (RECORD_TYPE
);
170 TYPE_NAME (ioparm_type
) = get_identifier ("_gfc_ioparm");
172 ADD_FIELD (unit
, gfc_int4_type_node
);
173 ADD_FIELD (err
, gfc_int4_type_node
);
174 ADD_FIELD (end
, gfc_int4_type_node
);
175 ADD_FIELD (eor
, gfc_int4_type_node
);
176 ADD_FIELD (list_format
, gfc_int4_type_node
);
177 ADD_FIELD (library_return
, gfc_int4_type_node
);
179 ADD_FIELD (iostat
, gfc_pint4_type_node
);
180 ADD_FIELD (exist
, gfc_pint4_type_node
);
181 ADD_FIELD (opened
, gfc_pint4_type_node
);
182 ADD_FIELD (number
, gfc_pint4_type_node
);
183 ADD_FIELD (named
, gfc_pint4_type_node
);
184 ADD_FIELD (rec
, gfc_int4_type_node
);
185 ADD_FIELD (nextrec
, gfc_pint4_type_node
);
186 ADD_FIELD (size
, gfc_pint4_type_node
);
188 ADD_FIELD (recl_in
, gfc_int4_type_node
);
189 ADD_FIELD (recl_out
, gfc_pint4_type_node
);
191 ADD_FIELD (iolength
, gfc_pint4_type_node
);
199 ADD_STRING (position
);
204 ADD_STRING (advance
);
206 ADD_STRING (internal_unit
);
207 ADD_STRING (sequential
);
210 ADD_STRING (formatted
);
211 ADD_STRING (unformatted
);
214 ADD_STRING (readwrite
);
216 ADD_STRING (namelist_name
);
217 ADD_FIELD (namelist_read_mode
, gfc_int4_type_node
);
219 gfc_finish_type (ioparm_type
);
221 ioparm_var
= build_decl (VAR_DECL
, get_identifier (PREFIX("ioparm")),
223 DECL_EXTERNAL (ioparm_var
) = 1;
224 TREE_PUBLIC (ioparm_var
) = 1;
226 locus_line
= build_decl (VAR_DECL
, get_identifier (PREFIX("line")),
228 DECL_EXTERNAL (locus_line
) = 1;
229 TREE_PUBLIC (locus_line
) = 1;
231 locus_file
= build_decl (VAR_DECL
, get_identifier (PREFIX("filename")),
233 DECL_EXTERNAL (locus_file
) = 1;
234 TREE_PUBLIC (locus_file
) = 1;
236 /* Define the transfer functions. */
239 gfc_build_library_function_decl (get_identifier
240 (PREFIX("transfer_integer")),
241 void_type_node
, 2, pvoid_type_node
,
245 gfc_build_library_function_decl (get_identifier
246 (PREFIX("transfer_logical")),
247 void_type_node
, 2, pvoid_type_node
,
251 gfc_build_library_function_decl (get_identifier
252 (PREFIX("transfer_character")),
253 void_type_node
, 2, pvoid_type_node
,
257 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
259 pvoid_type_node
, gfc_int4_type_node
);
262 gfc_build_library_function_decl (get_identifier
263 (PREFIX("transfer_complex")),
264 void_type_node
, 2, pvoid_type_node
,
267 /* Library entry points */
270 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
274 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
277 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
281 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
285 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
286 gfc_int4_type_node
, 0);
289 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
293 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
294 gfc_int4_type_node
, 0);
297 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
298 gfc_int4_type_node
, 0);
301 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
302 gfc_int4_type_node
, 0);
303 /* Library helpers */
306 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
307 gfc_int4_type_node
, 0);
310 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
311 gfc_int4_type_node
, 0);
313 iocall_iolength_done
=
314 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
315 gfc_int4_type_node
, 0);
317 iocall_set_nml_val_int
=
318 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
320 pvoid_type_node
, pvoid_type_node
,
321 gfc_int4_type_node
,gfc_int4_type_node
);
323 iocall_set_nml_val_float
=
324 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
326 pvoid_type_node
, pvoid_type_node
,
327 gfc_int4_type_node
,gfc_int4_type_node
);
328 iocall_set_nml_val_char
=
329 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")),
331 pvoid_type_node
, pvoid_type_node
,
332 gfc_int4_type_node
, gfc_int4_type_node
,
333 gfc_charlen_type_node
);
334 iocall_set_nml_val_complex
=
335 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
337 pvoid_type_node
, pvoid_type_node
,
338 gfc_int4_type_node
,gfc_int4_type_node
);
339 iocall_set_nml_val_log
=
340 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
342 pvoid_type_node
, pvoid_type_node
,
343 gfc_int4_type_node
,gfc_int4_type_node
);
348 /* Generate code to store an non-string I/O parameter into the
349 ioparm structure. This is a pass by value. */
352 set_parameter_value (stmtblock_t
* block
, tree var
, gfc_expr
* e
)
357 gfc_init_se (&se
, NULL
);
358 gfc_conv_expr_type (&se
, e
, TREE_TYPE (var
));
359 gfc_add_block_to_block (block
, &se
.pre
);
361 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (var
), ioparm_var
, var
, NULL_TREE
);
362 gfc_add_modify_expr (block
, tmp
, se
.expr
);
366 /* Generate code to store an non-string I/O parameter into the
367 ioparm structure. This is pass by reference. */
370 set_parameter_ref (stmtblock_t
* block
, tree var
, gfc_expr
* e
)
375 gfc_init_se (&se
, NULL
);
378 gfc_conv_expr_type (&se
, e
, TREE_TYPE (var
));
379 gfc_add_block_to_block (block
, &se
.pre
);
381 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (var
), ioparm_var
, var
, NULL_TREE
);
382 gfc_add_modify_expr (block
, tmp
, se
.expr
);
386 /* Generate code to store a string and its length into the
390 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
391 tree var_len
, gfc_expr
* e
)
399 gfc_init_se (&se
, NULL
);
400 gfc_conv_expr (&se
, e
);
402 io
= build3 (COMPONENT_REF
, TREE_TYPE (var
), ioparm_var
, var
, NULL_TREE
);
403 len
= build3 (COMPONENT_REF
, TREE_TYPE (var_len
), ioparm_var
, var_len
,
406 /* Integer variable assigned a format label. */
407 if (e
->ts
.type
== BT_INTEGER
&& e
->symtree
->n
.sym
->attr
.assign
== 1)
410 gfc_build_cstring_const ("Assigned label is not a format label");
411 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
412 tmp
= build2 (LE_EXPR
, boolean_type_node
,
413 tmp
, convert (TREE_TYPE (tmp
), integer_minus_one_node
));
414 gfc_trans_runtime_check (tmp
, msg
, &se
.pre
);
415 gfc_add_modify_expr (&se
.pre
, io
, GFC_DECL_ASSIGN_ADDR (se
.expr
));
416 gfc_add_modify_expr (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
420 gfc_conv_string_parameter (&se
);
421 gfc_add_modify_expr (&se
.pre
, io
, fold_convert (TREE_TYPE (io
), se
.expr
));
422 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
425 gfc_add_block_to_block (block
, &se
.pre
);
426 gfc_add_block_to_block (postblock
, &se
.post
);
431 /* Set a member of the ioparm structure to one. */
433 set_flag (stmtblock_t
*block
, tree var
)
435 tree tmp
, type
= TREE_TYPE (var
);
437 tmp
= build3 (COMPONENT_REF
, type
, ioparm_var
, var
, NULL_TREE
);
438 gfc_add_modify_expr (block
, tmp
, convert (type
, integer_one_node
));
442 /* Add a case to a IO-result switch. */
445 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
450 return; /* No label, no case */
452 value
= build_int_cst (NULL_TREE
, label_value
);
454 /* Make a backend label for this case. */
455 tmp
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
456 DECL_CONTEXT (tmp
) = current_function_decl
;
458 /* And the case itself. */
459 tmp
= build3_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
460 gfc_add_expr_to_block (body
, tmp
);
462 /* Jump to the label. */
463 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
464 gfc_add_expr_to_block (body
, tmp
);
468 /* Generate a switch statement that branches to the correct I/O
469 result label. The last statement of an I/O call stores the
470 result into a variable because there is often cleanup that
471 must be done before the switch, so a temporary would have to
472 be created anyway. */
475 io_result (stmtblock_t
* block
, gfc_st_label
* err_label
,
476 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
481 /* If no labels are specified, ignore the result instead
482 of building an empty switch. */
483 if (err_label
== NULL
485 && eor_label
== NULL
)
488 /* Build a switch statement. */
489 gfc_start_block (&body
);
491 /* The label values here must be the same as the values
492 in the library_return enum in the runtime library */
493 add_case (1, err_label
, &body
);
494 add_case (2, end_label
, &body
);
495 add_case (3, eor_label
, &body
);
497 tmp
= gfc_finish_block (&body
);
499 rc
= build3 (COMPONENT_REF
, TREE_TYPE (ioparm_library_return
), ioparm_var
,
500 ioparm_library_return
, NULL_TREE
);
502 tmp
= build3_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
504 gfc_add_expr_to_block (block
, tmp
);
508 /* Store the current file and line number to variables so that if a
509 library call goes awry, we can tell the user where the problem is. */
512 set_error_locus (stmtblock_t
* block
, locus
* where
)
519 tmp
= gfc_build_cstring_const (f
->filename
);
521 tmp
= gfc_build_addr_expr (pchar_type_node
, tmp
);
522 gfc_add_modify_expr (block
, locus_file
, tmp
);
524 #ifdef USE_MAPPED_LOCATION
525 line
= LOCATION_LINE (where
->lb
->location
);
527 line
= where
->lb
->linenum
;
529 gfc_add_modify_expr (block
, locus_line
, build_int_cst (NULL_TREE
, line
));
533 /* Translate an OPEN statement. */
536 gfc_trans_open (gfc_code
* code
)
538 stmtblock_t block
, post_block
;
542 gfc_init_block (&block
);
543 gfc_init_block (&post_block
);
545 set_error_locus (&block
, &code
->loc
);
549 set_parameter_value (&block
, ioparm_unit
, p
->unit
);
552 set_string (&block
, &post_block
, ioparm_file
, ioparm_file_len
, p
->file
);
555 set_string (&block
, &post_block
, ioparm_status
,
556 ioparm_status_len
, p
->status
);
559 set_string (&block
, &post_block
, ioparm_access
,
560 ioparm_access_len
, p
->access
);
563 set_string (&block
, &post_block
, ioparm_form
, ioparm_form_len
, p
->form
);
566 set_parameter_value (&block
, ioparm_recl_in
, p
->recl
);
569 set_string (&block
, &post_block
, ioparm_blank
, ioparm_blank_len
,
573 set_string (&block
, &post_block
, ioparm_position
,
574 ioparm_position_len
, p
->position
);
577 set_string (&block
, &post_block
, ioparm_action
,
578 ioparm_action_len
, p
->action
);
581 set_string (&block
, &post_block
, ioparm_delim
, ioparm_delim_len
,
585 set_string (&block
, &post_block
, ioparm_pad
, ioparm_pad_len
, p
->pad
);
588 set_parameter_ref (&block
, ioparm_iostat
, p
->iostat
);
591 set_flag (&block
, ioparm_err
);
593 tmp
= gfc_build_function_call (iocall_open
, NULL_TREE
);
594 gfc_add_expr_to_block (&block
, tmp
);
596 gfc_add_block_to_block (&block
, &post_block
);
598 io_result (&block
, p
->err
, NULL
, NULL
);
600 return gfc_finish_block (&block
);
604 /* Translate a CLOSE statement. */
607 gfc_trans_close (gfc_code
* code
)
609 stmtblock_t block
, post_block
;
613 gfc_init_block (&block
);
614 gfc_init_block (&post_block
);
616 set_error_locus (&block
, &code
->loc
);
620 set_parameter_value (&block
, ioparm_unit
, p
->unit
);
623 set_string (&block
, &post_block
, ioparm_status
,
624 ioparm_status_len
, p
->status
);
627 set_parameter_ref (&block
, ioparm_iostat
, p
->iostat
);
630 set_flag (&block
, ioparm_err
);
632 tmp
= gfc_build_function_call (iocall_close
, NULL_TREE
);
633 gfc_add_expr_to_block (&block
, tmp
);
635 gfc_add_block_to_block (&block
, &post_block
);
637 io_result (&block
, p
->err
, NULL
, NULL
);
639 return gfc_finish_block (&block
);
643 /* Common subroutine for building a file positioning statement. */
646 build_filepos (tree function
, gfc_code
* code
)
652 p
= code
->ext
.filepos
;
654 gfc_init_block (&block
);
656 set_error_locus (&block
, &code
->loc
);
659 set_parameter_value (&block
, ioparm_unit
, p
->unit
);
662 set_parameter_ref (&block
, ioparm_iostat
, p
->iostat
);
665 set_flag (&block
, ioparm_err
);
667 tmp
= gfc_build_function_call (function
, NULL
);
668 gfc_add_expr_to_block (&block
, tmp
);
670 io_result (&block
, p
->err
, NULL
, NULL
);
672 return gfc_finish_block (&block
);
676 /* Translate a BACKSPACE statement. */
679 gfc_trans_backspace (gfc_code
* code
)
682 return build_filepos (iocall_backspace
, code
);
686 /* Translate an ENDFILE statement. */
689 gfc_trans_endfile (gfc_code
* code
)
692 return build_filepos (iocall_endfile
, code
);
696 /* Translate a REWIND statement. */
699 gfc_trans_rewind (gfc_code
* code
)
702 return build_filepos (iocall_rewind
, code
);
706 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
709 gfc_trans_inquire (gfc_code
* code
)
711 stmtblock_t block
, post_block
;
715 gfc_init_block (&block
);
716 gfc_init_block (&post_block
);
718 set_error_locus (&block
, &code
->loc
);
719 p
= code
->ext
.inquire
;
722 set_parameter_value (&block
, ioparm_unit
, p
->unit
);
725 set_string (&block
, &post_block
, ioparm_file
, ioparm_file_len
, p
->file
);
728 set_parameter_ref (&block
, ioparm_iostat
, p
->iostat
);
731 set_parameter_ref (&block
, ioparm_exist
, p
->exist
);
734 set_parameter_ref (&block
, ioparm_opened
, p
->opened
);
737 set_parameter_ref (&block
, ioparm_number
, p
->number
);
740 set_parameter_ref (&block
, ioparm_named
, p
->named
);
743 set_string (&block
, &post_block
, ioparm_name
, ioparm_name_len
, p
->name
);
746 set_string (&block
, &post_block
, ioparm_access
,
747 ioparm_access_len
, p
->access
);
750 set_string (&block
, &post_block
, ioparm_sequential
,
751 ioparm_sequential_len
, p
->sequential
);
754 set_string (&block
, &post_block
, ioparm_direct
,
755 ioparm_direct_len
, p
->direct
);
758 set_string (&block
, &post_block
, ioparm_form
, ioparm_form_len
, p
->form
);
761 set_string (&block
, &post_block
, ioparm_formatted
,
762 ioparm_formatted_len
, p
->formatted
);
765 set_string (&block
, &post_block
, ioparm_unformatted
,
766 ioparm_unformatted_len
, p
->unformatted
);
769 set_parameter_ref (&block
, ioparm_recl_out
, p
->recl
);
772 set_parameter_ref (&block
, ioparm_nextrec
, p
->nextrec
);
775 set_string (&block
, &post_block
, ioparm_blank
, ioparm_blank_len
,
779 set_string (&block
, &post_block
, ioparm_position
,
780 ioparm_position_len
, p
->position
);
783 set_string (&block
, &post_block
, ioparm_action
,
784 ioparm_action_len
, p
->action
);
787 set_string (&block
, &post_block
, ioparm_read
, ioparm_read_len
, p
->read
);
790 set_string (&block
, &post_block
, ioparm_write
,
791 ioparm_write_len
, p
->write
);
794 set_string (&block
, &post_block
, ioparm_readwrite
,
795 ioparm_readwrite_len
, p
->readwrite
);
798 set_string (&block
, &post_block
, ioparm_delim
, ioparm_delim_len
,
802 set_string (&block
, &post_block
, ioparm_pad
, ioparm_pad_len
,
806 set_flag (&block
, ioparm_err
);
808 tmp
= gfc_build_function_call (iocall_inquire
, NULL
);
809 gfc_add_expr_to_block (&block
, tmp
);
811 gfc_add_block_to_block (&block
, &post_block
);
813 io_result (&block
, p
->err
, NULL
, NULL
);
815 return gfc_finish_block (&block
);
820 gfc_new_nml_name_expr (char * name
)
823 nml_name
= gfc_get_expr();
824 nml_name
->ref
= NULL
;
825 nml_name
->expr_type
= EXPR_CONSTANT
;
826 nml_name
->ts
.kind
= gfc_default_character_kind
;
827 nml_name
->ts
.type
= BT_CHARACTER
;
828 nml_name
->value
.character
.length
= strlen(name
);
829 nml_name
->value
.character
.string
= name
;
835 get_new_var_expr(gfc_symbol
* sym
)
839 nml_var
= gfc_get_expr();
840 nml_var
->expr_type
= EXPR_VARIABLE
;
841 nml_var
->ts
= sym
->ts
;
843 nml_var
->rank
= sym
->as
->rank
;
844 nml_var
->symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
845 nml_var
->symtree
->n
.sym
= sym
;
846 nml_var
->where
= sym
->declared_at
;
847 sym
->attr
.referenced
= 1;
852 /* For a scalar variable STRING whose address is ADDR_EXPR, generate a
853 call to iocall_set_nml_val. For derived type variable, recursively
854 generate calls to iocall_set_nml_val for each leaf field. The leafs
855 have no names -- their STRING field is null, and are interpreted by
856 the run-time library as having only the value, as in the example:
860 Note that the first output field appears after the name of the
861 variable, not of the field name. This causes a little complication
865 transfer_namelist_element (stmtblock_t
* block
, gfc_typespec
* ts
, tree addr_expr
,
866 tree string
, tree string_length
)
868 tree tmp
, args
, arg2
;
871 gcc_assert (POINTER_TYPE_P (TREE_TYPE (addr_expr
)));
873 if (ts
->type
== BT_DERIVED
)
876 expr
= gfc_build_indirect_ref (addr_expr
);
878 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
880 tree field
= c
->backend_decl
;
881 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
882 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
),
883 expr
, field
, NULL_TREE
);
886 gfc_todo_error ("NAMELIST IO of array in derived type");
888 tmp
= gfc_build_addr_expr (NULL
, tmp
);
889 transfer_namelist_element (block
, &c
->ts
, tmp
, string
, string_length
);
891 /* The first output field bears the name of the topmost
892 derived type variable. All other fields are anonymous
893 and appear with nulls in their string and string_length
894 fields. After the first use, we set string and
895 string_length to null. */
896 string
= null_pointer_node
;
897 string_length
= integer_zero_node
;
903 args
= gfc_chainon_list (NULL_TREE
, addr_expr
);
904 args
= gfc_chainon_list (args
, string
);
905 args
= gfc_chainon_list (args
, string_length
);
906 arg2
= build_int_cst (gfc_array_index_type
, ts
->kind
);
907 args
= gfc_chainon_list (args
,arg2
);
912 tmp
= gfc_build_function_call (iocall_set_nml_val_int
, args
);
916 expr
= gfc_build_indirect_ref (addr_expr
);
917 gcc_assert (TREE_CODE (TREE_TYPE (expr
)) == ARRAY_TYPE
);
918 args
= gfc_chainon_list (args
,
919 TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (expr
))));
920 tmp
= gfc_build_function_call (iocall_set_nml_val_char
, args
);
924 tmp
= gfc_build_function_call (iocall_set_nml_val_float
, args
);
928 tmp
= gfc_build_function_call (iocall_set_nml_val_log
, args
);
932 tmp
= gfc_build_function_call (iocall_set_nml_val_complex
, args
);
936 internal_error ("Bad namelist IO basetype (%d)", ts
->type
);
939 gfc_add_expr_to_block (block
, tmp
);
942 /* Create a data transfer statement. Not all of the fields are valid
943 for both reading and writing, but improper use has been filtered
947 build_dt (tree
* function
, gfc_code
* code
)
949 stmtblock_t block
, post_block
;
952 gfc_expr
*nmlname
, *nmlvar
;
956 gfc_init_block (&block
);
957 gfc_init_block (&post_block
);
959 set_error_locus (&block
, &code
->loc
);
962 gcc_assert (dt
!= NULL
);
966 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
968 set_string (&block
, &post_block
, ioparm_internal_unit
,
969 ioparm_internal_unit_len
, dt
->io_unit
);
972 set_parameter_value (&block
, ioparm_unit
, dt
->io_unit
);
976 set_parameter_value (&block
, ioparm_rec
, dt
->rec
);
979 set_string (&block
, &post_block
, ioparm_advance
, ioparm_advance_len
,
983 set_string (&block
, &post_block
, ioparm_format
, ioparm_format_len
,
986 if (dt
->format_label
)
988 if (dt
->format_label
== &format_asterisk
)
989 set_flag (&block
, ioparm_list_format
);
991 set_string (&block
, &post_block
, ioparm_format
,
992 ioparm_format_len
, dt
->format_label
->format
);
996 set_parameter_ref (&block
, ioparm_iostat
, dt
->iostat
);
999 set_parameter_ref (&block
, ioparm_size
, dt
->size
);
1002 set_flag (&block
, ioparm_err
);
1005 set_flag(&block
, ioparm_eor
);
1008 set_flag(&block
, ioparm_end
);
1012 if (dt
->format_expr
|| dt
->format_label
)
1013 fatal_error("A format cannot be specified with a namelist");
1015 nmlname
= gfc_new_nml_name_expr(dt
->namelist
->name
);
1017 set_string (&block
, &post_block
, ioparm_namelist_name
,
1018 ioparm_namelist_name_len
, nmlname
);
1020 if (last_dt
== READ
)
1021 set_flag (&block
, ioparm_namelist_read_mode
);
1023 for (nml
= dt
->namelist
->namelist
; nml
; nml
= nml
->next
)
1025 gfc_init_se (&se
, NULL
);
1026 gfc_init_se (&se2
, NULL
);
1027 nmlvar
= get_new_var_expr (nml
->sym
);
1028 nmlname
= gfc_new_nml_name_expr (nml
->sym
->name
);
1029 gfc_conv_expr_reference (&se2
, nmlname
);
1030 gfc_conv_expr_reference (&se
, nmlvar
);
1031 gfc_evaluate_now (se
.expr
, &se
.pre
);
1033 transfer_namelist_element (&block
, &nml
->sym
->ts
, se
.expr
,
1034 se2
.expr
, se2
.string_length
);
1038 tmp
= gfc_build_function_call (*function
, NULL_TREE
);
1039 gfc_add_expr_to_block (&block
, tmp
);
1041 gfc_add_block_to_block (&block
, &post_block
);
1043 return gfc_finish_block (&block
);
1047 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1048 this as a third sort of data transfer statement, except that
1049 lengths are summed instead of actually transferring any data. */
1052 gfc_trans_iolength (gfc_code
* code
)
1058 gfc_init_block (&block
);
1060 set_error_locus (&block
, &code
->loc
);
1062 inq
= code
->ext
.inquire
;
1064 /* First check that preconditions are met. */
1065 gcc_assert (inq
!= NULL
);
1066 gcc_assert (inq
->iolength
!= NULL
);
1068 /* Connect to the iolength variable. */
1070 set_parameter_ref (&block
, ioparm_iolength
, inq
->iolength
);
1074 dt
= build_dt(&iocall_iolength
, code
);
1076 gfc_add_expr_to_block (&block
, dt
);
1078 return gfc_finish_block (&block
);
1082 /* Translate a READ statement. */
1085 gfc_trans_read (gfc_code
* code
)
1089 return build_dt (&iocall_read
, code
);
1093 /* Translate a WRITE statement */
1096 gfc_trans_write (gfc_code
* code
)
1100 return build_dt (&iocall_write
, code
);
1104 /* Finish a data transfer statement. */
1107 gfc_trans_dt_end (gfc_code
* code
)
1112 gfc_init_block (&block
);
1117 function
= iocall_read_done
;
1121 function
= iocall_write_done
;
1125 function
= iocall_iolength_done
;
1132 tmp
= gfc_build_function_call (function
, NULL
);
1133 gfc_add_expr_to_block (&block
, tmp
);
1135 if (last_dt
!= IOLENGTH
)
1137 gcc_assert (code
->ext
.dt
!= NULL
);
1138 io_result (&block
, code
->ext
.dt
->err
,
1139 code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1142 return gfc_finish_block (&block
);
1146 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
);
1148 /* Given an array field in a derived type variable, generate the code
1149 for the loop that iterates over array elements, and the code that
1150 accesses those array elements. Use transfer_expr to generate code
1151 for transferring that element. Because elements may also be
1152 derived types, transfer_expr and transfer_array_component are mutually
1156 transfer_array_component (tree expr
, gfc_component
* cm
)
1166 gfc_start_block (&block
);
1167 gfc_init_se (&se
, NULL
);
1169 /* Create and initialize Scalarization Status. Unlike in
1170 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1171 care of this task, because we don't have a gfc_expr at hand.
1172 Build one manually, as in gfc_trans_subarray_assign. */
1175 ss
->type
= GFC_SS_COMPONENT
;
1177 ss
->shape
= gfc_get_shape (cm
->as
->rank
);
1178 ss
->next
= gfc_ss_terminator
;
1179 ss
->data
.info
.dimen
= cm
->as
->rank
;
1180 ss
->data
.info
.descriptor
= expr
;
1181 ss
->data
.info
.data
= gfc_conv_array_data (expr
);
1182 ss
->data
.info
.offset
= gfc_conv_array_offset (expr
);
1183 for (n
= 0; n
< cm
->as
->rank
; n
++)
1185 ss
->data
.info
.dim
[n
] = n
;
1186 ss
->data
.info
.start
[n
] = gfc_conv_array_lbound (expr
, n
);
1187 ss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1189 mpz_init (ss
->shape
[n
]);
1190 mpz_sub (ss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1191 cm
->as
->lower
[n
]->value
.integer
);
1192 mpz_add_ui (ss
->shape
[n
], ss
->shape
[n
], 1);
1195 /* Once we got ss, we use scalarizer to create the loop. */
1197 gfc_init_loopinfo (&loop
);
1198 gfc_add_ss_to_loop (&loop
, ss
);
1199 gfc_conv_ss_startstride (&loop
);
1200 gfc_conv_loop_setup (&loop
);
1201 gfc_mark_ss_chain_used (ss
, 1);
1202 gfc_start_scalarized_body (&loop
, &body
);
1204 gfc_copy_loopinfo_to_se (&se
, &loop
);
1207 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1209 gfc_conv_tmp_array_ref (&se
);
1211 /* Now se.expr contains an element of the array. Take the address and pass
1212 it to the IO routines. */
1213 tmp
= gfc_build_addr_expr (NULL
, se
.expr
);
1214 transfer_expr (&se
, &cm
->ts
, tmp
);
1216 /* We are done now with the loop body. Wrap up the scalarizer and
1219 gfc_add_block_to_block (&body
, &se
.pre
);
1220 gfc_add_block_to_block (&body
, &se
.post
);
1222 gfc_trans_scalarizing_loops (&loop
, &body
);
1224 gfc_add_block_to_block (&block
, &loop
.pre
);
1225 gfc_add_block_to_block (&block
, &loop
.post
);
1227 for (n
= 0; n
< cm
->as
->rank
; n
++)
1228 mpz_clear (ss
->shape
[n
]);
1229 gfc_free (ss
->shape
);
1231 gfc_cleanup_loop (&loop
);
1233 return gfc_finish_block (&block
);
1236 /* Generate the call for a scalar transfer node. */
1239 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1241 tree args
, tmp
, function
, arg2
, field
, expr
;
1252 arg2
= build_int_cst (NULL_TREE
, kind
);
1253 function
= iocall_x_integer
;
1257 arg2
= build_int_cst (NULL_TREE
, kind
);
1258 function
= iocall_x_real
;
1262 arg2
= build_int_cst (NULL_TREE
, kind
);
1263 function
= iocall_x_complex
;
1267 arg2
= build_int_cst (NULL_TREE
, kind
);
1268 function
= iocall_x_logical
;
1272 if (se
->string_length
)
1273 arg2
= se
->string_length
;
1276 tmp
= gfc_build_indirect_ref (addr_expr
);
1277 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
1278 arg2
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
1280 function
= iocall_x_character
;
1284 /* Recurse into the elements of the derived type. */
1285 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
1286 expr
= gfc_build_indirect_ref (expr
);
1288 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1290 field
= c
->backend_decl
;
1291 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
1293 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), expr
, field
,
1298 tmp
= transfer_array_component (tmp
, c
);
1299 gfc_add_expr_to_block (&se
->pre
, tmp
);
1304 tmp
= gfc_build_addr_expr (NULL
, tmp
);
1305 transfer_expr (se
, &c
->ts
, tmp
);
1311 internal_error ("Bad IO basetype (%d)", ts
->type
);
1314 args
= gfc_chainon_list (NULL_TREE
, addr_expr
);
1315 args
= gfc_chainon_list (args
, arg2
);
1317 tmp
= gfc_build_function_call (function
, args
);
1318 gfc_add_expr_to_block (&se
->pre
, tmp
);
1319 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1324 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1327 gfc_trans_transfer (gfc_code
* code
)
1329 stmtblock_t block
, body
;
1336 gfc_start_block (&block
);
1339 ss
= gfc_walk_expr (expr
);
1341 gfc_init_se (&se
, NULL
);
1343 if (ss
== gfc_ss_terminator
)
1344 gfc_init_block (&body
);
1347 /* Initialize the scalarizer. */
1348 gfc_init_loopinfo (&loop
);
1349 gfc_add_ss_to_loop (&loop
, ss
);
1351 /* Initialize the loop. */
1352 gfc_conv_ss_startstride (&loop
);
1353 gfc_conv_loop_setup (&loop
);
1355 /* The main loop body. */
1356 gfc_mark_ss_chain_used (ss
, 1);
1357 gfc_start_scalarized_body (&loop
, &body
);
1359 gfc_copy_loopinfo_to_se (&se
, &loop
);
1363 gfc_conv_expr_reference (&se
, expr
);
1365 transfer_expr (&se
, &expr
->ts
, se
.expr
);
1367 gfc_add_block_to_block (&body
, &se
.pre
);
1368 gfc_add_block_to_block (&body
, &se
.post
);
1371 tmp
= gfc_finish_block (&body
);
1374 gcc_assert (se
.ss
== gfc_ss_terminator
);
1375 gfc_trans_scalarizing_loops (&loop
, &body
);
1377 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1378 tmp
= gfc_finish_block (&loop
.pre
);
1379 gfc_cleanup_loop (&loop
);
1382 gfc_add_expr_to_block (&block
, tmp
);
1384 return gfc_finish_block (&block
);
1387 #include "gt-fortran-trans-io.h"