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 = build3 (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 = build3 (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 = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
405 len = build3 (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 = build2 (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 = build3 (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 = build3_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 = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
502 ioparm_library_return, NULL_TREE);
504 tmp = build3_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 = build3 (COMPONENT_REF, TREE_TYPE (field),
877 expr, field, NULL_TREE);
880 gfc_todo_error ("NAMELIST IO of array in derived type");
882 tmp = gfc_build_addr_expr (NULL, tmp);
883 transfer_namelist_element (block, &c->ts, tmp, string, string_length);
885 /* The first output field bears the name of the topmost
886 derived type variable. All other fields are anonymous
887 and appear with nulls in their string and string_length
888 fields. After the first use, we set string and
889 string_length to null. */
890 string = null_pointer_node;
891 string_length = integer_zero_node;
897 args = gfc_chainon_list (NULL_TREE, addr_expr);
898 args = gfc_chainon_list (args, string);
899 args = gfc_chainon_list (args, string_length);
900 arg2 = build_int_cst (gfc_array_index_type, ts->kind);
901 args = gfc_chainon_list (args,arg2);
906 tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
910 expr = gfc_build_indirect_ref (addr_expr);
911 assert (TREE_CODE (TREE_TYPE (expr)) == ARRAY_TYPE);
912 args = gfc_chainon_list (args,
913 TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (expr))));
914 tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
918 tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
922 tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
926 tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
930 internal_error ("Bad namelist IO basetype (%d)", ts->type);
933 gfc_add_expr_to_block (block, tmp);
936 /* Create a data transfer statement. Not all of the fields are valid
937 for both reading and writing, but improper use has been filtered
941 build_dt (tree * function, gfc_code * code)
943 stmtblock_t block, post_block;
946 gfc_expr *nmlname, *nmlvar;
950 gfc_init_block (&block);
951 gfc_init_block (&post_block);
953 set_error_locus (&block, &code->loc);
960 if (dt->io_unit->ts.type == BT_CHARACTER)
962 set_string (&block, &post_block, ioparm_internal_unit,
963 ioparm_internal_unit_len, dt->io_unit);
966 set_parameter_value (&block, ioparm_unit, dt->io_unit);
970 set_parameter_value (&block, ioparm_rec, dt->rec);
973 set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
977 set_string (&block, &post_block, ioparm_format, ioparm_format_len,
980 if (dt->format_label)
982 if (dt->format_label == &format_asterisk)
983 set_flag (&block, ioparm_list_format);
985 set_string (&block, &post_block, ioparm_format,
986 ioparm_format_len, dt->format_label->format);
990 set_parameter_ref (&block, ioparm_iostat, dt->iostat);
993 set_parameter_ref (&block, ioparm_size, dt->size);
996 set_flag (&block, ioparm_err);
999 set_flag(&block, ioparm_eor);
1002 set_flag(&block, ioparm_end);
1006 if (dt->format_expr || dt->format_label)
1007 fatal_error("A format cannot be specified with a namelist");
1009 nmlname = gfc_new_nml_name_expr(dt->namelist->name);
1011 set_string (&block, &post_block, ioparm_namelist_name,
1012 ioparm_namelist_name_len, nmlname);
1014 if (last_dt == READ)
1015 set_flag (&block, ioparm_namelist_read_mode);
1017 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1019 gfc_init_se (&se, NULL);
1020 gfc_init_se (&se2, NULL);
1021 nmlvar = get_new_var_expr (nml->sym);
1022 nmlname = gfc_new_nml_name_expr (nml->sym->name);
1023 gfc_conv_expr_reference (&se2, nmlname);
1024 gfc_conv_expr_reference (&se, nmlvar);
1025 gfc_evaluate_now (se.expr, &se.pre);
1027 transfer_namelist_element (&block, &nml->sym->ts, se.expr,
1028 se2.expr, se2.string_length);
1032 tmp = gfc_build_function_call (*function, NULL_TREE);
1033 gfc_add_expr_to_block (&block, tmp);
1035 gfc_add_block_to_block (&block, &post_block);
1037 return gfc_finish_block (&block);
1041 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1042 this as a third sort of data transfer statement, except that
1043 lengths are summed instead of actually transfering any data. */
1046 gfc_trans_iolength (gfc_code * code)
1052 gfc_init_block (&block);
1054 set_error_locus (&block, &code->loc);
1056 inq = code->ext.inquire;
1058 /* First check that preconditions are met. */
1059 assert(inq != NULL);
1060 assert(inq->iolength != NULL);
1062 /* Connect to the iolength variable. */
1064 set_parameter_ref (&block, ioparm_iolength, inq->iolength);
1068 dt = build_dt(&iocall_iolength, code);
1070 gfc_add_expr_to_block (&block, dt);
1072 return gfc_finish_block (&block);
1076 /* Translate a READ statement. */
1079 gfc_trans_read (gfc_code * code)
1083 return build_dt (&iocall_read, code);
1087 /* Translate a WRITE statement */
1090 gfc_trans_write (gfc_code * code)
1094 return build_dt (&iocall_write, code);
1098 /* Finish a data transfer statement. */
1101 gfc_trans_dt_end (gfc_code * code)
1106 gfc_init_block (&block);
1111 function = iocall_read_done;
1115 function = iocall_write_done;
1119 function = iocall_iolength_done;
1126 tmp = gfc_build_function_call (function, NULL);
1127 gfc_add_expr_to_block (&block, tmp);
1129 if (last_dt != IOLENGTH)
1131 assert(code->ext.dt != NULL);
1132 io_result (&block, code->ext.dt->err,
1133 code->ext.dt->end, code->ext.dt->eor);
1136 return gfc_finish_block (&block);
1140 /* Generate the call for a scalar transfer node. */
1143 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1145 tree args, tmp, function, arg2, field, expr;
1156 arg2 = build_int_cst (NULL_TREE, kind);
1157 function = iocall_x_integer;
1161 arg2 = build_int_cst (NULL_TREE, kind);
1162 function = iocall_x_real;
1166 arg2 = build_int_cst (NULL_TREE, kind);
1167 function = iocall_x_complex;
1171 arg2 = build_int_cst (NULL_TREE, kind);
1172 function = iocall_x_logical;
1176 arg2 = se->string_length;
1177 function = iocall_x_character;
1181 expr = gfc_evaluate_now (addr_expr, &se->pre);
1182 expr = gfc_build_indirect_ref (expr);
1184 for (c = ts->derived->components; c; c = c->next)
1186 field = c->backend_decl;
1187 assert (field && TREE_CODE (field) == FIELD_DECL);
1189 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1192 if (c->ts.type == BT_CHARACTER)
1194 assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1196 TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1199 gfc_todo_error ("IO of arrays in derived types");
1201 tmp = gfc_build_addr_expr (NULL, tmp);
1202 transfer_expr (se, &c->ts, tmp);
1207 internal_error ("Bad IO basetype (%d)", ts->type);
1210 args = gfc_chainon_list (NULL_TREE, addr_expr);
1211 args = gfc_chainon_list (args, arg2);
1213 tmp = gfc_build_function_call (function, args);
1214 gfc_add_expr_to_block (&se->pre, tmp);
1215 gfc_add_block_to_block (&se->pre, &se->post);
1220 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1223 gfc_trans_transfer (gfc_code * code)
1225 stmtblock_t block, body;
1232 gfc_start_block (&block);
1235 ss = gfc_walk_expr (expr);
1237 gfc_init_se (&se, NULL);
1239 if (ss == gfc_ss_terminator)
1240 gfc_init_block (&body);
1243 /* Initialize the scalarizer. */
1244 gfc_init_loopinfo (&loop);
1245 gfc_add_ss_to_loop (&loop, ss);
1247 /* Initialize the loop. */
1248 gfc_conv_ss_startstride (&loop);
1249 gfc_conv_loop_setup (&loop);
1251 /* The main loop body. */
1252 gfc_mark_ss_chain_used (ss, 1);
1253 gfc_start_scalarized_body (&loop, &body);
1255 gfc_copy_loopinfo_to_se (&se, &loop);
1259 gfc_conv_expr_reference (&se, expr);
1261 transfer_expr (&se, &expr->ts, se.expr);
1263 gfc_add_block_to_block (&body, &se.pre);
1264 gfc_add_block_to_block (&body, &se.post);
1267 tmp = gfc_finish_block (&body);
1270 assert (se.ss == gfc_ss_terminator);
1271 gfc_trans_scalarizing_loops (&loop, &body);
1273 gfc_add_block_to_block (&loop.pre, &loop.post);
1274 tmp = gfc_finish_block (&loop.pre);
1275 gfc_cleanup_loop (&loop);
1278 gfc_add_expr_to_block (&block, tmp);
1280 return gfc_finish_block (&block);;
1283 #include "gt-fortran-trans-io.h"