1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005 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;
129 static GTY(()) tree iocall_set_nml_val_dim;
131 /* Variable for keeping track of what the last data transfer statement
132 was. Used for deciding which subroutine to call when the data
133 transfer is complete. */
134 static enum { READ, WRITE, IOLENGTH } last_dt;
136 #define ADD_FIELD(name, type) \
137 ioparm_ ## name = gfc_add_field_to_struct \
138 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
139 get_identifier (stringize(name)), type)
141 #define ADD_STRING(name) \
142 ioparm_ ## name = gfc_add_field_to_struct \
143 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
144 get_identifier (stringize(name)), pchar_type_node); \
145 ioparm_ ## name ## _len = gfc_add_field_to_struct \
146 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
147 get_identifier (stringize(name) "_len"), gfc_charlen_type_node)
150 /* Create function decls for IO library functions. */
153 gfc_build_io_library_fndecls (void)
155 tree gfc_int4_type_node;
156 tree gfc_pint4_type_node;
159 gfc_int4_type_node = gfc_get_int_type (4);
160 gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
162 /* Build the st_parameter structure. Information associated with I/O
163 calls are transferred here. This must match the one defined in the
166 ioparm_type = make_node (RECORD_TYPE);
167 TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm");
169 ADD_FIELD (unit, gfc_int4_type_node);
170 ADD_FIELD (err, gfc_int4_type_node);
171 ADD_FIELD (end, gfc_int4_type_node);
172 ADD_FIELD (eor, gfc_int4_type_node);
173 ADD_FIELD (list_format, gfc_int4_type_node);
174 ADD_FIELD (library_return, gfc_int4_type_node);
176 ADD_FIELD (iostat, gfc_pint4_type_node);
177 ADD_FIELD (exist, gfc_pint4_type_node);
178 ADD_FIELD (opened, gfc_pint4_type_node);
179 ADD_FIELD (number, gfc_pint4_type_node);
180 ADD_FIELD (named, gfc_pint4_type_node);
181 ADD_FIELD (rec, gfc_int4_type_node);
182 ADD_FIELD (nextrec, gfc_pint4_type_node);
183 ADD_FIELD (size, gfc_pint4_type_node);
185 ADD_FIELD (recl_in, gfc_int4_type_node);
186 ADD_FIELD (recl_out, gfc_pint4_type_node);
188 ADD_FIELD (iolength, gfc_pint4_type_node);
196 ADD_STRING (position);
201 ADD_STRING (advance);
203 ADD_STRING (internal_unit);
204 ADD_STRING (sequential);
207 ADD_STRING (formatted);
208 ADD_STRING (unformatted);
211 ADD_STRING (readwrite);
213 ADD_STRING (namelist_name);
214 ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
216 gfc_finish_type (ioparm_type);
218 ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
220 DECL_EXTERNAL (ioparm_var) = 1;
221 TREE_PUBLIC (ioparm_var) = 1;
223 locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
225 DECL_EXTERNAL (locus_line) = 1;
226 TREE_PUBLIC (locus_line) = 1;
228 locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
230 DECL_EXTERNAL (locus_file) = 1;
231 TREE_PUBLIC (locus_file) = 1;
233 /* Define the transfer functions. */
236 gfc_build_library_function_decl (get_identifier
237 (PREFIX("transfer_integer")),
238 void_type_node, 2, pvoid_type_node,
242 gfc_build_library_function_decl (get_identifier
243 (PREFIX("transfer_logical")),
244 void_type_node, 2, pvoid_type_node,
248 gfc_build_library_function_decl (get_identifier
249 (PREFIX("transfer_character")),
250 void_type_node, 2, pvoid_type_node,
254 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
256 pvoid_type_node, gfc_int4_type_node);
259 gfc_build_library_function_decl (get_identifier
260 (PREFIX("transfer_complex")),
261 void_type_node, 2, pvoid_type_node,
264 /* Library entry points */
267 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
271 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
274 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
278 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
282 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
283 gfc_int4_type_node, 0);
286 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
290 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
291 gfc_int4_type_node, 0);
294 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
295 gfc_int4_type_node, 0);
298 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
299 gfc_int4_type_node, 0);
300 /* Library helpers */
303 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
304 gfc_int4_type_node, 0);
307 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
308 gfc_int4_type_node, 0);
310 iocall_iolength_done =
311 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
312 gfc_int4_type_node, 0);
316 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
318 pvoid_type_node, pvoid_type_node,
319 gfc_int4_type_node, gfc_charlen_type_node,
322 iocall_set_nml_val_dim =
323 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
325 gfc_int4_type_node, gfc_int4_type_node,
326 gfc_int4_type_node, gfc_int4_type_node);
330 /* Generate code to store an non-string I/O parameter into the
331 ioparm structure. This is a pass by value. */
334 set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
339 gfc_init_se (&se, NULL);
340 gfc_conv_expr_type (&se, e, TREE_TYPE (var));
341 gfc_add_block_to_block (block, &se.pre);
343 tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
344 gfc_add_modify_expr (block, tmp, se.expr);
348 /* Generate code to store an non-string I/O parameter into the
349 ioparm structure. This is pass by reference. */
352 set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
357 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 a string and its length into the
372 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
373 tree var_len, gfc_expr * e)
381 gfc_init_se (&se, NULL);
383 io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
384 len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
387 /* Integer variable assigned a format label. */
388 if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
390 gfc_conv_label_variable (&se, e);
392 gfc_build_cstring_const ("Assigned label is not a format label");
393 tmp = GFC_DECL_STRING_LEN (se.expr);
394 tmp = build2 (LE_EXPR, boolean_type_node,
395 tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
396 gfc_trans_runtime_check (tmp, msg, &se.pre);
397 gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr));
398 gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
402 gfc_conv_expr (&se, e);
403 gfc_conv_string_parameter (&se);
404 gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
405 gfc_add_modify_expr (&se.pre, len, se.string_length);
408 gfc_add_block_to_block (block, &se.pre);
409 gfc_add_block_to_block (postblock, &se.post);
414 /* Set a member of the ioparm structure to one. */
416 set_flag (stmtblock_t *block, tree var)
418 tree tmp, type = TREE_TYPE (var);
420 tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
421 gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
425 /* Add a case to a IO-result switch. */
428 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
433 return; /* No label, no case */
435 value = build_int_cst (NULL_TREE, label_value);
437 /* Make a backend label for this case. */
438 tmp = gfc_build_label_decl (NULL_TREE);
440 /* And the case itself. */
441 tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
442 gfc_add_expr_to_block (body, tmp);
444 /* Jump to the label. */
445 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
446 gfc_add_expr_to_block (body, tmp);
450 /* Generate a switch statement that branches to the correct I/O
451 result label. The last statement of an I/O call stores the
452 result into a variable because there is often cleanup that
453 must be done before the switch, so a temporary would have to
454 be created anyway. */
457 io_result (stmtblock_t * block, gfc_st_label * err_label,
458 gfc_st_label * end_label, gfc_st_label * eor_label)
463 /* If no labels are specified, ignore the result instead
464 of building an empty switch. */
465 if (err_label == NULL
467 && eor_label == NULL)
470 /* Build a switch statement. */
471 gfc_start_block (&body);
473 /* The label values here must be the same as the values
474 in the library_return enum in the runtime library */
475 add_case (1, err_label, &body);
476 add_case (2, end_label, &body);
477 add_case (3, eor_label, &body);
479 tmp = gfc_finish_block (&body);
481 rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
482 ioparm_library_return, NULL_TREE);
484 tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
486 gfc_add_expr_to_block (block, tmp);
490 /* Store the current file and line number to variables so that if a
491 library call goes awry, we can tell the user where the problem is. */
494 set_error_locus (stmtblock_t * block, locus * where)
501 tmp = gfc_build_cstring_const (f->filename);
503 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
504 gfc_add_modify_expr (block, locus_file, tmp);
506 #ifdef USE_MAPPED_LOCATION
507 line = LOCATION_LINE (where->lb->location);
509 line = where->lb->linenum;
511 gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line));
515 /* Translate an OPEN statement. */
518 gfc_trans_open (gfc_code * code)
520 stmtblock_t block, post_block;
524 gfc_init_block (&block);
525 gfc_init_block (&post_block);
527 set_error_locus (&block, &code->loc);
531 set_parameter_value (&block, ioparm_unit, p->unit);
534 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
537 set_string (&block, &post_block, ioparm_status,
538 ioparm_status_len, p->status);
541 set_string (&block, &post_block, ioparm_access,
542 ioparm_access_len, p->access);
545 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
548 set_parameter_value (&block, ioparm_recl_in, p->recl);
551 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
555 set_string (&block, &post_block, ioparm_position,
556 ioparm_position_len, p->position);
559 set_string (&block, &post_block, ioparm_action,
560 ioparm_action_len, p->action);
563 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
567 set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
570 set_parameter_ref (&block, ioparm_iostat, p->iostat);
573 set_flag (&block, ioparm_err);
575 tmp = gfc_build_function_call (iocall_open, NULL_TREE);
576 gfc_add_expr_to_block (&block, tmp);
578 gfc_add_block_to_block (&block, &post_block);
580 io_result (&block, p->err, NULL, NULL);
582 return gfc_finish_block (&block);
586 /* Translate a CLOSE statement. */
589 gfc_trans_close (gfc_code * code)
591 stmtblock_t block, post_block;
595 gfc_init_block (&block);
596 gfc_init_block (&post_block);
598 set_error_locus (&block, &code->loc);
602 set_parameter_value (&block, ioparm_unit, p->unit);
605 set_string (&block, &post_block, ioparm_status,
606 ioparm_status_len, p->status);
609 set_parameter_ref (&block, ioparm_iostat, p->iostat);
612 set_flag (&block, ioparm_err);
614 tmp = gfc_build_function_call (iocall_close, NULL_TREE);
615 gfc_add_expr_to_block (&block, tmp);
617 gfc_add_block_to_block (&block, &post_block);
619 io_result (&block, p->err, NULL, NULL);
621 return gfc_finish_block (&block);
625 /* Common subroutine for building a file positioning statement. */
628 build_filepos (tree function, gfc_code * code)
634 p = code->ext.filepos;
636 gfc_init_block (&block);
638 set_error_locus (&block, &code->loc);
641 set_parameter_value (&block, ioparm_unit, p->unit);
644 set_parameter_ref (&block, ioparm_iostat, p->iostat);
647 set_flag (&block, ioparm_err);
649 tmp = gfc_build_function_call (function, NULL);
650 gfc_add_expr_to_block (&block, tmp);
652 io_result (&block, p->err, NULL, NULL);
654 return gfc_finish_block (&block);
658 /* Translate a BACKSPACE statement. */
661 gfc_trans_backspace (gfc_code * code)
664 return build_filepos (iocall_backspace, code);
668 /* Translate an ENDFILE statement. */
671 gfc_trans_endfile (gfc_code * code)
674 return build_filepos (iocall_endfile, code);
678 /* Translate a REWIND statement. */
681 gfc_trans_rewind (gfc_code * code)
684 return build_filepos (iocall_rewind, code);
688 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
691 gfc_trans_inquire (gfc_code * code)
693 stmtblock_t block, post_block;
697 gfc_init_block (&block);
698 gfc_init_block (&post_block);
700 set_error_locus (&block, &code->loc);
701 p = code->ext.inquire;
704 set_parameter_value (&block, ioparm_unit, p->unit);
707 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
710 set_parameter_ref (&block, ioparm_iostat, p->iostat);
713 set_parameter_ref (&block, ioparm_exist, p->exist);
716 set_parameter_ref (&block, ioparm_opened, p->opened);
719 set_parameter_ref (&block, ioparm_number, p->number);
722 set_parameter_ref (&block, ioparm_named, p->named);
725 set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
728 set_string (&block, &post_block, ioparm_access,
729 ioparm_access_len, p->access);
732 set_string (&block, &post_block, ioparm_sequential,
733 ioparm_sequential_len, p->sequential);
736 set_string (&block, &post_block, ioparm_direct,
737 ioparm_direct_len, p->direct);
740 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
743 set_string (&block, &post_block, ioparm_formatted,
744 ioparm_formatted_len, p->formatted);
747 set_string (&block, &post_block, ioparm_unformatted,
748 ioparm_unformatted_len, p->unformatted);
751 set_parameter_ref (&block, ioparm_recl_out, p->recl);
754 set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
757 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
761 set_string (&block, &post_block, ioparm_position,
762 ioparm_position_len, p->position);
765 set_string (&block, &post_block, ioparm_action,
766 ioparm_action_len, p->action);
769 set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
772 set_string (&block, &post_block, ioparm_write,
773 ioparm_write_len, p->write);
776 set_string (&block, &post_block, ioparm_readwrite,
777 ioparm_readwrite_len, p->readwrite);
780 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
784 set_string (&block, &post_block, ioparm_pad, ioparm_pad_len,
788 set_flag (&block, ioparm_err);
790 tmp = gfc_build_function_call (iocall_inquire, NULL);
791 gfc_add_expr_to_block (&block, tmp);
793 gfc_add_block_to_block (&block, &post_block);
795 io_result (&block, p->err, NULL, NULL);
797 return gfc_finish_block (&block);
801 gfc_new_nml_name_expr (const char * name)
805 nml_name = gfc_get_expr();
806 nml_name->ref = NULL;
807 nml_name->expr_type = EXPR_CONSTANT;
808 nml_name->ts.kind = gfc_default_character_kind;
809 nml_name->ts.type = BT_CHARACTER;
810 nml_name->value.character.length = strlen(name);
811 nml_name->value.character.string = gfc_getmem (strlen (name) + 1);
812 strcpy (nml_name->value.character.string, name);
817 /* nml_full_name builds up the fully qualified name of a
818 derived type component. */
821 nml_full_name (const char* var_name, const char* cmp_name)
823 int full_name_length;
826 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
827 full_name = (char*)gfc_getmem (full_name_length + 1);
828 strcpy (full_name, var_name);
829 full_name = strcat (full_name, "%");
830 full_name = strcat (full_name, cmp_name);
834 /* nml_get_addr_expr builds an address expression from the
835 gfc_symbol or gfc_component backend_decl's. An offset is
836 provided so that the address of an element of an array of
837 derived types is returned. This is used in the runtime to
838 determine that span of the derived type. */
841 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
844 tree decl = NULL_TREE;
848 int dummy_arg_flagged;
852 sym->attr.referenced = 1;
853 decl = gfc_get_symbol_decl (sym);
856 decl = c->backend_decl;
858 gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
859 || TREE_CODE (decl) == VAR_DECL
860 || TREE_CODE (decl) == PARM_DECL)
861 || TREE_CODE (decl) == COMPONENT_REF));
865 /* Build indirect reference, if dummy argument. */
867 dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
869 itmp = (dummy_arg_flagged) ? gfc_build_indirect_ref (tmp) : tmp;
871 /* If an array, set flag and use indirect ref. if built. */
873 array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
874 && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
879 /* Treat the component of a derived type, using base_addr for
882 if (TREE_CODE (decl) == FIELD_DECL)
883 tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp),
884 base_addr, tmp, NULL_TREE);
886 /* If we have a derived type component, a reference to the first
887 element of the array is built. This is done so that base_addr,
888 used in the build of the component reference, always points to
892 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
894 /* Now build the address expression. */
896 tmp = gfc_build_addr_expr (NULL, tmp);
898 /* If scalar dummy, resolve indirect reference now. */
900 if (dummy_arg_flagged && !array_flagged)
901 tmp = gfc_build_indirect_ref (tmp);
903 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
908 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
909 call to iocall_set_nml_val. For derived type variable, recursively
910 generate calls to iocall_set_nml_val for each component. */
912 #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
913 #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
914 #define IARG(i) build_int_cst (gfc_array_index_type, i)
917 transfer_namelist_element (stmtblock_t * block, const char * var_name,
918 gfc_symbol * sym, gfc_component * c,
921 gfc_typespec * ts = NULL;
922 gfc_array_spec * as = NULL;
923 tree addr_expr = NULL;
933 gcc_assert (sym || c);
935 /* Build the namelist object name. */
937 string = gfc_build_cstring_const (var_name);
938 string = gfc_build_addr_expr (pchar_type_node, string);
940 /* Build ts, as and data address using symbol or component. */
942 ts = (sym) ? &sym->ts : &c->ts;
943 as = (sym) ? sym->as : c->as;
945 addr_expr = nml_get_addr_expr (sym, c, base_addr);
952 dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
953 dtype = gfc_get_dtype (dt);
957 itype = GFC_DTYPE_UNKNOWN;
963 itype = GFC_DTYPE_INTEGER;
966 itype = GFC_DTYPE_LOGICAL;
969 itype = GFC_DTYPE_REAL;
972 itype = GFC_DTYPE_COMPLEX;
975 itype = GFC_DTYPE_DERIVED;
978 itype = GFC_DTYPE_CHARACTER;
984 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
987 /* Build up the arguments for the transfer call.
988 The call for the scalar part transfers:
989 (address, name, type, kind or string_length, dtype) */
991 NML_FIRST_ARG (addr_expr);
992 NML_ADD_ARG (string);
993 NML_ADD_ARG (IARG (ts->kind));
995 if (ts->type == BT_CHARACTER)
996 NML_ADD_ARG (ts->cl->backend_decl);
998 NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node));
1000 NML_ADD_ARG (dtype);
1001 tmp = gfc_build_function_call (iocall_set_nml_val, args);
1002 gfc_add_expr_to_block (block, tmp);
1004 /* If the object is an array, transfer rank times:
1005 (null pointer, name, stride, lbound, ubound) */
1007 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1009 NML_FIRST_ARG (IARG (n_dim));
1010 NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim));
1011 NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim));
1012 NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1013 tmp = gfc_build_function_call (iocall_set_nml_val_dim, args);
1014 gfc_add_expr_to_block (block, tmp);
1017 if (ts->type == BT_DERIVED)
1021 /* Provide the RECORD_TYPE to build component references. */
1023 tree expr = gfc_build_indirect_ref (addr_expr);
1025 for (cmp = ts->derived->components; cmp; cmp = cmp->next)
1027 char *full_name = nml_full_name (var_name, cmp->name);
1028 transfer_namelist_element (block,
1031 gfc_free (full_name);
1038 #undef NML_FIRST_ARG
1040 /* Create a data transfer statement. Not all of the fields are valid
1041 for both reading and writing, but improper use has been filtered
1045 build_dt (tree * function, gfc_code * code)
1047 stmtblock_t block, post_block;
1053 gfc_init_block (&block);
1054 gfc_init_block (&post_block);
1056 set_error_locus (&block, &code->loc);
1059 gcc_assert (dt != NULL);
1063 if (dt->io_unit->ts.type == BT_CHARACTER)
1065 set_string (&block, &post_block, ioparm_internal_unit,
1066 ioparm_internal_unit_len, dt->io_unit);
1069 set_parameter_value (&block, ioparm_unit, dt->io_unit);
1073 set_parameter_value (&block, ioparm_rec, dt->rec);
1076 set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
1079 if (dt->format_expr)
1080 set_string (&block, &post_block, ioparm_format, ioparm_format_len,
1083 if (dt->format_label)
1085 if (dt->format_label == &format_asterisk)
1086 set_flag (&block, ioparm_list_format);
1088 set_string (&block, &post_block, ioparm_format,
1089 ioparm_format_len, dt->format_label->format);
1093 set_parameter_ref (&block, ioparm_iostat, dt->iostat);
1096 set_parameter_ref (&block, ioparm_size, dt->size);
1099 set_flag (&block, ioparm_err);
1102 set_flag(&block, ioparm_eor);
1105 set_flag(&block, ioparm_end);
1109 if (dt->format_expr || dt->format_label)
1110 gfc_internal_error ("build_dt: format with namelist");
1112 nmlname = gfc_new_nml_name_expr(dt->namelist->name);
1114 set_string (&block, &post_block, ioparm_namelist_name,
1115 ioparm_namelist_name_len, nmlname);
1117 if (last_dt == READ)
1118 set_flag (&block, ioparm_namelist_read_mode);
1120 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1121 transfer_namelist_element (&block, nml->sym->name, nml->sym,
1125 tmp = gfc_build_function_call (*function, NULL_TREE);
1126 gfc_add_expr_to_block (&block, tmp);
1128 gfc_add_block_to_block (&block, &post_block);
1130 return gfc_finish_block (&block);
1134 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1135 this as a third sort of data transfer statement, except that
1136 lengths are summed instead of actually transferring any data. */
1139 gfc_trans_iolength (gfc_code * code)
1145 gfc_init_block (&block);
1147 set_error_locus (&block, &code->loc);
1149 inq = code->ext.inquire;
1151 /* First check that preconditions are met. */
1152 gcc_assert (inq != NULL);
1153 gcc_assert (inq->iolength != NULL);
1155 /* Connect to the iolength variable. */
1157 set_parameter_ref (&block, ioparm_iolength, inq->iolength);
1161 dt = build_dt(&iocall_iolength, code);
1163 gfc_add_expr_to_block (&block, dt);
1165 return gfc_finish_block (&block);
1169 /* Translate a READ statement. */
1172 gfc_trans_read (gfc_code * code)
1176 return build_dt (&iocall_read, code);
1180 /* Translate a WRITE statement */
1183 gfc_trans_write (gfc_code * code)
1187 return build_dt (&iocall_write, code);
1191 /* Finish a data transfer statement. */
1194 gfc_trans_dt_end (gfc_code * code)
1199 gfc_init_block (&block);
1204 function = iocall_read_done;
1208 function = iocall_write_done;
1212 function = iocall_iolength_done;
1219 tmp = gfc_build_function_call (function, NULL);
1220 gfc_add_expr_to_block (&block, tmp);
1222 if (last_dt != IOLENGTH)
1224 gcc_assert (code->ext.dt != NULL);
1225 io_result (&block, code->ext.dt->err,
1226 code->ext.dt->end, code->ext.dt->eor);
1229 return gfc_finish_block (&block);
1233 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
1235 /* Given an array field in a derived type variable, generate the code
1236 for the loop that iterates over array elements, and the code that
1237 accesses those array elements. Use transfer_expr to generate code
1238 for transferring that element. Because elements may also be
1239 derived types, transfer_expr and transfer_array_component are mutually
1243 transfer_array_component (tree expr, gfc_component * cm)
1253 gfc_start_block (&block);
1254 gfc_init_se (&se, NULL);
1256 /* Create and initialize Scalarization Status. Unlike in
1257 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1258 care of this task, because we don't have a gfc_expr at hand.
1259 Build one manually, as in gfc_trans_subarray_assign. */
1262 ss->type = GFC_SS_COMPONENT;
1264 ss->shape = gfc_get_shape (cm->as->rank);
1265 ss->next = gfc_ss_terminator;
1266 ss->data.info.dimen = cm->as->rank;
1267 ss->data.info.descriptor = expr;
1268 ss->data.info.data = gfc_conv_array_data (expr);
1269 ss->data.info.offset = gfc_conv_array_offset (expr);
1270 for (n = 0; n < cm->as->rank; n++)
1272 ss->data.info.dim[n] = n;
1273 ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1274 ss->data.info.stride[n] = gfc_index_one_node;
1276 mpz_init (ss->shape[n]);
1277 mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1278 cm->as->lower[n]->value.integer);
1279 mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1282 /* Once we got ss, we use scalarizer to create the loop. */
1284 gfc_init_loopinfo (&loop);
1285 gfc_add_ss_to_loop (&loop, ss);
1286 gfc_conv_ss_startstride (&loop);
1287 gfc_conv_loop_setup (&loop);
1288 gfc_mark_ss_chain_used (ss, 1);
1289 gfc_start_scalarized_body (&loop, &body);
1291 gfc_copy_loopinfo_to_se (&se, &loop);
1294 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1296 gfc_conv_tmp_array_ref (&se);
1298 /* Now se.expr contains an element of the array. Take the address and pass
1299 it to the IO routines. */
1300 tmp = gfc_build_addr_expr (NULL, se.expr);
1301 transfer_expr (&se, &cm->ts, tmp);
1303 /* We are done now with the loop body. Wrap up the scalarizer and
1306 gfc_add_block_to_block (&body, &se.pre);
1307 gfc_add_block_to_block (&body, &se.post);
1309 gfc_trans_scalarizing_loops (&loop, &body);
1311 gfc_add_block_to_block (&block, &loop.pre);
1312 gfc_add_block_to_block (&block, &loop.post);
1314 for (n = 0; n < cm->as->rank; n++)
1315 mpz_clear (ss->shape[n]);
1316 gfc_free (ss->shape);
1318 gfc_cleanup_loop (&loop);
1320 return gfc_finish_block (&block);
1323 /* Generate the call for a scalar transfer node. */
1326 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1328 tree args, tmp, function, arg2, field, expr;
1339 arg2 = build_int_cst (NULL_TREE, kind);
1340 function = iocall_x_integer;
1344 arg2 = build_int_cst (NULL_TREE, kind);
1345 function = iocall_x_real;
1349 arg2 = build_int_cst (NULL_TREE, kind);
1350 function = iocall_x_complex;
1354 arg2 = build_int_cst (NULL_TREE, kind);
1355 function = iocall_x_logical;
1359 if (se->string_length)
1360 arg2 = se->string_length;
1363 tmp = gfc_build_indirect_ref (addr_expr);
1364 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1365 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1367 function = iocall_x_character;
1371 /* Recurse into the elements of the derived type. */
1372 expr = gfc_evaluate_now (addr_expr, &se->pre);
1373 expr = gfc_build_indirect_ref (expr);
1375 for (c = ts->derived->components; c; c = c->next)
1377 field = c->backend_decl;
1378 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
1380 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1385 tmp = transfer_array_component (tmp, c);
1386 gfc_add_expr_to_block (&se->pre, tmp);
1391 tmp = gfc_build_addr_expr (NULL, tmp);
1392 transfer_expr (se, &c->ts, tmp);
1398 internal_error ("Bad IO basetype (%d)", ts->type);
1401 args = gfc_chainon_list (NULL_TREE, addr_expr);
1402 args = gfc_chainon_list (args, arg2);
1404 tmp = gfc_build_function_call (function, args);
1405 gfc_add_expr_to_block (&se->pre, tmp);
1406 gfc_add_block_to_block (&se->pre, &se->post);
1411 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1414 gfc_trans_transfer (gfc_code * code)
1416 stmtblock_t block, body;
1423 gfc_start_block (&block);
1426 ss = gfc_walk_expr (expr);
1428 gfc_init_se (&se, NULL);
1430 if (ss == gfc_ss_terminator)
1431 gfc_init_block (&body);
1434 /* Initialize the scalarizer. */
1435 gfc_init_loopinfo (&loop);
1436 gfc_add_ss_to_loop (&loop, ss);
1438 /* Initialize the loop. */
1439 gfc_conv_ss_startstride (&loop);
1440 gfc_conv_loop_setup (&loop);
1442 /* The main loop body. */
1443 gfc_mark_ss_chain_used (ss, 1);
1444 gfc_start_scalarized_body (&loop, &body);
1446 gfc_copy_loopinfo_to_se (&se, &loop);
1450 gfc_conv_expr_reference (&se, expr);
1452 transfer_expr (&se, &expr->ts, se.expr);
1454 gfc_add_block_to_block (&body, &se.pre);
1455 gfc_add_block_to_block (&body, &se.post);
1458 tmp = gfc_finish_block (&body);
1461 gcc_assert (se.ss == gfc_ss_terminator);
1462 gfc_trans_scalarizing_loops (&loop, &body);
1464 gfc_add_block_to_block (&loop.pre, &loop.post);
1465 tmp = gfc_finish_block (&loop.pre);
1466 gfc_cleanup_loop (&loop);
1469 gfc_add_expr_to_block (&block, tmp);
1471 return gfc_finish_block (&block);
1474 #include "gt-fortran-trans-io.h"