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"
33 #include "trans-stmt.h"
34 #include "trans-array.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
39 /* Members of the ioparm structure. */
41 static GTY(()) tree ioparm_unit;
42 static GTY(()) tree ioparm_err;
43 static GTY(()) tree ioparm_end;
44 static GTY(()) tree ioparm_eor;
45 static GTY(()) tree ioparm_list_format;
46 static GTY(()) tree ioparm_library_return;
47 static GTY(()) tree ioparm_iostat;
48 static GTY(()) tree ioparm_exist;
49 static GTY(()) tree ioparm_opened;
50 static GTY(()) tree ioparm_number;
51 static GTY(()) tree ioparm_named;
52 static GTY(()) tree ioparm_rec;
53 static GTY(()) tree ioparm_nextrec;
54 static GTY(()) tree ioparm_size;
55 static GTY(()) tree ioparm_recl_in;
56 static GTY(()) tree ioparm_recl_out;
57 static GTY(()) tree ioparm_iolength;
58 static GTY(()) tree ioparm_file;
59 static GTY(()) tree ioparm_file_len;
60 static GTY(()) tree ioparm_status;
61 static GTY(()) tree ioparm_status_len;
62 static GTY(()) tree ioparm_access;
63 static GTY(()) tree ioparm_access_len;
64 static GTY(()) tree ioparm_form;
65 static GTY(()) tree ioparm_form_len;
66 static GTY(()) tree ioparm_blank;
67 static GTY(()) tree ioparm_blank_len;
68 static GTY(()) tree ioparm_position;
69 static GTY(()) tree ioparm_position_len;
70 static GTY(()) tree ioparm_action;
71 static GTY(()) tree ioparm_action_len;
72 static GTY(()) tree ioparm_delim;
73 static GTY(()) tree ioparm_delim_len;
74 static GTY(()) tree ioparm_pad;
75 static GTY(()) tree ioparm_pad_len;
76 static GTY(()) tree ioparm_format;
77 static GTY(()) tree ioparm_format_len;
78 static GTY(()) tree ioparm_advance;
79 static GTY(()) tree ioparm_advance_len;
80 static GTY(()) tree ioparm_name;
81 static GTY(()) tree ioparm_name_len;
82 static GTY(()) tree ioparm_internal_unit;
83 static GTY(()) tree ioparm_internal_unit_len;
84 static GTY(()) tree ioparm_sequential;
85 static GTY(()) tree ioparm_sequential_len;
86 static GTY(()) tree ioparm_direct;
87 static GTY(()) tree ioparm_direct_len;
88 static GTY(()) tree ioparm_formatted;
89 static GTY(()) tree ioparm_formatted_len;
90 static GTY(()) tree ioparm_unformatted;
91 static GTY(()) tree ioparm_unformatted_len;
92 static GTY(()) tree ioparm_read;
93 static GTY(()) tree ioparm_read_len;
94 static GTY(()) tree ioparm_write;
95 static GTY(()) tree ioparm_write_len;
96 static GTY(()) tree ioparm_readwrite;
97 static GTY(()) tree ioparm_readwrite_len;
98 static GTY(()) tree ioparm_namelist_name;
99 static GTY(()) tree ioparm_namelist_name_len;
100 static GTY(()) tree ioparm_namelist_read_mode;
102 /* The global I/O variables */
104 static GTY(()) tree ioparm_var;
105 static GTY(()) tree locus_file;
106 static GTY(()) tree locus_line;
109 /* Library I/O subroutines */
111 static GTY(()) tree iocall_read;
112 static GTY(()) tree iocall_read_done;
113 static GTY(()) tree iocall_write;
114 static GTY(()) tree iocall_write_done;
115 static GTY(()) tree iocall_x_integer;
116 static GTY(()) tree iocall_x_logical;
117 static GTY(()) tree iocall_x_character;
118 static GTY(()) tree iocall_x_real;
119 static GTY(()) tree iocall_x_complex;
120 static GTY(()) tree iocall_open;
121 static GTY(()) tree iocall_close;
122 static GTY(()) tree iocall_inquire;
123 static GTY(()) tree iocall_iolength;
124 static GTY(()) tree iocall_iolength_done;
125 static GTY(()) tree iocall_rewind;
126 static GTY(()) tree iocall_backspace;
127 static GTY(()) tree iocall_endfile;
128 static GTY(()) tree iocall_set_nml_val_int;
129 static GTY(()) tree iocall_set_nml_val_float;
130 static GTY(()) tree iocall_set_nml_val_char;
131 static GTY(()) tree iocall_set_nml_val_complex;
132 static GTY(()) tree iocall_set_nml_val_log;
134 /* Variable for keeping track of what the last data transfer statement
135 was. Used for deciding which subroutine to call when the data
136 transfer is complete. */
137 static enum { READ, WRITE, IOLENGTH } last_dt;
139 #define ADD_FIELD(name, type) \
140 ioparm_ ## name = gfc_add_field_to_struct \
141 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
142 get_identifier (stringize(name)), type)
144 #define ADD_STRING(name) \
145 ioparm_ ## name = gfc_add_field_to_struct \
146 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
147 get_identifier (stringize(name)), pchar_type_node); \
148 ioparm_ ## name ## _len = gfc_add_field_to_struct \
149 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
150 get_identifier (stringize(name) "_len"), gfc_int4_type_node)
153 /* Create function decls for IO library functions. */
156 gfc_build_io_library_fndecls (void)
158 tree gfc_int4_type_node;
159 tree gfc_pint4_type_node;
162 gfc_int4_type_node = gfc_get_int_type (4);
163 gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
165 /* Build the st_parameter structure. Information associated with I/O
166 calls are transferred here. This must match the one defined in the
169 ioparm_type = make_node (RECORD_TYPE);
170 TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm");
172 ADD_FIELD (unit, gfc_int4_type_node);
173 ADD_FIELD (err, gfc_int4_type_node);
174 ADD_FIELD (end, gfc_int4_type_node);
175 ADD_FIELD (eor, gfc_int4_type_node);
176 ADD_FIELD (list_format, gfc_int4_type_node);
177 ADD_FIELD (library_return, gfc_int4_type_node);
179 ADD_FIELD (iostat, gfc_pint4_type_node);
180 ADD_FIELD (exist, gfc_pint4_type_node);
181 ADD_FIELD (opened, gfc_pint4_type_node);
182 ADD_FIELD (number, gfc_pint4_type_node);
183 ADD_FIELD (named, gfc_pint4_type_node);
184 ADD_FIELD (rec, gfc_pint4_type_node);
185 ADD_FIELD (nextrec, gfc_pint4_type_node);
186 ADD_FIELD (size, gfc_pint4_type_node);
188 ADD_FIELD (recl_in, gfc_pint4_type_node);
189 ADD_FIELD (recl_out, gfc_pint4_type_node);
191 ADD_FIELD (iolength, gfc_pint4_type_node);
199 ADD_STRING (position);
204 ADD_STRING (advance);
206 ADD_STRING (internal_unit);
207 ADD_STRING (sequential);
210 ADD_STRING (formatted);
211 ADD_STRING (unformatted);
214 ADD_STRING (readwrite);
216 ADD_STRING (namelist_name);
217 ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
219 gfc_finish_type (ioparm_type);
221 ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
223 DECL_EXTERNAL (ioparm_var) = 1;
224 TREE_PUBLIC (ioparm_var) = 1;
226 locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
228 DECL_EXTERNAL (locus_line) = 1;
229 TREE_PUBLIC (locus_line) = 1;
231 locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
233 DECL_EXTERNAL (locus_file) = 1;
234 TREE_PUBLIC (locus_file) = 1;
236 /* Define the transfer functions. */
239 gfc_build_library_function_decl (get_identifier
240 (PREFIX("transfer_integer")),
241 void_type_node, 2, pvoid_type_node,
245 gfc_build_library_function_decl (get_identifier
246 (PREFIX("transfer_logical")),
247 void_type_node, 2, pvoid_type_node,
251 gfc_build_library_function_decl (get_identifier
252 (PREFIX("transfer_character")),
253 void_type_node, 2, pvoid_type_node,
257 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
259 pvoid_type_node, gfc_int4_type_node);
262 gfc_build_library_function_decl (get_identifier
263 (PREFIX("transfer_complex")),
264 void_type_node, 2, pvoid_type_node,
267 /* Library entry points */
270 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
274 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
277 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
281 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
285 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
286 gfc_int4_type_node, 0);
289 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
293 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
294 gfc_int4_type_node, 0);
297 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
298 gfc_int4_type_node, 0);
301 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
302 gfc_int4_type_node, 0);
303 /* Library helpers */
306 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
307 gfc_int4_type_node, 0);
310 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
311 gfc_int4_type_node, 0);
313 iocall_iolength_done =
314 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
315 gfc_int4_type_node, 0);
317 iocall_set_nml_val_int =
318 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
320 pvoid_type_node, pvoid_type_node,
321 gfc_int4_type_node,gfc_int4_type_node);
323 iocall_set_nml_val_float =
324 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
326 pvoid_type_node, pvoid_type_node,
327 gfc_int4_type_node,gfc_int4_type_node);
328 iocall_set_nml_val_char =
329 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")),
331 pvoid_type_node, pvoid_type_node,
332 gfc_int4_type_node, gfc_int4_type_node,
333 gfc_charlen_type_node);
334 iocall_set_nml_val_complex =
335 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
337 pvoid_type_node, pvoid_type_node,
338 gfc_int4_type_node,gfc_int4_type_node);
339 iocall_set_nml_val_log =
340 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
342 pvoid_type_node, pvoid_type_node,
343 gfc_int4_type_node,gfc_int4_type_node);
348 /* Generate code to store an non-string I/O parameter into the
349 ioparm structure. This is a pass by value. */
352 set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
357 gfc_init_se (&se, NULL);
358 gfc_conv_expr_type (&se, e, TREE_TYPE (var));
359 gfc_add_block_to_block (block, &se.pre);
361 tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
362 gfc_add_modify_expr (block, tmp, se.expr);
366 /* Generate code to store an non-string I/O parameter into the
367 ioparm structure. This is pass by reference. */
370 set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
375 gfc_init_se (&se, NULL);
378 gfc_conv_expr_type (&se, e, TREE_TYPE (var));
379 gfc_add_block_to_block (block, &se.pre);
381 tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
382 gfc_add_modify_expr (block, tmp, se.expr);
386 /* Generate code to store a string and its length into the
390 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
391 tree var_len, gfc_expr * e)
399 gfc_init_se (&se, NULL);
400 gfc_conv_expr (&se, e);
402 io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
403 len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
406 /* Integer variable assigned a format label. */
407 if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
410 gfc_build_cstring_const ("Assigned label is not a format label");
411 tmp = GFC_DECL_STRING_LEN (se.expr);
412 tmp = build2 (LE_EXPR, boolean_type_node,
413 tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
414 gfc_trans_runtime_check (tmp, msg, &se.pre);
415 gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr));
416 gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
420 gfc_conv_string_parameter (&se);
421 gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
422 gfc_add_modify_expr (&se.pre, len, se.string_length);
425 gfc_add_block_to_block (block, &se.pre);
426 gfc_add_block_to_block (postblock, &se.post);
431 /* Set a member of the ioparm structure to one. */
433 set_flag (stmtblock_t *block, tree var)
435 tree tmp, type = TREE_TYPE (var);
437 tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
438 gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
442 /* Add a case to a IO-result switch. */
445 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
450 return; /* No label, no case */
452 value = build_int_cst (NULL_TREE, label_value);
454 /* Make a backend label for this case. */
455 tmp = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
456 DECL_CONTEXT (tmp) = current_function_decl;
458 /* And the case itself. */
459 tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
460 gfc_add_expr_to_block (body, tmp);
462 /* Jump to the label. */
463 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
464 gfc_add_expr_to_block (body, tmp);
468 /* Generate a switch statement that branches to the correct I/O
469 result label. The last statement of an I/O call stores the
470 result into a variable because there is often cleanup that
471 must be done before the switch, so a temporary would have to
472 be created anyway. */
475 io_result (stmtblock_t * block, gfc_st_label * err_label,
476 gfc_st_label * end_label, gfc_st_label * eor_label)
481 /* If no labels are specified, ignore the result instead
482 of building an empty switch. */
483 if (err_label == NULL
485 && eor_label == NULL)
488 /* Build a switch statement. */
489 gfc_start_block (&body);
491 /* The label values here must be the same as the values
492 in the library_return enum in the runtime library */
493 add_case (1, err_label, &body);
494 add_case (2, end_label, &body);
495 add_case (3, eor_label, &body);
497 tmp = gfc_finish_block (&body);
499 rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
500 ioparm_library_return, NULL_TREE);
502 tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
504 gfc_add_expr_to_block (block, tmp);
508 /* Store the current file and line number to variables so that if a
509 library call goes awry, we can tell the user where the problem is. */
512 set_error_locus (stmtblock_t * block, locus * where)
519 tmp = gfc_build_cstring_const (f->filename);
521 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
522 gfc_add_modify_expr (block, locus_file, tmp);
524 #ifdef USE_MAPPED_LOCATION
525 line = LOCATION_LINE (where->lb->location);
527 line = where->lb->linenum;
529 gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line));
533 /* Translate an OPEN statement. */
536 gfc_trans_open (gfc_code * code)
538 stmtblock_t block, post_block;
542 gfc_init_block (&block);
543 gfc_init_block (&post_block);
545 set_error_locus (&block, &code->loc);
549 set_parameter_value (&block, ioparm_unit, p->unit);
552 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
555 set_string (&block, &post_block, ioparm_status,
556 ioparm_status_len, p->status);
559 set_string (&block, &post_block, ioparm_access,
560 ioparm_access_len, p->access);
563 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
566 set_parameter_value (&block, ioparm_recl_in, p->recl);
569 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
573 set_string (&block, &post_block, ioparm_position,
574 ioparm_position_len, p->position);
577 set_string (&block, &post_block, ioparm_action,
578 ioparm_action_len, p->action);
581 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
585 set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
588 set_parameter_ref (&block, ioparm_iostat, p->iostat);
591 set_flag (&block, ioparm_err);
593 tmp = gfc_build_function_call (iocall_open, NULL_TREE);
594 gfc_add_expr_to_block (&block, tmp);
596 gfc_add_block_to_block (&block, &post_block);
598 io_result (&block, p->err, NULL, NULL);
600 return gfc_finish_block (&block);
604 /* Translate a CLOSE statement. */
607 gfc_trans_close (gfc_code * code)
609 stmtblock_t block, post_block;
613 gfc_init_block (&block);
614 gfc_init_block (&post_block);
616 set_error_locus (&block, &code->loc);
620 set_parameter_value (&block, ioparm_unit, p->unit);
623 set_string (&block, &post_block, ioparm_status,
624 ioparm_status_len, p->status);
627 set_parameter_ref (&block, ioparm_iostat, p->iostat);
630 set_flag (&block, ioparm_err);
632 tmp = gfc_build_function_call (iocall_close, NULL_TREE);
633 gfc_add_expr_to_block (&block, tmp);
635 gfc_add_block_to_block (&block, &post_block);
637 io_result (&block, p->err, NULL, NULL);
639 return gfc_finish_block (&block);
643 /* Common subroutine for building a file positioning statement. */
646 build_filepos (tree function, gfc_code * code)
652 p = code->ext.filepos;
654 gfc_init_block (&block);
656 set_error_locus (&block, &code->loc);
659 set_parameter_value (&block, ioparm_unit, p->unit);
662 set_parameter_ref (&block, ioparm_iostat, p->iostat);
665 set_flag (&block, ioparm_err);
667 tmp = gfc_build_function_call (function, NULL);
668 gfc_add_expr_to_block (&block, tmp);
670 io_result (&block, p->err, NULL, NULL);
672 return gfc_finish_block (&block);
676 /* Translate a BACKSPACE statement. */
679 gfc_trans_backspace (gfc_code * code)
682 return build_filepos (iocall_backspace, code);
686 /* Translate an ENDFILE statement. */
689 gfc_trans_endfile (gfc_code * code)
692 return build_filepos (iocall_endfile, code);
696 /* Translate a REWIND statement. */
699 gfc_trans_rewind (gfc_code * code)
702 return build_filepos (iocall_rewind, code);
706 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
709 gfc_trans_inquire (gfc_code * code)
711 stmtblock_t block, post_block;
715 gfc_init_block (&block);
716 gfc_init_block (&post_block);
718 set_error_locus (&block, &code->loc);
719 p = code->ext.inquire;
722 set_parameter_value (&block, ioparm_unit, p->unit);
725 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
728 set_parameter_ref (&block, ioparm_iostat, p->iostat);
731 set_parameter_ref (&block, ioparm_exist, p->exist);
734 set_parameter_ref (&block, ioparm_opened, p->opened);
737 set_parameter_ref (&block, ioparm_number, p->number);
740 set_parameter_ref (&block, ioparm_named, p->named);
743 set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
746 set_string (&block, &post_block, ioparm_access,
747 ioparm_access_len, p->access);
750 set_string (&block, &post_block, ioparm_sequential,
751 ioparm_sequential_len, p->sequential);
754 set_string (&block, &post_block, ioparm_direct,
755 ioparm_direct_len, p->direct);
758 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
761 set_string (&block, &post_block, ioparm_formatted,
762 ioparm_formatted_len, p->formatted);
765 set_string (&block, &post_block, ioparm_unformatted,
766 ioparm_unformatted_len, p->unformatted);
769 set_parameter_ref (&block, ioparm_recl_out, p->recl);
772 set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
775 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
779 set_string (&block, &post_block, ioparm_position,
780 ioparm_position_len, p->position);
783 set_string (&block, &post_block, ioparm_action,
784 ioparm_action_len, p->action);
787 set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
790 set_string (&block, &post_block, ioparm_write,
791 ioparm_write_len, p->write);
794 set_string (&block, &post_block, ioparm_readwrite,
795 ioparm_readwrite_len, p->readwrite);
798 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
802 set_flag (&block, ioparm_err);
804 tmp = gfc_build_function_call (iocall_inquire, NULL);
805 gfc_add_expr_to_block (&block, tmp);
807 gfc_add_block_to_block (&block, &post_block);
809 io_result (&block, p->err, NULL, NULL);
811 return gfc_finish_block (&block);
816 gfc_new_nml_name_expr (char * name)
819 nml_name = gfc_get_expr();
820 nml_name->ref = NULL;
821 nml_name->expr_type = EXPR_CONSTANT;
822 nml_name->ts.kind = gfc_default_character_kind;
823 nml_name->ts.type = BT_CHARACTER;
824 nml_name->value.character.length = strlen(name);
825 nml_name->value.character.string = name;
831 get_new_var_expr(gfc_symbol * sym)
835 nml_var = gfc_get_expr();
836 nml_var->expr_type = EXPR_VARIABLE;
837 nml_var->ts = sym->ts;
839 nml_var->rank = sym->as->rank;
840 nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
841 nml_var->symtree->n.sym = sym;
842 nml_var->where = sym->declared_at;
843 sym->attr.referenced = 1;
848 /* For a scalar variable STRING whose address is ADDR_EXPR, generate a
849 call to iocall_set_nml_val. For derived type variable, recursively
850 generate calls to iocall_set_nml_val for each leaf field. The leafs
851 have no names -- their STRING field is null, and are interpreted by
852 the run-time library as having only the value, as in the example:
856 Note that the first output field appears after the name of the
857 variable, not of the field name. This causes a little complication
861 transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr,
862 tree string, tree string_length)
864 tree tmp, args, arg2;
867 gcc_assert (POINTER_TYPE_P (TREE_TYPE (addr_expr)));
869 if (ts->type == BT_DERIVED)
872 expr = gfc_build_indirect_ref (addr_expr);
874 for (c = ts->derived->components; c; c = c->next)
876 tree field = c->backend_decl;
877 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
878 tmp = build3 (COMPONENT_REF, TREE_TYPE (field),
879 expr, field, NULL_TREE);
882 gfc_todo_error ("NAMELIST IO of array in derived type");
884 tmp = gfc_build_addr_expr (NULL, tmp);
885 transfer_namelist_element (block, &c->ts, tmp, string, string_length);
887 /* The first output field bears the name of the topmost
888 derived type variable. All other fields are anonymous
889 and appear with nulls in their string and string_length
890 fields. After the first use, we set string and
891 string_length to null. */
892 string = null_pointer_node;
893 string_length = integer_zero_node;
899 args = gfc_chainon_list (NULL_TREE, addr_expr);
900 args = gfc_chainon_list (args, string);
901 args = gfc_chainon_list (args, string_length);
902 arg2 = build_int_cst (gfc_array_index_type, ts->kind);
903 args = gfc_chainon_list (args,arg2);
908 tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
912 expr = gfc_build_indirect_ref (addr_expr);
913 gcc_assert (TREE_CODE (TREE_TYPE (expr)) == ARRAY_TYPE);
914 args = gfc_chainon_list (args,
915 TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (expr))));
916 tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
920 tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
924 tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
928 tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
932 internal_error ("Bad namelist IO basetype (%d)", ts->type);
935 gfc_add_expr_to_block (block, tmp);
938 /* Create a data transfer statement. Not all of the fields are valid
939 for both reading and writing, but improper use has been filtered
943 build_dt (tree * function, gfc_code * code)
945 stmtblock_t block, post_block;
948 gfc_expr *nmlname, *nmlvar;
952 gfc_init_block (&block);
953 gfc_init_block (&post_block);
955 set_error_locus (&block, &code->loc);
958 gcc_assert (dt != NULL);
962 if (dt->io_unit->ts.type == BT_CHARACTER)
964 set_string (&block, &post_block, ioparm_internal_unit,
965 ioparm_internal_unit_len, dt->io_unit);
968 set_parameter_value (&block, ioparm_unit, dt->io_unit);
972 set_parameter_value (&block, ioparm_rec, dt->rec);
975 set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
979 set_string (&block, &post_block, ioparm_format, ioparm_format_len,
982 if (dt->format_label)
984 if (dt->format_label == &format_asterisk)
985 set_flag (&block, ioparm_list_format);
987 set_string (&block, &post_block, ioparm_format,
988 ioparm_format_len, dt->format_label->format);
992 set_parameter_ref (&block, ioparm_iostat, dt->iostat);
995 set_parameter_ref (&block, ioparm_size, dt->size);
998 set_flag (&block, ioparm_err);
1001 set_flag(&block, ioparm_eor);
1004 set_flag(&block, ioparm_end);
1008 if (dt->format_expr || dt->format_label)
1009 fatal_error("A format cannot be specified with a namelist");
1011 nmlname = gfc_new_nml_name_expr(dt->namelist->name);
1013 set_string (&block, &post_block, ioparm_namelist_name,
1014 ioparm_namelist_name_len, nmlname);
1016 if (last_dt == READ)
1017 set_flag (&block, ioparm_namelist_read_mode);
1019 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1021 gfc_init_se (&se, NULL);
1022 gfc_init_se (&se2, NULL);
1023 nmlvar = get_new_var_expr (nml->sym);
1024 nmlname = gfc_new_nml_name_expr (nml->sym->name);
1025 gfc_conv_expr_reference (&se2, nmlname);
1026 gfc_conv_expr_reference (&se, nmlvar);
1027 gfc_evaluate_now (se.expr, &se.pre);
1029 transfer_namelist_element (&block, &nml->sym->ts, se.expr,
1030 se2.expr, se2.string_length);
1034 tmp = gfc_build_function_call (*function, NULL_TREE);
1035 gfc_add_expr_to_block (&block, tmp);
1037 gfc_add_block_to_block (&block, &post_block);
1039 return gfc_finish_block (&block);
1043 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1044 this as a third sort of data transfer statement, except that
1045 lengths are summed instead of actually transfering any data. */
1048 gfc_trans_iolength (gfc_code * code)
1054 gfc_init_block (&block);
1056 set_error_locus (&block, &code->loc);
1058 inq = code->ext.inquire;
1060 /* First check that preconditions are met. */
1061 gcc_assert (inq != NULL);
1062 gcc_assert (inq->iolength != NULL);
1064 /* Connect to the iolength variable. */
1066 set_parameter_ref (&block, ioparm_iolength, inq->iolength);
1070 dt = build_dt(&iocall_iolength, code);
1072 gfc_add_expr_to_block (&block, dt);
1074 return gfc_finish_block (&block);
1078 /* Translate a READ statement. */
1081 gfc_trans_read (gfc_code * code)
1085 return build_dt (&iocall_read, code);
1089 /* Translate a WRITE statement */
1092 gfc_trans_write (gfc_code * code)
1096 return build_dt (&iocall_write, code);
1100 /* Finish a data transfer statement. */
1103 gfc_trans_dt_end (gfc_code * code)
1108 gfc_init_block (&block);
1113 function = iocall_read_done;
1117 function = iocall_write_done;
1121 function = iocall_iolength_done;
1128 tmp = gfc_build_function_call (function, NULL);
1129 gfc_add_expr_to_block (&block, tmp);
1131 if (last_dt != IOLENGTH)
1133 gcc_assert (code->ext.dt != NULL);
1134 io_result (&block, code->ext.dt->err,
1135 code->ext.dt->end, code->ext.dt->eor);
1138 return gfc_finish_block (&block);
1142 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
1144 /* Given an array field in a derived type variable, generate the code
1145 for the loop that iterates over array elements, and the code that
1146 accesses those array elements. Use transfer_expr to generate code
1147 for transferring that element. Because elements may also be
1148 derived types, transfer_expr and transfer_array_component are mutually
1152 transfer_array_component (tree expr, gfc_component * cm)
1162 gfc_start_block (&block);
1163 gfc_init_se (&se, NULL);
1165 /* Create and initialize Scalarization Status. Unlike in
1166 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1167 care of this task, because we don't have a gfc_expr at hand.
1168 Build one manually, as in gfc_trans_subarray_assign. */
1171 ss->type = GFC_SS_COMPONENT;
1173 ss->shape = gfc_get_shape (cm->as->rank);
1174 ss->next = gfc_ss_terminator;
1175 ss->data.info.dimen = cm->as->rank;
1176 ss->data.info.descriptor = expr;
1177 ss->data.info.data = gfc_conv_array_data (expr);
1178 ss->data.info.offset = gfc_conv_array_offset (expr);
1179 for (n = 0; n < cm->as->rank; n++)
1181 ss->data.info.dim[n] = n;
1182 ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1183 ss->data.info.stride[n] = gfc_index_one_node;
1185 mpz_init (ss->shape[n]);
1186 mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1187 cm->as->lower[n]->value.integer);
1188 mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1191 /* Once we got ss, we use scalarizer to create the loop. */
1193 gfc_init_loopinfo (&loop);
1194 gfc_add_ss_to_loop (&loop, ss);
1195 gfc_conv_ss_startstride (&loop);
1196 gfc_conv_loop_setup (&loop);
1197 gfc_mark_ss_chain_used (ss, 1);
1198 gfc_start_scalarized_body (&loop, &body);
1200 gfc_copy_loopinfo_to_se (&se, &loop);
1203 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1205 gfc_conv_tmp_array_ref (&se);
1207 /* Now se.expr contains an element of the array. Take the address and pass
1208 it to the IO routines. */
1209 tmp = gfc_build_addr_expr (NULL, se.expr);
1210 transfer_expr (&se, &cm->ts, tmp);
1212 /* We are done now with the loop body. Wrap up the scalarizer and
1215 gfc_add_block_to_block (&body, &se.pre);
1216 gfc_add_block_to_block (&body, &se.post);
1218 gfc_trans_scalarizing_loops (&loop, &body);
1220 gfc_add_block_to_block (&block, &loop.pre);
1221 gfc_add_block_to_block (&block, &loop.post);
1223 for (n = 0; n < cm->as->rank; n++)
1224 mpz_clear (ss->shape[n]);
1225 gfc_free (ss->shape);
1227 gfc_cleanup_loop (&loop);
1229 return gfc_finish_block (&block);
1232 /* Generate the call for a scalar transfer node. */
1235 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1237 tree args, tmp, function, arg2, field, expr;
1248 arg2 = build_int_cst (NULL_TREE, kind);
1249 function = iocall_x_integer;
1253 arg2 = build_int_cst (NULL_TREE, kind);
1254 function = iocall_x_real;
1258 arg2 = build_int_cst (NULL_TREE, kind);
1259 function = iocall_x_complex;
1263 arg2 = build_int_cst (NULL_TREE, kind);
1264 function = iocall_x_logical;
1268 if (se->string_length)
1269 arg2 = se->string_length;
1272 tmp = gfc_build_indirect_ref (addr_expr);
1273 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1274 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1276 function = iocall_x_character;
1280 /* Recurse into the elements of the derived type. */
1281 expr = gfc_evaluate_now (addr_expr, &se->pre);
1282 expr = gfc_build_indirect_ref (expr);
1284 for (c = ts->derived->components; c; c = c->next)
1286 field = c->backend_decl;
1287 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
1289 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1294 tmp = transfer_array_component (tmp, c);
1295 gfc_add_expr_to_block (&se->pre, tmp);
1300 tmp = gfc_build_addr_expr (NULL, tmp);
1301 transfer_expr (se, &c->ts, tmp);
1307 internal_error ("Bad IO basetype (%d)", ts->type);
1310 args = gfc_chainon_list (NULL_TREE, addr_expr);
1311 args = gfc_chainon_list (args, arg2);
1313 tmp = gfc_build_function_call (function, args);
1314 gfc_add_expr_to_block (&se->pre, tmp);
1315 gfc_add_block_to_block (&se->pre, &se->post);
1320 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1323 gfc_trans_transfer (gfc_code * code)
1325 stmtblock_t block, body;
1332 gfc_start_block (&block);
1335 ss = gfc_walk_expr (expr);
1337 gfc_init_se (&se, NULL);
1339 if (ss == gfc_ss_terminator)
1340 gfc_init_block (&body);
1343 /* Initialize the scalarizer. */
1344 gfc_init_loopinfo (&loop);
1345 gfc_add_ss_to_loop (&loop, ss);
1347 /* Initialize the loop. */
1348 gfc_conv_ss_startstride (&loop);
1349 gfc_conv_loop_setup (&loop);
1351 /* The main loop body. */
1352 gfc_mark_ss_chain_used (ss, 1);
1353 gfc_start_scalarized_body (&loop, &body);
1355 gfc_copy_loopinfo_to_se (&se, &loop);
1359 gfc_conv_expr_reference (&se, expr);
1361 transfer_expr (&se, &expr->ts, se.expr);
1363 gfc_add_block_to_block (&body, &se.pre);
1364 gfc_add_block_to_block (&body, &se.post);
1367 tmp = gfc_finish_block (&body);
1370 gcc_assert (se.ss == gfc_ss_terminator);
1371 gfc_trans_scalarizing_loops (&loop, &body);
1373 gfc_add_block_to_block (&loop.pre, &loop.post);
1374 tmp = gfc_finish_block (&loop.pre);
1375 gfc_cleanup_loop (&loop);
1378 gfc_add_expr_to_block (&block, tmp);
1380 return gfc_finish_block (&block);
1383 #include "gt-fortran-trans-io.h"