1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004 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"
36 #include "trans-stmt.h"
37 #include "trans-array.h"
38 #include "trans-types.h"
39 #include "trans-const.h"
42 static GTY(()) tree gfc_pint4_type_node
;
44 /* Members of the ioparm structure. */
46 static GTY(()) tree ioparm_unit
;
47 static GTY(()) tree ioparm_err
;
48 static GTY(()) tree ioparm_end
;
49 static GTY(()) tree ioparm_eor
;
50 static GTY(()) tree ioparm_list_format
;
51 static GTY(()) tree ioparm_library_return
;
52 static GTY(()) tree ioparm_iostat
;
53 static GTY(()) tree ioparm_exist
;
54 static GTY(()) tree ioparm_opened
;
55 static GTY(()) tree ioparm_number
;
56 static GTY(()) tree ioparm_named
;
57 static GTY(()) tree ioparm_rec
;
58 static GTY(()) tree ioparm_nextrec
;
59 static GTY(()) tree ioparm_size
;
60 static GTY(()) tree ioparm_recl_in
;
61 static GTY(()) tree ioparm_recl_out
;
62 static GTY(()) tree ioparm_file
;
63 static GTY(()) tree ioparm_file_len
;
64 static GTY(()) tree ioparm_status
;
65 static GTY(()) tree ioparm_status_len
;
66 static GTY(()) tree ioparm_access
;
67 static GTY(()) tree ioparm_access_len
;
68 static GTY(()) tree ioparm_form
;
69 static GTY(()) tree ioparm_form_len
;
70 static GTY(()) tree ioparm_blank
;
71 static GTY(()) tree ioparm_blank_len
;
72 static GTY(()) tree ioparm_position
;
73 static GTY(()) tree ioparm_position_len
;
74 static GTY(()) tree ioparm_action
;
75 static GTY(()) tree ioparm_action_len
;
76 static GTY(()) tree ioparm_delim
;
77 static GTY(()) tree ioparm_delim_len
;
78 static GTY(()) tree ioparm_pad
;
79 static GTY(()) tree ioparm_pad_len
;
80 static GTY(()) tree ioparm_format
;
81 static GTY(()) tree ioparm_format_len
;
82 static GTY(()) tree ioparm_advance
;
83 static GTY(()) tree ioparm_advance_len
;
84 static GTY(()) tree ioparm_name
;
85 static GTY(()) tree ioparm_name_len
;
86 static GTY(()) tree ioparm_internal_unit
;
87 static GTY(()) tree ioparm_internal_unit_len
;
88 static GTY(()) tree ioparm_sequential
;
89 static GTY(()) tree ioparm_sequential_len
;
90 static GTY(()) tree ioparm_direct
;
91 static GTY(()) tree ioparm_direct_len
;
92 static GTY(()) tree ioparm_formatted
;
93 static GTY(()) tree ioparm_formatted_len
;
94 static GTY(()) tree ioparm_unformatted
;
95 static GTY(()) tree ioparm_unformatted_len
;
96 static GTY(()) tree ioparm_read
;
97 static GTY(()) tree ioparm_read_len
;
98 static GTY(()) tree ioparm_write
;
99 static GTY(()) tree ioparm_write_len
;
100 static GTY(()) tree ioparm_readwrite
;
101 static GTY(()) tree ioparm_readwrite_len
;
102 static GTY(()) tree ioparm_namelist_name
;
103 static GTY(()) tree ioparm_namelist_name_len
;
104 static GTY(()) tree ioparm_namelist_read_mode
;
106 /* The global I/O variables */
108 static GTY(()) tree ioparm_var
;
109 static GTY(()) tree locus_file
;
110 static GTY(()) tree locus_line
;
113 /* Library I/O subroutines */
115 static GTY(()) tree iocall_read
;
116 static GTY(()) tree iocall_read_done
;
117 static GTY(()) tree iocall_write
;
118 static GTY(()) tree iocall_write_done
;
119 static GTY(()) tree iocall_x_integer
;
120 static GTY(()) tree iocall_x_logical
;
121 static GTY(()) tree iocall_x_character
;
122 static GTY(()) tree iocall_x_real
;
123 static GTY(()) tree iocall_x_complex
;
124 static GTY(()) tree iocall_open
;
125 static GTY(()) tree iocall_close
;
126 static GTY(()) tree iocall_inquire
;
127 static GTY(()) tree iocall_rewind
;
128 static GTY(()) tree iocall_backspace
;
129 static GTY(()) tree iocall_endfile
;
130 static GTY(()) tree iocall_set_nml_val_int
;
131 static GTY(()) tree iocall_set_nml_val_float
;
132 static GTY(()) tree iocall_set_nml_val_char
;
133 static GTY(()) tree iocall_set_nml_val_complex
;
134 static GTY(()) tree iocall_set_nml_val_log
;
136 /* Variable for keeping track of what the last data transfer statement
137 was. Used for deciding which subroutine to call when the data
138 transfer is complete. */
139 static enum { READ
, WRITE
} last_dt
;
141 #define ADD_FIELD(name, type) \
142 ioparm_ ## name = gfc_add_field_to_struct \
143 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
144 get_identifier (stringize(name)), type)
146 #define ADD_STRING(name) \
147 ioparm_ ## name = gfc_add_field_to_struct \
148 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
149 get_identifier (stringize(name)), pchar_type_node); \
150 ioparm_ ## name ## _len = gfc_add_field_to_struct \
151 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
152 get_identifier (stringize(name) "_len"), gfc_int4_type_node)
155 /* Create function decls for IO library functions. */
158 gfc_build_io_library_fndecls (void)
162 gfc_pint4_type_node
= build_pointer_type (gfc_int4_type_node
);
164 /* Build the st_parameter structure. Information associated with I/O
165 calls are transferred here. This must match the one defined in the
168 ioparm_type
= make_node (RECORD_TYPE
);
169 TYPE_NAME (ioparm_type
) = get_identifier ("_gfc_ioparm");
171 ADD_FIELD (unit
, gfc_int4_type_node
);
172 ADD_FIELD (err
, gfc_int4_type_node
);
173 ADD_FIELD (end
, gfc_int4_type_node
);
174 ADD_FIELD (eor
, gfc_int4_type_node
);
175 ADD_FIELD (list_format
, gfc_int4_type_node
);
176 ADD_FIELD (library_return
, gfc_int4_type_node
);
178 ADD_FIELD (iostat
, gfc_pint4_type_node
);
179 ADD_FIELD (exist
, gfc_pint4_type_node
);
180 ADD_FIELD (opened
, gfc_pint4_type_node
);
181 ADD_FIELD (number
, gfc_pint4_type_node
);
182 ADD_FIELD (named
, gfc_pint4_type_node
);
183 ADD_FIELD (rec
, gfc_pint4_type_node
);
184 ADD_FIELD (nextrec
, gfc_pint4_type_node
);
185 ADD_FIELD (size
, gfc_pint4_type_node
);
187 ADD_FIELD (recl_in
, gfc_pint4_type_node
);
188 ADD_FIELD (recl_out
, gfc_pint4_type_node
);
196 ADD_STRING (position
);
201 ADD_STRING (advance
);
203 ADD_STRING (internal_unit
);
204 ADD_STRING (sequential
);
207 ADD_STRING (formatted
);
208 ADD_STRING (unformatted
);
211 ADD_STRING (readwrite
);
213 ADD_STRING (namelist_name
);
214 ADD_FIELD (namelist_read_mode
, gfc_int4_type_node
);
216 gfc_finish_type (ioparm_type
);
218 ioparm_var
= build_decl (VAR_DECL
, get_identifier (PREFIX("ioparm")),
220 DECL_EXTERNAL (ioparm_var
) = 1;
221 TREE_PUBLIC (ioparm_var
) = 1;
223 locus_line
= build_decl (VAR_DECL
, get_identifier (PREFIX("line")),
225 DECL_EXTERNAL (locus_line
) = 1;
226 TREE_PUBLIC (locus_line
) = 1;
228 locus_file
= build_decl (VAR_DECL
, get_identifier (PREFIX("filename")),
230 DECL_EXTERNAL (locus_file
) = 1;
231 TREE_PUBLIC (locus_file
) = 1;
233 /* Define the transfer functions. */
236 gfc_build_library_function_decl (get_identifier
237 (PREFIX("transfer_integer")),
238 void_type_node
, 2, pvoid_type_node
,
242 gfc_build_library_function_decl (get_identifier
243 (PREFIX("transfer_logical")),
244 void_type_node
, 2, pvoid_type_node
,
248 gfc_build_library_function_decl (get_identifier
249 (PREFIX("transfer_character")),
250 void_type_node
, 2, pvoid_type_node
,
254 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
256 pvoid_type_node
, gfc_int4_type_node
);
259 gfc_build_library_function_decl (get_identifier
260 (PREFIX("transfer_complex")),
261 void_type_node
, 2, pvoid_type_node
,
264 /* Library entry points */
267 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
271 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
274 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
278 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
282 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
283 gfc_int4_type_node
, 0);
286 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
287 gfc_int4_type_node
, 0);
290 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
291 gfc_int4_type_node
, 0);
294 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
295 gfc_int4_type_node
, 0);
296 /* Library helpers */
299 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
300 gfc_int4_type_node
, 0);
303 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
304 gfc_int4_type_node
, 0);
305 iocall_set_nml_val_int
=
306 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
308 pvoid_type_node
, pvoid_type_node
,
309 gfc_int4_type_node
,gfc_int4_type_node
);
311 iocall_set_nml_val_float
=
312 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
314 pvoid_type_node
, pvoid_type_node
,
315 gfc_int4_type_node
,gfc_int4_type_node
);
316 iocall_set_nml_val_char
=
317 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")),
319 pvoid_type_node
, pvoid_type_node
,
320 gfc_int4_type_node
,gfc_int4_type_node
);
321 iocall_set_nml_val_complex
=
322 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
324 pvoid_type_node
, pvoid_type_node
,
325 gfc_int4_type_node
,gfc_int4_type_node
);
326 iocall_set_nml_val_log
=
327 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
329 pvoid_type_node
, pvoid_type_node
,
330 gfc_int4_type_node
,gfc_int4_type_node
);
335 /* Generate code to store an non-string I/O parameter into the
336 ioparm structure. This is a pass by value. */
339 set_parameter_value (stmtblock_t
* block
, tree var
, gfc_expr
* e
)
344 gfc_init_se (&se
, NULL
);
345 gfc_conv_expr_type (&se
, e
, TREE_TYPE (var
));
346 gfc_add_block_to_block (block
, &se
.pre
);
348 tmp
= build (COMPONENT_REF
, TREE_TYPE (var
), ioparm_var
, var
);
349 gfc_add_modify_expr (block
, tmp
, se
.expr
);
353 /* Generate code to store an non-string I/O parameter into the
354 ioparm structure. This is pass by reference. */
357 set_parameter_ref (stmtblock_t
* block
, tree var
, gfc_expr
* e
)
362 gfc_init_se (&se
, NULL
);
365 gfc_conv_expr_type (&se
, e
, TREE_TYPE (var
));
366 gfc_add_block_to_block (block
, &se
.pre
);
368 tmp
= build (COMPONENT_REF
, TREE_TYPE (var
), ioparm_var
, var
);
369 gfc_add_modify_expr (block
, tmp
, se
.expr
);
373 /* Generate code to store a string and its length into the
377 set_string (stmtblock_t
* block
, stmtblock_t
* postblock
, tree var
,
378 tree var_len
, gfc_expr
* e
)
386 gfc_init_se (&se
, NULL
);
387 gfc_conv_expr (&se
, e
);
389 io
= build (COMPONENT_REF
, TREE_TYPE (var
), ioparm_var
, var
);
390 len
= build (COMPONENT_REF
, TREE_TYPE (var_len
), ioparm_var
, var_len
);
392 /* Integer variable assigned a format label. */
393 if (e
->ts
.type
== BT_INTEGER
&& e
->symtree
->n
.sym
->attr
.assign
== 1)
396 gfc_build_string_const (37, "Assigned label is not a format label");
397 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
398 tmp
= build (LE_EXPR
, boolean_type_node
, tmp
, integer_minus_one_node
);
399 gfc_trans_runtime_check (tmp
, msg
, &se
.pre
);
400 gfc_add_modify_expr (&se
.pre
, io
, GFC_DECL_ASSIGN_ADDR (se
.expr
));
401 gfc_add_modify_expr (&se
.pre
, len
, GFC_DECL_STRING_LEN (se
.expr
));
405 gfc_conv_string_parameter (&se
);
406 gfc_add_modify_expr (&se
.pre
, io
, se
.expr
);
407 gfc_add_modify_expr (&se
.pre
, len
, se
.string_length
);
410 gfc_add_block_to_block (block
, &se
.pre
);
411 gfc_add_block_to_block (postblock
, &se
.post
);
416 /* Set a member of the ioparm structure to one. */
418 set_flag (stmtblock_t
*block
, tree var
)
422 tmp
= build (COMPONENT_REF
, TREE_TYPE(var
), ioparm_var
, var
);
423 gfc_add_modify_expr (block
, tmp
, integer_one_node
);
427 /* Add a case to a IO-result switch. */
430 add_case (int label_value
, gfc_st_label
* label
, stmtblock_t
* body
)
435 return; /* No label, no case */
437 value
= build_int_2 (label_value
, 0);
439 /* Make a backend label for this case. */
440 tmp
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
441 DECL_CONTEXT (tmp
) = current_function_decl
;
443 /* And the case itself. */
444 tmp
= build_v (CASE_LABEL_EXPR
, value
, NULL_TREE
, tmp
);
445 gfc_add_expr_to_block (body
, tmp
);
447 /* Jump to the label. */
448 tmp
= build1_v (GOTO_EXPR
, gfc_get_label_decl (label
));
449 gfc_add_expr_to_block (body
, tmp
);
453 /* Generate a switch statement that branches to the correct I/O
454 result label. The last statement of an I/O call stores the
455 result into a variable because there is often cleanup that
456 must be done before the switch, so a temporary would have to
457 be created anyway. */
460 io_result (stmtblock_t
* block
, gfc_st_label
* err_label
,
461 gfc_st_label
* end_label
, gfc_st_label
* eor_label
)
466 /* If no labels are specified, ignore the result instead
467 of building an empty switch. */
468 if (err_label
== NULL
470 && eor_label
== NULL
)
473 /* Build a switch statement. */
474 gfc_start_block (&body
);
476 /* The label values here must be the same as the values
477 in the library_return enum in the runtime library */
478 add_case (1, err_label
, &body
);
479 add_case (2, end_label
, &body
);
480 add_case (3, eor_label
, &body
);
482 tmp
= gfc_finish_block (&body
);
484 rc
= build (COMPONENT_REF
, TREE_TYPE (ioparm_library_return
), ioparm_var
,
485 ioparm_library_return
);
487 tmp
= build_v (SWITCH_EXPR
, rc
, tmp
, NULL_TREE
);
489 gfc_add_expr_to_block (block
, tmp
);
493 /* Store the current file and line number to variables so that if a
494 library call goes awry, we can tell the user where the problem is. */
497 set_error_locus (stmtblock_t
* block
, locus
* where
)
504 tmp
= gfc_build_string_const (strlen (f
->filename
) + 1, f
->filename
);
506 tmp
= gfc_build_addr_expr (pchar_type_node
, tmp
);
507 gfc_add_modify_expr (block
, locus_file
, tmp
);
509 line
= where
->lp
->start_line
+ where
->line
;
510 gfc_add_modify_expr (block
, locus_line
, build_int_2 (line
, 0));
514 /* Translate an OPEN statement. */
517 gfc_trans_open (gfc_code
* code
)
519 stmtblock_t block
, post_block
;
523 gfc_init_block (&block
);
524 gfc_init_block (&post_block
);
526 set_error_locus (&block
, &code
->loc
);
530 set_parameter_value (&block
, ioparm_unit
, p
->unit
);
533 set_string (&block
, &post_block
, ioparm_file
, ioparm_file_len
, p
->file
);
536 set_string (&block
, &post_block
, ioparm_status
,
537 ioparm_status_len
, p
->status
);
540 set_string (&block
, &post_block
, ioparm_access
,
541 ioparm_access_len
, p
->access
);
544 set_string (&block
, &post_block
, ioparm_form
, ioparm_form_len
, p
->form
);
547 set_parameter_value (&block
, ioparm_recl_in
, p
->recl
);
550 set_string (&block
, &post_block
, ioparm_blank
, ioparm_blank_len
,
554 set_string (&block
, &post_block
, ioparm_position
,
555 ioparm_position_len
, p
->position
);
558 set_string (&block
, &post_block
, ioparm_action
,
559 ioparm_action_len
, p
->action
);
562 set_string (&block
, &post_block
, ioparm_delim
, ioparm_delim_len
,
566 set_string (&block
, &post_block
, ioparm_pad
, ioparm_pad_len
, p
->pad
);
569 set_parameter_ref (&block
, ioparm_iostat
, p
->iostat
);
572 set_flag (&block
, ioparm_err
);
574 tmp
= gfc_build_function_call (iocall_open
, NULL_TREE
);
575 gfc_add_expr_to_block (&block
, tmp
);
577 gfc_add_block_to_block (&block
, &post_block
);
579 io_result (&block
, p
->err
, NULL
, NULL
);
581 return gfc_finish_block (&block
);
585 /* Translate a CLOSE statement. */
588 gfc_trans_close (gfc_code
* code
)
590 stmtblock_t block
, post_block
;
594 gfc_init_block (&block
);
595 gfc_init_block (&post_block
);
597 set_error_locus (&block
, &code
->loc
);
601 set_parameter_value (&block
, ioparm_unit
, p
->unit
);
604 set_string (&block
, &post_block
, ioparm_status
,
605 ioparm_status_len
, p
->status
);
608 set_parameter_ref (&block
, ioparm_iostat
, p
->iostat
);
611 set_flag (&block
, ioparm_err
);
613 tmp
= gfc_build_function_call (iocall_close
, NULL_TREE
);
614 gfc_add_expr_to_block (&block
, tmp
);
616 gfc_add_block_to_block (&block
, &post_block
);
618 io_result (&block
, p
->err
, NULL
, NULL
);
620 return gfc_finish_block (&block
);
624 /* Common subroutine for building a file positioning statement. */
627 build_filepos (tree function
, gfc_code
* code
)
633 p
= code
->ext
.filepos
;
635 gfc_init_block (&block
);
637 set_error_locus (&block
, &code
->loc
);
640 set_parameter_value (&block
, ioparm_unit
, p
->unit
);
643 set_parameter_ref (&block
, ioparm_iostat
, p
->iostat
);
646 set_flag (&block
, ioparm_err
);
648 tmp
= gfc_build_function_call (function
, NULL
);
649 gfc_add_expr_to_block (&block
, tmp
);
651 io_result (&block
, p
->err
, NULL
, NULL
);
653 return gfc_finish_block (&block
);
657 /* Translate a BACKSPACE statement. */
660 gfc_trans_backspace (gfc_code
* code
)
663 return build_filepos (iocall_backspace
, code
);
667 /* Translate an ENDFILE statement. */
670 gfc_trans_endfile (gfc_code
* code
)
673 return build_filepos (iocall_endfile
, code
);
677 /* Translate a REWIND statement. */
680 gfc_trans_rewind (gfc_code
* code
)
683 return build_filepos (iocall_rewind
, code
);
687 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
690 gfc_trans_inquire (gfc_code
* code
)
692 stmtblock_t block
, post_block
;
696 gfc_init_block (&block
);
697 gfc_init_block (&post_block
);
699 set_error_locus (&block
, &code
->loc
);
700 p
= code
->ext
.inquire
;
703 set_parameter_value (&block
, ioparm_unit
, p
->unit
);
706 set_string (&block
, &post_block
, ioparm_file
, ioparm_file_len
, p
->file
);
709 set_parameter_ref (&block
, ioparm_iostat
, p
->iostat
);
712 set_parameter_ref (&block
, ioparm_exist
, p
->exist
);
715 set_parameter_ref (&block
, ioparm_opened
, p
->opened
);
718 set_parameter_ref (&block
, ioparm_number
, p
->number
);
721 set_parameter_ref (&block
, ioparm_named
, p
->named
);
724 set_string (&block
, &post_block
, ioparm_name
, ioparm_name_len
, p
->name
);
727 set_string (&block
, &post_block
, ioparm_access
,
728 ioparm_access_len
, p
->access
);
731 set_string (&block
, &post_block
, ioparm_sequential
,
732 ioparm_sequential_len
, p
->sequential
);
735 set_string (&block
, &post_block
, ioparm_direct
,
736 ioparm_direct_len
, p
->direct
);
739 set_string (&block
, &post_block
, ioparm_form
, ioparm_form_len
, p
->form
);
742 set_string (&block
, &post_block
, ioparm_formatted
,
743 ioparm_formatted_len
, p
->formatted
);
746 set_string (&block
, &post_block
, ioparm_unformatted
,
747 ioparm_unformatted_len
, p
->unformatted
);
750 set_parameter_ref (&block
, ioparm_recl_out
, p
->recl
);
753 set_parameter_ref (&block
, ioparm_nextrec
, p
->nextrec
);
756 set_string (&block
, &post_block
, ioparm_blank
, ioparm_blank_len
,
760 set_string (&block
, &post_block
, ioparm_position
,
761 ioparm_position_len
, p
->position
);
764 set_string (&block
, &post_block
, ioparm_action
,
765 ioparm_action_len
, p
->action
);
768 set_string (&block
, &post_block
, ioparm_read
, ioparm_read_len
, p
->read
);
771 set_string (&block
, &post_block
, ioparm_write
,
772 ioparm_write_len
, p
->write
);
775 set_string (&block
, &post_block
, ioparm_readwrite
,
776 ioparm_readwrite_len
, p
->readwrite
);
779 set_string (&block
, &post_block
, ioparm_delim
, ioparm_delim_len
,
783 set_flag (&block
, ioparm_err
);
785 tmp
= gfc_build_function_call (iocall_inquire
, NULL
);
786 gfc_add_expr_to_block (&block
, tmp
);
788 gfc_add_block_to_block (&block
, &post_block
);
790 io_result (&block
, p
->err
, NULL
, NULL
);
792 return gfc_finish_block (&block
);
796 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
797 this as a third sort of data transfer statement, except that
798 lengths are summed instead of actually transfering any data. */
801 gfc_trans_iolength (gfc_code
* c ATTRIBUTE_UNUSED
)
803 gfc_todo_error ("IOLENGTH statement");
807 gfc_new_nml_name_expr (char * name
)
810 nml_name
= gfc_get_expr();
811 nml_name
->ref
= NULL
;
812 nml_name
->expr_type
= EXPR_CONSTANT
;
813 nml_name
->ts
.kind
= gfc_default_character_kind ();
814 nml_name
->ts
.type
= BT_CHARACTER
;
815 nml_name
->value
.character
.length
= strlen(name
);
816 nml_name
->value
.character
.string
= name
;
822 get_new_var_expr(gfc_symbol
* sym
)
826 nml_var
= gfc_get_expr();
827 nml_var
->expr_type
= EXPR_VARIABLE
;
828 nml_var
->ts
= sym
->ts
;
830 nml_var
->rank
= sym
->as
->rank
;
831 nml_var
->symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
832 nml_var
->symtree
->n
.sym
= sym
;
833 nml_var
->where
= sym
->declared_at
;
834 sym
->attr
.referenced
= 1;
840 /* Create a data transfer statement. Not all of the fields are valid
841 for both reading and writing, but improper use has been filtered
845 build_dt (tree
* function
, gfc_code
* code
)
847 stmtblock_t block
, post_block
;
849 tree tmp
, args
, arg2
;
850 gfc_expr
*nmlname
, *nmlvar
;
851 gfc_namelist
*nml
, *nml_tail
;
853 int ts_kind
, ts_type
, name_len
;
855 gfc_init_block (&block
);
856 gfc_init_block (&post_block
);
858 set_error_locus (&block
, &code
->loc
);
863 if (dt
->io_unit
->ts
.type
== BT_CHARACTER
)
865 set_string (&block
, &post_block
, ioparm_internal_unit
,
866 ioparm_internal_unit_len
, dt
->io_unit
);
869 set_parameter_value (&block
, ioparm_unit
, dt
->io_unit
);
873 set_parameter_value (&block
, ioparm_rec
, dt
->rec
);
876 set_string (&block
, &post_block
, ioparm_advance
, ioparm_advance_len
,
880 set_string (&block
, &post_block
, ioparm_format
, ioparm_format_len
,
883 if (dt
->format_label
)
885 if (dt
->format_label
== &format_asterisk
)
886 set_flag (&block
, ioparm_list_format
);
888 set_string (&block
, &post_block
, ioparm_format
,
889 ioparm_format_len
, dt
->format_label
->format
);
893 set_parameter_ref (&block
, ioparm_iostat
, dt
->iostat
);
896 set_parameter_ref (&block
, ioparm_size
, dt
->size
);
899 set_flag (&block
, ioparm_err
);
902 set_flag(&block
, ioparm_eor
);
905 set_flag(&block
, ioparm_end
);
909 if (dt
->format_expr
|| dt
->format_label
)
910 fatal_error("A format cannot be specified with a namelist");
912 nmlname
= gfc_new_nml_name_expr(dt
->namelist
->name
);
914 set_string (&block
, &post_block
, ioparm_namelist_name
,
915 ioparm_namelist_name_len
, nmlname
);
918 set_flag (&block
, ioparm_namelist_read_mode
);
920 nml
= dt
->namelist
->namelist
;
921 nml_tail
= dt
->namelist
->namelist_tail
;
925 gfc_init_se (&se
, NULL
);
926 gfc_init_se (&se2
, NULL
);
927 nmlvar
= get_new_var_expr(nml
->sym
);
928 nmlname
= gfc_new_nml_name_expr(nml
->sym
->name
);
929 name_len
= strlen(nml
->sym
->name
);
930 ts_kind
= nml
->sym
->ts
.kind
;
931 ts_type
= nml
->sym
->ts
.type
;
933 gfc_conv_expr_reference (&se2
, nmlname
);
934 gfc_conv_expr_reference (&se
, nmlvar
);
935 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
936 args
= gfc_chainon_list (args
, se2
.expr
);
937 args
= gfc_chainon_list (args
, se2
.string_length
);
938 arg2
= build_int_2 (ts_kind
, 0);
939 args
= gfc_chainon_list (args
,arg2
);
943 tmp
= gfc_build_function_call (iocall_set_nml_val_int
, args
);
946 tmp
= gfc_build_function_call (iocall_set_nml_val_char
, args
);
949 tmp
= gfc_build_function_call (iocall_set_nml_val_float
, args
);
952 tmp
= gfc_build_function_call (iocall_set_nml_val_log
, args
);
955 tmp
= gfc_build_function_call (iocall_set_nml_val_complex
, args
);
958 internal_error ("Bad namelist IO basetype (%d)", ts_type
);
961 gfc_add_expr_to_block (&block
, tmp
);
967 tmp
= gfc_build_function_call (*function
, NULL_TREE
);
968 gfc_add_expr_to_block (&block
, tmp
);
970 gfc_add_block_to_block (&block
, &post_block
);
972 return gfc_finish_block (&block
);
976 /* Translate a READ statement. */
979 gfc_trans_read (gfc_code
* code
)
983 return build_dt (&iocall_read
, code
);
987 /* Translate a WRITE statement */
990 gfc_trans_write (gfc_code
* code
)
994 return build_dt (&iocall_write
, code
);
998 /* Finish a data transfer statement. */
1001 gfc_trans_dt_end (gfc_code
* code
)
1006 gfc_init_block (&block
);
1008 function
= (last_dt
== READ
) ? iocall_read_done
: iocall_write_done
;
1010 tmp
= gfc_build_function_call (function
, NULL
);
1011 gfc_add_expr_to_block (&block
, tmp
);
1013 io_result (&block
, code
->ext
.dt
->err
, code
->ext
.dt
->end
, code
->ext
.dt
->eor
);
1015 return gfc_finish_block (&block
);
1019 /* Generate the call for a scalar transfer node. */
1022 transfer_expr (gfc_se
* se
, gfc_typespec
* ts
, tree addr_expr
)
1024 tree args
, tmp
, function
, arg2
, field
, expr
;
1035 arg2
= build_int_2 (kind
, 0);
1036 function
= iocall_x_integer
;
1040 arg2
= build_int_2 (kind
, 0);
1041 function
= iocall_x_real
;
1045 arg2
= build_int_2 (kind
, 0);
1046 function
= iocall_x_complex
;
1050 arg2
= build_int_2 (kind
, 0);
1051 function
= iocall_x_logical
;
1055 arg2
= se
->string_length
;
1056 function
= iocall_x_character
;
1060 expr
= gfc_evaluate_now (addr_expr
, &se
->pre
);
1061 expr
= gfc_build_indirect_ref (expr
);
1063 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1065 field
= c
->backend_decl
;
1066 assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
1068 tmp
= build (COMPONENT_REF
, TREE_TYPE (field
), expr
, field
);
1070 if (c
->ts
.type
== BT_CHARACTER
)
1072 assert (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
);
1074 TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp
)));
1076 transfer_expr (se
, &c
->ts
, gfc_build_addr_expr (NULL
, tmp
));
1081 internal_error ("Bad IO basetype (%d)", ts
->type
);
1084 args
= gfc_chainon_list (NULL_TREE
, addr_expr
);
1085 args
= gfc_chainon_list (args
, arg2
);
1087 tmp
= gfc_build_function_call (function
, args
);
1088 gfc_add_expr_to_block (&se
->pre
, tmp
);
1089 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1093 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1096 gfc_trans_transfer (gfc_code
* code
)
1098 stmtblock_t block
, body
;
1105 gfc_start_block (&block
);
1108 ss
= gfc_walk_expr (expr
);
1110 gfc_init_se (&se
, NULL
);
1112 if (ss
== gfc_ss_terminator
)
1113 gfc_init_block (&body
);
1116 /* Initialize the scalarizer. */
1117 gfc_init_loopinfo (&loop
);
1118 gfc_add_ss_to_loop (&loop
, ss
);
1120 /* Initialize the loop. */
1121 gfc_conv_ss_startstride (&loop
);
1122 gfc_conv_loop_setup (&loop
);
1124 /* The main loop body. */
1125 gfc_mark_ss_chain_used (ss
, 1);
1126 gfc_start_scalarized_body (&loop
, &body
);
1128 gfc_copy_loopinfo_to_se (&se
, &loop
);
1132 gfc_conv_expr_reference (&se
, expr
);
1134 transfer_expr (&se
, &expr
->ts
, se
.expr
);
1136 gfc_add_block_to_block (&body
, &se
.pre
);
1137 gfc_add_block_to_block (&body
, &se
.post
);
1140 tmp
= gfc_finish_block (&body
);
1143 assert (se
.ss
== gfc_ss_terminator
);
1144 gfc_trans_scalarizing_loops (&loop
, &body
);
1146 gfc_add_block_to_block (&loop
.pre
, &loop
.post
);
1147 tmp
= gfc_finish_block (&loop
.pre
);
1148 gfc_cleanup_loop (&loop
);
1151 gfc_add_expr_to_block (&block
, tmp
);
1153 return gfc_finish_block (&block
);;
1156 #include "gt-fortran-trans-io.h"