gcc:
[official-gcc.git] / gcc / fortran / trans-io.c
blob2c8a9cdec28346407745c8e6967b162a1f0d94d4
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
10 version.
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
15 for more details.
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, 51 Franklin Street, Fifth Floor, Boston, MA
20 02110-1301, USA. */
23 #include "config.h"
24 #include "system.h"
25 #include "coretypes.h"
26 #include "tree.h"
27 #include "tree-gimple.h"
28 #include "ggc.h"
29 #include "toplev.h"
30 #include "real.h"
31 #include "gfortran.h"
32 #include "trans.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_internal_unit_desc;
85 static GTY(()) tree ioparm_sequential;
86 static GTY(()) tree ioparm_sequential_len;
87 static GTY(()) tree ioparm_direct;
88 static GTY(()) tree ioparm_direct_len;
89 static GTY(()) tree ioparm_formatted;
90 static GTY(()) tree ioparm_formatted_len;
91 static GTY(()) tree ioparm_unformatted;
92 static GTY(()) tree ioparm_unformatted_len;
93 static GTY(()) tree ioparm_read;
94 static GTY(()) tree ioparm_read_len;
95 static GTY(()) tree ioparm_write;
96 static GTY(()) tree ioparm_write_len;
97 static GTY(()) tree ioparm_readwrite;
98 static GTY(()) tree ioparm_readwrite_len;
99 static GTY(()) tree ioparm_namelist_name;
100 static GTY(()) tree ioparm_namelist_name_len;
101 static GTY(()) tree ioparm_namelist_read_mode;
102 static GTY(()) tree ioparm_iomsg;
103 static GTY(()) tree ioparm_iomsg_len;
105 /* The global I/O variables */
107 static GTY(()) tree ioparm_var;
108 static GTY(()) tree locus_file;
109 static GTY(()) tree locus_line;
112 /* Library I/O subroutines */
114 static GTY(()) tree iocall_read;
115 static GTY(()) tree iocall_read_done;
116 static GTY(()) tree iocall_write;
117 static GTY(()) tree iocall_write_done;
118 static GTY(()) tree iocall_x_integer;
119 static GTY(()) tree iocall_x_logical;
120 static GTY(()) tree iocall_x_character;
121 static GTY(()) tree iocall_x_real;
122 static GTY(()) tree iocall_x_complex;
123 static GTY(()) tree iocall_x_array;
124 static GTY(()) tree iocall_open;
125 static GTY(()) tree iocall_close;
126 static GTY(()) tree iocall_inquire;
127 static GTY(()) tree iocall_iolength;
128 static GTY(()) tree iocall_iolength_done;
129 static GTY(()) tree iocall_rewind;
130 static GTY(()) tree iocall_backspace;
131 static GTY(()) tree iocall_endfile;
132 static GTY(()) tree iocall_flush;
133 static GTY(()) tree iocall_set_nml_val;
134 static GTY(()) tree iocall_set_nml_val_dim;
136 /* Variable for keeping track of what the last data transfer statement
137 was. Used for deciding which subroutine to call when the data
138 transfer is complete. */
139 static enum { READ, WRITE, IOLENGTH } last_dt;
141 #define ADD_FIELD(name, type) \
142 ioparm_ ## name = gfc_add_field_to_struct \
143 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
144 get_identifier (stringize(name)), type)
146 #define ADD_STRING(name) \
147 ioparm_ ## name = gfc_add_field_to_struct \
148 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
149 get_identifier (stringize(name)), pchar_type_node); \
150 ioparm_ ## name ## _len = gfc_add_field_to_struct \
151 (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
152 get_identifier (stringize(name) "_len"), gfc_charlen_type_node)
155 /* Create function decls for IO library functions. */
157 void
158 gfc_build_io_library_fndecls (void)
160 tree gfc_int4_type_node;
161 tree gfc_pint4_type_node;
162 tree ioparm_type;
164 gfc_int4_type_node = gfc_get_int_type (4);
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
169 library exactly. */
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_int4_type_node);
187 ADD_FIELD (nextrec, gfc_pint4_type_node);
188 ADD_FIELD (size, gfc_pint4_type_node);
190 ADD_FIELD (recl_in, gfc_int4_type_node);
191 ADD_FIELD (recl_out, gfc_pint4_type_node);
193 ADD_FIELD (iolength, gfc_pint4_type_node);
195 ADD_STRING (file);
196 ADD_STRING (status);
198 ADD_STRING (access);
199 ADD_STRING (form);
200 ADD_STRING (blank);
201 ADD_STRING (position);
202 ADD_STRING (action);
203 ADD_STRING (delim);
204 ADD_STRING (pad);
205 ADD_STRING (format);
206 ADD_STRING (advance);
207 ADD_STRING (name);
208 ADD_STRING (internal_unit);
209 ADD_FIELD (internal_unit_desc, pchar_type_node);
210 ADD_STRING (sequential);
212 ADD_STRING (direct);
213 ADD_STRING (formatted);
214 ADD_STRING (unformatted);
215 ADD_STRING (read);
216 ADD_STRING (write);
217 ADD_STRING (readwrite);
219 ADD_STRING (namelist_name);
220 ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
221 ADD_STRING (iomsg);
223 gfc_finish_type (ioparm_type);
225 ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
226 ioparm_type);
227 DECL_EXTERNAL (ioparm_var) = 1;
228 TREE_PUBLIC (ioparm_var) = 1;
230 locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
231 gfc_int4_type_node);
232 DECL_EXTERNAL (locus_line) = 1;
233 TREE_PUBLIC (locus_line) = 1;
235 locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
236 pchar_type_node);
237 DECL_EXTERNAL (locus_file) = 1;
238 TREE_PUBLIC (locus_file) = 1;
240 /* Define the transfer functions. */
242 iocall_x_integer =
243 gfc_build_library_function_decl (get_identifier
244 (PREFIX("transfer_integer")),
245 void_type_node, 2, pvoid_type_node,
246 gfc_int4_type_node);
248 iocall_x_logical =
249 gfc_build_library_function_decl (get_identifier
250 (PREFIX("transfer_logical")),
251 void_type_node, 2, pvoid_type_node,
252 gfc_int4_type_node);
254 iocall_x_character =
255 gfc_build_library_function_decl (get_identifier
256 (PREFIX("transfer_character")),
257 void_type_node, 2, pvoid_type_node,
258 gfc_int4_type_node);
260 iocall_x_real =
261 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
262 void_type_node, 2,
263 pvoid_type_node, gfc_int4_type_node);
265 iocall_x_complex =
266 gfc_build_library_function_decl (get_identifier
267 (PREFIX("transfer_complex")),
268 void_type_node, 2, pvoid_type_node,
269 gfc_int4_type_node);
271 iocall_x_array =
272 gfc_build_library_function_decl (get_identifier
273 (PREFIX("transfer_array")),
274 void_type_node, 2, pvoid_type_node,
275 gfc_charlen_type_node);
277 /* Library entry points */
279 iocall_read =
280 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
281 void_type_node, 0);
283 iocall_write =
284 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
285 void_type_node, 0);
286 iocall_open =
287 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
288 void_type_node, 0);
290 iocall_close =
291 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
292 void_type_node, 0);
294 iocall_inquire =
295 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
296 gfc_int4_type_node, 0);
298 iocall_iolength =
299 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
300 void_type_node, 0);
302 iocall_rewind =
303 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
304 gfc_int4_type_node, 0);
306 iocall_backspace =
307 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
308 gfc_int4_type_node, 0);
310 iocall_endfile =
311 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
312 gfc_int4_type_node, 0);
314 iocall_flush =
315 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
316 gfc_int4_type_node, 0);
318 /* Library helpers */
320 iocall_read_done =
321 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
322 gfc_int4_type_node, 0);
324 iocall_write_done =
325 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
326 gfc_int4_type_node, 0);
328 iocall_iolength_done =
329 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
330 gfc_int4_type_node, 0);
333 iocall_set_nml_val =
334 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
335 void_type_node, 5,
336 pvoid_type_node, pvoid_type_node,
337 gfc_int4_type_node, gfc_charlen_type_node,
338 gfc_int4_type_node);
340 iocall_set_nml_val_dim =
341 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
342 void_type_node, 4,
343 gfc_int4_type_node, gfc_int4_type_node,
344 gfc_int4_type_node, gfc_int4_type_node);
348 /* Generate code to store a non-string I/O parameter into the
349 ioparm structure. This is a pass by value. */
351 static void
352 set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
354 gfc_se se;
355 tree tmp;
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 a non-string I/O parameter into the
367 ioparm structure. This is pass by reference. */
369 static void
370 set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
372 gfc_se se;
373 tree tmp;
375 gfc_init_se (&se, NULL);
376 se.want_pointer = 1;
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);
385 /* Given an array expr, find its address and length to get a string. If the
386 array is full, the string's address is the address of array's first element
387 and the length is the size of the whole array. If it is an element, the
388 string's address is the element's address and the length is the rest size of
389 the array.
392 static void
393 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
395 tree tmp;
396 tree array;
397 tree type;
398 tree size;
399 int rank;
400 gfc_symbol *sym;
402 sym = e->symtree->n.sym;
403 rank = sym->as->rank - 1;
405 if (e->ref->u.ar.type == AR_FULL)
407 se->expr = gfc_get_symbol_decl (sym);
408 se->expr = gfc_conv_array_data (se->expr);
410 else
412 gfc_conv_expr (se, e);
415 array = sym->backend_decl;
416 type = TREE_TYPE (array);
418 if (GFC_ARRAY_TYPE_P (type))
419 size = GFC_TYPE_ARRAY_SIZE (type);
420 else
422 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
423 size = gfc_conv_array_stride (array, rank);
424 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
425 gfc_conv_array_ubound (array, rank),
426 gfc_conv_array_lbound (array, rank));
427 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
428 gfc_index_one_node);
429 size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
432 gcc_assert (size);
434 /* If it is an element, we need the its address and size of the rest. */
435 if (e->ref->u.ar.type == AR_ELEMENT)
437 size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
438 TREE_OPERAND (se->expr, 1));
439 se->expr = gfc_build_addr_expr (NULL, se->expr);
442 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
443 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
445 se->string_length = fold_convert (gfc_charlen_type_node, size);
449 /* Generate code to store a string and its length into the
450 ioparm structure. */
452 static void
453 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
454 tree var_len, gfc_expr * e)
456 gfc_se se;
457 tree tmp;
458 tree msg;
459 tree io;
460 tree len;
462 gfc_init_se (&se, NULL);
464 io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
465 len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
466 NULL_TREE);
468 /* Integer variable assigned a format label. */
469 if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
471 gfc_conv_label_variable (&se, e);
472 msg =
473 gfc_build_cstring_const ("Assigned label is not a format label");
474 tmp = GFC_DECL_STRING_LEN (se.expr);
475 tmp = build2 (LE_EXPR, boolean_type_node,
476 tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
477 gfc_trans_runtime_check (tmp, msg, &se.pre);
478 gfc_add_modify_expr (&se.pre, io,
479 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
480 gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
482 else
484 /* General character. */
485 if (e->ts.type == BT_CHARACTER && e->rank == 0)
486 gfc_conv_expr (&se, e);
487 /* Array assigned Hollerith constant or character array. */
488 else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
489 gfc_convert_array_to_string (&se, e);
490 else
491 gcc_unreachable ();
493 gfc_conv_string_parameter (&se);
494 gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
495 gfc_add_modify_expr (&se.pre, len, se.string_length);
498 gfc_add_block_to_block (block, &se.pre);
499 gfc_add_block_to_block (postblock, &se.post);
503 /* Generate code to store the character (array) and the character length
504 for an internal unit. */
506 static void
507 set_internal_unit (stmtblock_t * block, tree iunit, tree iunit_len,
508 tree iunit_desc, gfc_expr * e)
510 gfc_se se;
511 tree io;
512 tree len;
513 tree desc;
514 tree tmp;
516 gfc_init_se (&se, NULL);
518 io = build3 (COMPONENT_REF, TREE_TYPE (iunit), ioparm_var, iunit, NULL_TREE);
519 len = build3 (COMPONENT_REF, TREE_TYPE (iunit_len), ioparm_var, iunit_len,
520 NULL_TREE);
521 desc = build3 (COMPONENT_REF, TREE_TYPE (iunit_desc), ioparm_var, iunit_desc,
522 NULL_TREE);
524 gcc_assert (e->ts.type == BT_CHARACTER);
526 /* Character scalars. */
527 if (e->rank == 0)
529 gfc_conv_expr (&se, e);
530 gfc_conv_string_parameter (&se);
531 tmp = se.expr;
532 se.expr = fold_convert (pchar_type_node, integer_zero_node);
535 /* Character array. */
536 else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
538 se.ss = gfc_walk_expr (e);
540 /* Return the data pointer and rank from the descriptor. */
541 gfc_conv_expr_descriptor (&se, e, se.ss);
542 tmp = gfc_conv_descriptor_data_get (se.expr);
543 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
545 else
546 gcc_unreachable ();
548 /* The cast is needed for character substrings and the descriptor
549 data. */
550 gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
551 gfc_add_modify_expr (&se.pre, len, se.string_length);
552 gfc_add_modify_expr (&se.pre, desc, se.expr);
554 gfc_add_block_to_block (block, &se.pre);
557 /* Set a member of the ioparm structure to one. */
558 static void
559 set_flag (stmtblock_t *block, tree var)
561 tree tmp, type = TREE_TYPE (var);
563 tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
564 gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
568 /* Add a case to a IO-result switch. */
570 static void
571 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
573 tree tmp, value;
575 if (label == NULL)
576 return; /* No label, no case */
578 value = build_int_cst (NULL_TREE, label_value);
580 /* Make a backend label for this case. */
581 tmp = gfc_build_label_decl (NULL_TREE);
583 /* And the case itself. */
584 tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
585 gfc_add_expr_to_block (body, tmp);
587 /* Jump to the label. */
588 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
589 gfc_add_expr_to_block (body, tmp);
593 /* Generate a switch statement that branches to the correct I/O
594 result label. The last statement of an I/O call stores the
595 result into a variable because there is often cleanup that
596 must be done before the switch, so a temporary would have to
597 be created anyway. */
599 static void
600 io_result (stmtblock_t * block, gfc_st_label * err_label,
601 gfc_st_label * end_label, gfc_st_label * eor_label)
603 stmtblock_t body;
604 tree tmp, rc;
606 /* If no labels are specified, ignore the result instead
607 of building an empty switch. */
608 if (err_label == NULL
609 && end_label == NULL
610 && eor_label == NULL)
611 return;
613 /* Build a switch statement. */
614 gfc_start_block (&body);
616 /* The label values here must be the same as the values
617 in the library_return enum in the runtime library */
618 add_case (1, err_label, &body);
619 add_case (2, end_label, &body);
620 add_case (3, eor_label, &body);
622 tmp = gfc_finish_block (&body);
624 rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
625 ioparm_library_return, NULL_TREE);
627 tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
629 gfc_add_expr_to_block (block, tmp);
633 /* Store the current file and line number to variables so that if a
634 library call goes awry, we can tell the user where the problem is. */
636 static void
637 set_error_locus (stmtblock_t * block, locus * where)
639 gfc_file *f;
640 tree tmp;
641 int line;
643 f = where->lb->file;
644 tmp = gfc_build_cstring_const (f->filename);
646 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
647 gfc_add_modify_expr (block, locus_file, tmp);
649 #ifdef USE_MAPPED_LOCATION
650 line = LOCATION_LINE (where->lb->location);
651 #else
652 line = where->lb->linenum;
653 #endif
654 gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line));
658 /* Translate an OPEN statement. */
660 tree
661 gfc_trans_open (gfc_code * code)
663 stmtblock_t block, post_block;
664 gfc_open *p;
665 tree tmp;
667 gfc_init_block (&block);
668 gfc_init_block (&post_block);
670 set_error_locus (&block, &code->loc);
671 p = code->ext.open;
673 if (p->unit)
674 set_parameter_value (&block, ioparm_unit, p->unit);
676 if (p->file)
677 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
679 if (p->status)
680 set_string (&block, &post_block, ioparm_status,
681 ioparm_status_len, p->status);
683 if (p->access)
684 set_string (&block, &post_block, ioparm_access,
685 ioparm_access_len, p->access);
687 if (p->form)
688 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
690 if (p->recl)
691 set_parameter_value (&block, ioparm_recl_in, p->recl);
693 if (p->blank)
694 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
695 p->blank);
697 if (p->position)
698 set_string (&block, &post_block, ioparm_position,
699 ioparm_position_len, p->position);
701 if (p->action)
702 set_string (&block, &post_block, ioparm_action,
703 ioparm_action_len, p->action);
705 if (p->delim)
706 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
707 p->delim);
709 if (p->pad)
710 set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
712 if (p->iomsg)
713 set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
714 p->iomsg);
716 if (p->iostat)
717 set_parameter_ref (&block, ioparm_iostat, p->iostat);
719 if (p->err)
720 set_flag (&block, ioparm_err);
722 tmp = gfc_build_function_call (iocall_open, NULL_TREE);
723 gfc_add_expr_to_block (&block, tmp);
725 gfc_add_block_to_block (&block, &post_block);
727 io_result (&block, p->err, NULL, NULL);
729 return gfc_finish_block (&block);
733 /* Translate a CLOSE statement. */
735 tree
736 gfc_trans_close (gfc_code * code)
738 stmtblock_t block, post_block;
739 gfc_close *p;
740 tree tmp;
742 gfc_init_block (&block);
743 gfc_init_block (&post_block);
745 set_error_locus (&block, &code->loc);
746 p = code->ext.close;
748 if (p->unit)
749 set_parameter_value (&block, ioparm_unit, p->unit);
751 if (p->status)
752 set_string (&block, &post_block, ioparm_status,
753 ioparm_status_len, p->status);
755 if (p->iomsg)
756 set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
757 p->iomsg);
759 if (p->iostat)
760 set_parameter_ref (&block, ioparm_iostat, p->iostat);
762 if (p->err)
763 set_flag (&block, ioparm_err);
765 tmp = gfc_build_function_call (iocall_close, NULL_TREE);
766 gfc_add_expr_to_block (&block, tmp);
768 gfc_add_block_to_block (&block, &post_block);
770 io_result (&block, p->err, NULL, NULL);
772 return gfc_finish_block (&block);
776 /* Common subroutine for building a file positioning statement. */
778 static tree
779 build_filepos (tree function, gfc_code * code)
781 stmtblock_t block, post_block;
782 gfc_filepos *p;
783 tree tmp;
785 p = code->ext.filepos;
787 gfc_init_block (&block);
788 gfc_init_block (&post_block);
790 set_error_locus (&block, &code->loc);
792 if (p->unit)
793 set_parameter_value (&block, ioparm_unit, p->unit);
795 if (p->iomsg)
796 set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
797 p->iomsg);
799 if (p->iostat)
800 set_parameter_ref (&block, ioparm_iostat, p->iostat);
802 if (p->err)
803 set_flag (&block, ioparm_err);
805 tmp = gfc_build_function_call (function, NULL);
806 gfc_add_expr_to_block (&block, tmp);
808 gfc_add_block_to_block (&block, &post_block);
810 io_result (&block, p->err, NULL, NULL);
812 return gfc_finish_block (&block);
816 /* Translate a BACKSPACE statement. */
818 tree
819 gfc_trans_backspace (gfc_code * code)
822 return build_filepos (iocall_backspace, code);
826 /* Translate an ENDFILE statement. */
828 tree
829 gfc_trans_endfile (gfc_code * code)
832 return build_filepos (iocall_endfile, code);
836 /* Translate a REWIND statement. */
838 tree
839 gfc_trans_rewind (gfc_code * code)
842 return build_filepos (iocall_rewind, code);
846 /* Translate a FLUSH statement. */
848 tree
849 gfc_trans_flush (gfc_code * code)
852 return build_filepos (iocall_flush, code);
856 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
858 tree
859 gfc_trans_inquire (gfc_code * code)
861 stmtblock_t block, post_block;
862 gfc_inquire *p;
863 tree tmp;
865 gfc_init_block (&block);
866 gfc_init_block (&post_block);
868 set_error_locus (&block, &code->loc);
869 p = code->ext.inquire;
871 /* Sanity check. */
872 if (p->unit && p->file)
873 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers.", &code->loc);
875 if (p->unit)
876 set_parameter_value (&block, ioparm_unit, p->unit);
878 if (p->file)
879 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
881 if (p->iomsg)
882 set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
883 p->iomsg);
885 if (p->iostat)
886 set_parameter_ref (&block, ioparm_iostat, p->iostat);
888 if (p->exist)
889 set_parameter_ref (&block, ioparm_exist, p->exist);
891 if (p->opened)
892 set_parameter_ref (&block, ioparm_opened, p->opened);
894 if (p->number)
895 set_parameter_ref (&block, ioparm_number, p->number);
897 if (p->named)
898 set_parameter_ref (&block, ioparm_named, p->named);
900 if (p->name)
901 set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
903 if (p->access)
904 set_string (&block, &post_block, ioparm_access,
905 ioparm_access_len, p->access);
907 if (p->sequential)
908 set_string (&block, &post_block, ioparm_sequential,
909 ioparm_sequential_len, p->sequential);
911 if (p->direct)
912 set_string (&block, &post_block, ioparm_direct,
913 ioparm_direct_len, p->direct);
915 if (p->form)
916 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
918 if (p->formatted)
919 set_string (&block, &post_block, ioparm_formatted,
920 ioparm_formatted_len, p->formatted);
922 if (p->unformatted)
923 set_string (&block, &post_block, ioparm_unformatted,
924 ioparm_unformatted_len, p->unformatted);
926 if (p->recl)
927 set_parameter_ref (&block, ioparm_recl_out, p->recl);
929 if (p->nextrec)
930 set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
932 if (p->blank)
933 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
934 p->blank);
936 if (p->position)
937 set_string (&block, &post_block, ioparm_position,
938 ioparm_position_len, p->position);
940 if (p->action)
941 set_string (&block, &post_block, ioparm_action,
942 ioparm_action_len, p->action);
944 if (p->read)
945 set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
947 if (p->write)
948 set_string (&block, &post_block, ioparm_write,
949 ioparm_write_len, p->write);
951 if (p->readwrite)
952 set_string (&block, &post_block, ioparm_readwrite,
953 ioparm_readwrite_len, p->readwrite);
955 if (p->delim)
956 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
957 p->delim);
959 if (p->pad)
960 set_string (&block, &post_block, ioparm_pad, ioparm_pad_len,
961 p->pad);
963 if (p->err)
964 set_flag (&block, ioparm_err);
966 tmp = gfc_build_function_call (iocall_inquire, NULL);
967 gfc_add_expr_to_block (&block, tmp);
969 gfc_add_block_to_block (&block, &post_block);
971 io_result (&block, p->err, NULL, NULL);
973 return gfc_finish_block (&block);
976 static gfc_expr *
977 gfc_new_nml_name_expr (const char * name)
979 gfc_expr * nml_name;
981 nml_name = gfc_get_expr();
982 nml_name->ref = NULL;
983 nml_name->expr_type = EXPR_CONSTANT;
984 nml_name->ts.kind = gfc_default_character_kind;
985 nml_name->ts.type = BT_CHARACTER;
986 nml_name->value.character.length = strlen(name);
987 nml_name->value.character.string = gfc_getmem (strlen (name) + 1);
988 strcpy (nml_name->value.character.string, name);
990 return nml_name;
993 /* nml_full_name builds up the fully qualified name of a
994 derived type component. */
996 static char*
997 nml_full_name (const char* var_name, const char* cmp_name)
999 int full_name_length;
1000 char * full_name;
1002 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1003 full_name = (char*)gfc_getmem (full_name_length + 1);
1004 strcpy (full_name, var_name);
1005 full_name = strcat (full_name, "%");
1006 full_name = strcat (full_name, cmp_name);
1007 return full_name;
1010 /* nml_get_addr_expr builds an address expression from the
1011 gfc_symbol or gfc_component backend_decl's. An offset is
1012 provided so that the address of an element of an array of
1013 derived types is returned. This is used in the runtime to
1014 determine that span of the derived type. */
1016 static tree
1017 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1018 tree base_addr)
1020 tree decl = NULL_TREE;
1021 tree tmp;
1022 tree itmp;
1023 int array_flagged;
1024 int dummy_arg_flagged;
1026 if (sym)
1028 sym->attr.referenced = 1;
1029 decl = gfc_get_symbol_decl (sym);
1031 else
1032 decl = c->backend_decl;
1034 gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1035 || TREE_CODE (decl) == VAR_DECL
1036 || TREE_CODE (decl) == PARM_DECL)
1037 || TREE_CODE (decl) == COMPONENT_REF));
1039 tmp = decl;
1041 /* Build indirect reference, if dummy argument. */
1043 dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
1045 itmp = (dummy_arg_flagged) ? gfc_build_indirect_ref (tmp) : tmp;
1047 /* If an array, set flag and use indirect ref. if built. */
1049 array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
1050 && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
1052 if (array_flagged)
1053 tmp = itmp;
1055 /* Treat the component of a derived type, using base_addr for
1056 the derived type. */
1058 if (TREE_CODE (decl) == FIELD_DECL)
1059 tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp),
1060 base_addr, tmp, NULL_TREE);
1062 /* If we have a derived type component, a reference to the first
1063 element of the array is built. This is done so that base_addr,
1064 used in the build of the component reference, always points to
1065 a RECORD_TYPE. */
1067 if (array_flagged)
1068 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
1070 /* Now build the address expression. */
1072 tmp = gfc_build_addr_expr (NULL, tmp);
1074 /* If scalar dummy, resolve indirect reference now. */
1076 if (dummy_arg_flagged && !array_flagged)
1077 tmp = gfc_build_indirect_ref (tmp);
1079 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1081 return tmp;
1084 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1085 call to iocall_set_nml_val. For derived type variable, recursively
1086 generate calls to iocall_set_nml_val for each component. */
1088 #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
1089 #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
1090 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1092 static void
1093 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1094 gfc_symbol * sym, gfc_component * c,
1095 tree base_addr)
1097 gfc_typespec * ts = NULL;
1098 gfc_array_spec * as = NULL;
1099 tree addr_expr = NULL;
1100 tree dt = NULL;
1101 tree string;
1102 tree tmp;
1103 tree args;
1104 tree dtype;
1105 int n_dim;
1106 int itype;
1107 int rank = 0;
1109 gcc_assert (sym || c);
1111 /* Build the namelist object name. */
1113 string = gfc_build_cstring_const (var_name);
1114 string = gfc_build_addr_expr (pchar_type_node, string);
1116 /* Build ts, as and data address using symbol or component. */
1118 ts = (sym) ? &sym->ts : &c->ts;
1119 as = (sym) ? sym->as : c->as;
1121 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1123 if (as)
1124 rank = as->rank;
1126 if (rank)
1128 dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1129 dtype = gfc_get_dtype (dt);
1131 else
1133 itype = GFC_DTYPE_UNKNOWN;
1135 switch (ts->type)
1138 case BT_INTEGER:
1139 itype = GFC_DTYPE_INTEGER;
1140 break;
1141 case BT_LOGICAL:
1142 itype = GFC_DTYPE_LOGICAL;
1143 break;
1144 case BT_REAL:
1145 itype = GFC_DTYPE_REAL;
1146 break;
1147 case BT_COMPLEX:
1148 itype = GFC_DTYPE_COMPLEX;
1149 break;
1150 case BT_DERIVED:
1151 itype = GFC_DTYPE_DERIVED;
1152 break;
1153 case BT_CHARACTER:
1154 itype = GFC_DTYPE_CHARACTER;
1155 break;
1156 default:
1157 gcc_unreachable ();
1160 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1163 /* Build up the arguments for the transfer call.
1164 The call for the scalar part transfers:
1165 (address, name, type, kind or string_length, dtype) */
1167 NML_FIRST_ARG (addr_expr);
1168 NML_ADD_ARG (string);
1169 NML_ADD_ARG (IARG (ts->kind));
1171 if (ts->type == BT_CHARACTER)
1172 NML_ADD_ARG (ts->cl->backend_decl);
1173 else
1174 NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node));
1176 NML_ADD_ARG (dtype);
1177 tmp = gfc_build_function_call (iocall_set_nml_val, args);
1178 gfc_add_expr_to_block (block, tmp);
1180 /* If the object is an array, transfer rank times:
1181 (null pointer, name, stride, lbound, ubound) */
1183 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1185 NML_FIRST_ARG (IARG (n_dim));
1186 NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim));
1187 NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim));
1188 NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1189 tmp = gfc_build_function_call (iocall_set_nml_val_dim, args);
1190 gfc_add_expr_to_block (block, tmp);
1193 if (ts->type == BT_DERIVED)
1195 gfc_component *cmp;
1197 /* Provide the RECORD_TYPE to build component references. */
1199 tree expr = gfc_build_indirect_ref (addr_expr);
1201 for (cmp = ts->derived->components; cmp; cmp = cmp->next)
1203 char *full_name = nml_full_name (var_name, cmp->name);
1204 transfer_namelist_element (block,
1205 full_name,
1206 NULL, cmp, expr);
1207 gfc_free (full_name);
1212 #undef IARG
1213 #undef NML_ADD_ARG
1214 #undef NML_FIRST_ARG
1216 /* Create a data transfer statement. Not all of the fields are valid
1217 for both reading and writing, but improper use has been filtered
1218 out by now. */
1220 static tree
1221 build_dt (tree * function, gfc_code * code)
1223 stmtblock_t block, post_block;
1224 gfc_dt *dt;
1225 tree tmp;
1226 gfc_expr *nmlname;
1227 gfc_namelist *nml;
1229 gfc_init_block (&block);
1230 gfc_init_block (&post_block);
1232 set_error_locus (&block, &code->loc);
1233 dt = code->ext.dt;
1235 gcc_assert (dt != NULL);
1237 if (dt->io_unit)
1239 if (dt->io_unit->ts.type == BT_CHARACTER)
1241 set_internal_unit (&block,
1242 ioparm_internal_unit,
1243 ioparm_internal_unit_len,
1244 ioparm_internal_unit_desc,
1245 dt->io_unit);
1247 else
1248 set_parameter_value (&block, ioparm_unit, dt->io_unit);
1251 if (dt->rec)
1252 set_parameter_value (&block, ioparm_rec, dt->rec);
1254 if (dt->advance)
1255 set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
1256 dt->advance);
1258 if (dt->format_expr)
1259 set_string (&block, &post_block, ioparm_format, ioparm_format_len,
1260 dt->format_expr);
1262 if (dt->format_label)
1264 if (dt->format_label == &format_asterisk)
1265 set_flag (&block, ioparm_list_format);
1266 else
1267 set_string (&block, &post_block, ioparm_format,
1268 ioparm_format_len, dt->format_label->format);
1271 if (dt->iomsg)
1272 set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
1273 dt->iomsg);
1275 if (dt->iostat)
1276 set_parameter_ref (&block, ioparm_iostat, dt->iostat);
1278 if (dt->size)
1279 set_parameter_ref (&block, ioparm_size, dt->size);
1281 if (dt->err)
1282 set_flag (&block, ioparm_err);
1284 if (dt->eor)
1285 set_flag(&block, ioparm_eor);
1287 if (dt->end)
1288 set_flag(&block, ioparm_end);
1290 if (dt->namelist)
1292 if (dt->format_expr || dt->format_label)
1293 gfc_internal_error ("build_dt: format with namelist");
1295 nmlname = gfc_new_nml_name_expr(dt->namelist->name);
1297 set_string (&block, &post_block, ioparm_namelist_name,
1298 ioparm_namelist_name_len, nmlname);
1300 if (last_dt == READ)
1301 set_flag (&block, ioparm_namelist_read_mode);
1303 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1304 transfer_namelist_element (&block, nml->sym->name, nml->sym,
1305 NULL, NULL);
1308 tmp = gfc_build_function_call (*function, NULL_TREE);
1309 gfc_add_expr_to_block (&block, tmp);
1311 gfc_add_block_to_block (&block, &post_block);
1313 return gfc_finish_block (&block);
1317 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1318 this as a third sort of data transfer statement, except that
1319 lengths are summed instead of actually transferring any data. */
1321 tree
1322 gfc_trans_iolength (gfc_code * code)
1324 stmtblock_t block;
1325 gfc_inquire *inq;
1326 tree dt;
1328 gfc_init_block (&block);
1330 set_error_locus (&block, &code->loc);
1332 inq = code->ext.inquire;
1334 /* First check that preconditions are met. */
1335 gcc_assert (inq != NULL);
1336 gcc_assert (inq->iolength != NULL);
1338 /* Connect to the iolength variable. */
1339 if (inq->iolength)
1340 set_parameter_ref (&block, ioparm_iolength, inq->iolength);
1342 /* Actual logic. */
1343 last_dt = IOLENGTH;
1344 dt = build_dt(&iocall_iolength, code);
1346 gfc_add_expr_to_block (&block, dt);
1348 return gfc_finish_block (&block);
1352 /* Translate a READ statement. */
1354 tree
1355 gfc_trans_read (gfc_code * code)
1358 last_dt = READ;
1359 return build_dt (&iocall_read, code);
1363 /* Translate a WRITE statement */
1365 tree
1366 gfc_trans_write (gfc_code * code)
1369 last_dt = WRITE;
1370 return build_dt (&iocall_write, code);
1374 /* Finish a data transfer statement. */
1376 tree
1377 gfc_trans_dt_end (gfc_code * code)
1379 tree function, tmp;
1380 stmtblock_t block;
1382 gfc_init_block (&block);
1384 switch (last_dt)
1386 case READ:
1387 function = iocall_read_done;
1388 break;
1390 case WRITE:
1391 function = iocall_write_done;
1392 break;
1394 case IOLENGTH:
1395 function = iocall_iolength_done;
1396 break;
1398 default:
1399 gcc_unreachable ();
1402 tmp = gfc_build_function_call (function, NULL);
1403 gfc_add_expr_to_block (&block, tmp);
1405 if (last_dt != IOLENGTH)
1407 gcc_assert (code->ext.dt != NULL);
1408 io_result (&block, code->ext.dt->err,
1409 code->ext.dt->end, code->ext.dt->eor);
1412 return gfc_finish_block (&block);
1415 static void
1416 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
1418 /* Given an array field in a derived type variable, generate the code
1419 for the loop that iterates over array elements, and the code that
1420 accesses those array elements. Use transfer_expr to generate code
1421 for transferring that element. Because elements may also be
1422 derived types, transfer_expr and transfer_array_component are mutually
1423 recursive. */
1425 static tree
1426 transfer_array_component (tree expr, gfc_component * cm)
1428 tree tmp;
1429 stmtblock_t body;
1430 stmtblock_t block;
1431 gfc_loopinfo loop;
1432 int n;
1433 gfc_ss *ss;
1434 gfc_se se;
1436 gfc_start_block (&block);
1437 gfc_init_se (&se, NULL);
1439 /* Create and initialize Scalarization Status. Unlike in
1440 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1441 care of this task, because we don't have a gfc_expr at hand.
1442 Build one manually, as in gfc_trans_subarray_assign. */
1444 ss = gfc_get_ss ();
1445 ss->type = GFC_SS_COMPONENT;
1446 ss->expr = NULL;
1447 ss->shape = gfc_get_shape (cm->as->rank);
1448 ss->next = gfc_ss_terminator;
1449 ss->data.info.dimen = cm->as->rank;
1450 ss->data.info.descriptor = expr;
1451 ss->data.info.data = gfc_conv_array_data (expr);
1452 ss->data.info.offset = gfc_conv_array_offset (expr);
1453 for (n = 0; n < cm->as->rank; n++)
1455 ss->data.info.dim[n] = n;
1456 ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1457 ss->data.info.stride[n] = gfc_index_one_node;
1459 mpz_init (ss->shape[n]);
1460 mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1461 cm->as->lower[n]->value.integer);
1462 mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1465 /* Once we got ss, we use scalarizer to create the loop. */
1467 gfc_init_loopinfo (&loop);
1468 gfc_add_ss_to_loop (&loop, ss);
1469 gfc_conv_ss_startstride (&loop);
1470 gfc_conv_loop_setup (&loop);
1471 gfc_mark_ss_chain_used (ss, 1);
1472 gfc_start_scalarized_body (&loop, &body);
1474 gfc_copy_loopinfo_to_se (&se, &loop);
1475 se.ss = ss;
1477 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1478 se.expr = expr;
1479 gfc_conv_tmp_array_ref (&se);
1481 /* Now se.expr contains an element of the array. Take the address and pass
1482 it to the IO routines. */
1483 tmp = gfc_build_addr_expr (NULL, se.expr);
1484 transfer_expr (&se, &cm->ts, tmp);
1486 /* We are done now with the loop body. Wrap up the scalarizer and
1487 return. */
1489 gfc_add_block_to_block (&body, &se.pre);
1490 gfc_add_block_to_block (&body, &se.post);
1492 gfc_trans_scalarizing_loops (&loop, &body);
1494 gfc_add_block_to_block (&block, &loop.pre);
1495 gfc_add_block_to_block (&block, &loop.post);
1497 for (n = 0; n < cm->as->rank; n++)
1498 mpz_clear (ss->shape[n]);
1499 gfc_free (ss->shape);
1501 gfc_cleanup_loop (&loop);
1503 return gfc_finish_block (&block);
1506 /* Generate the call for a scalar transfer node. */
1508 static void
1509 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1511 tree args, tmp, function, arg2, field, expr;
1512 gfc_component *c;
1513 int kind;
1515 kind = ts->kind;
1516 function = NULL;
1517 arg2 = NULL;
1519 switch (ts->type)
1521 case BT_INTEGER:
1522 arg2 = build_int_cst (NULL_TREE, kind);
1523 function = iocall_x_integer;
1524 break;
1526 case BT_REAL:
1527 arg2 = build_int_cst (NULL_TREE, kind);
1528 function = iocall_x_real;
1529 break;
1531 case BT_COMPLEX:
1532 arg2 = build_int_cst (NULL_TREE, kind);
1533 function = iocall_x_complex;
1534 break;
1536 case BT_LOGICAL:
1537 arg2 = build_int_cst (NULL_TREE, kind);
1538 function = iocall_x_logical;
1539 break;
1541 case BT_CHARACTER:
1542 if (se->string_length)
1543 arg2 = se->string_length;
1544 else
1546 tmp = gfc_build_indirect_ref (addr_expr);
1547 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1548 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1550 function = iocall_x_character;
1551 break;
1553 case BT_DERIVED:
1554 /* Recurse into the elements of the derived type. */
1555 expr = gfc_evaluate_now (addr_expr, &se->pre);
1556 expr = gfc_build_indirect_ref (expr);
1558 for (c = ts->derived->components; c; c = c->next)
1560 field = c->backend_decl;
1561 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
1563 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1564 NULL_TREE);
1566 if (c->dimension)
1568 tmp = transfer_array_component (tmp, c);
1569 gfc_add_expr_to_block (&se->pre, tmp);
1571 else
1573 if (!c->pointer)
1574 tmp = gfc_build_addr_expr (NULL, tmp);
1575 transfer_expr (se, &c->ts, tmp);
1578 return;
1580 default:
1581 internal_error ("Bad IO basetype (%d)", ts->type);
1584 args = gfc_chainon_list (NULL_TREE, addr_expr);
1585 args = gfc_chainon_list (args, arg2);
1587 tmp = gfc_build_function_call (function, args);
1588 gfc_add_expr_to_block (&se->pre, tmp);
1589 gfc_add_block_to_block (&se->pre, &se->post);
1594 /* Generate a call to pass an array descriptor to the IO library. The
1595 array should be of one of the intrinsic types. */
1597 static void
1598 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1600 tree args, tmp, charlen_arg;
1602 if (ts->type == BT_CHARACTER)
1603 charlen_arg = se->string_length;
1604 else
1605 charlen_arg = build_int_cstu (NULL_TREE, 0);
1607 args = gfc_chainon_list (NULL_TREE, addr_expr);
1608 args = gfc_chainon_list (args, charlen_arg);
1609 tmp = gfc_build_function_call (iocall_x_array, args);
1610 gfc_add_expr_to_block (&se->pre, tmp);
1611 gfc_add_block_to_block (&se->pre, &se->post);
1615 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1617 tree
1618 gfc_trans_transfer (gfc_code * code)
1620 stmtblock_t block, body;
1621 gfc_loopinfo loop;
1622 gfc_expr *expr;
1623 gfc_ss *ss;
1624 gfc_se se;
1625 tree tmp;
1627 gfc_start_block (&block);
1628 gfc_init_block (&body);
1630 expr = code->expr;
1631 ss = gfc_walk_expr (expr);
1633 gfc_init_se (&se, NULL);
1635 if (ss == gfc_ss_terminator)
1637 gfc_conv_expr_reference (&se, expr);
1638 transfer_expr (&se, &expr->ts, se.expr);
1640 else if (expr->ts.type == BT_DERIVED)
1642 /* Initialize the scalarizer. */
1643 gfc_init_loopinfo (&loop);
1644 gfc_add_ss_to_loop (&loop, ss);
1646 /* Initialize the loop. */
1647 gfc_conv_ss_startstride (&loop);
1648 gfc_conv_loop_setup (&loop);
1650 /* The main loop body. */
1651 gfc_mark_ss_chain_used (ss, 1);
1652 gfc_start_scalarized_body (&loop, &body);
1654 gfc_copy_loopinfo_to_se (&se, &loop);
1655 se.ss = ss;
1657 gfc_conv_expr_reference (&se, expr);
1658 transfer_expr (&se, &expr->ts, se.expr);
1660 else
1662 /* Pass the array descriptor to the library. */
1663 gfc_conv_expr_descriptor (&se, expr, ss);
1664 tmp = gfc_build_addr_expr (NULL, se.expr);
1665 transfer_array_desc (&se, &expr->ts, tmp);
1668 gfc_add_block_to_block (&body, &se.pre);
1669 gfc_add_block_to_block (&body, &se.post);
1671 if (se.ss == NULL)
1672 tmp = gfc_finish_block (&body);
1673 else
1675 gcc_assert (se.ss == gfc_ss_terminator);
1676 gfc_trans_scalarizing_loops (&loop, &body);
1678 gfc_add_block_to_block (&loop.pre, &loop.post);
1679 tmp = gfc_finish_block (&loop.pre);
1680 gfc_cleanup_loop (&loop);
1683 gfc_add_expr_to_block (&block, tmp);
1685 return gfc_finish_block (&block);
1688 #include "gt-fortran-trans-io.h"