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