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