]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/trans-io.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
alpha.c (va_list_skip_additions): Only define if TARGET_ABI_OSF.
[thirdparty/gcc.git] / gcc / fortran / trans-io.c
CommitLineData
6de9cd9a 1/* IO Code translation/library interface
ec378180 2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
6de9cd9a
DN		 3 Contributed by Paul Brook
4
9fc4d79b 5This file is part of GCC.
6de9cd9a 6
9fc4d79b
TS		 7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 2, or (at your option) any later
10version.
6de9cd9a 11
9fc4d79b
TS		 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
6de9cd9a
DN		 16
17You should have received a copy of the GNU General Public License
9fc4d79b
TS		 18along with GCC; see the file COPYING. If not, write to the Free
19Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2002111-1307, USA. */
6de9cd9a
DN		 21
22
23#include "config.h"
24#include "system.h"
25#include "coretypes.h"
26#include "tree.h"
eadf906f 27#include "tree-gimple.h"
6de9cd9a
DN		 28#include "ggc.h"
29#include "toplev.h"
30#include "real.h"
6de9cd9a
DN		 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"
37
38
6de9cd9a
DN		 39/* Members of the ioparm structure. */
40
41static GTY(()) tree ioparm_unit;
42static GTY(()) tree ioparm_err;
43static GTY(()) tree ioparm_end;
44static GTY(()) tree ioparm_eor;
45static GTY(()) tree ioparm_list_format;
46static GTY(()) tree ioparm_library_return;
47static GTY(()) tree ioparm_iostat;
48static GTY(()) tree ioparm_exist;
49static GTY(()) tree ioparm_opened;
50static GTY(()) tree ioparm_number;
51static GTY(()) tree ioparm_named;
52static GTY(()) tree ioparm_rec;
53static GTY(()) tree ioparm_nextrec;
54static GTY(()) tree ioparm_size;
55static GTY(()) tree ioparm_recl_in;
56static GTY(()) tree ioparm_recl_out;
8750f9cd 57static GTY(()) tree ioparm_iolength;
6de9cd9a
DN		 58static GTY(()) tree ioparm_file;
59static GTY(()) tree ioparm_file_len;
60static GTY(()) tree ioparm_status;
61static GTY(()) tree ioparm_status_len;
62static GTY(()) tree ioparm_access;
63static GTY(()) tree ioparm_access_len;
64static GTY(()) tree ioparm_form;
65static GTY(()) tree ioparm_form_len;
66static GTY(()) tree ioparm_blank;
67static GTY(()) tree ioparm_blank_len;
68static GTY(()) tree ioparm_position;
69static GTY(()) tree ioparm_position_len;
70static GTY(()) tree ioparm_action;
71static GTY(()) tree ioparm_action_len;
72static GTY(()) tree ioparm_delim;
73static GTY(()) tree ioparm_delim_len;
74static GTY(()) tree ioparm_pad;
75static GTY(()) tree ioparm_pad_len;
76static GTY(()) tree ioparm_format;
77static GTY(()) tree ioparm_format_len;
78static GTY(()) tree ioparm_advance;
79static GTY(()) tree ioparm_advance_len;
80static GTY(()) tree ioparm_name;
81static GTY(()) tree ioparm_name_len;
82static GTY(()) tree ioparm_internal_unit;
83static GTY(()) tree ioparm_internal_unit_len;
84static GTY(()) tree ioparm_sequential;
85static GTY(()) tree ioparm_sequential_len;
86static GTY(()) tree ioparm_direct;
87static GTY(()) tree ioparm_direct_len;
88static GTY(()) tree ioparm_formatted;
89static GTY(()) tree ioparm_formatted_len;
90static GTY(()) tree ioparm_unformatted;
91static GTY(()) tree ioparm_unformatted_len;
92static GTY(()) tree ioparm_read;
93static GTY(()) tree ioparm_read_len;
94static GTY(()) tree ioparm_write;
95static GTY(()) tree ioparm_write_len;
96static GTY(()) tree ioparm_readwrite;
97static GTY(()) tree ioparm_readwrite_len;
98static GTY(()) tree ioparm_namelist_name;
99static GTY(()) tree ioparm_namelist_name_len;
100static GTY(()) tree ioparm_namelist_read_mode;
101
102/* The global I/O variables */
103
104static GTY(()) tree ioparm_var;
105static GTY(()) tree locus_file;
106static GTY(()) tree locus_line;
107
108
109/* Library I/O subroutines */
110
111static GTY(()) tree iocall_read;
112static GTY(()) tree iocall_read_done;
113static GTY(()) tree iocall_write;
114static GTY(()) tree iocall_write_done;
115static GTY(()) tree iocall_x_integer;
116static GTY(()) tree iocall_x_logical;
117static GTY(()) tree iocall_x_character;
118static GTY(()) tree iocall_x_real;
119static GTY(()) tree iocall_x_complex;
120static GTY(()) tree iocall_open;
121static GTY(()) tree iocall_close;
122static GTY(()) tree iocall_inquire;
8750f9cd
JB		 123static GTY(()) tree iocall_iolength;
124static GTY(()) tree iocall_iolength_done;
6de9cd9a
DN		 125static GTY(()) tree iocall_rewind;
126static GTY(()) tree iocall_backspace;
127static GTY(()) tree iocall_endfile;
128static GTY(()) tree iocall_set_nml_val_int;
129static GTY(()) tree iocall_set_nml_val_float;
130static GTY(()) tree iocall_set_nml_val_char;
131static GTY(()) tree iocall_set_nml_val_complex;
132static GTY(()) tree iocall_set_nml_val_log;
133
134/* Variable for keeping track of what the last data transfer statement
135 was. Used for deciding which subroutine to call when the data
f7b529fa 136 transfer is complete. */
8750f9cd 137static enum { READ, WRITE, IOLENGTH } last_dt;
6de9cd9a
DN		 138
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)
143
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, \
b8d5e926 150 get_identifier (stringize(name) "_len"), gfc_charlen_type_node)
6de9cd9a
DN		 151
152
153/* Create function decls for IO library functions. */
154
155void
156gfc_build_io_library_fndecls (void)
157{
e2cad04b
RH		 158 tree gfc_int4_type_node;
159 tree gfc_pint4_type_node;
6de9cd9a
DN		 160 tree ioparm_type;
161
e2cad04b 162 gfc_int4_type_node = gfc_get_int_type (4);
6de9cd9a
DN		 163 gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
164
e2cad04b
RH		 165 /* Build the st_parameter structure. Information associated with I/O
166 calls are transferred here. This must match the one defined in the
f7b529fa 167 library exactly. */
6de9cd9a
DN		 168
169 ioparm_type = make_node (RECORD_TYPE);
170 TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm");
171
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);
178
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);
b8d5e926 184 ADD_FIELD (rec, gfc_int4_type_node);
6de9cd9a
DN		 185 ADD_FIELD (nextrec, gfc_pint4_type_node);
186 ADD_FIELD (size, gfc_pint4_type_node);
187
b8d5e926 188 ADD_FIELD (recl_in, gfc_int4_type_node);
6de9cd9a
DN		 189 ADD_FIELD (recl_out, gfc_pint4_type_node);
190
8750f9cd
JB		 191 ADD_FIELD (iolength, gfc_pint4_type_node);
192
6de9cd9a
DN		 193 ADD_STRING (file);
194 ADD_STRING (status);
195
196 ADD_STRING (access);
197 ADD_STRING (form);
198 ADD_STRING (blank);
199 ADD_STRING (position);
200 ADD_STRING (action);
201 ADD_STRING (delim);
202 ADD_STRING (pad);
203 ADD_STRING (format);
204 ADD_STRING (advance);
205 ADD_STRING (name);
206 ADD_STRING (internal_unit);
207 ADD_STRING (sequential);
208
209 ADD_STRING (direct);
210 ADD_STRING (formatted);
211 ADD_STRING (unformatted);
212 ADD_STRING (read);
213 ADD_STRING (write);
214 ADD_STRING (readwrite);
215
216 ADD_STRING (namelist_name);
217 ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
218
219 gfc_finish_type (ioparm_type);
220
221 ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
222 ioparm_type);
223 DECL_EXTERNAL (ioparm_var) = 1;
224 TREE_PUBLIC (ioparm_var) = 1;
225
226 locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
227 gfc_int4_type_node);
228 DECL_EXTERNAL (locus_line) = 1;
229 TREE_PUBLIC (locus_line) = 1;
230
231 locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
232 pchar_type_node);
233 DECL_EXTERNAL (locus_file) = 1;
234 TREE_PUBLIC (locus_file) = 1;
235
236 /* Define the transfer functions. */
237
238 iocall_x_integer =
239 gfc_build_library_function_decl (get_identifier
240 (PREFIX("transfer_integer")),
241 void_type_node, 2, pvoid_type_node,
242 gfc_int4_type_node);
243
244 iocall_x_logical =
245 gfc_build_library_function_decl (get_identifier
246 (PREFIX("transfer_logical")),
247 void_type_node, 2, pvoid_type_node,
248 gfc_int4_type_node);
249
250 iocall_x_character =
251 gfc_build_library_function_decl (get_identifier
252 (PREFIX("transfer_character")),
253 void_type_node, 2, pvoid_type_node,
254 gfc_int4_type_node);
255
256 iocall_x_real =
257 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
258 void_type_node, 2,
259 pvoid_type_node, gfc_int4_type_node);
260
261 iocall_x_complex =
262 gfc_build_library_function_decl (get_identifier
263 (PREFIX("transfer_complex")),
264 void_type_node, 2, pvoid_type_node,
265 gfc_int4_type_node);
266
267 /* Library entry points */
268
269 iocall_read =
270 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
271 void_type_node, 0);
272
273 iocall_write =
274 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
275 void_type_node, 0);
276 iocall_open =
277 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
278 void_type_node, 0);
279
280 iocall_close =
281 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
282 void_type_node, 0);
283
284 iocall_inquire =
285 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
286 gfc_int4_type_node, 0);
287
8750f9cd
JB		 288 iocall_iolength =
289 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
290 void_type_node, 0);
291
6de9cd9a
DN		 292 iocall_rewind =
293 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
294 gfc_int4_type_node, 0);
295
296 iocall_backspace =
297 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
298 gfc_int4_type_node, 0);
299
300 iocall_endfile =
301 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
302 gfc_int4_type_node, 0);
303 /* Library helpers */
304
305 iocall_read_done =
306 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
307 gfc_int4_type_node, 0);
308
309 iocall_write_done =
310 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
311 gfc_int4_type_node, 0);
8750f9cd
JB		 312
313 iocall_iolength_done =
314 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
315 gfc_int4_type_node, 0);
316
6de9cd9a
DN		 317 iocall_set_nml_val_int =
318 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
319 void_type_node, 4,
320 pvoid_type_node, pvoid_type_node,
321 gfc_int4_type_node,gfc_int4_type_node);
322
323 iocall_set_nml_val_float =
324 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
325 void_type_node, 4,
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")),
3bc268e6 330 void_type_node, 5,
6de9cd9a 331 pvoid_type_node, pvoid_type_node,
3bc268e6 332 gfc_int4_type_node, gfc_int4_type_node,
d7177ab2 333 gfc_charlen_type_node);
6de9cd9a
DN		 334 iocall_set_nml_val_complex =
335 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
336 void_type_node, 4,
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")),
341 void_type_node, 4,
342 pvoid_type_node, pvoid_type_node,
343 gfc_int4_type_node,gfc_int4_type_node);
344
345}
346
347
348/* Generate code to store an non-string I/O parameter into the
349 ioparm structure. This is a pass by value. */
350
351static void
352set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
353{
354 gfc_se se;
355 tree tmp;
356
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);
360
923ab88c 361 tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
6de9cd9a
DN		 362 gfc_add_modify_expr (block, tmp, se.expr);
363}
364
365
366/* Generate code to store an non-string I/O parameter into the
367 ioparm structure. This is pass by reference. */
368
369static void
370set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
371{
372 gfc_se se;
373 tree tmp;
374
375 gfc_init_se (&se, NULL);
376 se.want_pointer = 1;
377
378 gfc_conv_expr_type (&se, e, TREE_TYPE (var));
379 gfc_add_block_to_block (block, &se.pre);
380
923ab88c 381 tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
6de9cd9a
DN		 382 gfc_add_modify_expr (block, tmp, se.expr);
383}
384
385
386/* Generate code to store a string and its length into the
387 ioparm structure. */
388
389static void
390set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
391 tree var_len, gfc_expr * e)
392{
393 gfc_se se;
394 tree tmp;
395 tree msg;
396 tree io;
397 tree len;
398
399 gfc_init_se (&se, NULL);
6de9cd9a 400
923ab88c
TS		 401 io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
402 len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
403 NULL_TREE);
6de9cd9a 404
7ab92584 405 /* Integer variable assigned a format label. */
6de9cd9a
DN		 406 if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
407 {
ce2df7c6 408 gfc_conv_label_variable (&se, e);
6de9cd9a 409 msg =
95638988 410 gfc_build_cstring_const ("Assigned label is not a format label");
6de9cd9a 411 tmp = GFC_DECL_STRING_LEN (se.expr);
923ab88c
TS		 412 tmp = build2 (LE_EXPR, boolean_type_node,
413 tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
6de9cd9a
DN		 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));
417 }
418 else
419 {
ce2df7c6 420 gfc_conv_expr (&se, e);
6de9cd9a 421 gfc_conv_string_parameter (&se);
7ab92584 422 gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
6de9cd9a
DN		 423 gfc_add_modify_expr (&se.pre, len, se.string_length);
424 }
425
426 gfc_add_block_to_block (block, &se.pre);
427 gfc_add_block_to_block (postblock, &se.post);
428
429}
430
431
432/* Set a member of the ioparm structure to one. */
433static void
434set_flag (stmtblock_t *block, tree var)
435{
7ab92584 436 tree tmp, type = TREE_TYPE (var);
6de9cd9a 437
923ab88c 438 tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
7ab92584 439 gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
6de9cd9a
DN		 440}
441
442
443/* Add a case to a IO-result switch. */
444
445static void
446add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
447{
448 tree tmp, value;
449
450 if (label == NULL)
451 return; /* No label, no case */
452
7d60be94 453 value = build_int_cst (NULL_TREE, label_value);
6de9cd9a
DN		 454
455 /* Make a backend label for this case. */
c006df4e 456 tmp = gfc_build_label_decl (NULL_TREE);
6de9cd9a
DN		 457
458 /* And the case itself. */
923ab88c 459 tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
6de9cd9a
DN		 460 gfc_add_expr_to_block (body, tmp);
461
462 /* Jump to the label. */
463 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
464 gfc_add_expr_to_block (body, tmp);
465}
466
467
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. */
473
474static void
475io_result (stmtblock_t * block, gfc_st_label * err_label,
476 gfc_st_label * end_label, gfc_st_label * eor_label)
477{
478 stmtblock_t body;
479 tree tmp, rc;
480
481 /* If no labels are specified, ignore the result instead
482 of building an empty switch. */
483 if (err_label == NULL
484 && end_label == NULL
485 && eor_label == NULL)
486 return;
487
488 /* Build a switch statement. */
489 gfc_start_block (&body);
490
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);
496
497 tmp = gfc_finish_block (&body);
498
923ab88c
TS		 499 rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
500 ioparm_library_return, NULL_TREE);
6de9cd9a 501
923ab88c 502 tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
6de9cd9a
DN		 503
504 gfc_add_expr_to_block (block, tmp);
505}
506
507
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. */
510
511static void
512set_error_locus (stmtblock_t * block, locus * where)
513{
514 gfc_file *f;
515 tree tmp;
516 int line;
517
d4fa05b9 518 f = where->lb->file;
95638988 519 tmp = gfc_build_cstring_const (f->filename);
6de9cd9a
DN		 520
521 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
522 gfc_add_modify_expr (block, locus_file, tmp);
523
c8cc8542
PB		 524#ifdef USE_MAPPED_LOCATION
525 line = LOCATION_LINE (where->lb->location);
526#else
d4fa05b9 527 line = where->lb->linenum;
c8cc8542 528#endif
7d60be94 529 gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line));
6de9cd9a
DN		 530}
531
532
533/* Translate an OPEN statement. */
534
535tree
536gfc_trans_open (gfc_code * code)
537{
538 stmtblock_t block, post_block;
539 gfc_open *p;
540 tree tmp;
541
542 gfc_init_block (&block);
543 gfc_init_block (&post_block);
544
545 set_error_locus (&block, &code->loc);
546 p = code->ext.open;
547
548 if (p->unit)
549 set_parameter_value (&block, ioparm_unit, p->unit);
550
551 if (p->file)
552 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
553
554 if (p->status)
555 set_string (&block, &post_block, ioparm_status,
556 ioparm_status_len, p->status);
557
558 if (p->access)
559 set_string (&block, &post_block, ioparm_access,
560 ioparm_access_len, p->access);
561
562 if (p->form)
563 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
564
565 if (p->recl)
566 set_parameter_value (&block, ioparm_recl_in, p->recl);
567
568 if (p->blank)
569 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
570 p->blank);
571
572 if (p->position)
573 set_string (&block, &post_block, ioparm_position,
574 ioparm_position_len, p->position);
575
576 if (p->action)
577 set_string (&block, &post_block, ioparm_action,
578 ioparm_action_len, p->action);
579
580 if (p->delim)
581 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
582 p->delim);
583
584 if (p->pad)
585 set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
586
587 if (p->iostat)
588 set_parameter_ref (&block, ioparm_iostat, p->iostat);
589
590 if (p->err)
591 set_flag (&block, ioparm_err);
592
593 tmp = gfc_build_function_call (iocall_open, NULL_TREE);
594 gfc_add_expr_to_block (&block, tmp);
595
596 gfc_add_block_to_block (&block, &post_block);
597
598 io_result (&block, p->err, NULL, NULL);
599
600 return gfc_finish_block (&block);
601}
602
603
604/* Translate a CLOSE statement. */
605
606tree
607gfc_trans_close (gfc_code * code)
608{
609 stmtblock_t block, post_block;
610 gfc_close *p;
611 tree tmp;
612
613 gfc_init_block (&block);
614 gfc_init_block (&post_block);
615
616 set_error_locus (&block, &code->loc);
617 p = code->ext.close;
618
619 if (p->unit)
620 set_parameter_value (&block, ioparm_unit, p->unit);
621
622 if (p->status)
623 set_string (&block, &post_block, ioparm_status,
624 ioparm_status_len, p->status);
625
626 if (p->iostat)
627 set_parameter_ref (&block, ioparm_iostat, p->iostat);
628
629 if (p->err)
630 set_flag (&block, ioparm_err);
631
632 tmp = gfc_build_function_call (iocall_close, NULL_TREE);
633 gfc_add_expr_to_block (&block, tmp);
634
635 gfc_add_block_to_block (&block, &post_block);
636
637 io_result (&block, p->err, NULL, NULL);
638
639 return gfc_finish_block (&block);
640}
641
642
643/* Common subroutine for building a file positioning statement. */
644
645static tree
646build_filepos (tree function, gfc_code * code)
647{
648 stmtblock_t block;
649 gfc_filepos *p;
650 tree tmp;
651
652 p = code->ext.filepos;
653
654 gfc_init_block (&block);
655
656 set_error_locus (&block, &code->loc);
657
658 if (p->unit)
659 set_parameter_value (&block, ioparm_unit, p->unit);
660
661 if (p->iostat)
662 set_parameter_ref (&block, ioparm_iostat, p->iostat);
663
664 if (p->err)
665 set_flag (&block, ioparm_err);
666
667 tmp = gfc_build_function_call (function, NULL);
668 gfc_add_expr_to_block (&block, tmp);
669
670 io_result (&block, p->err, NULL, NULL);
671
672 return gfc_finish_block (&block);
673}
674
675
676/* Translate a BACKSPACE statement. */
677
678tree
679gfc_trans_backspace (gfc_code * code)
680{
681
682 return build_filepos (iocall_backspace, code);
683}
684
685
686/* Translate an ENDFILE statement. */
687
688tree
689gfc_trans_endfile (gfc_code * code)
690{
691
692 return build_filepos (iocall_endfile, code);
693}
694
695
696/* Translate a REWIND statement. */
697
698tree
699gfc_trans_rewind (gfc_code * code)
700{
701
702 return build_filepos (iocall_rewind, code);
703}
704
705
706/* Translate the non-IOLENGTH form of an INQUIRE statement. */
707
708tree
709gfc_trans_inquire (gfc_code * code)
710{
711 stmtblock_t block, post_block;
712 gfc_inquire *p;
713 tree tmp;
714
715 gfc_init_block (&block);
716 gfc_init_block (&post_block);
717
718 set_error_locus (&block, &code->loc);
719 p = code->ext.inquire;
720
721 if (p->unit)
722 set_parameter_value (&block, ioparm_unit, p->unit);
723
724 if (p->file)
725 set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
726
727 if (p->iostat)
728 set_parameter_ref (&block, ioparm_iostat, p->iostat);
729
730 if (p->exist)
731 set_parameter_ref (&block, ioparm_exist, p->exist);
732
733 if (p->opened)
734 set_parameter_ref (&block, ioparm_opened, p->opened);
735
736 if (p->number)
737 set_parameter_ref (&block, ioparm_number, p->number);
738
739 if (p->named)
740 set_parameter_ref (&block, ioparm_named, p->named);
741
742 if (p->name)
743 set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
744
745 if (p->access)
746 set_string (&block, &post_block, ioparm_access,
747 ioparm_access_len, p->access);
748
749 if (p->sequential)
750 set_string (&block, &post_block, ioparm_sequential,
751 ioparm_sequential_len, p->sequential);
752
753 if (p->direct)
754 set_string (&block, &post_block, ioparm_direct,
755 ioparm_direct_len, p->direct);
756
757 if (p->form)
758 set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
759
760 if (p->formatted)
761 set_string (&block, &post_block, ioparm_formatted,
762 ioparm_formatted_len, p->formatted);
763
764 if (p->unformatted)
765 set_string (&block, &post_block, ioparm_unformatted,
766 ioparm_unformatted_len, p->unformatted);
767
768 if (p->recl)
769 set_parameter_ref (&block, ioparm_recl_out, p->recl);
770
771 if (p->nextrec)
772 set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
773
774 if (p->blank)
775 set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
776 p->blank);
777
778 if (p->position)
779 set_string (&block, &post_block, ioparm_position,
780 ioparm_position_len, p->position);
781
782 if (p->action)
783 set_string (&block, &post_block, ioparm_action,
784 ioparm_action_len, p->action);
785
786 if (p->read)
787 set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
788
789 if (p->write)
790 set_string (&block, &post_block, ioparm_write,
791 ioparm_write_len, p->write);
792
793 if (p->readwrite)
794 set_string (&block, &post_block, ioparm_readwrite,
795 ioparm_readwrite_len, p->readwrite);
796
797 if (p->delim)
798 set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
799 p->delim);
800
dae24534
BD		 801 if (p->pad)
802 set_string (&block, &post_block, ioparm_pad, ioparm_pad_len,
803 p->pad);
804
6de9cd9a
DN		 805 if (p->err)
806 set_flag (&block, ioparm_err);
807
808 tmp = gfc_build_function_call (iocall_inquire, NULL);
809 gfc_add_expr_to_block (&block, tmp);
810
811 gfc_add_block_to_block (&block, &post_block);
812
813 io_result (&block, p->err, NULL, NULL);
814
815 return gfc_finish_block (&block);
816}
817
818
6de9cd9a 819static gfc_expr *
cb9e4f55 820gfc_new_nml_name_expr (const char * name)
6de9cd9a
DN		 821{
822 gfc_expr * nml_name;
823 nml_name = gfc_get_expr();
824 nml_name->ref = NULL;
825 nml_name->expr_type = EXPR_CONSTANT;
9d64df18 826 nml_name->ts.kind = gfc_default_character_kind;
6de9cd9a
DN		 827 nml_name->ts.type = BT_CHARACTER;
828 nml_name->value.character.length = strlen(name);
cb9e4f55
TS		 829 nml_name->value.character.string = gfc_getmem (strlen (name) + 1);
830 strcpy (nml_name->value.character.string, name);
6de9cd9a
DN		 831
832 return nml_name;
833}
834
835static gfc_expr *
836get_new_var_expr(gfc_symbol * sym)
837{
838 gfc_expr * nml_var;
839
840 nml_var = gfc_get_expr();
841 nml_var->expr_type = EXPR_VARIABLE;
842 nml_var->ts = sym->ts;
843 if (sym->as)
844 nml_var->rank = sym->as->rank;
845 nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
846 nml_var->symtree->n.sym = sym;
847 nml_var->where = sym->declared_at;
848 sym->attr.referenced = 1;
849
850 return nml_var;
851}
852
3bc268e6
VL		 853/* For a scalar variable STRING whose address is ADDR_EXPR, generate a
854 call to iocall_set_nml_val. For derived type variable, recursively
855 generate calls to iocall_set_nml_val for each leaf field. The leafs
856 have no names -- their STRING field is null, and are interpreted by
857 the run-time library as having only the value, as in the example:
858
859 &foo bzz=1,2,3,4,5/
860
861 Note that the first output field appears after the name of the
862 variable, not of the field name. This causes a little complication
f7b529fa 863 documented below. */
3bc268e6
VL		 864
865static void
866transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr,
867 tree string, tree string_length)
868{
869 tree tmp, args, arg2;
870 tree expr;
871
6e45f57b 872 gcc_assert (POINTER_TYPE_P (TREE_TYPE (addr_expr)));
3bc268e6
VL		 873
874 if (ts->type == BT_DERIVED)
875 {
876 gfc_component *c;
877 expr = gfc_build_indirect_ref (addr_expr);
878
879 for (c = ts->derived->components; c; c = c->next)
880 {
881 tree field = c->backend_decl;
6e45f57b 882 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
923ab88c
TS		 883 tmp = build3 (COMPONENT_REF, TREE_TYPE (field),
884 expr, field, NULL_TREE);
3bc268e6
VL		 885
886 if (c->dimension)
887 gfc_todo_error ("NAMELIST IO of array in derived type");
888 if (!c->pointer)
889 tmp = gfc_build_addr_expr (NULL, tmp);
890 transfer_namelist_element (block, &c->ts, tmp, string, string_length);
891
892 /* The first output field bears the name of the topmost
893 derived type variable. All other fields are anonymous
894 and appear with nulls in their string and string_length
895 fields. After the first use, we set string and
f7b529fa 896 string_length to null. */
3bc268e6
VL		 897 string = null_pointer_node;
898 string_length = integer_zero_node;
899 }
900
901 return;
902 }
903
904 args = gfc_chainon_list (NULL_TREE, addr_expr);
905 args = gfc_chainon_list (args, string);
906 args = gfc_chainon_list (args, string_length);
7d60be94 907 arg2 = build_int_cst (gfc_array_index_type, ts->kind);
3bc268e6
VL		 908 args = gfc_chainon_list (args,arg2);
909
910 switch (ts->type)
911 {
912 case BT_INTEGER:
913 tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
914 break;
915
916 case BT_CHARACTER:
917 expr = gfc_build_indirect_ref (addr_expr);
6e45f57b 918 gcc_assert (TREE_CODE (TREE_TYPE (expr)) == ARRAY_TYPE);
3bc268e6
VL		 919 args = gfc_chainon_list (args,
920 TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (expr))));
921 tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
922 break;
923
924 case BT_REAL:
925 tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
926 break;
927
928 case BT_LOGICAL:
929 tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
930 break;
931
932 case BT_COMPLEX:
933 tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
934 break;
935
936 default :
937 internal_error ("Bad namelist IO basetype (%d)", ts->type);
938 }
939
940 gfc_add_expr_to_block (block, tmp);
941}
6de9cd9a
DN		 942
943/* Create a data transfer statement. Not all of the fields are valid
944 for both reading and writing, but improper use has been filtered
945 out by now. */
946
947static tree
948build_dt (tree * function, gfc_code * code)
949{
950 stmtblock_t block, post_block;
951 gfc_dt *dt;
3bc268e6 952 tree tmp;
6de9cd9a 953 gfc_expr *nmlname, *nmlvar;
3bc268e6 954 gfc_namelist *nml;
6de9cd9a 955 gfc_se se,se2;
6de9cd9a
DN		 956
957 gfc_init_block (&block);
958 gfc_init_block (&post_block);
959
960 set_error_locus (&block, &code->loc);
961 dt = code->ext.dt;
962
6e45f57b 963 gcc_assert (dt != NULL);
8750f9cd 964
6de9cd9a
DN		 965 if (dt->io_unit)
966 {
967 if (dt->io_unit->ts.type == BT_CHARACTER)
968 {
969 set_string (&block, &post_block, ioparm_internal_unit,
970 ioparm_internal_unit_len, dt->io_unit);
971 }
972 else
973 set_parameter_value (&block, ioparm_unit, dt->io_unit);
974 }
975
976 if (dt->rec)
977 set_parameter_value (&block, ioparm_rec, dt->rec);
978
979 if (dt->advance)
980 set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
981 dt->advance);
982
983 if (dt->format_expr)
984 set_string (&block, &post_block, ioparm_format, ioparm_format_len,
985 dt->format_expr);
986
987 if (dt->format_label)
988 {
989 if (dt->format_label == &format_asterisk)
990 set_flag (&block, ioparm_list_format);
991 else
992 set_string (&block, &post_block, ioparm_format,
993 ioparm_format_len, dt->format_label->format);
994 }
995
996 if (dt->iostat)
997 set_parameter_ref (&block, ioparm_iostat, dt->iostat);
998
999 if (dt->size)
1000 set_parameter_ref (&block, ioparm_size, dt->size);
1001
1002 if (dt->err)
1003 set_flag (&block, ioparm_err);
1004
1005 if (dt->eor)
1006 set_flag(&block, ioparm_eor);
1007
1008 if (dt->end)
1009 set_flag(&block, ioparm_end);
1010
1011 if (dt->namelist)
1012 {
1013 if (dt->format_expr || dt->format_label)
1014 fatal_error("A format cannot be specified with a namelist");
1015
1016 nmlname = gfc_new_nml_name_expr(dt->namelist->name);
1017
1018 set_string (&block, &post_block, ioparm_namelist_name,
1019 ioparm_namelist_name_len, nmlname);
1020
1021 if (last_dt == READ)
1022 set_flag (&block, ioparm_namelist_read_mode);
1023
3bc268e6
VL		 1024 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1025 {
1026 gfc_init_se (&se, NULL);
1027 gfc_init_se (&se2, NULL);
1028 nmlvar = get_new_var_expr (nml->sym);
1029 nmlname = gfc_new_nml_name_expr (nml->sym->name);
1030 gfc_conv_expr_reference (&se2, nmlname);
1031 gfc_conv_expr_reference (&se, nmlvar);
1032 gfc_evaluate_now (se.expr, &se.pre);
1033
1034 transfer_namelist_element (&block, &nml->sym->ts, se.expr,
1035 se2.expr, se2.string_length);
1036 }
6de9cd9a
DN		 1037 }
1038
1039 tmp = gfc_build_function_call (*function, NULL_TREE);
1040 gfc_add_expr_to_block (&block, tmp);
1041
1042 gfc_add_block_to_block (&block, &post_block);
1043
1044 return gfc_finish_block (&block);
1045}
1046
1047
8750f9cd
JB		 1048/* Translate the IOLENGTH form of an INQUIRE statement. We treat
1049 this as a third sort of data transfer statement, except that
e7dc5b4f 1050 lengths are summed instead of actually transferring any data. */
8750f9cd
JB		 1051
1052tree
1053gfc_trans_iolength (gfc_code * code)
1054{
1055 stmtblock_t block;
1056 gfc_inquire *inq;
1057 tree dt;
1058
1059 gfc_init_block (&block);
1060
1061 set_error_locus (&block, &code->loc);
1062
1063 inq = code->ext.inquire;
1064
1065 /* First check that preconditions are met. */
6e45f57b
PB		 1066 gcc_assert (inq != NULL);
1067 gcc_assert (inq->iolength != NULL);
8750f9cd
JB		 1068
1069 /* Connect to the iolength variable. */
1070 if (inq->iolength)
1071 set_parameter_ref (&block, ioparm_iolength, inq->iolength);
1072
1073 /* Actual logic. */
1074 last_dt = IOLENGTH;
1075 dt = build_dt(&iocall_iolength, code);
1076
1077 gfc_add_expr_to_block (&block, dt);
1078
1079 return gfc_finish_block (&block);
1080}
1081
1082
6de9cd9a
DN		 1083/* Translate a READ statement. */
1084
1085tree
1086gfc_trans_read (gfc_code * code)
1087{
1088
1089 last_dt = READ;
1090 return build_dt (&iocall_read, code);
1091}
1092
1093
1094/* Translate a WRITE statement */
1095
1096tree
1097gfc_trans_write (gfc_code * code)
1098{
1099
1100 last_dt = WRITE;
1101 return build_dt (&iocall_write, code);
1102}
1103
1104
1105/* Finish a data transfer statement. */
1106
1107tree
1108gfc_trans_dt_end (gfc_code * code)
1109{
1110 tree function, tmp;
1111 stmtblock_t block;
1112
1113 gfc_init_block (&block);
1114
8750f9cd
JB		 1115 switch (last_dt)
1116 {
1117 case READ:
1118 function = iocall_read_done;
1119 break;
1120
1121 case WRITE:
1122 function = iocall_write_done;
1123 break;
1124
1125 case IOLENGTH:
1126 function = iocall_iolength_done;
1127 break;
1128
1129 default:
6e45f57b 1130 gcc_unreachable ();
8750f9cd 1131 }
6de9cd9a
DN		 1132
1133 tmp = gfc_build_function_call (function, NULL);
1134 gfc_add_expr_to_block (&block, tmp);
1135
8750f9cd
JB		 1136 if (last_dt != IOLENGTH)
1137 {
6e45f57b 1138 gcc_assert (code->ext.dt != NULL);
8750f9cd
JB		 1139 io_result (&block, code->ext.dt->err,
1140 code->ext.dt->end, code->ext.dt->eor);
1141 }
6de9cd9a
DN		 1142
1143 return gfc_finish_block (&block);
1144}
1145
d2ccf6aa
VL		 1146static void
1147transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
1148
1149/* Given an array field in a derived type variable, generate the code
1150 for the loop that iterates over array elements, and the code that
1151 accesses those array elements. Use transfer_expr to generate code
1152 for transferring that element. Because elements may also be
1153 derived types, transfer_expr and transfer_array_component are mutually
1154 recursive. */
1155
1156static tree
1157transfer_array_component (tree expr, gfc_component * cm)
1158{
1159 tree tmp;
1160 stmtblock_t body;
1161 stmtblock_t block;
1162 gfc_loopinfo loop;
1163 int n;
1164 gfc_ss *ss;
1165 gfc_se se;
1166
1167 gfc_start_block (&block);
1168 gfc_init_se (&se, NULL);
1169
1170 /* Create and initialize Scalarization Status. Unlike in
1171 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1172 care of this task, because we don't have a gfc_expr at hand.
1173 Build one manually, as in gfc_trans_subarray_assign. */
1174
1175 ss = gfc_get_ss ();
1176 ss->type = GFC_SS_COMPONENT;
1177 ss->expr = NULL;
1178 ss->shape = gfc_get_shape (cm->as->rank);
1179 ss->next = gfc_ss_terminator;
1180 ss->data.info.dimen = cm->as->rank;
1181 ss->data.info.descriptor = expr;
1182 ss->data.info.data = gfc_conv_array_data (expr);
1183 ss->data.info.offset = gfc_conv_array_offset (expr);
1184 for (n = 0; n < cm->as->rank; n++)
1185 {
1186 ss->data.info.dim[n] = n;
1187 ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1188 ss->data.info.stride[n] = gfc_index_one_node;
1189
1190 mpz_init (ss->shape[n]);
1191 mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1192 cm->as->lower[n]->value.integer);
1193 mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1194 }
1195
f7b529fa 1196 /* Once we got ss, we use scalarizer to create the loop. */
d2ccf6aa
VL		 1197
1198 gfc_init_loopinfo (&loop);
1199 gfc_add_ss_to_loop (&loop, ss);
1200 gfc_conv_ss_startstride (&loop);
1201 gfc_conv_loop_setup (&loop);
1202 gfc_mark_ss_chain_used (ss, 1);
1203 gfc_start_scalarized_body (&loop, &body);
1204
1205 gfc_copy_loopinfo_to_se (&se, &loop);
1206 se.ss = ss;
1207
1208 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1209 se.expr = expr;
1210 gfc_conv_tmp_array_ref (&se);
1211
1212 /* Now se.expr contains an element of the array. Take the address and pass
1213 it to the IO routines. */
1214 tmp = gfc_build_addr_expr (NULL, se.expr);
1215 transfer_expr (&se, &cm->ts, tmp);
1216
1217 /* We are done now with the loop body. Wrap up the scalarizer and
f7b529fa 1218 return. */
d2ccf6aa
VL		 1219
1220 gfc_add_block_to_block (&body, &se.pre);
1221 gfc_add_block_to_block (&body, &se.post);
1222
1223 gfc_trans_scalarizing_loops (&loop, &body);
1224
1225 gfc_add_block_to_block (&block, &loop.pre);
1226 gfc_add_block_to_block (&block, &loop.post);
1227
d2ccf6aa
VL		 1228 for (n = 0; n < cm->as->rank; n++)
1229 mpz_clear (ss->shape[n]);
1230 gfc_free (ss->shape);
1231
96654664
PB		 1232 gfc_cleanup_loop (&loop);
1233
d2ccf6aa
VL		 1234 return gfc_finish_block (&block);
1235}
6de9cd9a
DN		 1236
1237/* Generate the call for a scalar transfer node. */
1238
1239static void
1240transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1241{
1242 tree args, tmp, function, arg2, field, expr;
1243 gfc_component *c;
1244 int kind;
1245
1246 kind = ts->kind;
1247 function = NULL;
1248 arg2 = NULL;
1249
1250 switch (ts->type)
1251 {
1252 case BT_INTEGER:
7d60be94 1253 arg2 = build_int_cst (NULL_TREE, kind);
6de9cd9a
DN		 1254 function = iocall_x_integer;
1255 break;
1256
1257 case BT_REAL:
7d60be94 1258 arg2 = build_int_cst (NULL_TREE, kind);
6de9cd9a
DN		 1259 function = iocall_x_real;
1260 break;
1261
1262 case BT_COMPLEX:
7d60be94 1263 arg2 = build_int_cst (NULL_TREE, kind);
6de9cd9a
DN		 1264 function = iocall_x_complex;
1265 break;
1266
1267 case BT_LOGICAL:
7d60be94 1268 arg2 = build_int_cst (NULL_TREE, kind);
6de9cd9a
DN		 1269 function = iocall_x_logical;
1270 break;
1271
1272 case BT_CHARACTER:
d2ccf6aa
VL		 1273 if (se->string_length)
1274 arg2 = se->string_length;
1275 else
1276 {
1277 tmp = gfc_build_indirect_ref (addr_expr);
1278 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1279 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1280 }
6de9cd9a
DN		 1281 function = iocall_x_character;
1282 break;
1283
1284 case BT_DERIVED:
d2ccf6aa 1285 /* Recurse into the elements of the derived type. */
6de9cd9a
DN		 1286 expr = gfc_evaluate_now (addr_expr, &se->pre);
1287 expr = gfc_build_indirect_ref (expr);
1288
1289 for (c = ts->derived->components; c; c = c->next)
1290 {
1291 field = c->backend_decl;
6e45f57b 1292 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
6de9cd9a 1293
923ab88c
TS		 1294 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1295 NULL_TREE);
6de9cd9a 1296
d2ccf6aa
VL		 1297 if (c->dimension)
1298 {
1299 tmp = transfer_array_component (tmp, c);
1300 gfc_add_expr_to_block (&se->pre, tmp);
1301 }
1302 else
1303 {
1304 if (!c->pointer)
1305 tmp = gfc_build_addr_expr (NULL, tmp);
1306 transfer_expr (se, &c->ts, tmp);
1307 }
6de9cd9a
DN		 1308 }
1309 return;
1310
1311 default:
1312 internal_error ("Bad IO basetype (%d)", ts->type);
1313 }
1314
1315 args = gfc_chainon_list (NULL_TREE, addr_expr);
1316 args = gfc_chainon_list (args, arg2);
1317
1318 tmp = gfc_build_function_call (function, args);
1319 gfc_add_expr_to_block (&se->pre, tmp);
1320 gfc_add_block_to_block (&se->pre, &se->post);
8750f9cd 1321
6de9cd9a
DN		 1322}
1323
1324
1325/* gfc_trans_transfer()-- Translate a TRANSFER code node */
1326
1327tree
1328gfc_trans_transfer (gfc_code * code)
1329{
1330 stmtblock_t block, body;
1331 gfc_loopinfo loop;
1332 gfc_expr *expr;
1333 gfc_ss *ss;
1334 gfc_se se;
1335 tree tmp;
1336
1337 gfc_start_block (&block);
1338
1339 expr = code->expr;
1340 ss = gfc_walk_expr (expr);
1341
1342 gfc_init_se (&se, NULL);
1343
1344 if (ss == gfc_ss_terminator)
1345 gfc_init_block (&body);
1346 else
1347 {
1348 /* Initialize the scalarizer. */
1349 gfc_init_loopinfo (&loop);
1350 gfc_add_ss_to_loop (&loop, ss);
1351
1352 /* Initialize the loop. */
1353 gfc_conv_ss_startstride (&loop);
1354 gfc_conv_loop_setup (&loop);
1355
1356 /* The main loop body. */
1357 gfc_mark_ss_chain_used (ss, 1);
1358 gfc_start_scalarized_body (&loop, &body);
1359
1360 gfc_copy_loopinfo_to_se (&se, &loop);
1361 se.ss = ss;
1362 }
1363
1364 gfc_conv_expr_reference (&se, expr);
1365
1366 transfer_expr (&se, &expr->ts, se.expr);
1367
1368 gfc_add_block_to_block (&body, &se.pre);
1369 gfc_add_block_to_block (&body, &se.post);
1370
1371 if (se.ss == NULL)
1372 tmp = gfc_finish_block (&body);
1373 else
1374 {
6e45f57b 1375 gcc_assert (se.ss == gfc_ss_terminator);
6de9cd9a
DN		 1376 gfc_trans_scalarizing_loops (&loop, &body);
1377
1378 gfc_add_block_to_block (&loop.pre, &loop.post);
1379 tmp = gfc_finish_block (&loop.pre);
1380 gfc_cleanup_loop (&loop);
1381 }
1382
1383 gfc_add_expr_to_block (&block, tmp);
1384
d2ccf6aa 1385 return gfc_finish_block (&block);
6de9cd9a
DN		 1386}
1387
1388#include "gt-fortran-trans-io.h"
1389
Mirror of https://gcc.gnu.org/git/gcc.git