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