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 gfc_strlen_type_node);
336 iocall_set_nml_val_complex =
337 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
339 pvoid_type_node, pvoid_type_node,
340 gfc_int4_type_node,gfc_int4_type_node);
341 iocall_set_nml_val_log =
342 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
344 pvoid_type_node, pvoid_type_node,
345 gfc_int4_type_node,gfc_int4_type_node);
350 /* Generate code to store an non-string I/O parameter into the
351 ioparm structure. This is a pass by value. */
354 set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
359 gfc_init_se (&se, NULL);
360 gfc_conv_expr_type (&se, e, TREE_TYPE (var));
361 gfc_add_block_to_block (block, &se.pre);
363 tmp = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
364 gfc_add_modify_expr (block, tmp, se.expr);
368 /* Generate code to store an non-string I/O parameter into the
369 ioparm structure. This is pass by reference. */
372 set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
377 gfc_init_se (&se, NULL);
380 gfc_conv_expr_type (&se, e, TREE_TYPE (var));
381 gfc_add_block_to_block (block, &se.pre);
383 tmp = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
384 gfc_add_modify_expr (block, tmp, se.expr);
388 /* Generate code to store a string and its length into the
392 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
393 tree var_len, gfc_expr * e)
401 gfc_init_se (&se, NULL);
402 gfc_conv_expr (&se, e);
404 io = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
405 len = build (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
408 /* Integer variable assigned a format label. */
409 if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
412 gfc_build_string_const (37, "Assigned label is not a format label");
413 tmp = GFC_DECL_STRING_LEN (se.expr);
414 tmp = build (LE_EXPR, boolean_type_node,
415 tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
416 gfc_trans_runtime_check (tmp, msg, &se.pre);
417 gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr));
418 gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
422 gfc_conv_string_parameter (&se);
423 gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
424 gfc_add_modify_expr (&se.pre, len, se.string_length);
427 gfc_add_block_to_block (block, &se.pre);
428 gfc_add_block_to_block (postblock, &se.post);
433 /* Set a member of the ioparm structure to one. */
435 set_flag (stmtblock_t *block, tree var)
437 tree tmp, type = TREE_TYPE (var);
439 tmp = build (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
440 gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
444 /* Add a case to a IO-result switch. */
447 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
452 return; /* No label, no case */
454 value = build_int_cst (NULL_TREE, label_value);
456 /* Make a backend label for this case. */
457 tmp = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
458 DECL_CONTEXT (tmp) = current_function_decl;
460 /* And the case itself. */
461 tmp = build_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
462 gfc_add_expr_to_block (body, tmp);
464 /* Jump to the label. */
465 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
466 gfc_add_expr_to_block (body, tmp);
470 /* Generate a switch statement that branches to the correct I/O
471 result label. The last statement of an I/O call stores the
472 result into a variable because there is often cleanup that
473 must be done before the switch, so a temporary would have to
474 be created anyway. */
477 io_result (stmtblock_t * block, gfc_st_label * err_label,
478 gfc_st_label * end_label, gfc_st_label * eor_label)
483 /* If no labels are specified, ignore the result instead
484 of building an empty switch. */
485 if (err_label == NULL
487 && eor_label == NULL)
490 /* Build a switch statement. */
491 gfc_start_block (&body);
493 /* The label values here must be the same as the values
494 in the library_return enum in the runtime library */
495 add_case (1, err_label, &body);
496 add_case (2, end_label, &body);
497 add_case (3, eor_label, &body);
499 tmp = gfc_finish_block (&body);
501 rc = build (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
502 ioparm_library_return, NULL_TREE);
504 tmp = build_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
506 gfc_add_expr_to_block (block, tmp);
510 /* Store the current file and line number to variables so that if a
511 library call goes awry, we can tell the user where the problem is. */
514 set_error_locus (stmtblock_t * block, locus * where)
521 tmp = gfc_build_string_const (strlen (f->filename) + 1, f->filename);
523 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
524 gfc_add_modify_expr (block, locus_file, tmp);
526 line = where->lb->linenum;
527 gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line));
531 /* Translate an OPEN statement. */
534 gfc_trans_open (gfc_code * code)
536 stmtblock_t block, post_block;
540 gfc_init_block (&block);
541 gfc_init_block (&post_block);
543 set_error_locus (&block, &code->loc);
547 set_parameter_value (&block, ioparm_unit, p->unit);
550 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
553 set_string (&block, &post_block, ioparm_status,
554 ioparm_status_len, p->status);
557 set_string (&block, &post_block, ioparm_access,
558 ioparm_access_len, p->access);
561 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
564 set_parameter_value (&block, ioparm_recl_in, p->recl);
567 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
571 set_string (&block, &post_block, ioparm_position,
572 ioparm_position_len, p->position);
575 set_string (&block, &post_block, ioparm_action,
576 ioparm_action_len, p->action);
579 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
583 set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
586 set_parameter_ref (&block, ioparm_iostat, p->iostat);
589 set_flag (&block, ioparm_err);
591 tmp = gfc_build_function_call (iocall_open, NULL_TREE);
592 gfc_add_expr_to_block (&block, tmp);
594 gfc_add_block_to_block (&block, &post_block);
596 io_result (&block, p->err, NULL, NULL);
598 return gfc_finish_block (&block);
602 /* Translate a CLOSE statement. */
605 gfc_trans_close (gfc_code * code)
607 stmtblock_t block, post_block;
611 gfc_init_block (&block);
612 gfc_init_block (&post_block);
614 set_error_locus (&block, &code->loc);
618 set_parameter_value (&block, ioparm_unit, p->unit);
621 set_string (&block, &post_block, ioparm_status,
622 ioparm_status_len, p->status);
625 set_parameter_ref (&block, ioparm_iostat, p->iostat);
628 set_flag (&block, ioparm_err);
630 tmp = gfc_build_function_call (iocall_close, NULL_TREE);
631 gfc_add_expr_to_block (&block, tmp);
633 gfc_add_block_to_block (&block, &post_block);
635 io_result (&block, p->err, NULL, NULL);
637 return gfc_finish_block (&block);
641 /* Common subroutine for building a file positioning statement. */
644 build_filepos (tree function, gfc_code * code)
650 p = code->ext.filepos;
652 gfc_init_block (&block);
654 set_error_locus (&block, &code->loc);
657 set_parameter_value (&block, ioparm_unit, p->unit);
660 set_parameter_ref (&block, ioparm_iostat, p->iostat);
663 set_flag (&block, ioparm_err);
665 tmp = gfc_build_function_call (function, NULL);
666 gfc_add_expr_to_block (&block, tmp);
668 io_result (&block, p->err, NULL, NULL);
670 return gfc_finish_block (&block);
674 /* Translate a BACKSPACE statement. */
677 gfc_trans_backspace (gfc_code * code)
680 return build_filepos (iocall_backspace, code);
684 /* Translate an ENDFILE statement. */
687 gfc_trans_endfile (gfc_code * code)
690 return build_filepos (iocall_endfile, code);
694 /* Translate a REWIND statement. */
697 gfc_trans_rewind (gfc_code * code)
700 return build_filepos (iocall_rewind, code);
704 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
707 gfc_trans_inquire (gfc_code * code)
709 stmtblock_t block, post_block;
713 gfc_init_block (&block);
714 gfc_init_block (&post_block);
716 set_error_locus (&block, &code->loc);
717 p = code->ext.inquire;
720 set_parameter_value (&block, ioparm_unit, p->unit);
723 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
726 set_parameter_ref (&block, ioparm_iostat, p->iostat);
729 set_parameter_ref (&block, ioparm_exist, p->exist);
732 set_parameter_ref (&block, ioparm_opened, p->opened);
735 set_parameter_ref (&block, ioparm_number, p->number);
738 set_parameter_ref (&block, ioparm_named, p->named);
741 set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
744 set_string (&block, &post_block, ioparm_access,
745 ioparm_access_len, p->access);
748 set_string (&block, &post_block, ioparm_sequential,
749 ioparm_sequential_len, p->sequential);
752 set_string (&block, &post_block, ioparm_direct,
753 ioparm_direct_len, p->direct);
756 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
759 set_string (&block, &post_block, ioparm_formatted,
760 ioparm_formatted_len, p->formatted);
763 set_string (&block, &post_block, ioparm_unformatted,
764 ioparm_unformatted_len, p->unformatted);
767 set_parameter_ref (&block, ioparm_recl_out, p->recl);
770 set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
773 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
777 set_string (&block, &post_block, ioparm_position,
778 ioparm_position_len, p->position);
781 set_string (&block, &post_block, ioparm_action,
782 ioparm_action_len, p->action);
785 set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
788 set_string (&block, &post_block, ioparm_write,
789 ioparm_write_len, p->write);
792 set_string (&block, &post_block, ioparm_readwrite,
793 ioparm_readwrite_len, p->readwrite);
796 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
800 set_flag (&block, ioparm_err);
802 tmp = gfc_build_function_call (iocall_inquire, NULL);
803 gfc_add_expr_to_block (&block, tmp);
805 gfc_add_block_to_block (&block, &post_block);
807 io_result (&block, p->err, NULL, NULL);
809 return gfc_finish_block (&block);
814 gfc_new_nml_name_expr (char * name)
817 nml_name = gfc_get_expr();
818 nml_name->ref = NULL;
819 nml_name->expr_type = EXPR_CONSTANT;
820 nml_name->ts.kind = gfc_default_character_kind ();
821 nml_name->ts.type = BT_CHARACTER;
822 nml_name->value.character.length = strlen(name);
823 nml_name->value.character.string = name;
829 get_new_var_expr(gfc_symbol * sym)
833 nml_var = gfc_get_expr();
834 nml_var->expr_type = EXPR_VARIABLE;
835 nml_var->ts = sym->ts;
837 nml_var->rank = sym->as->rank;
838 nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
839 nml_var->symtree->n.sym = sym;
840 nml_var->where = sym->declared_at;
841 sym->attr.referenced = 1;
846 /* For a scalar variable STRING whose address is ADDR_EXPR, generate a
847 call to iocall_set_nml_val. For derived type variable, recursively
848 generate calls to iocall_set_nml_val for each leaf field. The leafs
849 have no names -- their STRING field is null, and are interpreted by
850 the run-time library as having only the value, as in the example:
854 Note that the first output field appears after the name of the
855 variable, not of the field name. This causes a little complication
859 transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr,
860 tree string, tree string_length)
862 tree tmp, args, arg2;
865 assert (POINTER_TYPE_P (TREE_TYPE (addr_expr)));
867 if (ts->type == BT_DERIVED)
870 expr = gfc_build_indirect_ref (addr_expr);
872 for (c = ts->derived->components; c; c = c->next)
874 tree field = c->backend_decl;
875 assert (field && TREE_CODE (field) == FIELD_DECL);
876 tmp = build (COMPONENT_REF, TREE_TYPE (field), expr, field, NULL_TREE);
879 gfc_todo_error ("NAMELIST IO of array in derived type");
881 tmp = gfc_build_addr_expr (NULL, tmp);
882 transfer_namelist_element (block, &c->ts, tmp, string, string_length);
884 /* The first output field bears the name of the topmost
885 derived type variable. All other fields are anonymous
886 and appear with nulls in their string and string_length
887 fields. After the first use, we set string and
888 string_length to null. */
889 string = null_pointer_node;
890 string_length = integer_zero_node;
896 args = gfc_chainon_list (NULL_TREE, addr_expr);
897 args = gfc_chainon_list (args, string);
898 args = gfc_chainon_list (args, string_length);
899 arg2 = build_int_cst (gfc_array_index_type, ts->kind);
900 args = gfc_chainon_list (args,arg2);
905 tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
909 expr = gfc_build_indirect_ref (addr_expr);
910 assert (TREE_CODE (TREE_TYPE (expr)) == ARRAY_TYPE);
911 args = gfc_chainon_list (args,
912 TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (expr))));
913 tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
917 tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
921 tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
925 tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
929 internal_error ("Bad namelist IO basetype (%d)", ts->type);
932 gfc_add_expr_to_block (block, tmp);
935 /* Create a data transfer statement. Not all of the fields are valid
936 for both reading and writing, but improper use has been filtered
940 build_dt (tree * function, gfc_code * code)
942 stmtblock_t block, post_block;
945 gfc_expr *nmlname, *nmlvar;
949 gfc_init_block (&block);
950 gfc_init_block (&post_block);
952 set_error_locus (&block, &code->loc);
959 if (dt->io_unit->ts.type == BT_CHARACTER)
961 set_string (&block, &post_block, ioparm_internal_unit,
962 ioparm_internal_unit_len, dt->io_unit);
965 set_parameter_value (&block, ioparm_unit, dt->io_unit);
969 set_parameter_value (&block, ioparm_rec, dt->rec);
972 set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
976 set_string (&block, &post_block, ioparm_format, ioparm_format_len,
979 if (dt->format_label)
981 if (dt->format_label == &format_asterisk)
982 set_flag (&block, ioparm_list_format);
984 set_string (&block, &post_block, ioparm_format,
985 ioparm_format_len, dt->format_label->format);
989 set_parameter_ref (&block, ioparm_iostat, dt->iostat);
992 set_parameter_ref (&block, ioparm_size, dt->size);
995 set_flag (&block, ioparm_err);
998 set_flag(&block, ioparm_eor);
1001 set_flag(&block, ioparm_end);
1005 if (dt->format_expr || dt->format_label)
1006 fatal_error("A format cannot be specified with a namelist");
1008 nmlname = gfc_new_nml_name_expr(dt->namelist->name);
1010 set_string (&block, &post_block, ioparm_namelist_name,
1011 ioparm_namelist_name_len, nmlname);
1013 if (last_dt == READ)
1014 set_flag (&block, ioparm_namelist_read_mode);
1016 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1018 gfc_init_se (&se, NULL);
1019 gfc_init_se (&se2, NULL);
1020 nmlvar = get_new_var_expr (nml->sym);
1021 nmlname = gfc_new_nml_name_expr (nml->sym->name);
1022 gfc_conv_expr_reference (&se2, nmlname);
1023 gfc_conv_expr_reference (&se, nmlvar);
1024 gfc_evaluate_now (se.expr, &se.pre);
1026 transfer_namelist_element (&block, &nml->sym->ts, se.expr,
1027 se2.expr, se2.string_length);
1031 tmp = gfc_build_function_call (*function, NULL_TREE);
1032 gfc_add_expr_to_block (&block, tmp);
1034 gfc_add_block_to_block (&block, &post_block);
1036 return gfc_finish_block (&block);
1040 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1041 this as a third sort of data transfer statement, except that
1042 lengths are summed instead of actually transfering any data. */
1045 gfc_trans_iolength (gfc_code * code)
1051 gfc_init_block (&block);
1053 set_error_locus (&block, &code->loc);
1055 inq = code->ext.inquire;
1057 /* First check that preconditions are met. */
1058 assert(inq != NULL);
1059 assert(inq->iolength != NULL);
1061 /* Connect to the iolength variable. */
1063 set_parameter_ref (&block, ioparm_iolength, inq->iolength);
1067 dt = build_dt(&iocall_iolength, code);
1069 gfc_add_expr_to_block (&block, dt);
1071 return gfc_finish_block (&block);
1075 /* Translate a READ statement. */
1078 gfc_trans_read (gfc_code * code)
1082 return build_dt (&iocall_read, code);
1086 /* Translate a WRITE statement */
1089 gfc_trans_write (gfc_code * code)
1093 return build_dt (&iocall_write, code);
1097 /* Finish a data transfer statement. */
1100 gfc_trans_dt_end (gfc_code * code)
1105 gfc_init_block (&block);
1110 function = iocall_read_done;
1114 function = iocall_write_done;
1118 function = iocall_iolength_done;
1125 tmp = gfc_build_function_call (function, NULL);
1126 gfc_add_expr_to_block (&block, tmp);
1128 if (last_dt != IOLENGTH)
1130 assert(code->ext.dt != NULL);
1131 io_result (&block, code->ext.dt->err,
1132 code->ext.dt->end, code->ext.dt->eor);
1135 return gfc_finish_block (&block);
1139 /* Generate the call for a scalar transfer node. */
1142 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1144 tree args, tmp, function, arg2, field, expr;
1155 arg2 = build_int_cst (NULL_TREE, kind);
1156 function = iocall_x_integer;
1160 arg2 = build_int_cst (NULL_TREE, kind);
1161 function = iocall_x_real;
1165 arg2 = build_int_cst (NULL_TREE, kind);
1166 function = iocall_x_complex;
1170 arg2 = build_int_cst (NULL_TREE, kind);
1171 function = iocall_x_logical;
1175 arg2 = se->string_length;
1176 function = iocall_x_character;
1180 expr = gfc_evaluate_now (addr_expr, &se->pre);
1181 expr = gfc_build_indirect_ref (expr);
1183 for (c = ts->derived->components; c; c = c->next)
1185 field = c->backend_decl;
1186 assert (field && TREE_CODE (field) == FIELD_DECL);
1188 tmp = build (COMPONENT_REF, TREE_TYPE (field), expr, field,
1191 if (c->ts.type == BT_CHARACTER)
1193 assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1195 TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1198 gfc_todo_error ("IO of arrays in derived types");
1200 tmp = gfc_build_addr_expr (NULL, tmp);
1201 transfer_expr (se, &c->ts, tmp);
1206 internal_error ("Bad IO basetype (%d)", ts->type);
1209 args = gfc_chainon_list (NULL_TREE, addr_expr);
1210 args = gfc_chainon_list (args, arg2);
1212 tmp = gfc_build_function_call (function, args);
1213 gfc_add_expr_to_block (&se->pre, tmp);
1214 gfc_add_block_to_block (&se->pre, &se->post);
1219 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1222 gfc_trans_transfer (gfc_code * code)
1224 stmtblock_t block, body;
1231 gfc_start_block (&block);
1234 ss = gfc_walk_expr (expr);
1236 gfc_init_se (&se, NULL);
1238 if (ss == gfc_ss_terminator)
1239 gfc_init_block (&body);
1242 /* Initialize the scalarizer. */
1243 gfc_init_loopinfo (&loop);
1244 gfc_add_ss_to_loop (&loop, ss);
1246 /* Initialize the loop. */
1247 gfc_conv_ss_startstride (&loop);
1248 gfc_conv_loop_setup (&loop);
1250 /* The main loop body. */
1251 gfc_mark_ss_chain_used (ss, 1);
1252 gfc_start_scalarized_body (&loop, &body);
1254 gfc_copy_loopinfo_to_se (&se, &loop);
1258 gfc_conv_expr_reference (&se, expr);
1260 transfer_expr (&se, &expr->ts, se.expr);
1262 gfc_add_block_to_block (&body, &se.pre);
1263 gfc_add_block_to_block (&body, &se.post);
1266 tmp = gfc_finish_block (&body);
1269 assert (se.ss == gfc_ss_terminator);
1270 gfc_trans_scalarizing_loops (&loop, &body);
1272 gfc_add_block_to_block (&loop.pre, &loop.post);
1273 tmp = gfc_finish_block (&loop.pre);
1274 gfc_cleanup_loop (&loop);
1277 gfc_add_expr_to_block (&block, tmp);
1279 return gfc_finish_block (&block);;
1282 #include "gt-fortran-trans-io.h"