?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2015-12-18 Paul Thomas <pault@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / trans-io.c
blobd126b27f561f18139fab4af1317dd0a2b1d4edf7
1 /* IO Code translation/library interface
2 Copyright (C) 2002-2015 Free Software Foundation, Inc.
3 Contributed by Paul Brook
4
5 This file is part of GCC.
6
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 3, or (at your option) any later
10 version.
11
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.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21
22 #include "config.h"
23 #include "system.h"
24 #include "coretypes.h"
25 #include "tree.h"
26 #include "gfortran.h"
27 #include "trans.h"
28 #include "stringpool.h"
29 #include "fold-const.h"
30 #include "stor-layout.h"
31 #include "trans-stmt.h"
32 #include "trans-array.h"
33 #include "trans-types.h"
34 #include "trans-const.h"
35
36 /* Members of the ioparm structure. */
37
38 enum ioparam_type
39 {
40 IOPARM_ptype_common,
41 IOPARM_ptype_open,
42 IOPARM_ptype_close,
43 IOPARM_ptype_filepos,
44 IOPARM_ptype_inquire,
45 IOPARM_ptype_dt,
46 IOPARM_ptype_wait,
47 IOPARM_ptype_num
48 };
49
50 enum iofield_type
51 {
52 IOPARM_type_int4,
53 IOPARM_type_intio,
54 IOPARM_type_pint4,
55 IOPARM_type_pintio,
56 IOPARM_type_pchar,
57 IOPARM_type_parray,
58 IOPARM_type_pad,
59 IOPARM_type_char1,
60 IOPARM_type_char2,
61 IOPARM_type_common,
62 IOPARM_type_num
63 };
64
65 typedef struct GTY(()) gfc_st_parameter_field {
66 const char *name;
67 unsigned int mask;
68 enum ioparam_type param_type;
69 enum iofield_type type;
70 tree field;
71 tree field_len;
72 }
73 gfc_st_parameter_field;
74
75 typedef struct GTY(()) gfc_st_parameter {
76 const char *name;
77 tree type;
78 }
79 gfc_st_parameter;
80
81 enum iofield
82 {
83 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
84 #include "ioparm.def"
85 #undef IOPARM
86 IOPARM_field_num
87 };
88
89 static GTY(()) gfc_st_parameter st_parameter[] =
90 {
91 { "common", NULL },
92 { "open", NULL },
93 { "close", NULL },
94 { "filepos", NULL },
95 { "inquire", NULL },
96 { "dt", NULL },
97 { "wait", NULL }
98 };
99
100 static GTY(()) gfc_st_parameter_field st_parameter_field[] =
101 {
102 #define IOPARM(param_type, name, mask, type) \
103 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
104 #include "ioparm.def"
105 #undef IOPARM
106 { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL }
107 };
108
109 /* Library I/O subroutines */
110
111 enum iocall
112 {
113 IOCALL_READ,
114 IOCALL_READ_DONE,
115 IOCALL_WRITE,
116 IOCALL_WRITE_DONE,
117 IOCALL_X_INTEGER,
118 IOCALL_X_INTEGER_WRITE,
119 IOCALL_X_LOGICAL,
120 IOCALL_X_LOGICAL_WRITE,
121 IOCALL_X_CHARACTER,
122 IOCALL_X_CHARACTER_WRITE,
123 IOCALL_X_CHARACTER_WIDE,
124 IOCALL_X_CHARACTER_WIDE_WRITE,
125 IOCALL_X_REAL,
126 IOCALL_X_REAL_WRITE,
127 IOCALL_X_COMPLEX,
128 IOCALL_X_COMPLEX_WRITE,
129 IOCALL_X_REAL128,
130 IOCALL_X_REAL128_WRITE,
131 IOCALL_X_COMPLEX128,
132 IOCALL_X_COMPLEX128_WRITE,
133 IOCALL_X_ARRAY,
134 IOCALL_X_ARRAY_WRITE,
135 IOCALL_OPEN,
136 IOCALL_CLOSE,
137 IOCALL_INQUIRE,
138 IOCALL_IOLENGTH,
139 IOCALL_IOLENGTH_DONE,
140 IOCALL_REWIND,
141 IOCALL_BACKSPACE,
142 IOCALL_ENDFILE,
143 IOCALL_FLUSH,
144 IOCALL_SET_NML_VAL,
145 IOCALL_SET_NML_VAL_DIM,
146 IOCALL_WAIT,
147 IOCALL_NUM
148 };
149
150 static GTY(()) tree iocall[IOCALL_NUM];
151
152 /* Variable for keeping track of what the last data transfer statement
153 was. Used for deciding which subroutine to call when the data
154 transfer is complete. */
155 static enum { READ, WRITE, IOLENGTH } last_dt;
156
157 /* The data transfer parameter block that should be shared by all
158 data transfer calls belonging to the same read/write/iolength. */
159 static GTY(()) tree dt_parm;
160 static stmtblock_t *dt_post_end_block;
161
162 static void
163 gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
164 {
165 unsigned int type;
166 gfc_st_parameter_field *p;
167 char name[64];
168 size_t len;
169 tree t = make_node (RECORD_TYPE);
170 tree *chain = NULL;
171
172 len = strlen (st_parameter[ptype].name);
173 gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
174 memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
175 memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
176 len + 1);
177 TYPE_NAME (t) = get_identifier (name);
178
179 for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
180 if (p->param_type == ptype)
181 switch (p->type)
182 {
183 case IOPARM_type_int4:
184 case IOPARM_type_intio:
185 case IOPARM_type_pint4:
186 case IOPARM_type_pintio:
187 case IOPARM_type_parray:
188 case IOPARM_type_pchar:
189 case IOPARM_type_pad:
190 p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
191 types[p->type], &chain);
192 break;
193 case IOPARM_type_char1:
194 p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
195 pchar_type_node, &chain);
196 /* FALLTHROUGH */
197 case IOPARM_type_char2:
198 len = strlen (p->name);
199 gcc_assert (len <= sizeof (name) - sizeof ("_len"));
200 memcpy (name, p->name, len);
201 memcpy (name + len, "_len", sizeof ("_len"));
202 p->field_len = gfc_add_field_to_struct (t, get_identifier (name),
203 gfc_charlen_type_node,
204 &chain);
205 if (p->type == IOPARM_type_char2)
206 p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
207 pchar_type_node, &chain);
208 break;
209 case IOPARM_type_common:
210 p->field
211 = gfc_add_field_to_struct (t,
212 get_identifier (p->name),
213 st_parameter[IOPARM_ptype_common].type,
214 &chain);
215 break;
216 case IOPARM_type_num:
217 gcc_unreachable ();
218 }
219
220 gfc_finish_type (t);
221 st_parameter[ptype].type = t;
222 }
223
224
225 /* Build code to test an error condition and call generate_error if needed.
226 Note: This builds calls to generate_error in the runtime library function.
227 The function generate_error is dependent on certain parameters in the
228 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
229 Therefore, the code to set these flags must be generated before
230 this function is used. */
231
232 static void
233 gfc_trans_io_runtime_check (bool has_iostat, tree cond, tree var,
234 int error_code, const char * msgid,
235 stmtblock_t * pblock)
236 {
237 stmtblock_t block;
238 tree body;
239 tree tmp;
240 tree arg1, arg2, arg3;
241 char *message;
242
243 if (integer_zerop (cond))
244 return;
245
246 /* The code to generate the error. */
247 gfc_start_block (&block);
248
249 if (has_iostat)
250 gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_FAIL_IO,
251 NOT_TAKEN));
252 else
253 gfc_add_expr_to_block (&block, build_predict_expr (PRED_NORETURN,
254 NOT_TAKEN));
255
256 arg1 = gfc_build_addr_expr (NULL_TREE, var);
257
258 arg2 = build_int_cst (integer_type_node, error_code),
259
260 message = xasprintf ("%s", _(msgid));
261 arg3 = gfc_build_addr_expr (pchar_type_node,
262 gfc_build_localized_cstring_const (message));
263 free (message);
264
265 tmp = build_call_expr_loc (input_location,
266 gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
267
268 gfc_add_expr_to_block (&block, tmp);
269
270 body = gfc_finish_block (&block);
271
272 if (integer_onep (cond))
273 {
274 gfc_add_expr_to_block (pblock, body);
275 }
276 else
277 {
278 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
279 gfc_add_expr_to_block (pblock, tmp);
280 }
281 }
282
283
284 /* Create function decls for IO library functions. */
285
286 void
287 gfc_build_io_library_fndecls (void)
288 {
289 tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
290 tree gfc_intio_type_node;
291 tree parm_type, dt_parm_type;
292 HOST_WIDE_INT pad_size;
293 unsigned int ptype;
294
295 types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
296 types[IOPARM_type_intio] = gfc_intio_type_node
297 = gfc_get_int_type (gfc_intio_kind);
298 types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
299 types[IOPARM_type_pintio]
300 = build_pointer_type (gfc_intio_type_node);
301 types[IOPARM_type_parray] = pchar_type_node;
302 types[IOPARM_type_pchar] = pchar_type_node;
303 pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
304 pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
305 pad_idx = build_index_type (size_int (pad_size - 1));
306 types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
307
308 /* pad actually contains pointers and integers so it needs to have an
309 alignment that is at least as large as the needed alignment for those
310 types. See the st_parameter_dt structure in libgfortran/io/io.h for
311 what really goes into this space. */
312 TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
313 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)));
314
315 for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
316 gfc_build_st_parameter ((enum ioparam_type) ptype, types);
317
318 /* Define the transfer functions. */
319
320 dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
321
322 iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec (
323 get_identifier (PREFIX("transfer_integer")), ".wW",
324 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
325
326 iocall[IOCALL_X_INTEGER_WRITE] = gfc_build_library_function_decl_with_spec (
327 get_identifier (PREFIX("transfer_integer_write")), ".wR",
328 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
329
330 iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec (
331 get_identifier (PREFIX("transfer_logical")), ".wW",
332 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
333
334 iocall[IOCALL_X_LOGICAL_WRITE] = gfc_build_library_function_decl_with_spec (
335 get_identifier (PREFIX("transfer_logical_write")), ".wR",
336 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
337
338 iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec (
339 get_identifier (PREFIX("transfer_character")), ".wW",
340 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
341
342 iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec (
343 get_identifier (PREFIX("transfer_character_write")), ".wR",
344 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
345
346 iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec (
347 get_identifier (PREFIX("transfer_character_wide")), ".wW",
348 void_type_node, 4, dt_parm_type, pvoid_type_node,
349 gfc_charlen_type_node, gfc_int4_type_node);
350
351 iocall[IOCALL_X_CHARACTER_WIDE_WRITE] =
352 gfc_build_library_function_decl_with_spec (
353 get_identifier (PREFIX("transfer_character_wide_write")), ".wR",
354 void_type_node, 4, dt_parm_type, pvoid_type_node,
355 gfc_charlen_type_node, gfc_int4_type_node);
356
357 iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec (
358 get_identifier (PREFIX("transfer_real")), ".wW",
359 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
360
361 iocall[IOCALL_X_REAL_WRITE] = gfc_build_library_function_decl_with_spec (
362 get_identifier (PREFIX("transfer_real_write")), ".wR",
363 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
364
365 iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec (
366 get_identifier (PREFIX("transfer_complex")), ".wW",
367 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
368
369 iocall[IOCALL_X_COMPLEX_WRITE] = gfc_build_library_function_decl_with_spec (
370 get_identifier (PREFIX("transfer_complex_write")), ".wR",
371 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
372
373 /* Version for __float128. */
374 iocall[IOCALL_X_REAL128] = gfc_build_library_function_decl_with_spec (
375 get_identifier (PREFIX("transfer_real128")), ".wW",
376 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
377
378 iocall[IOCALL_X_REAL128_WRITE] = gfc_build_library_function_decl_with_spec (
379 get_identifier (PREFIX("transfer_real128_write")), ".wR",
380 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
381
382 iocall[IOCALL_X_COMPLEX128] = gfc_build_library_function_decl_with_spec (
383 get_identifier (PREFIX("transfer_complex128")), ".wW",
384 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
385
386 iocall[IOCALL_X_COMPLEX128_WRITE] = gfc_build_library_function_decl_with_spec (
387 get_identifier (PREFIX("transfer_complex128_write")), ".wR",
388 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
389
390 iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec (
391 get_identifier (PREFIX("transfer_array")), ".ww",
392 void_type_node, 4, dt_parm_type, pvoid_type_node,
393 integer_type_node, gfc_charlen_type_node);
394
395 iocall[IOCALL_X_ARRAY_WRITE] = gfc_build_library_function_decl_with_spec (
396 get_identifier (PREFIX("transfer_array_write")), ".wr",
397 void_type_node, 4, dt_parm_type, pvoid_type_node,
398 integer_type_node, gfc_charlen_type_node);
399
400 /* Library entry points */
401
402 iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
403 get_identifier (PREFIX("st_read")), ".w",
404 void_type_node, 1, dt_parm_type);
405
406 iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec (
407 get_identifier (PREFIX("st_write")), ".w",
408 void_type_node, 1, dt_parm_type);
409
410 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
411 iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec (
412 get_identifier (PREFIX("st_open")), ".w",
413 void_type_node, 1, parm_type);
414
415 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
416 iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec (
417 get_identifier (PREFIX("st_close")), ".w",
418 void_type_node, 1, parm_type);
419
420 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
421 iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec (
422 get_identifier (PREFIX("st_inquire")), ".w",
423 void_type_node, 1, parm_type);
424
425 iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec(
426 get_identifier (PREFIX("st_iolength")), ".w",
427 void_type_node, 1, dt_parm_type);
428
429 /* TODO: Change when asynchronous I/O is implemented. */
430 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
431 iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
432 get_identifier (PREFIX("st_wait")), ".X",
433 void_type_node, 1, parm_type);
434
435 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
436 iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec (
437 get_identifier (PREFIX("st_rewind")), ".w",
438 void_type_node, 1, parm_type);
439
440 iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec (
441 get_identifier (PREFIX("st_backspace")), ".w",
442 void_type_node, 1, parm_type);
443
444 iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec (
445 get_identifier (PREFIX("st_endfile")), ".w",
446 void_type_node, 1, parm_type);
447
448 iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec (
449 get_identifier (PREFIX("st_flush")), ".w",
450 void_type_node, 1, parm_type);
451
452 /* Library helpers */
453
454 iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec (
455 get_identifier (PREFIX("st_read_done")), ".w",
456 void_type_node, 1, dt_parm_type);
457
458 iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec (
459 get_identifier (PREFIX("st_write_done")), ".w",
460 void_type_node, 1, dt_parm_type);
461
462 iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec (
463 get_identifier (PREFIX("st_iolength_done")), ".w",
464 void_type_node, 1, dt_parm_type);
465
466 iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
467 get_identifier (PREFIX("st_set_nml_var")), ".w.R",
468 void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
469 gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node);
470
471 iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
472 get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
473 void_type_node, 5, dt_parm_type, gfc_int4_type_node,
474 gfc_array_index_type, gfc_array_index_type, gfc_array_index_type);
475 }
476
477
478 /* Generate code to store an integer constant into the
479 st_parameter_XXX structure. */
480
481 static unsigned int
482 set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
483 unsigned int val)
484 {
485 tree tmp;
486 gfc_st_parameter_field *p = &st_parameter_field[type];
487
488 if (p->param_type == IOPARM_ptype_common)
489 var = fold_build3_loc (input_location, COMPONENT_REF,
490 st_parameter[IOPARM_ptype_common].type,
491 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
492 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
493 var, p->field, NULL_TREE);
494 gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
495 return p->mask;
496 }
497
498
499 /* Generate code to store a non-string I/O parameter into the
500 st_parameter_XXX structure. This is a pass by value. */
501
502 static unsigned int
503 set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
504 gfc_expr *e)
505 {
506 gfc_se se;
507 tree tmp;
508 gfc_st_parameter_field *p = &st_parameter_field[type];
509 tree dest_type = TREE_TYPE (p->field);
510
511 gfc_init_se (&se, NULL);
512 gfc_conv_expr_val (&se, e);
513
514 se.expr = convert (dest_type, se.expr);
515 gfc_add_block_to_block (block, &se.pre);
516
517 if (p->param_type == IOPARM_ptype_common)
518 var = fold_build3_loc (input_location, COMPONENT_REF,
519 st_parameter[IOPARM_ptype_common].type,
520 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
521
522 tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
523 p->field, NULL_TREE);
524 gfc_add_modify (block, tmp, se.expr);
525 return p->mask;
526 }
527
528
529 /* Similar to set_parameter_value except generate runtime
530 error checks. */
531
532 static unsigned int
533 set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var,
534 enum iofield type, gfc_expr *e)
535 {
536 gfc_se se;
537 tree tmp;
538 gfc_st_parameter_field *p = &st_parameter_field[type];
539 tree dest_type = TREE_TYPE (p->field);
540
541 gfc_init_se (&se, NULL);
542 gfc_conv_expr_val (&se, e);
543
544 /* If we're storing a UNIT number, we need to check it first. */
545 if (type == IOPARM_common_unit && e->ts.kind > 4)
546 {
547 tree cond, val;
548 int i;
549
550 /* Don't evaluate the UNIT number multiple times. */
551 se.expr = gfc_evaluate_now (se.expr, &se.pre);
552
553 /* UNIT numbers should be greater than the min. */
554 i = gfc_validate_kind (BT_INTEGER, 4, false);
555 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
556 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
557 se.expr,
558 fold_convert (TREE_TYPE (se.expr), val));
559 gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
560 "Unit number in I/O statement too small",
561 &se.pre);
562
563 /* UNIT numbers should be less than the max. */
564 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
565 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
566 se.expr,
567 fold_convert (TREE_TYPE (se.expr), val));
568 gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
569 "Unit number in I/O statement too large",
570 &se.pre);
571 }
572
573 se.expr = convert (dest_type, se.expr);
574 gfc_add_block_to_block (block, &se.pre);
575
576 if (p->param_type == IOPARM_ptype_common)
577 var = fold_build3_loc (input_location, COMPONENT_REF,
578 st_parameter[IOPARM_ptype_common].type,
579 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
580
581 tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
582 p->field, NULL_TREE);
583 gfc_add_modify (block, tmp, se.expr);
584 return p->mask;
585 }
586
587
588 /* Build code to check the unit range if KIND=8 is used. Similar to
589 set_parameter_value_chk but we do not generate error calls for
590 inquire statements. */
591
592 static unsigned int
593 set_parameter_value_inquire (stmtblock_t *block, tree var,
594 enum iofield type, gfc_expr *e)
595 {
596 gfc_se se;
597 gfc_st_parameter_field *p = &st_parameter_field[type];
598 tree dest_type = TREE_TYPE (p->field);
599
600 gfc_init_se (&se, NULL);
601 gfc_conv_expr_val (&se, e);
602
603 /* If we're inquiring on a UNIT number, we need to check to make
604 sure it exists for larger than kind = 4. */
605 if (type == IOPARM_common_unit && e->ts.kind > 4)
606 {
607 stmtblock_t newblock;
608 tree cond1, cond2, cond3, val, body;
609 int i;
610
611 /* Don't evaluate the UNIT number multiple times. */
612 se.expr = gfc_evaluate_now (se.expr, &se.pre);
613
614 /* UNIT numbers should be greater than zero. */
615 i = gfc_validate_kind (BT_INTEGER, 4, false);
616 cond1 = build2_loc (input_location, LT_EXPR, boolean_type_node,
617 se.expr,
618 fold_convert (TREE_TYPE (se.expr),
619 integer_zero_node));
620 /* UNIT numbers should be less than the max. */
621 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
622 cond2 = build2_loc (input_location, GT_EXPR, boolean_type_node,
623 se.expr,
624 fold_convert (TREE_TYPE (se.expr), val));
625 cond3 = build2_loc (input_location, TRUTH_OR_EXPR,
626 boolean_type_node, cond1, cond2);
627
628 gfc_start_block (&newblock);
629
630 /* The unit number GFC_INVALID_UNIT is reserved. No units can
631 ever have this value. It is used here to signal to the
632 runtime library that the inquire unit number is outside the
633 allowable range and so cannot exist. It is needed when
634 -fdefault-integer-8 is used. */
635 set_parameter_const (&newblock, var, IOPARM_common_unit,
636 GFC_INVALID_UNIT);
637
638 body = gfc_finish_block (&newblock);
639
640 cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
641 var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
642 gfc_add_expr_to_block (&se.pre, var);
643 }
644
645 se.expr = convert (dest_type, se.expr);
646 gfc_add_block_to_block (block, &se.pre);
647
648 return p->mask;
649 }
650
651
652 /* Generate code to store a non-string I/O parameter into the
653 st_parameter_XXX structure. This is pass by reference. */
654
655 static unsigned int
656 set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
657 tree var, enum iofield type, gfc_expr *e)
658 {
659 gfc_se se;
660 tree tmp, addr;
661 gfc_st_parameter_field *p = &st_parameter_field[type];
662
663 gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
664 gfc_init_se (&se, NULL);
665 gfc_conv_expr_lhs (&se, e);
666
667 gfc_add_block_to_block (block, &se.pre);
668
669 if (TYPE_MODE (TREE_TYPE (se.expr))
670 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
671 {
672 addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
673
674 /* If this is for the iostat variable initialize the
675 user variable to LIBERROR_OK which is zero. */
676 if (type == IOPARM_common_iostat)
677 gfc_add_modify (block, se.expr,
678 build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
679 }
680 else
681 {
682 /* The type used by the library has different size
683 from the type of the variable supplied by the user.
684 Need to use a temporary. */
685 tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
686 st_parameter_field[type].name);
687
688 /* If this is for the iostat variable, initialize the
689 user variable to LIBERROR_OK which is zero. */
690 if (type == IOPARM_common_iostat)
691 gfc_add_modify (block, tmpvar,
692 build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
693
694 addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
695 /* After the I/O operation, we set the variable from the temporary. */
696 tmp = convert (TREE_TYPE (se.expr), tmpvar);
697 gfc_add_modify (postblock, se.expr, tmp);
698 }
699
700 if (p->param_type == IOPARM_ptype_common)
701 var = fold_build3_loc (input_location, COMPONENT_REF,
702 st_parameter[IOPARM_ptype_common].type,
703 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
704 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
705 var, p->field, NULL_TREE);
706 gfc_add_modify (block, tmp, addr);
707 return p->mask;
708 }
709
710 /* Given an array expr, find its address and length to get a string. If the
711 array is full, the string's address is the address of array's first element
712 and the length is the size of the whole array. If it is an element, the
713 string's address is the element's address and the length is the rest size of
714 the array. */
715
716 static void
717 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
718 {
719 tree size;
720
721 if (e->rank == 0)
722 {
723 tree type, array, tmp;
724 gfc_symbol *sym;
725 int rank;
726
727 /* If it is an element, we need its address and size of the rest. */
728 gcc_assert (e->expr_type == EXPR_VARIABLE);
729 gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
730 sym = e->symtree->n.sym;
731 rank = sym->as->rank - 1;
732 gfc_conv_expr (se, e);
733
734 array = sym->backend_decl;
735 type = TREE_TYPE (array);
736
737 if (GFC_ARRAY_TYPE_P (type))
738 size = GFC_TYPE_ARRAY_SIZE (type);
739 else
740 {
741 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
742 size = gfc_conv_array_stride (array, rank);
743 tmp = fold_build2_loc (input_location, MINUS_EXPR,
744 gfc_array_index_type,
745 gfc_conv_array_ubound (array, rank),
746 gfc_conv_array_lbound (array, rank));
747 tmp = fold_build2_loc (input_location, PLUS_EXPR,
748 gfc_array_index_type, tmp,
749 gfc_index_one_node);
750 size = fold_build2_loc (input_location, MULT_EXPR,
751 gfc_array_index_type, tmp, size);
752 }
753 gcc_assert (size);
754
755 size = fold_build2_loc (input_location, MINUS_EXPR,
756 gfc_array_index_type, size,
757 TREE_OPERAND (se->expr, 1));
758 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
759 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
760 size = fold_build2_loc (input_location, MULT_EXPR,
761 gfc_array_index_type, size,
762 fold_convert (gfc_array_index_type, tmp));
763 se->string_length = fold_convert (gfc_charlen_type_node, size);
764 return;
765 }
766
767 gfc_conv_array_parameter (se, e, true, NULL, NULL, &size);
768 se->string_length = fold_convert (gfc_charlen_type_node, size);
769 }
770
771
772 /* Generate code to store a string and its length into the
773 st_parameter_XXX structure. */
774
775 static unsigned int
776 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
777 enum iofield type, gfc_expr * e)
778 {
779 gfc_se se;
780 tree tmp;
781 tree io;
782 tree len;
783 gfc_st_parameter_field *p = &st_parameter_field[type];
784
785 gfc_init_se (&se, NULL);
786
787 if (p->param_type == IOPARM_ptype_common)
788 var = fold_build3_loc (input_location, COMPONENT_REF,
789 st_parameter[IOPARM_ptype_common].type,
790 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
791 io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
792 var, p->field, NULL_TREE);
793 len = fold_build3_loc (input_location, COMPONENT_REF,
794 TREE_TYPE (p->field_len),
795 var, p->field_len, NULL_TREE);
796
797 /* Integer variable assigned a format label. */
798 if (e->ts.type == BT_INTEGER
799 && e->rank == 0
800 && e->symtree->n.sym->attr.assign == 1)
801 {
802 char * msg;
803 tree cond;
804
805 gfc_conv_label_variable (&se, e);
806 tmp = GFC_DECL_STRING_LEN (se.expr);
807 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
808 tmp, build_int_cst (TREE_TYPE (tmp), 0));
809
810 msg = xasprintf ("Label assigned to variable '%s' (%%ld) is not a format "
811 "label", e->symtree->name);
812 gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
813 fold_convert (long_integer_type_node, tmp));
814 free (msg);
815
816 gfc_add_modify (&se.pre, io,
817 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
818 gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
819 }
820 else
821 {
822 /* General character. */
823 if (e->ts.type == BT_CHARACTER && e->rank == 0)
824 gfc_conv_expr (&se, e);
825 /* Array assigned Hollerith constant or character array. */
826 else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
827 gfc_convert_array_to_string (&se, e);
828 else
829 gcc_unreachable ();
830
831 gfc_conv_string_parameter (&se);
832 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
833 gfc_add_modify (&se.pre, len, se.string_length);
834 }
835
836 gfc_add_block_to_block (block, &se.pre);
837 gfc_add_block_to_block (postblock, &se.post);
838 return p->mask;
839 }
840
841
842 /* Generate code to store the character (array) and the character length
843 for an internal unit. */
844
845 static unsigned int
846 set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
847 tree var, gfc_expr * e)
848 {
849 gfc_se se;
850 tree io;
851 tree len;
852 tree desc;
853 tree tmp;
854 gfc_st_parameter_field *p;
855 unsigned int mask;
856
857 gfc_init_se (&se, NULL);
858
859 p = &st_parameter_field[IOPARM_dt_internal_unit];
860 mask = p->mask;
861 io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
862 var, p->field, NULL_TREE);
863 len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len),
864 var, p->field_len, NULL_TREE);
865 p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
866 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
867 var, p->field, NULL_TREE);
868
869 gcc_assert (e->ts.type == BT_CHARACTER);
870
871 /* Character scalars. */
872 if (e->rank == 0)
873 {
874 gfc_conv_expr (&se, e);
875 gfc_conv_string_parameter (&se);
876 tmp = se.expr;
877 se.expr = build_int_cst (pchar_type_node, 0);
878 }
879
880 /* Character array. */
881 else if (e->rank > 0)
882 {
883 if (is_subref_array (e))
884 {
885 /* Use a temporary for components of arrays of derived types
886 or substring array references. */
887 gfc_conv_subref_array_arg (&se, e, 0,
888 last_dt == READ ? INTENT_IN : INTENT_OUT, false);
889 tmp = build_fold_indirect_ref_loc (input_location,
890 se.expr);
891 se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
892 tmp = gfc_conv_descriptor_data_get (tmp);
893 }
894 else
895 {
896 /* Return the data pointer and rank from the descriptor. */
897 gfc_conv_expr_descriptor (&se, e);
898 tmp = gfc_conv_descriptor_data_get (se.expr);
899 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
900 }
901 }
902 else
903 gcc_unreachable ();
904
905 /* The cast is needed for character substrings and the descriptor
906 data. */
907 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
908 gfc_add_modify (&se.pre, len,
909 fold_convert (TREE_TYPE (len), se.string_length));
910 gfc_add_modify (&se.pre, desc, se.expr);
911
912 gfc_add_block_to_block (block, &se.pre);
913 gfc_add_block_to_block (post_block, &se.post);
914 return mask;
915 }
916
917 /* Add a case to a IO-result switch. */
918
919 static void
920 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
921 {
922 tree tmp, value;
923
924 if (label == NULL)
925 return; /* No label, no case */
926
927 value = build_int_cst (integer_type_node, label_value);
928
929 /* Make a backend label for this case. */
930 tmp = gfc_build_label_decl (NULL_TREE);
931
932 /* And the case itself. */
933 tmp = build_case_label (value, NULL_TREE, tmp);
934 gfc_add_expr_to_block (body, tmp);
935
936 /* Jump to the label. */
937 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
938 gfc_add_expr_to_block (body, tmp);
939 }
940
941
942 /* Generate a switch statement that branches to the correct I/O
943 result label. The last statement of an I/O call stores the
944 result into a variable because there is often cleanup that
945 must be done before the switch, so a temporary would have to
946 be created anyway. */
947
948 static void
949 io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
950 gfc_st_label * end_label, gfc_st_label * eor_label)
951 {
952 stmtblock_t body;
953 tree tmp, rc;
954 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
955
956 /* If no labels are specified, ignore the result instead
957 of building an empty switch. */
958 if (err_label == NULL
959 && end_label == NULL
960 && eor_label == NULL)
961 return;
962
963 /* Build a switch statement. */
964 gfc_start_block (&body);
965
966 /* The label values here must be the same as the values
967 in the library_return enum in the runtime library */
968 add_case (1, err_label, &body);
969 add_case (2, end_label, &body);
970 add_case (3, eor_label, &body);
971
972 tmp = gfc_finish_block (&body);
973
974 var = fold_build3_loc (input_location, COMPONENT_REF,
975 st_parameter[IOPARM_ptype_common].type,
976 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
977 rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
978 var, p->field, NULL_TREE);
979 rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc),
980 rc, build_int_cst (TREE_TYPE (rc),
981 IOPARM_common_libreturn_mask));
982
983 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
984 rc, tmp, NULL_TREE);
985
986 gfc_add_expr_to_block (block, tmp);
987 }
988
989
990 /* Store the current file and line number to variables so that if a
991 library call goes awry, we can tell the user where the problem is. */
992
993 static void
994 set_error_locus (stmtblock_t * block, tree var, locus * where)
995 {
996 gfc_file *f;
997 tree str, locus_file;
998 int line;
999 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
1000
1001 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1002 st_parameter[IOPARM_ptype_common].type,
1003 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
1004 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1005 TREE_TYPE (p->field), locus_file,
1006 p->field, NULL_TREE);
1007 f = where->lb->file;
1008 str = gfc_build_cstring_const (f->filename);
1009
1010 str = gfc_build_addr_expr (pchar_type_node, str);
1011 gfc_add_modify (block, locus_file, str);
1012
1013 line = LOCATION_LINE (where->lb->location);
1014 set_parameter_const (block, var, IOPARM_common_line, line);
1015 }
1016
1017
1018 /* Translate an OPEN statement. */
1019
1020 tree
1021 gfc_trans_open (gfc_code * code)
1022 {
1023 stmtblock_t block, post_block;
1024 gfc_open *p;
1025 tree tmp, var;
1026 unsigned int mask = 0;
1027
1028 gfc_start_block (&block);
1029 gfc_init_block (&post_block);
1030
1031 var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
1032
1033 set_error_locus (&block, var, &code->loc);
1034 p = code->ext.open;
1035
1036 if (p->iomsg)
1037 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1038 p->iomsg);
1039
1040 if (p->iostat)
1041 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1042 p->iostat);
1043
1044 if (p->err)
1045 mask |= IOPARM_common_err;
1046
1047 if (p->file)
1048 mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
1049
1050 if (p->status)
1051 mask |= set_string (&block, &post_block, var, IOPARM_open_status,
1052 p->status);
1053
1054 if (p->access)
1055 mask |= set_string (&block, &post_block, var, IOPARM_open_access,
1056 p->access);
1057
1058 if (p->form)
1059 mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
1060
1061 if (p->recl)
1062 mask |= set_parameter_value (&block, var, IOPARM_open_recl_in,
1063 p->recl);
1064
1065 if (p->blank)
1066 mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
1067 p->blank);
1068
1069 if (p->position)
1070 mask |= set_string (&block, &post_block, var, IOPARM_open_position,
1071 p->position);
1072
1073 if (p->action)
1074 mask |= set_string (&block, &post_block, var, IOPARM_open_action,
1075 p->action);
1076
1077 if (p->delim)
1078 mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
1079 p->delim);
1080
1081 if (p->pad)
1082 mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
1083
1084 if (p->decimal)
1085 mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
1086 p->decimal);
1087
1088 if (p->encoding)
1089 mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
1090 p->encoding);
1091
1092 if (p->round)
1093 mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
1094
1095 if (p->sign)
1096 mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
1097
1098 if (p->asynchronous)
1099 mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
1100 p->asynchronous);
1101
1102 if (p->convert)
1103 mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
1104 p->convert);
1105
1106 if (p->newunit)
1107 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
1108 p->newunit);
1109
1110 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1111
1112 if (p->unit)
1113 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
1114 else
1115 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1116
1117 tmp = gfc_build_addr_expr (NULL_TREE, var);
1118 tmp = build_call_expr_loc (input_location,
1119 iocall[IOCALL_OPEN], 1, tmp);
1120 gfc_add_expr_to_block (&block, tmp);
1121
1122 gfc_add_block_to_block (&block, &post_block);
1123
1124 io_result (&block, var, p->err, NULL, NULL);
1125
1126 return gfc_finish_block (&block);
1127 }
1128
1129
1130 /* Translate a CLOSE statement. */
1131
1132 tree
1133 gfc_trans_close (gfc_code * code)
1134 {
1135 stmtblock_t block, post_block;
1136 gfc_close *p;
1137 tree tmp, var;
1138 unsigned int mask = 0;
1139
1140 gfc_start_block (&block);
1141 gfc_init_block (&post_block);
1142
1143 var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
1144
1145 set_error_locus (&block, var, &code->loc);
1146 p = code->ext.close;
1147
1148 if (p->iomsg)
1149 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1150 p->iomsg);
1151
1152 if (p->iostat)
1153 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1154 p->iostat);
1155
1156 if (p->err)
1157 mask |= IOPARM_common_err;
1158
1159 if (p->status)
1160 mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1161 p->status);
1162
1163 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1164
1165 if (p->unit)
1166 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
1167 else
1168 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1169
1170 tmp = gfc_build_addr_expr (NULL_TREE, var);
1171 tmp = build_call_expr_loc (input_location,
1172 iocall[IOCALL_CLOSE], 1, tmp);
1173 gfc_add_expr_to_block (&block, tmp);
1174
1175 gfc_add_block_to_block (&block, &post_block);
1176
1177 io_result (&block, var, p->err, NULL, NULL);
1178
1179 return gfc_finish_block (&block);
1180 }
1181
1182
1183 /* Common subroutine for building a file positioning statement. */
1184
1185 static tree
1186 build_filepos (tree function, gfc_code * code)
1187 {
1188 stmtblock_t block, post_block;
1189 gfc_filepos *p;
1190 tree tmp, var;
1191 unsigned int mask = 0;
1192
1193 p = code->ext.filepos;
1194
1195 gfc_start_block (&block);
1196 gfc_init_block (&post_block);
1197
1198 var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1199 "filepos_parm");
1200
1201 set_error_locus (&block, var, &code->loc);
1202
1203 if (p->iomsg)
1204 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1205 p->iomsg);
1206
1207 if (p->iostat)
1208 mask |= set_parameter_ref (&block, &post_block, var,
1209 IOPARM_common_iostat, p->iostat);
1210
1211 if (p->err)
1212 mask |= IOPARM_common_err;
1213
1214 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1215
1216 if (p->unit)
1217 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit,
1218 p->unit);
1219 else
1220 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1221
1222 tmp = gfc_build_addr_expr (NULL_TREE, var);
1223 tmp = build_call_expr_loc (input_location,
1224 function, 1, tmp);
1225 gfc_add_expr_to_block (&block, tmp);
1226
1227 gfc_add_block_to_block (&block, &post_block);
1228
1229 io_result (&block, var, p->err, NULL, NULL);
1230
1231 return gfc_finish_block (&block);
1232 }
1233
1234
1235 /* Translate a BACKSPACE statement. */
1236
1237 tree
1238 gfc_trans_backspace (gfc_code * code)
1239 {
1240 return build_filepos (iocall[IOCALL_BACKSPACE], code);
1241 }
1242
1243
1244 /* Translate an ENDFILE statement. */
1245
1246 tree
1247 gfc_trans_endfile (gfc_code * code)
1248 {
1249 return build_filepos (iocall[IOCALL_ENDFILE], code);
1250 }
1251
1252
1253 /* Translate a REWIND statement. */
1254
1255 tree
1256 gfc_trans_rewind (gfc_code * code)
1257 {
1258 return build_filepos (iocall[IOCALL_REWIND], code);
1259 }
1260
1261
1262 /* Translate a FLUSH statement. */
1263
1264 tree
1265 gfc_trans_flush (gfc_code * code)
1266 {
1267 return build_filepos (iocall[IOCALL_FLUSH], code);
1268 }
1269
1270
1271 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1272
1273 tree
1274 gfc_trans_inquire (gfc_code * code)
1275 {
1276 stmtblock_t block, post_block;
1277 gfc_inquire *p;
1278 tree tmp, var;
1279 unsigned int mask = 0, mask2 = 0;
1280
1281 gfc_start_block (&block);
1282 gfc_init_block (&post_block);
1283
1284 var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1285 "inquire_parm");
1286
1287 set_error_locus (&block, var, &code->loc);
1288 p = code->ext.inquire;
1289
1290 if (p->iomsg)
1291 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1292 p->iomsg);
1293
1294 if (p->iostat)
1295 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1296 p->iostat);
1297
1298 if (p->err)
1299 mask |= IOPARM_common_err;
1300
1301 /* Sanity check. */
1302 if (p->unit && p->file)
1303 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1304
1305 if (p->file)
1306 mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1307 p->file);
1308
1309 if (p->exist)
1310 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1311 p->exist);
1312
1313 if (p->opened)
1314 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1315 p->opened);
1316
1317 if (p->number)
1318 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1319 p->number);
1320
1321 if (p->named)
1322 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1323 p->named);
1324
1325 if (p->name)
1326 mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1327 p->name);
1328
1329 if (p->access)
1330 mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1331 p->access);
1332
1333 if (p->sequential)
1334 mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1335 p->sequential);
1336
1337 if (p->direct)
1338 mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1339 p->direct);
1340
1341 if (p->form)
1342 mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1343 p->form);
1344
1345 if (p->formatted)
1346 mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1347 p->formatted);
1348
1349 if (p->unformatted)
1350 mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1351 p->unformatted);
1352
1353 if (p->recl)
1354 mask |= set_parameter_ref (&block, &post_block, var,
1355 IOPARM_inquire_recl_out, p->recl);
1356
1357 if (p->nextrec)
1358 mask |= set_parameter_ref (&block, &post_block, var,
1359 IOPARM_inquire_nextrec, p->nextrec);
1360
1361 if (p->blank)
1362 mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1363 p->blank);
1364
1365 if (p->delim)
1366 mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1367 p->delim);
1368
1369 if (p->position)
1370 mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1371 p->position);
1372
1373 if (p->action)
1374 mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1375 p->action);
1376
1377 if (p->read)
1378 mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1379 p->read);
1380
1381 if (p->write)
1382 mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1383 p->write);
1384
1385 if (p->readwrite)
1386 mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1387 p->readwrite);
1388
1389 if (p->pad)
1390 mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1391 p->pad);
1392
1393 if (p->convert)
1394 mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1395 p->convert);
1396
1397 if (p->strm_pos)
1398 mask |= set_parameter_ref (&block, &post_block, var,
1399 IOPARM_inquire_strm_pos_out, p->strm_pos);
1400
1401 /* The second series of flags. */
1402 if (p->asynchronous)
1403 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1404 p->asynchronous);
1405
1406 if (p->decimal)
1407 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1408 p->decimal);
1409
1410 if (p->encoding)
1411 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1412 p->encoding);
1413
1414 if (p->round)
1415 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1416 p->round);
1417
1418 if (p->sign)
1419 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1420 p->sign);
1421
1422 if (p->pending)
1423 mask2 |= set_parameter_ref (&block, &post_block, var,
1424 IOPARM_inquire_pending, p->pending);
1425
1426 if (p->size)
1427 mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1428 p->size);
1429
1430 if (p->id)
1431 mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1432 p->id);
1433 if (p->iqstream)
1434 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream,
1435 p->iqstream);
1436
1437 if (mask2)
1438 mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
1439
1440 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1441
1442 if (p->unit)
1443 {
1444 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1445 set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit);
1446 }
1447 else
1448 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1449
1450 tmp = gfc_build_addr_expr (NULL_TREE, var);
1451 tmp = build_call_expr_loc (input_location,
1452 iocall[IOCALL_INQUIRE], 1, tmp);
1453 gfc_add_expr_to_block (&block, tmp);
1454
1455 gfc_add_block_to_block (&block, &post_block);
1456
1457 io_result (&block, var, p->err, NULL, NULL);
1458
1459 return gfc_finish_block (&block);
1460 }
1461
1462
1463 tree
1464 gfc_trans_wait (gfc_code * code)
1465 {
1466 stmtblock_t block, post_block;
1467 gfc_wait *p;
1468 tree tmp, var;
1469 unsigned int mask = 0;
1470
1471 gfc_start_block (&block);
1472 gfc_init_block (&post_block);
1473
1474 var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1475 "wait_parm");
1476
1477 set_error_locus (&block, var, &code->loc);
1478 p = code->ext.wait;
1479
1480 /* Set parameters here. */
1481 if (p->iomsg)
1482 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1483 p->iomsg);
1484
1485 if (p->iostat)
1486 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1487 p->iostat);
1488
1489 if (p->err)
1490 mask |= IOPARM_common_err;
1491
1492 if (p->id)
1493 mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
1494
1495 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1496
1497 if (p->unit)
1498 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
1499
1500 tmp = gfc_build_addr_expr (NULL_TREE, var);
1501 tmp = build_call_expr_loc (input_location,
1502 iocall[IOCALL_WAIT], 1, tmp);
1503 gfc_add_expr_to_block (&block, tmp);
1504
1505 gfc_add_block_to_block (&block, &post_block);
1506
1507 io_result (&block, var, p->err, NULL, NULL);
1508
1509 return gfc_finish_block (&block);
1510
1511 }
1512
1513
1514 /* nml_full_name builds up the fully qualified name of a
1515 derived type component. '+' is used to denote a type extension. */
1516
1517 static char*
1518 nml_full_name (const char* var_name, const char* cmp_name, bool parent)
1519 {
1520 int full_name_length;
1521 char * full_name;
1522
1523 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1524 full_name = XCNEWVEC (char, full_name_length + 1);
1525 strcpy (full_name, var_name);
1526 full_name = strcat (full_name, parent ? "+" : "%");
1527 full_name = strcat (full_name, cmp_name);
1528 return full_name;
1529 }
1530
1531
1532 /* nml_get_addr_expr builds an address expression from the
1533 gfc_symbol or gfc_component backend_decl's. An offset is
1534 provided so that the address of an element of an array of
1535 derived types is returned. This is used in the runtime to
1536 determine that span of the derived type. */
1537
1538 static tree
1539 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1540 tree base_addr)
1541 {
1542 tree decl = NULL_TREE;
1543 tree tmp;
1544
1545 if (sym)
1546 {
1547 sym->attr.referenced = 1;
1548 decl = gfc_get_symbol_decl (sym);
1549
1550 /* If this is the enclosing function declaration, use
1551 the fake result instead. */
1552 if (decl == current_function_decl)
1553 decl = gfc_get_fake_result_decl (sym, 0);
1554 else if (decl == DECL_CONTEXT (current_function_decl))
1555 decl = gfc_get_fake_result_decl (sym, 1);
1556 }
1557 else
1558 decl = c->backend_decl;
1559
1560 gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1561 || TREE_CODE (decl) == VAR_DECL
1562 || TREE_CODE (decl) == PARM_DECL)
1563 || TREE_CODE (decl) == COMPONENT_REF));
1564
1565 tmp = decl;
1566
1567 /* Build indirect reference, if dummy argument. */
1568
1569 if (POINTER_TYPE_P (TREE_TYPE(tmp)))
1570 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1571
1572 /* Treat the component of a derived type, using base_addr for
1573 the derived type. */
1574
1575 if (TREE_CODE (decl) == FIELD_DECL)
1576 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
1577 base_addr, tmp, NULL_TREE);
1578
1579 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1580 tmp = gfc_conv_array_data (tmp);
1581 else
1582 {
1583 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1584 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1585
1586 if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1587 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1588
1589 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1590 tmp = build_fold_indirect_ref_loc (input_location,
1591 tmp);
1592 }
1593
1594 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1595
1596 return tmp;
1597 }
1598
1599
1600 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1601 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1602 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1603
1604 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1605
1606 static void
1607 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1608 gfc_symbol * sym, gfc_component * c,
1609 tree base_addr)
1610 {
1611 gfc_typespec * ts = NULL;
1612 gfc_array_spec * as = NULL;
1613 tree addr_expr = NULL;
1614 tree dt = NULL;
1615 tree string;
1616 tree tmp;
1617 tree dtype;
1618 tree dt_parm_addr;
1619 tree decl = NULL_TREE;
1620 tree gfc_int4_type_node = gfc_get_int_type (4);
1621 int n_dim;
1622 int itype;
1623 int rank = 0;
1624
1625 gcc_assert (sym || c);
1626
1627 /* Build the namelist object name. */
1628
1629 string = gfc_build_cstring_const (var_name);
1630 string = gfc_build_addr_expr (pchar_type_node, string);
1631
1632 /* Build ts, as and data address using symbol or component. */
1633
1634 ts = (sym) ? &sym->ts : &c->ts;
1635 as = (sym) ? sym->as : c->as;
1636
1637 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1638
1639 if (as)
1640 rank = as->rank;
1641
1642 if (rank)
1643 {
1644 decl = (sym) ? sym->backend_decl : c->backend_decl;
1645 if (sym && sym->attr.dummy)
1646 decl = build_fold_indirect_ref_loc (input_location, decl);
1647 dt = TREE_TYPE (decl);
1648 dtype = gfc_get_dtype (dt);
1649 }
1650 else
1651 {
1652 itype = ts->type;
1653 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1654 }
1655
1656 /* Build up the arguments for the transfer call.
1657 The call for the scalar part transfers:
1658 (address, name, type, kind or string_length, dtype) */
1659
1660 dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1661
1662 if (ts->type == BT_CHARACTER)
1663 tmp = ts->u.cl->backend_decl;
1664 else
1665 tmp = build_int_cst (gfc_charlen_type_node, 0);
1666 tmp = build_call_expr_loc (input_location,
1667 iocall[IOCALL_SET_NML_VAL], 6,
1668 dt_parm_addr, addr_expr, string,
1669 build_int_cst (gfc_int4_type_node, ts->kind),
1670 tmp, dtype);
1671 gfc_add_expr_to_block (block, tmp);
1672
1673 /* If the object is an array, transfer rank times:
1674 (null pointer, name, stride, lbound, ubound) */
1675
1676 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1677 {
1678 tmp = build_call_expr_loc (input_location,
1679 iocall[IOCALL_SET_NML_VAL_DIM], 5,
1680 dt_parm_addr,
1681 build_int_cst (gfc_int4_type_node, n_dim),
1682 gfc_conv_array_stride (decl, n_dim),
1683 gfc_conv_array_lbound (decl, n_dim),
1684 gfc_conv_array_ubound (decl, n_dim));
1685 gfc_add_expr_to_block (block, tmp);
1686 }
1687
1688 if (ts->type == BT_DERIVED && ts->u.derived->components)
1689 {
1690 gfc_component *cmp;
1691
1692 /* Provide the RECORD_TYPE to build component references. */
1693
1694 tree expr = build_fold_indirect_ref_loc (input_location,
1695 addr_expr);
1696
1697 for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1698 {
1699 char *full_name = nml_full_name (var_name, cmp->name,
1700 ts->u.derived->attr.extension);
1701 transfer_namelist_element (block,
1702 full_name,
1703 NULL, cmp, expr);
1704 free (full_name);
1705 }
1706 }
1707 }
1708
1709 #undef IARG
1710
1711 /* Create a data transfer statement. Not all of the fields are valid
1712 for both reading and writing, but improper use has been filtered
1713 out by now. */
1714
1715 static tree
1716 build_dt (tree function, gfc_code * code)
1717 {
1718 stmtblock_t block, post_block, post_end_block, post_iu_block;
1719 gfc_dt *dt;
1720 tree tmp, var;
1721 gfc_expr *nmlname;
1722 gfc_namelist *nml;
1723 unsigned int mask = 0;
1724
1725 gfc_start_block (&block);
1726 gfc_init_block (&post_block);
1727 gfc_init_block (&post_end_block);
1728 gfc_init_block (&post_iu_block);
1729
1730 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1731
1732 set_error_locus (&block, var, &code->loc);
1733
1734 if (last_dt == IOLENGTH)
1735 {
1736 gfc_inquire *inq;
1737
1738 inq = code->ext.inquire;
1739
1740 /* First check that preconditions are met. */
1741 gcc_assert (inq != NULL);
1742 gcc_assert (inq->iolength != NULL);
1743
1744 /* Connect to the iolength variable. */
1745 mask |= set_parameter_ref (&block, &post_end_block, var,
1746 IOPARM_dt_iolength, inq->iolength);
1747 dt = NULL;
1748 }
1749 else
1750 {
1751 dt = code->ext.dt;
1752 gcc_assert (dt != NULL);
1753 }
1754
1755 if (dt && dt->io_unit)
1756 {
1757 if (dt->io_unit->ts.type == BT_CHARACTER)
1758 {
1759 mask |= set_internal_unit (&block, &post_iu_block,
1760 var, dt->io_unit);
1761 set_parameter_const (&block, var, IOPARM_common_unit,
1762 dt->io_unit->ts.kind == 1 ? 0 : -1);
1763 }
1764 }
1765 else
1766 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1767
1768 if (dt)
1769 {
1770 if (dt->iomsg)
1771 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1772 dt->iomsg);
1773
1774 if (dt->iostat)
1775 mask |= set_parameter_ref (&block, &post_end_block, var,
1776 IOPARM_common_iostat, dt->iostat);
1777
1778 if (dt->err)
1779 mask |= IOPARM_common_err;
1780
1781 if (dt->eor)
1782 mask |= IOPARM_common_eor;
1783
1784 if (dt->end)
1785 mask |= IOPARM_common_end;
1786
1787 if (dt->id)
1788 mask |= set_parameter_ref (&block, &post_end_block, var,
1789 IOPARM_dt_id, dt->id);
1790
1791 if (dt->pos)
1792 mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1793
1794 if (dt->asynchronous)
1795 mask |= set_string (&block, &post_block, var,
1796 IOPARM_dt_asynchronous, dt->asynchronous);
1797
1798 if (dt->blank)
1799 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1800 dt->blank);
1801
1802 if (dt->decimal)
1803 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1804 dt->decimal);
1805
1806 if (dt->delim)
1807 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1808 dt->delim);
1809
1810 if (dt->pad)
1811 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1812 dt->pad);
1813
1814 if (dt->round)
1815 mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1816 dt->round);
1817
1818 if (dt->sign)
1819 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1820 dt->sign);
1821
1822 if (dt->rec)
1823 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1824
1825 if (dt->advance)
1826 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1827 dt->advance);
1828
1829 if (dt->format_expr)
1830 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1831 dt->format_expr);
1832
1833 if (dt->format_label)
1834 {
1835 if (dt->format_label == &format_asterisk)
1836 mask |= IOPARM_dt_list_format;
1837 else
1838 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1839 dt->format_label->format);
1840 }
1841
1842 if (dt->size)
1843 mask |= set_parameter_ref (&block, &post_end_block, var,
1844 IOPARM_dt_size, dt->size);
1845
1846 if (dt->namelist)
1847 {
1848 if (dt->format_expr || dt->format_label)
1849 gfc_internal_error ("build_dt: format with namelist");
1850
1851 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1852 dt->namelist->name,
1853 strlen (dt->namelist->name));
1854
1855 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1856 nmlname);
1857
1858 gfc_free_expr (nmlname);
1859
1860 if (last_dt == READ)
1861 mask |= IOPARM_dt_namelist_read_mode;
1862
1863 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1864
1865 dt_parm = var;
1866
1867 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1868 transfer_namelist_element (&block, nml->sym->name, nml->sym,
1869 NULL, NULL_TREE);
1870 }
1871 else
1872 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1873
1874 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1875 set_parameter_value_chk (&block, dt->iostat, var,
1876 IOPARM_common_unit, dt->io_unit);
1877 }
1878 else
1879 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1880
1881 tmp = gfc_build_addr_expr (NULL_TREE, var);
1882 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
1883 function, 1, tmp);
1884 gfc_add_expr_to_block (&block, tmp);
1885
1886 gfc_add_block_to_block (&block, &post_block);
1887
1888 dt_parm = var;
1889 dt_post_end_block = &post_end_block;
1890
1891 /* Set implied do loop exit condition. */
1892 if (last_dt == READ || last_dt == WRITE)
1893 {
1894 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
1895
1896 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1897 st_parameter[IOPARM_ptype_common].type,
1898 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
1899 NULL_TREE);
1900 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1901 TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
1902 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
1903 tmp, build_int_cst (TREE_TYPE (tmp),
1904 IOPARM_common_libreturn_mask));
1905 }
1906 else /* IOLENGTH */
1907 tmp = NULL_TREE;
1908
1909 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
1910
1911 gfc_add_block_to_block (&block, &post_iu_block);
1912
1913 dt_parm = NULL;
1914 dt_post_end_block = NULL;
1915
1916 return gfc_finish_block (&block);
1917 }
1918
1919
1920 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1921 this as a third sort of data transfer statement, except that
1922 lengths are summed instead of actually transferring any data. */
1923
1924 tree
1925 gfc_trans_iolength (gfc_code * code)
1926 {
1927 last_dt = IOLENGTH;
1928 return build_dt (iocall[IOCALL_IOLENGTH], code);
1929 }
1930
1931
1932 /* Translate a READ statement. */
1933
1934 tree
1935 gfc_trans_read (gfc_code * code)
1936 {
1937 last_dt = READ;
1938 return build_dt (iocall[IOCALL_READ], code);
1939 }
1940
1941
1942 /* Translate a WRITE statement */
1943
1944 tree
1945 gfc_trans_write (gfc_code * code)
1946 {
1947 last_dt = WRITE;
1948 return build_dt (iocall[IOCALL_WRITE], code);
1949 }
1950
1951
1952 /* Finish a data transfer statement. */
1953
1954 tree
1955 gfc_trans_dt_end (gfc_code * code)
1956 {
1957 tree function, tmp;
1958 stmtblock_t block;
1959
1960 gfc_init_block (&block);
1961
1962 switch (last_dt)
1963 {
1964 case READ:
1965 function = iocall[IOCALL_READ_DONE];
1966 break;
1967
1968 case WRITE:
1969 function = iocall[IOCALL_WRITE_DONE];
1970 break;
1971
1972 case IOLENGTH:
1973 function = iocall[IOCALL_IOLENGTH_DONE];
1974 break;
1975
1976 default:
1977 gcc_unreachable ();
1978 }
1979
1980 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
1981 tmp = build_call_expr_loc (input_location,
1982 function, 1, tmp);
1983 gfc_add_expr_to_block (&block, tmp);
1984 gfc_add_block_to_block (&block, dt_post_end_block);
1985 gfc_init_block (dt_post_end_block);
1986
1987 if (last_dt != IOLENGTH)
1988 {
1989 gcc_assert (code->ext.dt != NULL);
1990 io_result (&block, dt_parm, code->ext.dt->err,
1991 code->ext.dt->end, code->ext.dt->eor);
1992 }
1993
1994 return gfc_finish_block (&block);
1995 }
1996
1997 static void
1998 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
1999
2000 /* Given an array field in a derived type variable, generate the code
2001 for the loop that iterates over array elements, and the code that
2002 accesses those array elements. Use transfer_expr to generate code
2003 for transferring that element. Because elements may also be
2004 derived types, transfer_expr and transfer_array_component are mutually
2005 recursive. */
2006
2007 static tree
2008 transfer_array_component (tree expr, gfc_component * cm, locus * where)
2009 {
2010 tree tmp;
2011 stmtblock_t body;
2012 stmtblock_t block;
2013 gfc_loopinfo loop;
2014 int n;
2015 gfc_ss *ss;
2016 gfc_se se;
2017 gfc_array_info *ss_array;
2018
2019 gfc_start_block (&block);
2020 gfc_init_se (&se, NULL);
2021
2022 /* Create and initialize Scalarization Status. Unlike in
2023 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2024 care of this task, because we don't have a gfc_expr at hand.
2025 Build one manually, as in gfc_trans_subarray_assign. */
2026
2027 ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
2028 GFC_SS_COMPONENT);
2029 ss_array = &ss->info->data.array;
2030 ss_array->shape = gfc_get_shape (cm->as->rank);
2031 ss_array->descriptor = expr;
2032 ss_array->data = gfc_conv_array_data (expr);
2033 ss_array->offset = gfc_conv_array_offset (expr);
2034 for (n = 0; n < cm->as->rank; n++)
2035 {
2036 ss_array->start[n] = gfc_conv_array_lbound (expr, n);
2037 ss_array->stride[n] = gfc_index_one_node;
2038
2039 mpz_init (ss_array->shape[n]);
2040 mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
2041 cm->as->lower[n]->value.integer);
2042 mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
2043 }
2044
2045 /* Once we got ss, we use scalarizer to create the loop. */
2046
2047 gfc_init_loopinfo (&loop);
2048 gfc_add_ss_to_loop (&loop, ss);
2049 gfc_conv_ss_startstride (&loop);
2050 gfc_conv_loop_setup (&loop, where);
2051 gfc_mark_ss_chain_used (ss, 1);
2052 gfc_start_scalarized_body (&loop, &body);
2053
2054 gfc_copy_loopinfo_to_se (&se, &loop);
2055 se.ss = ss;
2056
2057 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2058 se.expr = expr;
2059 gfc_conv_tmp_array_ref (&se);
2060
2061 /* Now se.expr contains an element of the array. Take the address and pass
2062 it to the IO routines. */
2063 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2064 transfer_expr (&se, &cm->ts, tmp, NULL);
2065
2066 /* We are done now with the loop body. Wrap up the scalarizer and
2067 return. */
2068
2069 gfc_add_block_to_block (&body, &se.pre);
2070 gfc_add_block_to_block (&body, &se.post);
2071
2072 gfc_trans_scalarizing_loops (&loop, &body);
2073
2074 gfc_add_block_to_block (&block, &loop.pre);
2075 gfc_add_block_to_block (&block, &loop.post);
2076
2077 gcc_assert (ss_array->shape != NULL);
2078 gfc_free_shape (&ss_array->shape, cm->as->rank);
2079 gfc_cleanup_loop (&loop);
2080
2081 return gfc_finish_block (&block);
2082 }
2083
2084 /* Generate the call for a scalar transfer node. */
2085
2086 static void
2087 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
2088 {
2089 tree tmp, function, arg2, arg3, field, expr;
2090 gfc_component *c;
2091 int kind;
2092
2093 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2094 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2095 We need to translate the expression to a constant if it's either
2096 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2097 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2098 BT_DERIVED (could have been changed by gfc_conv_expr). */
2099 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2100 && ts->u.derived != NULL
2101 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2102 {
2103 ts->type = BT_INTEGER;
2104 ts->kind = gfc_index_integer_kind;
2105 }
2106
2107 kind = ts->kind;
2108 function = NULL;
2109 arg2 = NULL;
2110 arg3 = NULL;
2111
2112 switch (ts->type)
2113 {
2114 case BT_INTEGER:
2115 arg2 = build_int_cst (integer_type_node, kind);
2116 if (last_dt == READ)
2117 function = iocall[IOCALL_X_INTEGER];
2118 else
2119 function = iocall[IOCALL_X_INTEGER_WRITE];
2120
2121 break;
2122
2123 case BT_REAL:
2124 arg2 = build_int_cst (integer_type_node, kind);
2125 if (last_dt == READ)
2126 {
2127 if (gfc_real16_is_float128 && ts->kind == 16)
2128 function = iocall[IOCALL_X_REAL128];
2129 else
2130 function = iocall[IOCALL_X_REAL];
2131 }
2132 else
2133 {
2134 if (gfc_real16_is_float128 && ts->kind == 16)
2135 function = iocall[IOCALL_X_REAL128_WRITE];
2136 else
2137 function = iocall[IOCALL_X_REAL_WRITE];
2138 }
2139
2140 break;
2141
2142 case BT_COMPLEX:
2143 arg2 = build_int_cst (integer_type_node, kind);
2144 if (last_dt == READ)
2145 {
2146 if (gfc_real16_is_float128 && ts->kind == 16)
2147 function = iocall[IOCALL_X_COMPLEX128];
2148 else
2149 function = iocall[IOCALL_X_COMPLEX];
2150 }
2151 else
2152 {
2153 if (gfc_real16_is_float128 && ts->kind == 16)
2154 function = iocall[IOCALL_X_COMPLEX128_WRITE];
2155 else
2156 function = iocall[IOCALL_X_COMPLEX_WRITE];
2157 }
2158
2159 break;
2160
2161 case BT_LOGICAL:
2162 arg2 = build_int_cst (integer_type_node, kind);
2163 if (last_dt == READ)
2164 function = iocall[IOCALL_X_LOGICAL];
2165 else
2166 function = iocall[IOCALL_X_LOGICAL_WRITE];
2167
2168 break;
2169
2170 case BT_CHARACTER:
2171 if (kind == 4)
2172 {
2173 if (se->string_length)
2174 arg2 = se->string_length;
2175 else
2176 {
2177 tmp = build_fold_indirect_ref_loc (input_location,
2178 addr_expr);
2179 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2180 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2181 arg2 = fold_convert (gfc_charlen_type_node, arg2);
2182 }
2183 arg3 = build_int_cst (integer_type_node, kind);
2184 if (last_dt == READ)
2185 function = iocall[IOCALL_X_CHARACTER_WIDE];
2186 else
2187 function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
2188
2189 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2190 tmp = build_call_expr_loc (input_location,
2191 function, 4, tmp, addr_expr, arg2, arg3);
2192 gfc_add_expr_to_block (&se->pre, tmp);
2193 gfc_add_block_to_block (&se->pre, &se->post);
2194 return;
2195 }
2196 /* Fall through. */
2197 case BT_HOLLERITH:
2198 if (se->string_length)
2199 arg2 = se->string_length;
2200 else
2201 {
2202 tmp = build_fold_indirect_ref_loc (input_location,
2203 addr_expr);
2204 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2205 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2206 }
2207 if (last_dt == READ)
2208 function = iocall[IOCALL_X_CHARACTER];
2209 else
2210 function = iocall[IOCALL_X_CHARACTER_WRITE];
2211
2212 break;
2213
2214 case BT_DERIVED:
2215 if (ts->u.derived->components == NULL)
2216 return;
2217
2218 /* Recurse into the elements of the derived type. */
2219 expr = gfc_evaluate_now (addr_expr, &se->pre);
2220 expr = build_fold_indirect_ref_loc (input_location,
2221 expr);
2222
2223 /* Make sure that the derived type has been built. An external
2224 function, if only referenced in an io statement, requires this
2225 check (see PR58771). */
2226 if (ts->u.derived->backend_decl == NULL_TREE)
2227 (void) gfc_typenode_for_spec (ts);
2228
2229 for (c = ts->u.derived->components; c; c = c->next)
2230 {
2231 field = c->backend_decl;
2232 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2233
2234 tmp = fold_build3_loc (UNKNOWN_LOCATION,
2235 COMPONENT_REF, TREE_TYPE (field),
2236 expr, field, NULL_TREE);
2237
2238 if (c->attr.dimension)
2239 {
2240 tmp = transfer_array_component (tmp, c, & code->loc);
2241 gfc_add_expr_to_block (&se->pre, tmp);
2242 }
2243 else
2244 {
2245 if (!c->attr.pointer)
2246 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2247 transfer_expr (se, &c->ts, tmp, code);
2248 }
2249 }
2250 return;
2251
2252 default:
2253 gfc_internal_error ("Bad IO basetype (%d)", ts->type);
2254 }
2255
2256 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2257 tmp = build_call_expr_loc (input_location,
2258 function, 3, tmp, addr_expr, arg2);
2259 gfc_add_expr_to_block (&se->pre, tmp);
2260 gfc_add_block_to_block (&se->pre, &se->post);
2261
2262 }
2263
2264
2265 /* Generate a call to pass an array descriptor to the IO library. The
2266 array should be of one of the intrinsic types. */
2267
2268 static void
2269 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2270 {
2271 tree tmp, charlen_arg, kind_arg, io_call;
2272
2273 if (ts->type == BT_CHARACTER)
2274 charlen_arg = se->string_length;
2275 else
2276 charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
2277
2278 kind_arg = build_int_cst (integer_type_node, ts->kind);
2279
2280 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2281 if (last_dt == READ)
2282 io_call = iocall[IOCALL_X_ARRAY];
2283 else
2284 io_call = iocall[IOCALL_X_ARRAY_WRITE];
2285
2286 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2287 io_call, 4,
2288 tmp, addr_expr, kind_arg, charlen_arg);
2289 gfc_add_expr_to_block (&se->pre, tmp);
2290 gfc_add_block_to_block (&se->pre, &se->post);
2291 }
2292
2293
2294 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2295
2296 tree
2297 gfc_trans_transfer (gfc_code * code)
2298 {
2299 stmtblock_t block, body;
2300 gfc_loopinfo loop;
2301 gfc_expr *expr;
2302 gfc_ref *ref;
2303 gfc_ss *ss;
2304 gfc_se se;
2305 tree tmp;
2306 int n;
2307
2308 gfc_start_block (&block);
2309 gfc_init_block (&body);
2310
2311 expr = code->expr1;
2312 ref = NULL;
2313 gfc_init_se (&se, NULL);
2314
2315 if (expr->rank == 0)
2316 {
2317 /* Transfer a scalar value. */
2318 gfc_conv_expr_reference (&se, expr);
2319 transfer_expr (&se, &expr->ts, se.expr, code);
2320 }
2321 else
2322 {
2323 /* Transfer an array. If it is an array of an intrinsic
2324 type, pass the descriptor to the library. Otherwise
2325 scalarize the transfer. */
2326 if (expr->ref && !gfc_is_proc_ptr_comp (expr))
2327 {
2328 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2329 ref = ref->next);
2330 gcc_assert (ref && ref->type == REF_ARRAY);
2331 }
2332
2333 if (expr->ts.type != BT_DERIVED
2334 && ref && ref->next == NULL
2335 && !is_subref_array (expr))
2336 {
2337 bool seen_vector = false;
2338
2339 if (ref && ref->u.ar.type == AR_SECTION)
2340 {
2341 for (n = 0; n < ref->u.ar.dimen; n++)
2342 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2343 {
2344 seen_vector = true;
2345 break;
2346 }
2347 }
2348
2349 if (seen_vector && last_dt == READ)
2350 {
2351 /* Create a temp, read to that and copy it back. */
2352 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2353 tmp = se.expr;
2354 }
2355 else
2356 {
2357 /* Get the descriptor. */
2358 gfc_conv_expr_descriptor (&se, expr);
2359 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2360 }
2361
2362 transfer_array_desc (&se, &expr->ts, tmp);
2363 goto finish_block_label;
2364 }
2365
2366 /* Initialize the scalarizer. */
2367 ss = gfc_walk_expr (expr);
2368 gfc_init_loopinfo (&loop);
2369 gfc_add_ss_to_loop (&loop, ss);
2370
2371 /* Initialize the loop. */
2372 gfc_conv_ss_startstride (&loop);
2373 gfc_conv_loop_setup (&loop, &code->expr1->where);
2374
2375 /* The main loop body. */
2376 gfc_mark_ss_chain_used (ss, 1);
2377 gfc_start_scalarized_body (&loop, &body);
2378
2379 gfc_copy_loopinfo_to_se (&se, &loop);
2380 se.ss = ss;
2381
2382 gfc_conv_expr_reference (&se, expr);
2383 transfer_expr (&se, &expr->ts, se.expr, code);
2384 }
2385
2386 finish_block_label:
2387
2388 gfc_add_block_to_block (&body, &se.pre);
2389 gfc_add_block_to_block (&body, &se.post);
2390
2391 if (se.ss == NULL)
2392 tmp = gfc_finish_block (&body);
2393 else
2394 {
2395 gcc_assert (expr->rank != 0);
2396 gcc_assert (se.ss == gfc_ss_terminator);
2397 gfc_trans_scalarizing_loops (&loop, &body);
2398
2399 gfc_add_block_to_block (&loop.pre, &loop.post);
2400 tmp = gfc_finish_block (&loop.pre);
2401 gfc_cleanup_loop (&loop);
2402 }
2403
2404 gfc_add_expr_to_block (&block, tmp);
2405
2406 return gfc_finish_block (&block);
2407 }
2408
2409 #include "gt-fortran-trans-io.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org