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_iolength;
63 static GTY(()) tree ioparm_file;
64 static GTY(()) tree ioparm_file_len;
65 static GTY(()) tree ioparm_status;
66 static GTY(()) tree ioparm_status_len;
67 static GTY(()) tree ioparm_access;
68 static GTY(()) tree ioparm_access_len;
69 static GTY(()) tree ioparm_form;
70 static GTY(()) tree ioparm_form_len;
71 static GTY(()) tree ioparm_blank;
72 static GTY(()) tree ioparm_blank_len;
73 static GTY(()) tree ioparm_position;
74 static GTY(()) tree ioparm_position_len;
75 static GTY(()) tree ioparm_action;
76 static GTY(()) tree ioparm_action_len;
77 static GTY(()) tree ioparm_delim;
78 static GTY(()) tree ioparm_delim_len;
79 static GTY(()) tree ioparm_pad;
80 static GTY(()) tree ioparm_pad_len;
81 static GTY(()) tree ioparm_format;
82 static GTY(()) tree ioparm_format_len;
83 static GTY(()) tree ioparm_advance;
84 static GTY(()) tree ioparm_advance_len;
85 static GTY(()) tree ioparm_name;
86 static GTY(()) tree ioparm_name_len;
87 static GTY(()) tree ioparm_internal_unit;
88 static GTY(()) tree ioparm_internal_unit_len;
89 static GTY(()) tree ioparm_sequential;
90 static GTY(()) tree ioparm_sequential_len;
91 static GTY(()) tree ioparm_direct;
92 static GTY(()) tree ioparm_direct_len;
93 static GTY(()) tree ioparm_formatted;
94 static GTY(()) tree ioparm_formatted_len;
95 static GTY(()) tree ioparm_unformatted;
96 static GTY(()) tree ioparm_unformatted_len;
97 static GTY(()) tree ioparm_read;
98 static GTY(()) tree ioparm_read_len;
99 static GTY(()) tree ioparm_write;
100 static GTY(()) tree ioparm_write_len;
101 static GTY(()) tree ioparm_readwrite;
102 static GTY(()) tree ioparm_readwrite_len;
103 static GTY(()) tree ioparm_namelist_name;
104 static GTY(()) tree ioparm_namelist_name_len;
105 static GTY(()) tree ioparm_namelist_read_mode;
107 /* The global I/O variables */
109 static GTY(()) tree ioparm_var;
110 static GTY(()) tree locus_file;
111 static GTY(()) tree locus_line;
114 /* Library I/O subroutines */
116 static GTY(()) tree iocall_read;
117 static GTY(()) tree iocall_read_done;
118 static GTY(()) tree iocall_write;
119 static GTY(()) tree iocall_write_done;
120 static GTY(()) tree iocall_x_integer;
121 static GTY(()) tree iocall_x_logical;
122 static GTY(()) tree iocall_x_character;
123 static GTY(()) tree iocall_x_real;
124 static GTY(()) tree iocall_x_complex;
125 static GTY(()) tree iocall_open;
126 static GTY(()) tree iocall_close;
127 static GTY(()) tree iocall_inquire;
128 static GTY(()) tree iocall_iolength;
129 static GTY(()) tree iocall_iolength_done;
130 static GTY(()) tree iocall_rewind;
131 static GTY(()) tree iocall_backspace;
132 static GTY(()) tree iocall_endfile;
133 static GTY(()) tree iocall_set_nml_val_int;
134 static GTY(()) tree iocall_set_nml_val_float;
135 static GTY(()) tree iocall_set_nml_val_char;
136 static GTY(()) tree iocall_set_nml_val_complex;
137 static GTY(()) tree iocall_set_nml_val_log;
139 /* Variable for keeping track of what the last data transfer statement
140 was. Used for deciding which subroutine to call when the data
141 transfer is complete. */
142 static enum { READ, WRITE, IOLENGTH } last_dt;
144 #define ADD_FIELD(name, type) \
145 ioparm_ ## name = gfc_add_field_to_struct \
146 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
147 get_identifier (stringize(name)), type)
149 #define ADD_STRING(name) \
150 ioparm_ ## name = gfc_add_field_to_struct \
151 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
152 get_identifier (stringize(name)), pchar_type_node); \
153 ioparm_ ## name ## _len = gfc_add_field_to_struct \
154 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
155 get_identifier (stringize(name) "_len"), gfc_int4_type_node)
158 /* Create function decls for IO library functions. */
161 gfc_build_io_library_fndecls (void)
165 gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
167 /* Build the st_parameter structure. Information associated with I/O
168 calls are transferred here. This must match the one defined in the
171 ioparm_type = make_node (RECORD_TYPE);
172 TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm");
174 ADD_FIELD (unit, gfc_int4_type_node);
175 ADD_FIELD (err, gfc_int4_type_node);
176 ADD_FIELD (end, gfc_int4_type_node);
177 ADD_FIELD (eor, gfc_int4_type_node);
178 ADD_FIELD (list_format, gfc_int4_type_node);
179 ADD_FIELD (library_return, gfc_int4_type_node);
181 ADD_FIELD (iostat, gfc_pint4_type_node);
182 ADD_FIELD (exist, gfc_pint4_type_node);
183 ADD_FIELD (opened, gfc_pint4_type_node);
184 ADD_FIELD (number, gfc_pint4_type_node);
185 ADD_FIELD (named, gfc_pint4_type_node);
186 ADD_FIELD (rec, gfc_pint4_type_node);
187 ADD_FIELD (nextrec, gfc_pint4_type_node);
188 ADD_FIELD (size, gfc_pint4_type_node);
190 ADD_FIELD (recl_in, gfc_pint4_type_node);
191 ADD_FIELD (recl_out, gfc_pint4_type_node);
193 ADD_FIELD (iolength, gfc_pint4_type_node);
201 ADD_STRING (position);
206 ADD_STRING (advance);
208 ADD_STRING (internal_unit);
209 ADD_STRING (sequential);
212 ADD_STRING (formatted);
213 ADD_STRING (unformatted);
216 ADD_STRING (readwrite);
218 ADD_STRING (namelist_name);
219 ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
221 gfc_finish_type (ioparm_type);
223 ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
225 DECL_EXTERNAL (ioparm_var) = 1;
226 TREE_PUBLIC (ioparm_var) = 1;
228 locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
230 DECL_EXTERNAL (locus_line) = 1;
231 TREE_PUBLIC (locus_line) = 1;
233 locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
235 DECL_EXTERNAL (locus_file) = 1;
236 TREE_PUBLIC (locus_file) = 1;
238 /* Define the transfer functions. */
241 gfc_build_library_function_decl (get_identifier
242 (PREFIX("transfer_integer")),
243 void_type_node, 2, pvoid_type_node,
247 gfc_build_library_function_decl (get_identifier
248 (PREFIX("transfer_logical")),
249 void_type_node, 2, pvoid_type_node,
253 gfc_build_library_function_decl (get_identifier
254 (PREFIX("transfer_character")),
255 void_type_node, 2, pvoid_type_node,
259 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
261 pvoid_type_node, gfc_int4_type_node);
264 gfc_build_library_function_decl (get_identifier
265 (PREFIX("transfer_complex")),
266 void_type_node, 2, pvoid_type_node,
269 /* Library entry points */
272 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
276 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
279 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
283 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
287 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
288 gfc_int4_type_node, 0);
291 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
295 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
296 gfc_int4_type_node, 0);
299 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
300 gfc_int4_type_node, 0);
303 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
304 gfc_int4_type_node, 0);
305 /* Library helpers */
308 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
309 gfc_int4_type_node, 0);
312 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
313 gfc_int4_type_node, 0);
315 iocall_iolength_done =
316 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
317 gfc_int4_type_node, 0);
319 iocall_set_nml_val_int =
320 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
322 pvoid_type_node, pvoid_type_node,
323 gfc_int4_type_node,gfc_int4_type_node);
325 iocall_set_nml_val_float =
326 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
328 pvoid_type_node, pvoid_type_node,
329 gfc_int4_type_node,gfc_int4_type_node);
330 iocall_set_nml_val_char =
331 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")),
333 pvoid_type_node, pvoid_type_node,
334 gfc_int4_type_node,gfc_int4_type_node);
335 iocall_set_nml_val_complex =
336 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
338 pvoid_type_node, pvoid_type_node,
339 gfc_int4_type_node,gfc_int4_type_node);
340 iocall_set_nml_val_log =
341 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
343 pvoid_type_node, pvoid_type_node,
344 gfc_int4_type_node,gfc_int4_type_node);
349 /* Generate code to store an non-string I/O parameter into the
350 ioparm structure. This is a pass by value. */
353 set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
358 gfc_init_se (&se, NULL);
359 gfc_conv_expr_type (&se, e, TREE_TYPE (var));
360 gfc_add_block_to_block (block, &se.pre);
362 tmp = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
363 gfc_add_modify_expr (block, tmp, se.expr);
367 /* Generate code to store an non-string I/O parameter into the
368 ioparm structure. This is pass by reference. */
371 set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
376 gfc_init_se (&se, NULL);
379 gfc_conv_expr_type (&se, e, TREE_TYPE (var));
380 gfc_add_block_to_block (block, &se.pre);
382 tmp = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
383 gfc_add_modify_expr (block, tmp, se.expr);
387 /* Generate code to store a string and its length into the
391 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
392 tree var_len, gfc_expr * e)
400 gfc_init_se (&se, NULL);
401 gfc_conv_expr (&se, e);
403 io = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
404 len = build (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
407 /* Integer variable assigned a format label. */
408 if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
411 gfc_build_string_const (37, "Assigned label is not a format label");
412 tmp = GFC_DECL_STRING_LEN (se.expr);
413 tmp = build (LE_EXPR, boolean_type_node,
414 tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
415 gfc_trans_runtime_check (tmp, msg, &se.pre);
416 gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr));
417 gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
421 gfc_conv_string_parameter (&se);
422 gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
423 gfc_add_modify_expr (&se.pre, len, se.string_length);
426 gfc_add_block_to_block (block, &se.pre);
427 gfc_add_block_to_block (postblock, &se.post);
432 /* Set a member of the ioparm structure to one. */
434 set_flag (stmtblock_t *block, tree var)
436 tree tmp, type = TREE_TYPE (var);
438 tmp = build (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
439 gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
443 /* Add a case to a IO-result switch. */
446 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
451 return; /* No label, no case */
453 value = build_int_2 (label_value, 0);
455 /* Make a backend label for this case. */
456 tmp = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
457 DECL_CONTEXT (tmp) = current_function_decl;
459 /* And the case itself. */
460 tmp = build_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
461 gfc_add_expr_to_block (body, tmp);
463 /* Jump to the label. */
464 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
465 gfc_add_expr_to_block (body, tmp);
469 /* Generate a switch statement that branches to the correct I/O
470 result label. The last statement of an I/O call stores the
471 result into a variable because there is often cleanup that
472 must be done before the switch, so a temporary would have to
473 be created anyway. */
476 io_result (stmtblock_t * block, gfc_st_label * err_label,
477 gfc_st_label * end_label, gfc_st_label * eor_label)
482 /* If no labels are specified, ignore the result instead
483 of building an empty switch. */
484 if (err_label == NULL
486 && eor_label == NULL)
489 /* Build a switch statement. */
490 gfc_start_block (&body);
492 /* The label values here must be the same as the values
493 in the library_return enum in the runtime library */
494 add_case (1, err_label, &body);
495 add_case (2, end_label, &body);
496 add_case (3, eor_label, &body);
498 tmp = gfc_finish_block (&body);
500 rc = build (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
501 ioparm_library_return, NULL_TREE);
503 tmp = build_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
505 gfc_add_expr_to_block (block, tmp);
509 /* Store the current file and line number to variables so that if a
510 library call goes awry, we can tell the user where the problem is. */
513 set_error_locus (stmtblock_t * block, locus * where)
520 tmp = gfc_build_string_const (strlen (f->filename) + 1, f->filename);
522 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
523 gfc_add_modify_expr (block, locus_file, tmp);
525 line = where->lb->linenum;
526 gfc_add_modify_expr (block, locus_line, build_int_2 (line, 0));
530 /* Translate an OPEN statement. */
533 gfc_trans_open (gfc_code * code)
535 stmtblock_t block, post_block;
539 gfc_init_block (&block);
540 gfc_init_block (&post_block);
542 set_error_locus (&block, &code->loc);
546 set_parameter_value (&block, ioparm_unit, p->unit);
549 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
552 set_string (&block, &post_block, ioparm_status,
553 ioparm_status_len, p->status);
556 set_string (&block, &post_block, ioparm_access,
557 ioparm_access_len, p->access);
560 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
563 set_parameter_value (&block, ioparm_recl_in, p->recl);
566 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
570 set_string (&block, &post_block, ioparm_position,
571 ioparm_position_len, p->position);
574 set_string (&block, &post_block, ioparm_action,
575 ioparm_action_len, p->action);
578 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
582 set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
585 set_parameter_ref (&block, ioparm_iostat, p->iostat);
588 set_flag (&block, ioparm_err);
590 tmp = gfc_build_function_call (iocall_open, NULL_TREE);
591 gfc_add_expr_to_block (&block, tmp);
593 gfc_add_block_to_block (&block, &post_block);
595 io_result (&block, p->err, NULL, NULL);
597 return gfc_finish_block (&block);
601 /* Translate a CLOSE statement. */
604 gfc_trans_close (gfc_code * code)
606 stmtblock_t block, post_block;
610 gfc_init_block (&block);
611 gfc_init_block (&post_block);
613 set_error_locus (&block, &code->loc);
617 set_parameter_value (&block, ioparm_unit, p->unit);
620 set_string (&block, &post_block, ioparm_status,
621 ioparm_status_len, p->status);
624 set_parameter_ref (&block, ioparm_iostat, p->iostat);
627 set_flag (&block, ioparm_err);
629 tmp = gfc_build_function_call (iocall_close, NULL_TREE);
630 gfc_add_expr_to_block (&block, tmp);
632 gfc_add_block_to_block (&block, &post_block);
634 io_result (&block, p->err, NULL, NULL);
636 return gfc_finish_block (&block);
640 /* Common subroutine for building a file positioning statement. */
643 build_filepos (tree function, gfc_code * code)
649 p = code->ext.filepos;
651 gfc_init_block (&block);
653 set_error_locus (&block, &code->loc);
656 set_parameter_value (&block, ioparm_unit, p->unit);
659 set_parameter_ref (&block, ioparm_iostat, p->iostat);
662 set_flag (&block, ioparm_err);
664 tmp = gfc_build_function_call (function, NULL);
665 gfc_add_expr_to_block (&block, tmp);
667 io_result (&block, p->err, NULL, NULL);
669 return gfc_finish_block (&block);
673 /* Translate a BACKSPACE statement. */
676 gfc_trans_backspace (gfc_code * code)
679 return build_filepos (iocall_backspace, code);
683 /* Translate an ENDFILE statement. */
686 gfc_trans_endfile (gfc_code * code)
689 return build_filepos (iocall_endfile, code);
693 /* Translate a REWIND statement. */
696 gfc_trans_rewind (gfc_code * code)
699 return build_filepos (iocall_rewind, code);
703 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
706 gfc_trans_inquire (gfc_code * code)
708 stmtblock_t block, post_block;
712 gfc_init_block (&block);
713 gfc_init_block (&post_block);
715 set_error_locus (&block, &code->loc);
716 p = code->ext.inquire;
719 set_parameter_value (&block, ioparm_unit, p->unit);
722 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
725 set_parameter_ref (&block, ioparm_iostat, p->iostat);
728 set_parameter_ref (&block, ioparm_exist, p->exist);
731 set_parameter_ref (&block, ioparm_opened, p->opened);
734 set_parameter_ref (&block, ioparm_number, p->number);
737 set_parameter_ref (&block, ioparm_named, p->named);
740 set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
743 set_string (&block, &post_block, ioparm_access,
744 ioparm_access_len, p->access);
747 set_string (&block, &post_block, ioparm_sequential,
748 ioparm_sequential_len, p->sequential);
751 set_string (&block, &post_block, ioparm_direct,
752 ioparm_direct_len, p->direct);
755 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
758 set_string (&block, &post_block, ioparm_formatted,
759 ioparm_formatted_len, p->formatted);
762 set_string (&block, &post_block, ioparm_unformatted,
763 ioparm_unformatted_len, p->unformatted);
766 set_parameter_ref (&block, ioparm_recl_out, p->recl);
769 set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
772 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
776 set_string (&block, &post_block, ioparm_position,
777 ioparm_position_len, p->position);
780 set_string (&block, &post_block, ioparm_action,
781 ioparm_action_len, p->action);
784 set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
787 set_string (&block, &post_block, ioparm_write,
788 ioparm_write_len, p->write);
791 set_string (&block, &post_block, ioparm_readwrite,
792 ioparm_readwrite_len, p->readwrite);
795 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
799 set_flag (&block, ioparm_err);
801 tmp = gfc_build_function_call (iocall_inquire, NULL);
802 gfc_add_expr_to_block (&block, tmp);
804 gfc_add_block_to_block (&block, &post_block);
806 io_result (&block, p->err, NULL, NULL);
808 return gfc_finish_block (&block);
813 gfc_new_nml_name_expr (char * name)
816 nml_name = gfc_get_expr();
817 nml_name->ref = NULL;
818 nml_name->expr_type = EXPR_CONSTANT;
819 nml_name->ts.kind = gfc_default_character_kind ();
820 nml_name->ts.type = BT_CHARACTER;
821 nml_name->value.character.length = strlen(name);
822 nml_name->value.character.string = name;
828 get_new_var_expr(gfc_symbol * sym)
832 nml_var = gfc_get_expr();
833 nml_var->expr_type = EXPR_VARIABLE;
834 nml_var->ts = sym->ts;
836 nml_var->rank = sym->as->rank;
837 nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
838 nml_var->symtree->n.sym = sym;
839 nml_var->where = sym->declared_at;
840 sym->attr.referenced = 1;
846 /* Create a data transfer statement. Not all of the fields are valid
847 for both reading and writing, but improper use has been filtered
851 build_dt (tree * function, gfc_code * code)
853 stmtblock_t block, post_block;
855 tree tmp, args, arg2;
856 gfc_expr *nmlname, *nmlvar;
857 gfc_namelist *nml, *nml_tail;
859 int ts_kind, ts_type, name_len;
861 gfc_init_block (&block);
862 gfc_init_block (&post_block);
864 set_error_locus (&block, &code->loc);
871 if (dt->io_unit->ts.type == BT_CHARACTER)
873 set_string (&block, &post_block, ioparm_internal_unit,
874 ioparm_internal_unit_len, dt->io_unit);
877 set_parameter_value (&block, ioparm_unit, dt->io_unit);
881 set_parameter_value (&block, ioparm_rec, dt->rec);
884 set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
888 set_string (&block, &post_block, ioparm_format, ioparm_format_len,
891 if (dt->format_label)
893 if (dt->format_label == &format_asterisk)
894 set_flag (&block, ioparm_list_format);
896 set_string (&block, &post_block, ioparm_format,
897 ioparm_format_len, dt->format_label->format);
901 set_parameter_ref (&block, ioparm_iostat, dt->iostat);
904 set_parameter_ref (&block, ioparm_size, dt->size);
907 set_flag (&block, ioparm_err);
910 set_flag(&block, ioparm_eor);
913 set_flag(&block, ioparm_end);
917 if (dt->format_expr || dt->format_label)
918 fatal_error("A format cannot be specified with a namelist");
920 nmlname = gfc_new_nml_name_expr(dt->namelist->name);
922 set_string (&block, &post_block, ioparm_namelist_name,
923 ioparm_namelist_name_len, nmlname);
926 set_flag (&block, ioparm_namelist_read_mode);
928 nml = dt->namelist->namelist;
929 nml_tail = dt->namelist->namelist_tail;
933 gfc_init_se (&se, NULL);
934 gfc_init_se (&se2, NULL);
935 nmlvar = get_new_var_expr(nml->sym);
936 nmlname = gfc_new_nml_name_expr(nml->sym->name);
937 name_len = strlen(nml->sym->name);
938 ts_kind = nml->sym->ts.kind;
939 ts_type = nml->sym->ts.type;
941 gfc_conv_expr_reference (&se2, nmlname);
942 gfc_conv_expr_reference (&se, nmlvar);
943 args = gfc_chainon_list (NULL_TREE, se.expr);
944 args = gfc_chainon_list (args, se2.expr);
945 args = gfc_chainon_list (args, se2.string_length);
946 arg2 = build_int_2 (ts_kind, 0);
947 args = gfc_chainon_list (args,arg2);
951 tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
954 tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
957 tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
960 tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
963 tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
966 internal_error ("Bad namelist IO basetype (%d)", ts_type);
969 gfc_add_expr_to_block (&block, tmp);
975 tmp = gfc_build_function_call (*function, NULL_TREE);
976 gfc_add_expr_to_block (&block, tmp);
978 gfc_add_block_to_block (&block, &post_block);
980 return gfc_finish_block (&block);
984 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
985 this as a third sort of data transfer statement, except that
986 lengths are summed instead of actually transfering any data. */
989 gfc_trans_iolength (gfc_code * code)
995 gfc_init_block (&block);
997 set_error_locus (&block, &code->loc);
999 inq = code->ext.inquire;
1001 /* First check that preconditions are met. */
1002 assert(inq != NULL);
1003 assert(inq->iolength != NULL);
1005 /* Connect to the iolength variable. */
1007 set_parameter_ref (&block, ioparm_iolength, inq->iolength);
1011 dt = build_dt(&iocall_iolength, code);
1013 gfc_add_expr_to_block (&block, dt);
1015 return gfc_finish_block (&block);
1019 /* Translate a READ statement. */
1022 gfc_trans_read (gfc_code * code)
1026 return build_dt (&iocall_read, code);
1030 /* Translate a WRITE statement */
1033 gfc_trans_write (gfc_code * code)
1037 return build_dt (&iocall_write, code);
1041 /* Finish a data transfer statement. */
1044 gfc_trans_dt_end (gfc_code * code)
1049 gfc_init_block (&block);
1054 function = iocall_read_done;
1058 function = iocall_write_done;
1062 function = iocall_iolength_done;
1069 tmp = gfc_build_function_call (function, NULL);
1070 gfc_add_expr_to_block (&block, tmp);
1072 if (last_dt != IOLENGTH)
1074 assert(code->ext.dt != NULL);
1075 io_result (&block, code->ext.dt->err,
1076 code->ext.dt->end, code->ext.dt->eor);
1079 return gfc_finish_block (&block);
1083 /* Generate the call for a scalar transfer node. */
1086 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1088 tree args, tmp, function, arg2, field, expr;
1099 arg2 = build_int_2 (kind, 0);
1100 function = iocall_x_integer;
1104 arg2 = build_int_2 (kind, 0);
1105 function = iocall_x_real;
1109 arg2 = build_int_2 (kind, 0);
1110 function = iocall_x_complex;
1114 arg2 = build_int_2 (kind, 0);
1115 function = iocall_x_logical;
1119 arg2 = se->string_length;
1120 function = iocall_x_character;
1124 expr = gfc_evaluate_now (addr_expr, &se->pre);
1125 expr = gfc_build_indirect_ref (expr);
1127 for (c = ts->derived->components; c; c = c->next)
1129 field = c->backend_decl;
1130 assert (field && TREE_CODE (field) == FIELD_DECL);
1132 tmp = build (COMPONENT_REF, TREE_TYPE (field), expr, field,
1135 if (c->ts.type == BT_CHARACTER)
1137 assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1139 TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1141 transfer_expr (se, &c->ts, gfc_build_addr_expr (NULL, tmp));
1146 internal_error ("Bad IO basetype (%d)", ts->type);
1149 args = gfc_chainon_list (NULL_TREE, addr_expr);
1150 args = gfc_chainon_list (args, arg2);
1152 tmp = gfc_build_function_call (function, args);
1153 gfc_add_expr_to_block (&se->pre, tmp);
1154 gfc_add_block_to_block (&se->pre, &se->post);
1159 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1162 gfc_trans_transfer (gfc_code * code)
1164 stmtblock_t block, body;
1171 gfc_start_block (&block);
1174 ss = gfc_walk_expr (expr);
1176 gfc_init_se (&se, NULL);
1178 if (ss == gfc_ss_terminator)
1179 gfc_init_block (&body);
1182 /* Initialize the scalarizer. */
1183 gfc_init_loopinfo (&loop);
1184 gfc_add_ss_to_loop (&loop, ss);
1186 /* Initialize the loop. */
1187 gfc_conv_ss_startstride (&loop);
1188 gfc_conv_loop_setup (&loop);
1190 /* The main loop body. */
1191 gfc_mark_ss_chain_used (ss, 1);
1192 gfc_start_scalarized_body (&loop, &body);
1194 gfc_copy_loopinfo_to_se (&se, &loop);
1198 gfc_conv_expr_reference (&se, expr);
1200 transfer_expr (&se, &expr->ts, se.expr);
1202 gfc_add_block_to_block (&body, &se.pre);
1203 gfc_add_block_to_block (&body, &se.post);
1206 tmp = gfc_finish_block (&body);
1209 assert (se.ss == gfc_ss_terminator);
1210 gfc_trans_scalarizing_loops (&loop, &body);
1212 gfc_add_block_to_block (&loop.pre, &loop.post);
1213 tmp = gfc_finish_block (&loop.pre);
1214 gfc_cleanup_loop (&loop);
1217 gfc_add_expr_to_block (&block, tmp);
1219 return gfc_finish_block (&block);;
1222 #include "gt-fortran-trans-io.h"