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