?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
New I/O specifiers CARRIAGECONTROL, READONLY, SHARE with -fdec.
[official-gcc.git] / gcc / fortran / trans-io.c
blob285e551585c01d814bf0bd9d7b15ded5852b3c01
1 /* IO Code translation/library interface
2 Copyright (C) 2002-2016 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->namelist)
1915 {
1916 if (dt->format_expr || dt->format_label)
1917 gfc_internal_error ("build_dt: format with namelist");
1918
1919 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1920 dt->namelist->name,
1921 strlen (dt->namelist->name));
1922
1923 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1924 nmlname);
1925
1926 gfc_free_expr (nmlname);
1927
1928 if (last_dt == READ)
1929 mask |= IOPARM_dt_namelist_read_mode;
1930
1931 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1932
1933 dt_parm = var;
1934
1935 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1936 transfer_namelist_element (&block, nml->sym->name, nml->sym,
1937 NULL, NULL_TREE);
1938 }
1939 else
1940 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1941
1942 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1943 set_parameter_value_chk (&block, dt->iostat, var,
1944 IOPARM_common_unit, dt->io_unit);
1945 }
1946 else
1947 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1948
1949 tmp = gfc_build_addr_expr (NULL_TREE, var);
1950 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
1951 function, 1, tmp);
1952 gfc_add_expr_to_block (&block, tmp);
1953
1954 gfc_add_block_to_block (&block, &post_block);
1955
1956 dt_parm = var;
1957 dt_post_end_block = &post_end_block;
1958
1959 /* Set implied do loop exit condition. */
1960 if (last_dt == READ || last_dt == WRITE)
1961 {
1962 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
1963
1964 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1965 st_parameter[IOPARM_ptype_common].type,
1966 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
1967 NULL_TREE);
1968 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1969 TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
1970 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
1971 tmp, build_int_cst (TREE_TYPE (tmp),
1972 IOPARM_common_libreturn_mask));
1973 }
1974 else /* IOLENGTH */
1975 tmp = NULL_TREE;
1976
1977 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
1978
1979 gfc_add_block_to_block (&block, &post_iu_block);
1980
1981 dt_parm = NULL;
1982 dt_post_end_block = NULL;
1983
1984 return gfc_finish_block (&block);
1985 }
1986
1987
1988 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1989 this as a third sort of data transfer statement, except that
1990 lengths are summed instead of actually transferring any data. */
1991
1992 tree
1993 gfc_trans_iolength (gfc_code * code)
1994 {
1995 last_dt = IOLENGTH;
1996 return build_dt (iocall[IOCALL_IOLENGTH], code);
1997 }
1998
1999
2000 /* Translate a READ statement. */
2001
2002 tree
2003 gfc_trans_read (gfc_code * code)
2004 {
2005 last_dt = READ;
2006 return build_dt (iocall[IOCALL_READ], code);
2007 }
2008
2009
2010 /* Translate a WRITE statement */
2011
2012 tree
2013 gfc_trans_write (gfc_code * code)
2014 {
2015 last_dt = WRITE;
2016 return build_dt (iocall[IOCALL_WRITE], code);
2017 }
2018
2019
2020 /* Finish a data transfer statement. */
2021
2022 tree
2023 gfc_trans_dt_end (gfc_code * code)
2024 {
2025 tree function, tmp;
2026 stmtblock_t block;
2027
2028 gfc_init_block (&block);
2029
2030 switch (last_dt)
2031 {
2032 case READ:
2033 function = iocall[IOCALL_READ_DONE];
2034 break;
2035
2036 case WRITE:
2037 function = iocall[IOCALL_WRITE_DONE];
2038 break;
2039
2040 case IOLENGTH:
2041 function = iocall[IOCALL_IOLENGTH_DONE];
2042 break;
2043
2044 default:
2045 gcc_unreachable ();
2046 }
2047
2048 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2049 tmp = build_call_expr_loc (input_location,
2050 function, 1, tmp);
2051 gfc_add_expr_to_block (&block, tmp);
2052 gfc_add_block_to_block (&block, dt_post_end_block);
2053 gfc_init_block (dt_post_end_block);
2054
2055 if (last_dt != IOLENGTH)
2056 {
2057 gcc_assert (code->ext.dt != NULL);
2058 io_result (&block, dt_parm, code->ext.dt->err,
2059 code->ext.dt->end, code->ext.dt->eor);
2060 }
2061
2062 return gfc_finish_block (&block);
2063 }
2064
2065 static void
2066 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2067 gfc_code * code, tree vptr);
2068
2069 /* Given an array field in a derived type variable, generate the code
2070 for the loop that iterates over array elements, and the code that
2071 accesses those array elements. Use transfer_expr to generate code
2072 for transferring that element. Because elements may also be
2073 derived types, transfer_expr and transfer_array_component are mutually
2074 recursive. */
2075
2076 static tree
2077 transfer_array_component (tree expr, gfc_component * cm, locus * where)
2078 {
2079 tree tmp;
2080 stmtblock_t body;
2081 stmtblock_t block;
2082 gfc_loopinfo loop;
2083 int n;
2084 gfc_ss *ss;
2085 gfc_se se;
2086 gfc_array_info *ss_array;
2087
2088 gfc_start_block (&block);
2089 gfc_init_se (&se, NULL);
2090
2091 /* Create and initialize Scalarization Status. Unlike in
2092 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2093 care of this task, because we don't have a gfc_expr at hand.
2094 Build one manually, as in gfc_trans_subarray_assign. */
2095
2096 ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
2097 GFC_SS_COMPONENT);
2098 ss_array = &ss->info->data.array;
2099 ss_array->shape = gfc_get_shape (cm->as->rank);
2100 ss_array->descriptor = expr;
2101 ss_array->data = gfc_conv_array_data (expr);
2102 ss_array->offset = gfc_conv_array_offset (expr);
2103 for (n = 0; n < cm->as->rank; n++)
2104 {
2105 ss_array->start[n] = gfc_conv_array_lbound (expr, n);
2106 ss_array->stride[n] = gfc_index_one_node;
2107
2108 mpz_init (ss_array->shape[n]);
2109 mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
2110 cm->as->lower[n]->value.integer);
2111 mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
2112 }
2113
2114 /* Once we got ss, we use scalarizer to create the loop. */
2115
2116 gfc_init_loopinfo (&loop);
2117 gfc_add_ss_to_loop (&loop, ss);
2118 gfc_conv_ss_startstride (&loop);
2119 gfc_conv_loop_setup (&loop, where);
2120 gfc_mark_ss_chain_used (ss, 1);
2121 gfc_start_scalarized_body (&loop, &body);
2122
2123 gfc_copy_loopinfo_to_se (&se, &loop);
2124 se.ss = ss;
2125
2126 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2127 se.expr = expr;
2128 gfc_conv_tmp_array_ref (&se);
2129
2130 /* Now se.expr contains an element of the array. Take the address and pass
2131 it to the IO routines. */
2132 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2133 transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
2134
2135 /* We are done now with the loop body. Wrap up the scalarizer and
2136 return. */
2137
2138 gfc_add_block_to_block (&body, &se.pre);
2139 gfc_add_block_to_block (&body, &se.post);
2140
2141 gfc_trans_scalarizing_loops (&loop, &body);
2142
2143 gfc_add_block_to_block (&block, &loop.pre);
2144 gfc_add_block_to_block (&block, &loop.post);
2145
2146 gcc_assert (ss_array->shape != NULL);
2147 gfc_free_shape (&ss_array->shape, cm->as->rank);
2148 gfc_cleanup_loop (&loop);
2149
2150 return gfc_finish_block (&block);
2151 }
2152
2153
2154 /* Helper function for transfer_expr that looks for the DTIO procedure
2155 either as a typebound binding or in a generic interface. If present,
2156 the address expression of the procedure is returned. It is assumed
2157 that the procedure interface has been checked during resolution. */
2158
2159 static tree
2160 get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
2161 {
2162 gfc_symbol *derived;
2163 bool formatted = false;
2164 gfc_dt *dt = code->ext.dt;
2165
2166 if (dt && dt->format_expr)
2167 {
2168 char *fmt;
2169 fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
2170 -1);
2171 if (strtok (fmt, "DT") != NULL)
2172 formatted = true;
2173 }
2174 else if (dt && dt->format_label == &format_asterisk)
2175 {
2176 /* List directed io must call the formatted DTIO procedure. */
2177 formatted = true;
2178 }
2179
2180 if (ts->type == BT_DERIVED)
2181 derived = ts->u.derived;
2182 else
2183 derived = ts->u.derived->components->ts.u.derived;
2184
2185 *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
2186 formatted);
2187
2188 if (*dtio_sub)
2189 return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
2190
2191 return NULL_TREE;
2192
2193 }
2194
2195 /* Generate the call for a scalar transfer node. */
2196
2197 static void
2198 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2199 gfc_code * code, tree vptr)
2200 {
2201 tree tmp, function, arg2, arg3, field, expr;
2202 gfc_component *c;
2203 int kind;
2204
2205 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2206 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2207 We need to translate the expression to a constant if it's either
2208 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2209 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2210 BT_DERIVED (could have been changed by gfc_conv_expr). */
2211 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2212 && ts->u.derived != NULL
2213 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2214 {
2215 ts->type = BT_INTEGER;
2216 ts->kind = gfc_index_integer_kind;
2217 }
2218
2219 kind = ts->kind;
2220 function = NULL;
2221 arg2 = NULL;
2222 arg3 = NULL;
2223
2224 switch (ts->type)
2225 {
2226 case BT_INTEGER:
2227 arg2 = build_int_cst (integer_type_node, kind);
2228 if (last_dt == READ)
2229 function = iocall[IOCALL_X_INTEGER];
2230 else
2231 function = iocall[IOCALL_X_INTEGER_WRITE];
2232
2233 break;
2234
2235 case BT_REAL:
2236 arg2 = build_int_cst (integer_type_node, kind);
2237 if (last_dt == READ)
2238 {
2239 if (gfc_real16_is_float128 && ts->kind == 16)
2240 function = iocall[IOCALL_X_REAL128];
2241 else
2242 function = iocall[IOCALL_X_REAL];
2243 }
2244 else
2245 {
2246 if (gfc_real16_is_float128 && ts->kind == 16)
2247 function = iocall[IOCALL_X_REAL128_WRITE];
2248 else
2249 function = iocall[IOCALL_X_REAL_WRITE];
2250 }
2251
2252 break;
2253
2254 case BT_COMPLEX:
2255 arg2 = build_int_cst (integer_type_node, kind);
2256 if (last_dt == READ)
2257 {
2258 if (gfc_real16_is_float128 && ts->kind == 16)
2259 function = iocall[IOCALL_X_COMPLEX128];
2260 else
2261 function = iocall[IOCALL_X_COMPLEX];
2262 }
2263 else
2264 {
2265 if (gfc_real16_is_float128 && ts->kind == 16)
2266 function = iocall[IOCALL_X_COMPLEX128_WRITE];
2267 else
2268 function = iocall[IOCALL_X_COMPLEX_WRITE];
2269 }
2270
2271 break;
2272
2273 case BT_LOGICAL:
2274 arg2 = build_int_cst (integer_type_node, kind);
2275 if (last_dt == READ)
2276 function = iocall[IOCALL_X_LOGICAL];
2277 else
2278 function = iocall[IOCALL_X_LOGICAL_WRITE];
2279
2280 break;
2281
2282 case BT_CHARACTER:
2283 if (kind == 4)
2284 {
2285 if (se->string_length)
2286 arg2 = se->string_length;
2287 else
2288 {
2289 tmp = build_fold_indirect_ref_loc (input_location,
2290 addr_expr);
2291 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2292 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2293 arg2 = fold_convert (gfc_charlen_type_node, arg2);
2294 }
2295 arg3 = build_int_cst (integer_type_node, kind);
2296 if (last_dt == READ)
2297 function = iocall[IOCALL_X_CHARACTER_WIDE];
2298 else
2299 function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
2300
2301 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2302 tmp = build_call_expr_loc (input_location,
2303 function, 4, tmp, addr_expr, arg2, arg3);
2304 gfc_add_expr_to_block (&se->pre, tmp);
2305 gfc_add_block_to_block (&se->pre, &se->post);
2306 return;
2307 }
2308 /* Fall through. */
2309 case BT_HOLLERITH:
2310 if (se->string_length)
2311 arg2 = se->string_length;
2312 else
2313 {
2314 tmp = build_fold_indirect_ref_loc (input_location,
2315 addr_expr);
2316 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2317 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2318 }
2319 if (last_dt == READ)
2320 function = iocall[IOCALL_X_CHARACTER];
2321 else
2322 function = iocall[IOCALL_X_CHARACTER_WRITE];
2323
2324 break;
2325
2326 case_bt_struct:
2327 case BT_CLASS:
2328 if (ts->u.derived->components == NULL)
2329 return;
2330 if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
2331 {
2332 gfc_symbol *derived;
2333 gfc_symbol *dtio_sub = NULL;
2334 /* Test for a specific DTIO subroutine. */
2335 if (ts->type == BT_DERIVED)
2336 derived = ts->u.derived;
2337 else
2338 derived = ts->u.derived->components->ts.u.derived;
2339
2340 if (derived->attr.has_dtio_procs)
2341 arg2 = get_dtio_proc (ts, code, &dtio_sub);
2342
2343 if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
2344 {
2345 tree decl;
2346 decl = build_fold_indirect_ref_loc (input_location,
2347 se->expr);
2348 /* Remember that the first dummy of the DTIO subroutines
2349 is CLASS(derived) for extensible derived types, so the
2350 conversion must be done here for derived type and for
2351 scalarized CLASS array element io-list objects. */
2352 if ((ts->type == BT_DERIVED
2353 && !(ts->u.derived->attr.sequence
2354 || ts->u.derived->attr.is_bind_c))
2355 || (ts->type == BT_CLASS
2356 && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
2357 gfc_conv_derived_to_class (se, code->expr1,
2358 dtio_sub->formal->sym->ts,
2359 vptr, false, false);
2360 addr_expr = se->expr;
2361 function = iocall[IOCALL_X_DERIVED];
2362 break;
2363 }
2364 else if (ts->type == BT_DERIVED)
2365 {
2366 /* Recurse into the elements of the derived type. */
2367 expr = gfc_evaluate_now (addr_expr, &se->pre);
2368 expr = build_fold_indirect_ref_loc (input_location,
2369 expr);
2370
2371 /* Make sure that the derived type has been built. An external
2372 function, if only referenced in an io statement, requires this
2373 check (see PR58771). */
2374 if (ts->u.derived->backend_decl == NULL_TREE)
2375 (void) gfc_typenode_for_spec (ts);
2376
2377 for (c = ts->u.derived->components; c; c = c->next)
2378 {
2379 field = c->backend_decl;
2380 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2381
2382 tmp = fold_build3_loc (UNKNOWN_LOCATION,
2383 COMPONENT_REF, TREE_TYPE (field),
2384 expr, field, NULL_TREE);
2385
2386 if (c->attr.dimension)
2387 {
2388 tmp = transfer_array_component (tmp, c, & code->loc);
2389 gfc_add_expr_to_block (&se->pre, tmp);
2390 }
2391 else
2392 {
2393 if (!c->attr.pointer)
2394 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2395 transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
2396 }
2397 }
2398 return;
2399 }
2400 /* If a CLASS object gets through to here, fall through and ICE. */
2401 }
2402 gcc_fallthrough ();
2403 default:
2404 gfc_internal_error ("Bad IO basetype (%d)", ts->type);
2405 }
2406
2407 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2408 tmp = build_call_expr_loc (input_location,
2409 function, 3, tmp, addr_expr, arg2);
2410 gfc_add_expr_to_block (&se->pre, tmp);
2411 gfc_add_block_to_block (&se->pre, &se->post);
2412
2413 }
2414
2415
2416 /* Generate a call to pass an array descriptor to the IO library. The
2417 array should be of one of the intrinsic types. */
2418
2419 static void
2420 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2421 {
2422 tree tmp, charlen_arg, kind_arg, io_call;
2423
2424 if (ts->type == BT_CHARACTER)
2425 charlen_arg = se->string_length;
2426 else
2427 charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
2428
2429 kind_arg = build_int_cst (integer_type_node, ts->kind);
2430
2431 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2432 if (last_dt == READ)
2433 io_call = iocall[IOCALL_X_ARRAY];
2434 else
2435 io_call = iocall[IOCALL_X_ARRAY_WRITE];
2436
2437 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2438 io_call, 4,
2439 tmp, addr_expr, kind_arg, charlen_arg);
2440 gfc_add_expr_to_block (&se->pre, tmp);
2441 gfc_add_block_to_block (&se->pre, &se->post);
2442 }
2443
2444
2445 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2446
2447 tree
2448 gfc_trans_transfer (gfc_code * code)
2449 {
2450 stmtblock_t block, body;
2451 gfc_loopinfo loop;
2452 gfc_expr *expr;
2453 gfc_ref *ref;
2454 gfc_ss *ss;
2455 gfc_se se;
2456 tree tmp;
2457 tree vptr;
2458 int n;
2459
2460 gfc_start_block (&block);
2461 gfc_init_block (&body);
2462
2463 expr = code->expr1;
2464 ref = NULL;
2465 gfc_init_se (&se, NULL);
2466
2467 if (expr->rank == 0)
2468 {
2469 /* Transfer a scalar value. */
2470 if (expr->ts.type == BT_CLASS)
2471 {
2472 se.want_pointer = 1;
2473 gfc_conv_expr (&se, expr);
2474 vptr = gfc_get_vptr_from_expr (se.expr);
2475 }
2476 else
2477 {
2478 vptr = NULL_TREE;
2479 gfc_conv_expr_reference (&se, expr);
2480 }
2481 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
2482 }
2483 else
2484 {
2485 /* Transfer an array. If it is an array of an intrinsic
2486 type, pass the descriptor to the library. Otherwise
2487 scalarize the transfer. */
2488 if (expr->ref && !gfc_is_proc_ptr_comp (expr))
2489 {
2490 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2491 ref = ref->next);
2492 gcc_assert (ref && ref->type == REF_ARRAY);
2493 }
2494
2495 if (!(gfc_bt_struct (expr->ts.type)
2496 || expr->ts.type == BT_CLASS)
2497 && ref && ref->next == NULL
2498 && !is_subref_array (expr))
2499 {
2500 bool seen_vector = false;
2501
2502 if (ref && ref->u.ar.type == AR_SECTION)
2503 {
2504 for (n = 0; n < ref->u.ar.dimen; n++)
2505 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2506 {
2507 seen_vector = true;
2508 break;
2509 }
2510 }
2511
2512 if (seen_vector && last_dt == READ)
2513 {
2514 /* Create a temp, read to that and copy it back. */
2515 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2516 tmp = se.expr;
2517 }
2518 else
2519 {
2520 /* Get the descriptor. */
2521 gfc_conv_expr_descriptor (&se, expr);
2522 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2523 }
2524
2525 transfer_array_desc (&se, &expr->ts, tmp);
2526 goto finish_block_label;
2527 }
2528
2529 /* Initialize the scalarizer. */
2530 ss = gfc_walk_expr (expr);
2531 gfc_init_loopinfo (&loop);
2532 gfc_add_ss_to_loop (&loop, ss);
2533
2534 /* Initialize the loop. */
2535 gfc_conv_ss_startstride (&loop);
2536 gfc_conv_loop_setup (&loop, &code->expr1->where);
2537
2538 /* The main loop body. */
2539 gfc_mark_ss_chain_used (ss, 1);
2540 gfc_start_scalarized_body (&loop, &body);
2541
2542 gfc_copy_loopinfo_to_se (&se, &loop);
2543 se.ss = ss;
2544 gfc_conv_expr_reference (&se, expr);
2545 if (expr->ts.type == BT_CLASS)
2546 vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
2547 else
2548 vptr = NULL_TREE;
2549 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
2550 }
2551
2552 finish_block_label:
2553
2554 gfc_add_block_to_block (&body, &se.pre);
2555 gfc_add_block_to_block (&body, &se.post);
2556
2557 if (se.ss == NULL)
2558 tmp = gfc_finish_block (&body);
2559 else
2560 {
2561 gcc_assert (expr->rank != 0);
2562 gcc_assert (se.ss == gfc_ss_terminator);
2563 gfc_trans_scalarizing_loops (&loop, &body);
2564
2565 gfc_add_block_to_block (&loop.pre, &loop.post);
2566 tmp = gfc_finish_block (&loop.pre);
2567 gfc_cleanup_loop (&loop);
2568 }
2569
2570 gfc_add_expr_to_block (&block, tmp);
2571
2572 return gfc_finish_block (&block);
2573 }
2574
2575 #include "gt-fortran-trans-io.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org