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 227759 : gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
170 : {
171 227759 : unsigned int type;
172 227759 : gfc_st_parameter_field *p;
173 227759 : char name[64];
174 227759 : size_t len;
175 227759 : tree t = make_node (RECORD_TYPE);
176 227759 : tree *chain = NULL;
177 :
178 227759 : len = strlen (st_parameter[ptype].name);
179 227759 : gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
180 227759 : memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
181 227759 : memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
182 : len + 1);
183 227759 : TYPE_NAME (t) = get_identifier (name);
184 :
185 20270551 : for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
186 20042792 : if (p->param_type == ptype)
187 2863256 : switch (p->type)
188 : {
189 878499 : case IOPARM_type_int4:
190 878499 : case IOPARM_type_intio:
191 878499 : case IOPARM_type_pint4:
192 878499 : case IOPARM_type_pintio:
193 878499 : case IOPARM_type_parray:
194 878499 : case IOPARM_type_pchar:
195 878499 : case IOPARM_type_pad:
196 878499 : p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
197 878499 : types[p->type], &chain);
198 878499 : break;
199 943573 : case IOPARM_type_char1:
200 943573 : p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
201 : pchar_type_node, &chain);
202 : /* FALLTHROUGH */
203 1789535 : case IOPARM_type_char2:
204 1789535 : len = strlen (p->name);
205 1789535 : gcc_assert (len <= sizeof (name) - sizeof ("_len"));
206 1789535 : memcpy (name, p->name, len);
207 1789535 : memcpy (name + len, "_len", sizeof ("_len"));
208 1789535 : p->field_len = gfc_add_field_to_struct (t, get_identifier (name),
209 : gfc_charlen_type_node,
210 : &chain);
211 1789535 : if (p->type == IOPARM_type_char2)
212 845962 : p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
213 : pchar_type_node, &chain);
214 : break;
215 195222 : case IOPARM_type_common:
216 195222 : p->field
217 195222 : = gfc_add_field_to_struct (t,
218 : get_identifier (p->name),
219 : st_parameter[IOPARM_ptype_common].type,
220 : &chain);
221 195222 : 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 227759 : int save_warn_padded = warn_padded;
229 227759 : warn_padded = 0;
230 227759 : gfc_finish_type (t);
231 227759 : warn_padded = save_warn_padded;
232 227759 : st_parameter[ptype].type = t;
233 227759 : }
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 32537 : gfc_build_io_library_fndecls (void)
299 : {
300 32537 : tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
301 32537 : tree gfc_intio_type_node;
302 32537 : tree parm_type, dt_parm_type;
303 32537 : HOST_WIDE_INT pad_size;
304 32537 : unsigned int ptype;
305 :
306 32537 : types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
307 65074 : types[IOPARM_type_intio] = gfc_intio_type_node
308 32537 : = gfc_get_int_type (gfc_intio_kind);
309 32537 : types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
310 32537 : types[IOPARM_type_pintio]
311 32537 : = build_pointer_type (gfc_intio_type_node);
312 32537 : types[IOPARM_type_parray] = pchar_type_node;
313 32537 : types[IOPARM_type_pchar] = pchar_type_node;
314 32537 : pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
315 32537 : pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
316 32537 : pad_idx = build_index_type (size_int (pad_size - 1));
317 32537 : 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 32537 : 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 260296 : for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
327 227759 : gfc_build_st_parameter ((enum ioparam_type) ptype, types);
328 :
329 : /* Define the transfer functions. */
330 :
331 32537 : dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
332 :
333 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 65074 : iocall[IOCALL_X_CHARACTER_WIDE_WRITE] =
371 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
434 32537 : 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 32537 : parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
439 32537 : 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 32537 : parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
444 32537 : 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 32537 : 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 32537 : parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
453 32537 : 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 32537 : parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
458 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : 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 32537 : }
504 :
505 :
506 : static void
507 102440 : set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value)
508 : {
509 102440 : tree tmp;
510 102440 : gfc_st_parameter_field *p = &st_parameter_field[type];
511 :
512 102440 : if (p->param_type == IOPARM_ptype_common)
513 97658 : var = fold_build3_loc (input_location, COMPONENT_REF,
514 : st_parameter[IOPARM_ptype_common].type,
515 97658 : var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
516 102440 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
517 : var, p->field, NULL_TREE);
518 102440 : gfc_add_modify (block, tmp, value);
519 102440 : }
520 :
521 :
522 : /* Generate code to store an integer constant into the
523 : st_parameter_XXX structure. */
524 :
525 : static unsigned int
526 99346 : set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
527 : unsigned int val)
528 : {
529 99346 : gfc_st_parameter_field *p = &st_parameter_field[type];
530 :
531 99346 : set_parameter_tree (block, var, type,
532 99346 : build_int_cst (TREE_TYPE (p->field), val));
533 99346 : 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 31318 : set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var,
572 : enum iofield type, gfc_expr *e)
573 : {
574 31318 : gfc_se se;
575 31318 : tree tmp;
576 31318 : gfc_st_parameter_field *p = &st_parameter_field[type];
577 31318 : tree dest_type = TREE_TYPE (p->field);
578 :
579 31318 : gfc_init_se (&se, NULL);
580 31318 : gfc_conv_expr_val (&se, e);
581 :
582 : /* If we're storing a UNIT number, we need to check it first. */
583 31318 : 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 31318 : se.expr = convert (dest_type, se.expr);
612 31318 : gfc_add_block_to_block (block, &se.pre);
613 :
614 31318 : if (p->param_type == IOPARM_ptype_common)
615 31318 : var = fold_build3_loc (input_location, COMPONENT_REF,
616 : st_parameter[IOPARM_ptype_common].type,
617 31318 : var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
618 :
619 31318 : tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
620 : p->field, NULL_TREE);
621 31318 : gfc_add_modify (block, tmp, se.expr);
622 31318 : 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 25775 : set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
835 : enum iofield type, gfc_expr * e)
836 : {
837 25775 : gfc_se se;
838 25775 : tree tmp;
839 25775 : tree io;
840 25775 : tree len;
841 25775 : gfc_st_parameter_field *p = &st_parameter_field[type];
842 :
843 25775 : gfc_init_se (&se, NULL);
844 :
845 25775 : 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 25775 : io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
850 : var, p->field, NULL_TREE);
851 25775 : len = fold_build3_loc (input_location, COMPONENT_REF,
852 25775 : TREE_TYPE (p->field_len),
853 : var, p->field_len, NULL_TREE);
854 :
855 : /* Integer variable assigned a format label. */
856 25775 : 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 25774 : if (e->ts.type == BT_CHARACTER && e->rank == 0)
882 25649 : 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 25774 : gfc_conv_string_parameter (&se);
890 25774 : gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
891 25774 : gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len),
892 : se.string_length));
893 : }
894 :
895 25775 : gfc_add_block_to_block (block, &se.pre);
896 25775 : gfc_add_block_to_block (postblock, &se.post);
897 25775 : 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 10125 : set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
906 : tree var, gfc_expr * e)
907 : {
908 10125 : gfc_se se;
909 10125 : tree io;
910 10125 : tree len;
911 10125 : tree desc;
912 10125 : tree tmp;
913 10125 : gfc_st_parameter_field *p;
914 10125 : unsigned int mask;
915 :
916 10125 : gfc_init_se (&se, NULL);
917 :
918 10125 : p = &st_parameter_field[IOPARM_dt_internal_unit];
919 10125 : mask = p->mask;
920 10125 : io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
921 : var, p->field, NULL_TREE);
922 10125 : len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len),
923 : var, p->field_len, NULL_TREE);
924 10125 : p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
925 10125 : desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
926 : var, p->field, NULL_TREE);
927 :
928 10125 : gcc_assert (e->ts.type == BT_CHARACTER);
929 :
930 : /* Character scalars. */
931 10125 : if (e->rank == 0)
932 : {
933 9589 : gfc_conv_expr (&se, e);
934 9589 : gfc_conv_string_parameter (&se);
935 9589 : tmp = se.expr;
936 9589 : 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 10125 : gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
967 10125 : gfc_add_modify (&se.pre, len,
968 10125 : fold_convert (TREE_TYPE (len), se.string_length));
969 10125 : gfc_add_modify (&se.pre, desc, se.expr);
970 :
971 10125 : gfc_add_block_to_block (block, &se.pre);
972 10125 : gfc_add_block_to_block (post_block, &se.post);
973 10125 : 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 42406 : 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 42406 : stmtblock_t body;
1012 42406 : tree tmp, rc;
1013 42406 : 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 42406 : if (err_label == NULL
1018 42406 : && end_label == NULL
1019 41581 : && eor_label == NULL)
1020 41557 : 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 42490 : set_error_locus (stmtblock_t * block, tree var, locus * where)
1053 : {
1054 42490 : tree str, locus_file;
1055 42490 : gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
1056 :
1057 42490 : locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1058 : st_parameter[IOPARM_ptype_common].type,
1059 42490 : var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
1060 42490 : locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1061 42490 : TREE_TYPE (p->field), locus_file,
1062 : p->field, NULL_TREE);
1063 42490 : location_t loc = gfc_get_location (where);
1064 42490 : str = gfc_build_cstring_const (LOCATION_FILE (loc));
1065 42490 : str = gfc_build_addr_expr (pchar_type_node, str);
1066 42490 : gfc_add_modify (block, locus_file, str);
1067 :
1068 42490 : set_parameter_const (block, var, IOPARM_common_line, LOCATION_LINE (loc));
1069 42490 : }
1070 :
1071 :
1072 : /* Translate an OPEN statement. */
1073 :
1074 : tree
1075 3624 : gfc_trans_open (gfc_code * code)
1076 : {
1077 3624 : stmtblock_t block, post_block;
1078 3624 : gfc_open *p;
1079 3624 : tree tmp, var;
1080 3624 : unsigned int mask = 0;
1081 :
1082 3624 : gfc_start_block (&block);
1083 3624 : gfc_init_block (&post_block);
1084 :
1085 3624 : var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
1086 :
1087 3624 : set_error_locus (&block, var, &code->loc);
1088 3624 : p = code->ext.open;
1089 :
1090 3624 : if (p->iomsg)
1091 42 : mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1092 : p->iomsg);
1093 :
1094 3624 : if (p->iostat)
1095 130 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1096 : p->iostat);
1097 :
1098 3624 : if (p->err)
1099 75 : mask |= IOPARM_common_err;
1100 :
1101 3624 : if (p->file)
1102 1496 : mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
1103 :
1104 3624 : if (p->status)
1105 2154 : mask |= set_string (&block, &post_block, var, IOPARM_open_status,
1106 : p->status);
1107 :
1108 3624 : if (p->access)
1109 763 : mask |= set_string (&block, &post_block, var, IOPARM_open_access,
1110 : p->access);
1111 :
1112 3624 : if (p->form)
1113 1103 : mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
1114 :
1115 3624 : if (p->recl)
1116 242 : mask |= set_parameter_value (&block, var, IOPARM_open_recl_in,
1117 : p->recl);
1118 :
1119 3624 : if (p->blank)
1120 12 : mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
1121 : p->blank);
1122 :
1123 3624 : if (p->position)
1124 108 : mask |= set_string (&block, &post_block, var, IOPARM_open_position,
1125 : p->position);
1126 :
1127 3624 : if (p->action)
1128 231 : mask |= set_string (&block, &post_block, var, IOPARM_open_action,
1129 : p->action);
1130 :
1131 3624 : if (p->delim)
1132 120 : mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
1133 : p->delim);
1134 :
1135 3624 : if (p->pad)
1136 30 : mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
1137 :
1138 3624 : if (p->decimal)
1139 36 : mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
1140 : p->decimal);
1141 :
1142 3624 : if (p->encoding)
1143 60 : mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
1144 : p->encoding);
1145 :
1146 3624 : if (p->round)
1147 0 : mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
1148 :
1149 3624 : if (p->sign)
1150 18 : mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
1151 :
1152 3624 : if (p->asynchronous)
1153 100 : mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
1154 : p->asynchronous);
1155 :
1156 3624 : if (p->convert)
1157 72 : mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
1158 : p->convert);
1159 :
1160 3624 : if (p->newunit)
1161 183 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
1162 : p->newunit);
1163 :
1164 3624 : if (p->cc)
1165 24 : mask |= set_string (&block, &post_block, var, IOPARM_open_cc, p->cc);
1166 :
1167 3624 : if (p->share)
1168 24 : mask |= set_string (&block, &post_block, var, IOPARM_open_share, p->share);
1169 :
1170 3624 : mask |= set_parameter_const (&block, var, IOPARM_open_readonly, p->readonly);
1171 :
1172 3624 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
1173 :
1174 3624 : if (p->unit)
1175 3441 : 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 3624 : tmp = gfc_build_addr_expr (NULL_TREE, var);
1180 3624 : tmp = build_call_expr_loc (input_location,
1181 : iocall[IOCALL_OPEN], 1, tmp);
1182 3624 : gfc_add_expr_to_block (&block, tmp);
1183 :
1184 3624 : gfc_add_block_to_block (&block, &post_block);
1185 :
1186 3624 : io_result (&block, var, p->err, NULL, NULL);
1187 :
1188 3624 : return gfc_finish_block (&block);
1189 : }
1190 :
1191 :
1192 : /* Translate a CLOSE statement. */
1193 :
1194 : tree
1195 3104 : gfc_trans_close (gfc_code * code)
1196 : {
1197 3104 : stmtblock_t block, post_block;
1198 3104 : gfc_close *p;
1199 3104 : tree tmp, var;
1200 3104 : unsigned int mask = 0;
1201 :
1202 3104 : gfc_start_block (&block);
1203 3104 : gfc_init_block (&post_block);
1204 :
1205 3104 : var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
1206 :
1207 3104 : set_error_locus (&block, var, &code->loc);
1208 3104 : p = code->ext.close;
1209 :
1210 3104 : if (p->iomsg)
1211 12 : mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1212 : p->iomsg);
1213 :
1214 3104 : if (p->iostat)
1215 19 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1216 : p->iostat);
1217 :
1218 3104 : if (p->err)
1219 7 : mask |= IOPARM_common_err;
1220 :
1221 3104 : if (p->status)
1222 1389 : mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1223 : p->status);
1224 :
1225 3104 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
1226 :
1227 3104 : if (p->unit)
1228 3104 : 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 3104 : tmp = gfc_build_addr_expr (NULL_TREE, var);
1233 3104 : tmp = build_call_expr_loc (input_location,
1234 : iocall[IOCALL_CLOSE], 1, tmp);
1235 3104 : gfc_add_expr_to_block (&block, tmp);
1236 :
1237 3104 : gfc_add_block_to_block (&block, &post_block);
1238 :
1239 3104 : io_result (&block, var, p->err, NULL, NULL);
1240 :
1241 3104 : return gfc_finish_block (&block);
1242 : }
1243 :
1244 :
1245 : /* Common subroutine for building a file positioning statement. */
1246 :
1247 : static tree
1248 2793 : build_filepos (tree function, gfc_code * code)
1249 : {
1250 2793 : stmtblock_t block, post_block;
1251 2793 : gfc_filepos *p;
1252 2793 : tree tmp, var;
1253 2793 : unsigned int mask = 0;
1254 :
1255 2793 : p = code->ext.filepos;
1256 :
1257 2793 : gfc_start_block (&block);
1258 2793 : gfc_init_block (&post_block);
1259 :
1260 2793 : var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1261 : "filepos_parm");
1262 :
1263 2793 : set_error_locus (&block, var, &code->loc);
1264 :
1265 2793 : if (p->iomsg)
1266 30 : mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1267 : p->iomsg);
1268 :
1269 2793 : if (p->iostat)
1270 63 : mask |= set_parameter_ref (&block, &post_block, var,
1271 : IOPARM_common_iostat, p->iostat);
1272 :
1273 2793 : if (p->err)
1274 16 : mask |= IOPARM_common_err;
1275 :
1276 2793 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
1277 :
1278 2793 : if (p->unit)
1279 2793 : 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 2793 : tmp = gfc_build_addr_expr (NULL_TREE, var);
1285 2793 : tmp = build_call_expr_loc (input_location,
1286 : function, 1, tmp);
1287 2793 : gfc_add_expr_to_block (&block, tmp);
1288 :
1289 2793 : gfc_add_block_to_block (&block, &post_block);
1290 :
1291 2793 : io_result (&block, var, p->err, NULL, NULL);
1292 :
1293 2793 : 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 2270 : gfc_trans_rewind (gfc_code * code)
1319 : {
1320 2270 : 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 1868 : nml_full_name (const char* var_name, const char* cmp_name, bool parent)
1588 : {
1589 1868 : int full_name_length;
1590 1868 : char * full_name;
1591 :
1592 1868 : full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1593 1868 : full_name = XCNEWVEC (char, full_name_length + 1);
1594 1868 : strcpy (full_name, var_name);
1595 1868 : full_name = strcat (full_name, parent ? "+" : "%");
1596 1868 : full_name = strcat (full_name, cmp_name);
1597 1868 : 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 4915 : nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1609 : tree base_addr)
1610 : {
1611 4915 : tree decl = NULL_TREE;
1612 4915 : tree tmp;
1613 :
1614 4915 : if (sym)
1615 : {
1616 3035 : sym->attr.referenced = 1;
1617 3035 : decl = gfc_get_symbol_decl (sym);
1618 :
1619 : /* If this is the enclosing function declaration, use
1620 : the fake result instead. */
1621 3035 : if (decl == current_function_decl)
1622 12 : decl = gfc_get_fake_result_decl (sym, 0);
1623 3023 : else if (decl == DECL_CONTEXT (current_function_decl))
1624 0 : decl = gfc_get_fake_result_decl (sym, 1);
1625 : }
1626 : else
1627 1880 : decl = c->backend_decl;
1628 :
1629 4915 : 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 4915 : tmp = decl;
1635 :
1636 : /* Build indirect reference, if dummy argument. */
1637 :
1638 4915 : 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 4915 : if (TREE_CODE (decl) == FIELD_DECL)
1645 1880 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
1646 : base_addr, tmp, NULL_TREE);
1647 :
1648 4915 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1649 4915 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp))))
1650 12 : tmp = gfc_class_data_get (tmp);
1651 :
1652 4915 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1653 : {
1654 324 : tmp = gfc_conv_array_data (tmp);
1655 324 : STRIP_NOPS (tmp);
1656 : }
1657 : else
1658 : {
1659 4591 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1660 4399 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1661 :
1662 4591 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1663 0 : tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1664 :
1665 4591 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1666 0 : tmp = build_fold_indirect_ref_loc (input_location,
1667 : tmp);
1668 : }
1669 :
1670 4915 : gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1671 :
1672 4915 : return tmp;
1673 : }
1674 :
1675 :
1676 : /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1677 : call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1678 : generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1679 :
1680 : #define IARG(i) build_int_cst (gfc_array_index_type, i)
1681 :
1682 : static void
1683 4903 : transfer_namelist_element (stmtblock_t * block, const char * var_name,
1684 : gfc_symbol * sym, gfc_component * c,
1685 : tree base_addr)
1686 : {
1687 4903 : gfc_typespec * ts = NULL;
1688 4903 : gfc_array_spec * as = NULL;
1689 4903 : tree addr_expr = NULL;
1690 4903 : tree dt = NULL;
1691 4903 : tree string;
1692 4903 : tree tmp;
1693 4903 : tree dtype;
1694 4903 : tree dt_parm_addr;
1695 4903 : tree decl = NULL_TREE;
1696 4903 : tree gfc_int4_type_node = gfc_get_int_type (4);
1697 4903 : tree dtio_proc = null_pointer_node;
1698 4903 : tree vtable = null_pointer_node;
1699 4903 : int n_dim;
1700 4903 : int rank = 0;
1701 :
1702 4903 : gcc_assert (sym || c);
1703 :
1704 : /* Build the namelist object name. */
1705 4903 : if (sym && sym->attr.use_rename && sym->ns->use_stmts->rename
1706 73 : && strlen(sym->ns->use_stmts->rename->local_name) > 0
1707 36 : && strcmp(sym->ns->use_stmts->rename->use_name, var_name) == 0)
1708 18 : string = gfc_build_cstring_const (sym->ns->use_stmts->rename->local_name);
1709 : else
1710 4885 : string = gfc_build_cstring_const (var_name);
1711 4903 : string = gfc_build_addr_expr (pchar_type_node, string);
1712 :
1713 : /* Build ts, as and data address using symbol or component. */
1714 :
1715 4903 : ts = sym ? &sym->ts : &c->ts;
1716 :
1717 4903 : if (ts->type != BT_CLASS)
1718 4885 : as = sym ? sym->as : c->as;
1719 : else
1720 18 : as = sym ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as;
1721 :
1722 4903 : addr_expr = nml_get_addr_expr (sym, c, base_addr);
1723 :
1724 4903 : if (as)
1725 1963 : rank = as->rank;
1726 :
1727 1963 : if (rank)
1728 : {
1729 1963 : decl = sym ? sym->backend_decl : c->backend_decl;
1730 1963 : if (sym && sym->attr.dummy)
1731 325 : decl = build_fold_indirect_ref_loc (input_location, decl);
1732 :
1733 1963 : if (ts->type == BT_CLASS)
1734 12 : decl = gfc_class_data_get (decl);
1735 1963 : dt = TREE_TYPE (decl);
1736 1963 : dtype = gfc_get_dtype (dt);
1737 : }
1738 : else
1739 : {
1740 2940 : dt = gfc_typenode_for_spec (ts);
1741 2940 : dtype = gfc_get_dtype_rank_type (0, dt);
1742 : }
1743 :
1744 : /* Build up the arguments for the transfer call.
1745 : The call for the scalar part transfers:
1746 : (address, name, type, kind or string_length, dtype) */
1747 :
1748 4903 : dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1749 :
1750 : /* Check if the derived type has a specific DTIO for the mode.
1751 : Note that although namelist io is forbidden to have a format
1752 : list, the specific subroutine is of the formatted kind. */
1753 4903 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
1754 : {
1755 968 : gfc_symbol *derived;
1756 968 : if (ts->type==BT_CLASS)
1757 18 : derived = ts->u.derived->components->ts.u.derived;
1758 : else
1759 950 : derived = ts->u.derived;
1760 :
1761 968 : gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
1762 : last_dt == WRITE, true);
1763 :
1764 968 : if (ts->type == BT_CLASS && tb_io_st)
1765 : {
1766 : // polymorphic DTIO call (based on the dynamic type)
1767 18 : gfc_se se;
1768 18 : gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1769 : // build vtable expr
1770 18 : gfc_expr *expr = gfc_get_variable_expr (st);
1771 18 : gfc_add_vptr_component (expr);
1772 18 : gfc_init_se (&se, NULL);
1773 18 : se.want_pointer = 1;
1774 18 : gfc_conv_expr (&se, expr);
1775 18 : vtable = se.expr;
1776 : // build dtio expr
1777 18 : gfc_add_component_ref (expr,
1778 18 : tb_io_st->n.tb->u.generic->specific_st->name);
1779 18 : gfc_init_se (&se, NULL);
1780 18 : se.want_pointer = 1;
1781 18 : gfc_conv_expr (&se, expr);
1782 18 : gfc_free_expr (expr);
1783 18 : dtio_proc = se.expr;
1784 18 : }
1785 : else
1786 : {
1787 : // non-polymorphic DTIO call (based on the declared type)
1788 950 : gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived,
1789 : last_dt == WRITE, true);
1790 950 : if (dtio_sub != NULL)
1791 : {
1792 78 : dtio_proc = gfc_get_symbol_decl (dtio_sub);
1793 78 : dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
1794 78 : gfc_symbol *vtab = gfc_find_derived_vtab (derived);
1795 78 : vtable = vtab->backend_decl;
1796 78 : if (vtable == NULL_TREE)
1797 0 : vtable = gfc_get_symbol_decl (vtab);
1798 78 : vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
1799 : }
1800 : }
1801 : }
1802 :
1803 4903 : if (ts->type == BT_CHARACTER)
1804 1602 : tmp = ts->u.cl->backend_decl;
1805 : else
1806 3301 : tmp = build_int_cst (gfc_charlen_type_node, 0);
1807 :
1808 4903 : int abi_kind = gfc_type_abi_kind (ts);
1809 4903 : if (dtio_proc == null_pointer_node)
1810 4807 : tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_VAL], 6,
1811 : dt_parm_addr, addr_expr, string,
1812 4807 : build_int_cst (gfc_int4_type_node, abi_kind),
1813 : tmp, dtype);
1814 : else
1815 96 : tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_DTIO_VAL],
1816 : 8, dt_parm_addr, addr_expr, string,
1817 96 : build_int_cst (gfc_int4_type_node, abi_kind),
1818 : tmp, dtype, dtio_proc, vtable);
1819 4903 : gfc_add_expr_to_block (block, tmp);
1820 :
1821 : /* If the object is an array, transfer rank times:
1822 : (null pointer, name, stride, lbound, ubound) */
1823 :
1824 11829 : for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1825 : {
1826 2023 : if (c && c->attr.pdt_array)
1827 12 : decl = TREE_OPERAND (nml_get_addr_expr (sym, c, base_addr), 0);
1828 :
1829 2023 : tmp = build_call_expr_loc (input_location,
1830 : iocall[IOCALL_SET_NML_VAL_DIM], 5,
1831 : dt_parm_addr,
1832 2023 : build_int_cst (gfc_int4_type_node, n_dim),
1833 : gfc_conv_array_stride (decl, n_dim),
1834 : gfc_conv_array_lbound (decl, n_dim),
1835 : gfc_conv_array_ubound (decl, n_dim));
1836 2023 : gfc_add_expr_to_block (block, tmp);
1837 : }
1838 :
1839 4903 : if (gfc_bt_struct (ts->type) && ts->u.derived->components
1840 950 : && dtio_proc == null_pointer_node)
1841 : {
1842 872 : gfc_component *cmp;
1843 :
1844 : /* Provide the RECORD_TYPE to build component references. */
1845 :
1846 872 : tree expr = build_fold_indirect_ref_loc (input_location,
1847 : addr_expr);
1848 :
1849 2740 : for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1850 : {
1851 3736 : char *full_name = nml_full_name (var_name, cmp->name,
1852 1868 : ts->u.derived->attr.extension);
1853 1868 : transfer_namelist_element (block,
1854 : full_name,
1855 : NULL, cmp, expr);
1856 1868 : free (full_name);
1857 : }
1858 : }
1859 4903 : }
1860 :
1861 : #undef IARG
1862 :
1863 : /* Create a data transfer statement. Not all of the fields are valid
1864 : for both reading and writing, but improper use has been filtered
1865 : out by now. */
1866 :
1867 : static tree
1868 32115 : build_dt (tree function, gfc_code * code)
1869 : {
1870 32115 : stmtblock_t block, post_block, post_end_block, post_iu_block;
1871 32115 : gfc_dt *dt;
1872 32115 : tree tmp, var;
1873 32115 : gfc_expr *nmlname;
1874 32115 : gfc_namelist *nml;
1875 32115 : unsigned int mask = 0;
1876 :
1877 32115 : gfc_start_block (&block);
1878 32115 : gfc_init_block (&post_block);
1879 32115 : gfc_init_block (&post_end_block);
1880 32115 : gfc_init_block (&post_iu_block);
1881 :
1882 32115 : var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1883 :
1884 32115 : set_error_locus (&block, var, &code->loc);
1885 :
1886 32115 : if (last_dt == IOLENGTH)
1887 : {
1888 84 : gfc_inquire *inq;
1889 :
1890 84 : inq = code->ext.inquire;
1891 :
1892 : /* First check that preconditions are met. */
1893 84 : gcc_assert (inq != NULL);
1894 84 : gcc_assert (inq->iolength != NULL);
1895 :
1896 : /* Connect to the iolength variable. */
1897 84 : mask |= set_parameter_ref (&block, &post_end_block, var,
1898 : IOPARM_dt_iolength, inq->iolength);
1899 84 : dt = NULL;
1900 : }
1901 : else
1902 : {
1903 32031 : dt = code->ext.dt;
1904 32031 : gcc_assert (dt != NULL);
1905 : }
1906 :
1907 32115 : if (dt && dt->io_unit)
1908 : {
1909 32031 : if (dt->io_unit->ts.type == BT_CHARACTER)
1910 : {
1911 10125 : mask |= set_internal_unit (&block, &post_iu_block,
1912 : var, dt->io_unit);
1913 10125 : set_parameter_const (&block, var, IOPARM_common_unit,
1914 10125 : dt->io_unit->ts.kind == 1 ?
1915 : GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4);
1916 : }
1917 : }
1918 : else
1919 84 : set_parameter_const (&block, var, IOPARM_common_unit, 0);
1920 :
1921 10209 : if (dt)
1922 : {
1923 32031 : if (dt->iomsg)
1924 422 : mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1925 : dt->iomsg);
1926 :
1927 32031 : if (dt->iostat)
1928 1778 : mask |= set_parameter_ref (&block, &post_end_block, var,
1929 : IOPARM_common_iostat, dt->iostat);
1930 :
1931 32031 : if (dt->err)
1932 249 : mask |= IOPARM_common_err;
1933 :
1934 32031 : if (dt->eor)
1935 30 : mask |= IOPARM_common_eor;
1936 :
1937 32031 : if (dt->end)
1938 556 : mask |= IOPARM_common_end;
1939 :
1940 32031 : if (dt->id)
1941 19 : mask |= set_parameter_ref (&block, &post_end_block, var,
1942 : IOPARM_dt_id, dt->id);
1943 :
1944 32031 : if (dt->pos)
1945 168 : mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1946 :
1947 32031 : if (dt->asynchronous)
1948 194 : mask |= set_string (&block, &post_block, var,
1949 : IOPARM_dt_asynchronous, dt->asynchronous);
1950 :
1951 32031 : if (dt->blank)
1952 13 : mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1953 : dt->blank);
1954 :
1955 32031 : if (dt->decimal)
1956 141 : mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1957 : dt->decimal);
1958 :
1959 32031 : if (dt->delim)
1960 2 : mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1961 : dt->delim);
1962 :
1963 32031 : if (dt->pad)
1964 79 : mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1965 : dt->pad);
1966 :
1967 32031 : if (dt->round)
1968 313 : mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1969 : dt->round);
1970 :
1971 32031 : if (dt->sign)
1972 13 : mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1973 : dt->sign);
1974 :
1975 32031 : if (dt->rec)
1976 493 : mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1977 :
1978 32031 : if (dt->advance)
1979 359 : mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1980 : dt->advance);
1981 :
1982 32031 : if (dt->format_expr)
1983 12338 : mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1984 : dt->format_expr);
1985 :
1986 32031 : if (dt->format_label)
1987 : {
1988 16119 : if (dt->format_label == &format_asterisk)
1989 14339 : mask |= IOPARM_dt_list_format;
1990 : else
1991 1780 : mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1992 1780 : dt->format_label->format);
1993 : }
1994 :
1995 32031 : if (dt->size)
1996 55 : mask |= set_parameter_ref (&block, &post_end_block, var,
1997 : IOPARM_dt_size, dt->size);
1998 :
1999 32031 : if (dt->udtio)
2000 364 : mask |= IOPARM_dt_dtio;
2001 :
2002 32031 : if (dt->dec_ext)
2003 480 : mask |= IOPARM_dt_dec_ext;
2004 :
2005 32031 : if (dt->namelist)
2006 : {
2007 1210 : if (dt->format_expr || dt->format_label)
2008 0 : gfc_internal_error ("build_dt: format with namelist");
2009 :
2010 2420 : nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
2011 : dt->namelist->name,
2012 1210 : strlen (dt->namelist->name));
2013 :
2014 1210 : mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
2015 : nmlname);
2016 :
2017 1210 : gfc_free_expr (nmlname);
2018 :
2019 1210 : if (last_dt == READ)
2020 884 : mask |= IOPARM_dt_namelist_read_mode;
2021 :
2022 1210 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
2023 :
2024 1210 : dt_parm = var;
2025 :
2026 4245 : for (nml = dt->namelist->namelist; nml; nml = nml->next)
2027 3035 : transfer_namelist_element (&block, nml->sym->name, nml->sym,
2028 : NULL, NULL_TREE);
2029 : }
2030 : else
2031 30821 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
2032 :
2033 32031 : if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
2034 21906 : set_parameter_value_chk (&block, dt->iostat, var,
2035 : IOPARM_common_unit, dt->io_unit);
2036 : }
2037 : else
2038 84 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
2039 :
2040 32115 : tmp = gfc_build_addr_expr (NULL_TREE, var);
2041 32115 : tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2042 : function, 1, tmp);
2043 32115 : gfc_add_expr_to_block (&block, tmp);
2044 :
2045 32115 : gfc_add_block_to_block (&block, &post_block);
2046 :
2047 32115 : dt_parm = var;
2048 32115 : dt_post_end_block = &post_end_block;
2049 :
2050 : /* Set implied do loop exit condition. */
2051 32115 : if (last_dt == READ || last_dt == WRITE)
2052 : {
2053 32031 : gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
2054 :
2055 32031 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
2056 : st_parameter[IOPARM_ptype_common].type,
2057 32031 : dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
2058 : NULL_TREE);
2059 32031 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
2060 32031 : TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
2061 32031 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
2062 32031 : tmp, build_int_cst (TREE_TYPE (tmp),
2063 : IOPARM_common_libreturn_mask));
2064 : }
2065 : else /* IOLENGTH */
2066 : tmp = NULL_TREE;
2067 :
2068 32115 : gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
2069 :
2070 32115 : gfc_add_block_to_block (&block, &post_iu_block);
2071 :
2072 32115 : dt_parm = NULL;
2073 32115 : dt_post_end_block = NULL;
2074 :
2075 32115 : return gfc_finish_block (&block);
2076 : }
2077 :
2078 :
2079 : /* Translate the IOLENGTH form of an INQUIRE statement. We treat
2080 : this as a third sort of data transfer statement, except that
2081 : lengths are summed instead of actually transferring any data. */
2082 :
2083 : tree
2084 84 : gfc_trans_iolength (gfc_code * code)
2085 : {
2086 84 : last_dt = IOLENGTH;
2087 84 : return build_dt (iocall[IOCALL_IOLENGTH], code);
2088 : }
2089 :
2090 :
2091 : /* Translate a READ statement. */
2092 :
2093 : tree
2094 6417 : gfc_trans_read (gfc_code * code)
2095 : {
2096 6417 : last_dt = READ;
2097 6417 : return build_dt (iocall[IOCALL_READ], code);
2098 : }
2099 :
2100 :
2101 : /* Translate a WRITE statement */
2102 :
2103 : tree
2104 25614 : gfc_trans_write (gfc_code * code)
2105 : {
2106 25614 : last_dt = WRITE;
2107 25614 : return build_dt (iocall[IOCALL_WRITE], code);
2108 : }
2109 :
2110 :
2111 : /* Finish a data transfer statement. */
2112 :
2113 : tree
2114 32115 : gfc_trans_dt_end (gfc_code * code)
2115 : {
2116 32115 : tree function, tmp;
2117 32115 : stmtblock_t block;
2118 :
2119 32115 : gfc_init_block (&block);
2120 :
2121 32115 : switch (last_dt)
2122 : {
2123 6417 : case READ:
2124 6417 : function = iocall[IOCALL_READ_DONE];
2125 6417 : break;
2126 :
2127 25614 : case WRITE:
2128 25614 : function = iocall[IOCALL_WRITE_DONE];
2129 25614 : break;
2130 :
2131 84 : case IOLENGTH:
2132 84 : function = iocall[IOCALL_IOLENGTH_DONE];
2133 84 : break;
2134 :
2135 0 : default:
2136 0 : gcc_unreachable ();
2137 : }
2138 :
2139 32115 : tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2140 32115 : tmp = build_call_expr_loc (input_location,
2141 : function, 1, tmp);
2142 32115 : gfc_add_expr_to_block (&block, tmp);
2143 32115 : gfc_add_block_to_block (&block, dt_post_end_block);
2144 32115 : gfc_init_block (dt_post_end_block);
2145 :
2146 32115 : if (last_dt != IOLENGTH)
2147 : {
2148 32031 : gcc_assert (code->ext.dt != NULL);
2149 32031 : io_result (&block, dt_parm, code->ext.dt->err,
2150 : code->ext.dt->end, code->ext.dt->eor);
2151 : }
2152 :
2153 32115 : return gfc_finish_block (&block);
2154 : }
2155 :
2156 : static void
2157 : transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2158 : gfc_code * code, tree vptr);
2159 :
2160 : /* Given an array field in a derived type variable, generate the code
2161 : for the loop that iterates over array elements, and the code that
2162 : accesses those array elements. Use transfer_expr to generate code
2163 : for transferring that element. Because elements may also be
2164 : derived types, transfer_expr and transfer_array_component are mutually
2165 : recursive. */
2166 :
2167 : static tree
2168 81 : transfer_array_component (tree expr, gfc_component * cm, locus * where)
2169 : {
2170 81 : tree tmp;
2171 81 : stmtblock_t body;
2172 81 : stmtblock_t block;
2173 81 : gfc_loopinfo loop;
2174 81 : int n;
2175 81 : gfc_ss *ss;
2176 81 : gfc_se se;
2177 81 : gfc_array_info *ss_array;
2178 :
2179 81 : gfc_start_block (&block);
2180 81 : gfc_init_se (&se, NULL);
2181 :
2182 : /* Create and initialize Scalarization Status. Unlike in
2183 : gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2184 : care of this task, because we don't have a gfc_expr at hand.
2185 : Build one manually, as in gfc_trans_subarray_assign. */
2186 :
2187 81 : ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
2188 : GFC_SS_COMPONENT);
2189 81 : ss_array = &ss->info->data.array;
2190 :
2191 81 : if (cm->attr.pdt_array)
2192 12 : ss_array->shape = NULL;
2193 : else
2194 69 : ss_array->shape = gfc_get_shape (cm->as->rank);
2195 :
2196 81 : ss_array->descriptor = expr;
2197 81 : ss_array->data = gfc_conv_array_data (expr);
2198 81 : ss_array->offset = gfc_conv_array_offset (expr);
2199 162 : for (n = 0; n < cm->as->rank; n++)
2200 : {
2201 81 : ss_array->start[n] = gfc_conv_array_lbound (expr, n);
2202 81 : ss_array->stride[n] = gfc_index_one_node;
2203 :
2204 81 : if (cm->attr.pdt_array)
2205 12 : ss_array->end[n] = gfc_conv_array_ubound (expr, n);
2206 : else
2207 : {
2208 69 : mpz_init (ss_array->shape[n]);
2209 69 : mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
2210 69 : cm->as->lower[n]->value.integer);
2211 69 : mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
2212 : }
2213 : }
2214 :
2215 : /* Once we got ss, we use scalarizer to create the loop. */
2216 :
2217 81 : gfc_init_loopinfo (&loop);
2218 81 : gfc_add_ss_to_loop (&loop, ss);
2219 81 : gfc_conv_ss_startstride (&loop);
2220 81 : gfc_conv_loop_setup (&loop, where);
2221 81 : gfc_mark_ss_chain_used (ss, 1);
2222 81 : gfc_start_scalarized_body (&loop, &body);
2223 :
2224 81 : gfc_copy_loopinfo_to_se (&se, &loop);
2225 81 : se.ss = ss;
2226 :
2227 : /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2228 81 : se.expr = expr;
2229 81 : gfc_conv_tmp_array_ref (&se);
2230 :
2231 : /* Now se.expr contains an element of the array. Take the address and pass
2232 : it to the IO routines. */
2233 81 : tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2234 81 : transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
2235 :
2236 : /* We are done now with the loop body. Wrap up the scalarizer and
2237 : return. */
2238 :
2239 81 : gfc_add_block_to_block (&body, &se.pre);
2240 81 : gfc_add_block_to_block (&body, &se.post);
2241 :
2242 81 : gfc_trans_scalarizing_loops (&loop, &body);
2243 :
2244 81 : gfc_add_block_to_block (&block, &loop.pre);
2245 81 : gfc_add_block_to_block (&block, &loop.post);
2246 :
2247 81 : if (!cm->attr.pdt_array)
2248 : {
2249 69 : gcc_assert (ss_array->shape != NULL);
2250 69 : gfc_free_shape (&ss_array->shape, cm->as->rank);
2251 : }
2252 81 : gfc_cleanup_loop (&loop);
2253 :
2254 81 : return gfc_finish_block (&block);
2255 : }
2256 :
2257 :
2258 : /* Helper function for transfer_expr that looks for the DTIO procedure
2259 : either as a typebound binding or in a generic interface. If present,
2260 : the address expression of the procedure is returned. It is assumed
2261 : that the procedure interface has been checked during resolution. */
2262 :
2263 : static tree
2264 492 : get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
2265 : {
2266 492 : gfc_symbol *derived;
2267 492 : bool formatted = false;
2268 492 : gfc_dt *dt = code->ext.dt;
2269 :
2270 : /* Determine when to use the formatted DTIO procedure. */
2271 492 : if (dt && (dt->format_expr || dt->format_label))
2272 492 : formatted = true;
2273 :
2274 492 : if (ts->type == BT_CLASS)
2275 48 : derived = ts->u.derived->components->ts.u.derived;
2276 : else
2277 444 : derived = ts->u.derived;
2278 :
2279 492 : gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
2280 : last_dt == WRITE, formatted);
2281 492 : if (ts->type == BT_CLASS && tb_io_st)
2282 : {
2283 : // polymorphic DTIO call (based on the dynamic type)
2284 42 : gfc_se se;
2285 42 : gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1);
2286 42 : gfc_add_vptr_component (expr);
2287 42 : gfc_add_component_ref (expr,
2288 42 : tb_io_st->n.tb->u.generic->specific_st->name);
2289 42 : *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym;
2290 42 : gfc_init_se (&se, NULL);
2291 42 : se.want_pointer = 1;
2292 42 : gfc_conv_expr (&se, expr);
2293 42 : gfc_free_expr (expr);
2294 42 : return se.expr;
2295 : }
2296 : else
2297 : {
2298 : // non-polymorphic DTIO call (based on the declared type)
2299 450 : *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
2300 : formatted);
2301 :
2302 450 : if (*dtio_sub)
2303 450 : return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
2304 : }
2305 :
2306 : return NULL_TREE;
2307 : }
2308 :
2309 : /* Generate the call for a scalar transfer node. */
2310 :
2311 : static void
2312 43345 : transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2313 : gfc_code * code, tree vptr)
2314 : {
2315 43345 : tree tmp, function, arg2, arg3, field, expr;
2316 43345 : gfc_component *c;
2317 43345 : int kind;
2318 :
2319 : /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2320 : the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2321 : We need to translate the expression to a constant if it's either
2322 : C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2323 : type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2324 : BT_DERIVED (could have been changed by gfc_conv_expr). */
2325 43345 : if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2326 14308 : && ts->u.derived != NULL
2327 695 : && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2328 : {
2329 0 : ts->type = BT_INTEGER;
2330 0 : ts->kind = gfc_index_integer_kind;
2331 : }
2332 :
2333 : /* gfortran reaches here for "print *, c_loc(xxx)". */
2334 43345 : if (ts->type == BT_VOID
2335 0 : && code->expr1 && code->expr1->ts.type == BT_VOID
2336 0 : && code->expr1->symtree
2337 0 : && strcmp (code->expr1->symtree->name, "c_loc") == 0)
2338 : {
2339 0 : ts->type = BT_INTEGER;
2340 0 : ts->kind = gfc_index_integer_kind;
2341 : }
2342 :
2343 43345 : kind = gfc_type_abi_kind (ts);
2344 43345 : function = NULL;
2345 43345 : arg2 = NULL;
2346 43345 : arg3 = NULL;
2347 :
2348 43345 : switch (ts->type)
2349 : {
2350 13613 : case BT_INTEGER:
2351 13613 : arg2 = build_int_cst (integer_type_node, kind);
2352 13613 : if (last_dt == READ)
2353 2419 : function = iocall[IOCALL_X_INTEGER];
2354 : else
2355 11194 : function = iocall[IOCALL_X_INTEGER_WRITE];
2356 :
2357 : break;
2358 :
2359 187 : case BT_UNSIGNED:
2360 187 : arg2 = build_int_cst (unsigned_type_node, kind);
2361 187 : if (last_dt == READ)
2362 72 : function = iocall[IOCALL_X_UNSIGNED];
2363 : else
2364 115 : function = iocall[IOCALL_X_UNSIGNED_WRITE];
2365 :
2366 : break;
2367 :
2368 8665 : case BT_REAL:
2369 8665 : arg2 = build_int_cst (integer_type_node, kind);
2370 8665 : if (last_dt == READ)
2371 : {
2372 1701 : if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2373 96 : function = iocall[IOCALL_X_REAL128];
2374 : else
2375 1605 : function = iocall[IOCALL_X_REAL];
2376 : }
2377 : else
2378 : {
2379 6964 : if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2380 528 : function = iocall[IOCALL_X_REAL128_WRITE];
2381 : else
2382 6436 : function = iocall[IOCALL_X_REAL_WRITE];
2383 : }
2384 :
2385 : break;
2386 :
2387 797 : case BT_COMPLEX:
2388 797 : arg2 = build_int_cst (integer_type_node, kind);
2389 797 : if (last_dt == READ)
2390 : {
2391 361 : if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2392 0 : function = iocall[IOCALL_X_COMPLEX128];
2393 : else
2394 361 : function = iocall[IOCALL_X_COMPLEX];
2395 : }
2396 : else
2397 : {
2398 436 : if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2399 3 : function = iocall[IOCALL_X_COMPLEX128_WRITE];
2400 : else
2401 433 : function = iocall[IOCALL_X_COMPLEX_WRITE];
2402 : }
2403 :
2404 : break;
2405 :
2406 1074 : case BT_LOGICAL:
2407 1074 : arg2 = build_int_cst (integer_type_node, kind);
2408 1074 : if (last_dt == READ)
2409 120 : function = iocall[IOCALL_X_LOGICAL];
2410 : else
2411 954 : function = iocall[IOCALL_X_LOGICAL_WRITE];
2412 :
2413 : break;
2414 :
2415 18248 : case BT_CHARACTER:
2416 18248 : if (kind == 4)
2417 : {
2418 587 : if (se->string_length)
2419 : arg2 = se->string_length;
2420 : else
2421 : {
2422 0 : tmp = build_fold_indirect_ref_loc (input_location,
2423 : addr_expr);
2424 0 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2425 0 : arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2426 0 : arg2 = fold_convert (gfc_charlen_type_node, arg2);
2427 : }
2428 587 : arg3 = build_int_cst (integer_type_node, kind);
2429 587 : if (last_dt == READ)
2430 132 : function = iocall[IOCALL_X_CHARACTER_WIDE];
2431 : else
2432 455 : function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
2433 :
2434 587 : tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2435 587 : tmp = build_call_expr_loc (input_location,
2436 : function, 4, tmp, addr_expr, arg2, arg3);
2437 587 : gfc_add_expr_to_block (&se->pre, tmp);
2438 587 : gfc_add_block_to_block (&se->pre, &se->post);
2439 587 : return;
2440 : }
2441 : /* Fall through. */
2442 17673 : case BT_HOLLERITH:
2443 17673 : if (se->string_length)
2444 : arg2 = se->string_length;
2445 : else
2446 : {
2447 120 : tmp = build_fold_indirect_ref_loc (input_location,
2448 : addr_expr);
2449 120 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2450 120 : arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2451 : }
2452 17673 : if (last_dt == READ)
2453 1640 : function = iocall[IOCALL_X_CHARACTER];
2454 : else
2455 16033 : function = iocall[IOCALL_X_CHARACTER_WRITE];
2456 :
2457 : break;
2458 :
2459 749 : case_bt_struct:
2460 749 : case BT_CLASS:
2461 749 : if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS)
2462 : {
2463 749 : gfc_symbol *derived;
2464 749 : gfc_symbol *dtio_sub = NULL;
2465 : /* Test for a specific DTIO subroutine. */
2466 749 : if (ts->type == BT_DERIVED)
2467 695 : derived = ts->u.derived;
2468 : else
2469 54 : derived = ts->u.derived->components->ts.u.derived;
2470 :
2471 749 : if (derived->attr.has_dtio_procs)
2472 492 : arg2 = get_dtio_proc (ts, code, &dtio_sub);
2473 :
2474 749 : if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
2475 : {
2476 480 : tree decl;
2477 480 : decl = build_fold_indirect_ref_loc (input_location,
2478 : se->expr);
2479 : /* Remember that the first dummy of the DTIO subroutines
2480 : is CLASS(derived) for extensible derived types, so the
2481 : conversion must be done here for derived type and for
2482 : scalarized CLASS array element io-list objects. */
2483 480 : if ((ts->type == BT_DERIVED
2484 432 : && !(ts->u.derived->attr.sequence
2485 419 : || ts->u.derived->attr.is_bind_c))
2486 505 : || (ts->type == BT_CLASS
2487 48 : && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
2488 443 : gfc_conv_derived_to_class (se, code->expr1,
2489 443 : dtio_sub->formal->sym, vptr, false,
2490 : false, "transfer");
2491 480 : addr_expr = se->expr;
2492 480 : function = iocall[IOCALL_X_DERIVED];
2493 480 : break;
2494 : }
2495 269 : else if (gfc_bt_struct (ts->type))
2496 : {
2497 : /* Recurse into the elements of the derived type. */
2498 269 : expr = gfc_evaluate_now (addr_expr, &se->pre);
2499 269 : expr = build_fold_indirect_ref_loc (input_location, expr);
2500 :
2501 : /* Make sure that the derived type has been built. An external
2502 : function, if only referenced in an io statement, requires this
2503 : check (see PR58771). */
2504 269 : if (ts->u.derived->backend_decl == NULL_TREE)
2505 6 : (void) gfc_typenode_for_spec (ts);
2506 :
2507 805 : for (c = ts->u.derived->components; c; c = c->next)
2508 : {
2509 : /* Ignore hidden string lengths. */
2510 536 : if (c->name[0] == '_'
2511 524 : || c->attr.pdt_kind || c->attr.pdt_len)
2512 48 : continue;
2513 :
2514 488 : field = c->backend_decl;
2515 488 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2516 :
2517 488 : tmp = fold_build3_loc (UNKNOWN_LOCATION,
2518 488 : COMPONENT_REF, TREE_TYPE (field),
2519 : expr, field, NULL_TREE);
2520 :
2521 488 : if (c->attr.dimension)
2522 : {
2523 81 : tmp = transfer_array_component (tmp, c,
2524 : code ? &code->loc
2525 : : NULL);
2526 81 : gfc_add_expr_to_block (&se->pre, tmp);
2527 : }
2528 : else
2529 : {
2530 407 : tree strlen = NULL_TREE;
2531 :
2532 407 : if (!c->attr.pointer && !c->attr.pdt_string)
2533 395 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2534 :
2535 : /* Use the hidden string length for pdt strings. */
2536 407 : if (c->attr.pdt_string
2537 12 : && gfc_deferred_strlen (c, &strlen)
2538 419 : && strlen != NULL_TREE)
2539 : {
2540 12 : strlen = fold_build3_loc (UNKNOWN_LOCATION,
2541 : COMPONENT_REF,
2542 12 : TREE_TYPE (strlen),
2543 : expr, strlen, NULL_TREE);
2544 12 : se->string_length = strlen;
2545 : }
2546 :
2547 407 : transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
2548 :
2549 : /* Reset so that the pdt string length does not propagate
2550 : through to other strings. */
2551 407 : if (c->attr.pdt_string && strlen)
2552 12 : se->string_length = NULL_TREE;
2553 : }
2554 : }
2555 269 : return;
2556 : }
2557 : /* If a CLASS object gets through to here, fall through and ICE. */
2558 : }
2559 0 : gcc_fallthrough ();
2560 0 : default:
2561 0 : gfc_internal_error ("Bad IO basetype (%d)", ts->type);
2562 : }
2563 :
2564 42489 : tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2565 42489 : tmp = build_call_expr_loc (input_location,
2566 : function, 3, tmp, addr_expr, arg2);
2567 42489 : gfc_add_expr_to_block (&se->pre, tmp);
2568 42489 : gfc_add_block_to_block (&se->pre, &se->post);
2569 :
2570 : }
2571 :
2572 :
2573 : /* Generate a call to pass an array descriptor to the IO library. The
2574 : array should be of one of the intrinsic types. */
2575 :
2576 : static void
2577 3265 : transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2578 : {
2579 3265 : tree tmp, charlen_arg, kind_arg, io_call;
2580 :
2581 3265 : if (ts->type == BT_CHARACTER)
2582 539 : charlen_arg = se->string_length;
2583 : else
2584 2726 : charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
2585 :
2586 3265 : kind_arg = build_int_cst (integer_type_node, gfc_type_abi_kind (ts));
2587 :
2588 3265 : tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2589 3265 : if (last_dt == READ)
2590 904 : io_call = iocall[IOCALL_X_ARRAY];
2591 : else
2592 2361 : io_call = iocall[IOCALL_X_ARRAY_WRITE];
2593 :
2594 3265 : tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2595 : io_call, 4,
2596 : tmp, addr_expr, kind_arg, charlen_arg);
2597 3265 : gfc_add_expr_to_block (&se->pre, tmp);
2598 3265 : gfc_add_block_to_block (&se->pre, &se->post);
2599 3265 : }
2600 :
2601 :
2602 : /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2603 :
2604 : tree
2605 46122 : gfc_trans_transfer (gfc_code * code)
2606 : {
2607 46122 : stmtblock_t block, body;
2608 46122 : gfc_loopinfo loop;
2609 46122 : gfc_expr *expr;
2610 46122 : gfc_ref *ref;
2611 46122 : gfc_ss *ss;
2612 46122 : gfc_se se;
2613 46122 : tree tmp;
2614 46122 : tree vptr;
2615 46122 : int n;
2616 :
2617 46122 : gfc_start_block (&block);
2618 46122 : gfc_init_block (&body);
2619 :
2620 46122 : expr = code->expr1;
2621 46122 : ref = NULL;
2622 46122 : gfc_init_se (&se, NULL);
2623 :
2624 46122 : if (expr->rank == 0)
2625 : {
2626 : /* Transfer a scalar value. */
2627 39523 : if (expr->ts.type == BT_CLASS)
2628 : {
2629 24 : se.want_pointer = 1;
2630 24 : gfc_conv_expr (&se, expr);
2631 24 : vptr = gfc_get_vptr_from_expr (se.expr);
2632 : }
2633 : else
2634 : {
2635 39499 : vptr = NULL_TREE;
2636 39499 : gfc_conv_expr_reference (&se, expr);
2637 : }
2638 39523 : transfer_expr (&se, &expr->ts, se.expr, code, vptr);
2639 : }
2640 : else
2641 : {
2642 : /* Transfer an array. If it is an array of an intrinsic
2643 : type, pass the descriptor to the library. Otherwise
2644 : scalarize the transfer. */
2645 6599 : if (expr->ref && !gfc_is_proc_ptr_comp (expr))
2646 : {
2647 4487 : for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2648 189 : ref = ref->next);
2649 4298 : gcc_assert (ref && ref->type == REF_ARRAY);
2650 : }
2651 :
2652 : /* These expressions don't always have the dtype element length set
2653 : correctly, rendering them useless for array transfer. */
2654 6599 : if (expr->ts.type != BT_CLASS
2655 6575 : && expr->expr_type == EXPR_VARIABLE
2656 10873 : && ((expr->symtree->n.sym->ts.type == BT_DERIVED && expr->ts.deferred)
2657 4256 : || (expr->symtree->n.sym->assoc
2658 431 : && expr->symtree->n.sym->assoc->variable)
2659 3870 : || gfc_expr_attr (expr).pointer
2660 3841 : || (expr->symtree->n.sym->attr.pointer
2661 795 : && gfc_expr_attr (expr).target)))
2662 795 : goto scalarize;
2663 :
2664 5804 : if (gfc_expr_attr (expr).pdt_string)
2665 12 : goto scalarize;
2666 :
2667 : /* With array-bounds checking enabled, force scalarization in some
2668 : situations, e.g., when an array index depends on a function
2669 : evaluation or an expression and possibly has side-effects. */
2670 5792 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2671 623 : && ref
2672 329 : && ref->u.ar.type == AR_SECTION)
2673 : {
2674 477 : for (n = 0; n < ref->u.ar.dimen; n++)
2675 290 : if (ref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2676 80 : && ref->u.ar.start[n])
2677 : {
2678 80 : switch (ref->u.ar.start[n]->expr_type)
2679 : {
2680 18 : case EXPR_FUNCTION:
2681 18 : case EXPR_OP:
2682 18 : goto scalarize;
2683 : default:
2684 : break;
2685 : }
2686 : }
2687 : }
2688 :
2689 5774 : if (!(gfc_bt_struct (expr->ts.type)
2690 : || expr->ts.type == BT_CLASS)
2691 5676 : && ref && ref->next == NULL
2692 3265 : && !is_subref_array (expr))
2693 : {
2694 3265 : bool seen_vector = false;
2695 :
2696 3265 : if (ref && ref->u.ar.type == AR_SECTION)
2697 : {
2698 2268 : for (n = 0; n < ref->u.ar.dimen; n++)
2699 1319 : if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2700 : {
2701 : seen_vector = true;
2702 : break;
2703 : }
2704 : }
2705 :
2706 959 : if (seen_vector && last_dt == READ)
2707 : {
2708 : /* Create a temp, read to that and copy it back. */
2709 6 : gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2710 6 : tmp = se.expr;
2711 : }
2712 : else
2713 : {
2714 : /* Get the descriptor. */
2715 3259 : gfc_conv_expr_descriptor (&se, expr);
2716 3259 : tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2717 : }
2718 :
2719 3265 : transfer_array_desc (&se, &expr->ts, tmp);
2720 3265 : goto finish_block_label;
2721 : }
2722 :
2723 3334 : scalarize:
2724 : /* Initialize the scalarizer. */
2725 3334 : ss = gfc_walk_expr (expr);
2726 3334 : gfc_init_loopinfo (&loop);
2727 3334 : gfc_add_ss_to_loop (&loop, ss);
2728 :
2729 : /* Initialize the loop. */
2730 3334 : gfc_conv_ss_startstride (&loop);
2731 3334 : gfc_conv_loop_setup (&loop, &code->expr1->where);
2732 :
2733 : /* The main loop body. */
2734 3334 : gfc_mark_ss_chain_used (ss, 1);
2735 3334 : gfc_start_scalarized_body (&loop, &body);
2736 :
2737 3334 : gfc_copy_loopinfo_to_se (&se, &loop);
2738 3334 : se.ss = ss;
2739 :
2740 3334 : gfc_conv_expr_reference (&se, expr);
2741 :
2742 3334 : if (expr->ts.type == BT_CLASS)
2743 24 : vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
2744 : else
2745 : vptr = NULL_TREE;
2746 3334 : transfer_expr (&se, &expr->ts, se.expr, code, vptr);
2747 : }
2748 :
2749 46122 : finish_block_label:
2750 :
2751 46122 : gfc_add_block_to_block (&body, &se.pre);
2752 46122 : gfc_add_block_to_block (&body, &se.post);
2753 46122 : gfc_add_block_to_block (&body, &se.finalblock);
2754 :
2755 46122 : if (se.ss == NULL)
2756 42788 : tmp = gfc_finish_block (&body);
2757 : else
2758 : {
2759 3334 : gcc_assert (expr->rank != 0);
2760 3334 : gcc_assert (se.ss == gfc_ss_terminator);
2761 3334 : gfc_trans_scalarizing_loops (&loop, &body);
2762 :
2763 3334 : gfc_add_block_to_block (&loop.pre, &loop.post);
2764 3334 : tmp = gfc_finish_block (&loop.pre);
2765 3334 : gfc_cleanup_loop (&loop);
2766 : }
2767 :
2768 46122 : gfc_add_expr_to_block (&block, tmp);
2769 :
2770 46122 : return gfc_finish_block (&block);
2771 : }
2772 :
2773 : #include "gt-fortran-trans-io.h"
|
