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