Branch data Line data Source code
1 : : /* IO Code translation/library interface
2 : : Copyright (C) 2002-2023 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 : 203014 : gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
167 : : {
168 : 203014 : unsigned int type;
169 : 203014 : gfc_st_parameter_field *p;
170 : 203014 : char name[64];
171 : 203014 : size_t len;
172 : 203014 : tree t = make_node (RECORD_TYPE);
173 : 203014 : tree *chain = NULL;
174 : :
175 : 203014 : len = strlen (st_parameter[ptype].name);
176 : 203014 : gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
177 : 203014 : memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
178 : 203014 : memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
179 : : len + 1);
180 : 203014 : TYPE_NAME (t) = get_identifier (name);
181 : :
182 : 18068246 : for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
183 : 17865232 : if (p->param_type == ptype)
184 : 2552176 : switch (p->type)
185 : : {
186 : 783054 : case IOPARM_type_int4:
187 : 783054 : case IOPARM_type_intio:
188 : 783054 : case IOPARM_type_pint4:
189 : 783054 : case IOPARM_type_pintio:
190 : 783054 : case IOPARM_type_parray:
191 : 783054 : case IOPARM_type_pchar:
192 : 783054 : case IOPARM_type_pad:
193 : 783054 : p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
194 : 783054 : types[p->type], &chain);
195 : 783054 : break;
196 : 841058 : case IOPARM_type_char1:
197 : 841058 : p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
198 : : pchar_type_node, &chain);
199 : : /* FALLTHROUGH */
200 : 1595110 : case IOPARM_type_char2:
201 : 1595110 : len = strlen (p->name);
202 : 1595110 : gcc_assert (len <= sizeof (name) - sizeof ("_len"));
203 : 1595110 : memcpy (name, p->name, len);
204 : 1595110 : memcpy (name + len, "_len", sizeof ("_len"));
205 : 1595110 : p->field_len = gfc_add_field_to_struct (t, get_identifier (name),
206 : : gfc_charlen_type_node,
207 : : &chain);
208 : 1595110 : if (p->type == IOPARM_type_char2)
209 : 754052 : p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
210 : : pchar_type_node, &chain);
211 : : break;
212 : 174012 : case IOPARM_type_common:
213 : 174012 : p->field
214 : 174012 : = gfc_add_field_to_struct (t,
215 : : get_identifier (p->name),
216 : : st_parameter[IOPARM_ptype_common].type,
217 : : &chain);
218 : 174012 : 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 : 203014 : int save_warn_padded = warn_padded;
226 : 203014 : warn_padded = 0;
227 : 203014 : gfc_finish_type (t);
228 : 203014 : warn_padded = save_warn_padded;
229 : 203014 : st_parameter[ptype].type = t;
230 : 203014 : }
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 : 29002 : gfc_build_io_library_fndecls (void)
296 : : {
297 : 29002 : tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
298 : 29002 : tree gfc_intio_type_node;
299 : 29002 : tree parm_type, dt_parm_type;
300 : 29002 : HOST_WIDE_INT pad_size;
301 : 29002 : unsigned int ptype;
302 : :
303 : 29002 : types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
304 : 58004 : types[IOPARM_type_intio] = gfc_intio_type_node
305 : 29002 : = gfc_get_int_type (gfc_intio_kind);
306 : 29002 : types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
307 : 29002 : types[IOPARM_type_pintio]
308 : 29002 : = build_pointer_type (gfc_intio_type_node);
309 : 29002 : types[IOPARM_type_parray] = pchar_type_node;
310 : 29002 : types[IOPARM_type_pchar] = pchar_type_node;
311 : 29002 : pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
312 : 29002 : pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
313 : 29002 : pad_idx = build_index_type (size_int (pad_size - 1));
314 : 29002 : 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 : 29002 : 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 : 232016 : for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
324 : 203014 : gfc_build_st_parameter ((enum ioparam_type) ptype, types);
325 : :
326 : : /* Define the transfer functions. */
327 : :
328 : 29002 : dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
329 : :
330 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 58004 : iocall[IOCALL_X_CHARACTER_WIDE_WRITE] =
360 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
423 : 29002 : 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 : 29002 : parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
428 : 29002 : 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 : 29002 : parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
433 : 29002 : 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 : 29002 : 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 : 29002 : parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
442 : 29002 : 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 : 29002 : parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
447 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : 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 : 29002 : }
493 : :
494 : :
495 : : static void
496 : 90648 : set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value)
497 : : {
498 : 90648 : tree tmp;
499 : 90648 : gfc_st_parameter_field *p = &st_parameter_field[type];
500 : :
501 : 90648 : if (p->param_type == IOPARM_ptype_common)
502 : 86254 : var = fold_build3_loc (input_location, COMPONENT_REF,
503 : : st_parameter[IOPARM_ptype_common].type,
504 : 86254 : var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
505 : 90648 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
506 : : var, p->field, NULL_TREE);
507 : 90648 : gfc_add_modify (block, tmp, value);
508 : 90648 : }
509 : :
510 : :
511 : : /* Generate code to store an integer constant into the
512 : : st_parameter_XXX structure. */
513 : :
514 : : static unsigned int
515 : 87857 : set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
516 : : unsigned int val)
517 : : {
518 : 87857 : gfc_st_parameter_field *p = &st_parameter_field[type];
519 : :
520 : 87857 : set_parameter_tree (block, var, type,
521 : 87857 : build_int_cst (TREE_TYPE (p->field), val));
522 : 87857 : 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 : 28227 : set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var,
561 : : enum iofield type, gfc_expr *e)
562 : : {
563 : 28227 : gfc_se se;
564 : 28227 : tree tmp;
565 : 28227 : gfc_st_parameter_field *p = &st_parameter_field[type];
566 : 28227 : tree dest_type = TREE_TYPE (p->field);
567 : :
568 : 28227 : gfc_init_se (&se, NULL);
569 : 28227 : gfc_conv_expr_val (&se, e);
570 : :
571 : : /* If we're storing a UNIT number, we need to check it first. */
572 : 28227 : 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 : 28227 : se.expr = convert (dest_type, se.expr);
601 : 28227 : gfc_add_block_to_block (block, &se.pre);
602 : :
603 : 28227 : if (p->param_type == IOPARM_ptype_common)
604 : 28227 : var = fold_build3_loc (input_location, COMPONENT_REF,
605 : : st_parameter[IOPARM_ptype_common].type,
606 : 28227 : var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
607 : :
608 : 28227 : tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
609 : : p->field, NULL_TREE);
610 : 28227 : gfc_add_modify (block, tmp, se.expr);
611 : 28227 : 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 : 2791 : set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
684 : : tree var, enum iofield type, gfc_expr *e)
685 : : {
686 : 2791 : gfc_se se;
687 : 2791 : tree tmp, addr;
688 : 2791 : gfc_st_parameter_field *p = &st_parameter_field[type];
689 : :
690 : 2791 : gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
691 : 2791 : gfc_init_se (&se, NULL);
692 : 2791 : gfc_conv_expr_lhs (&se, e);
693 : :
694 : 2791 : gfc_add_block_to_block (block, &se.pre);
695 : :
696 : 5582 : if (TYPE_MODE (TREE_TYPE (se.expr))
697 : 2791 : == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
698 : : {
699 : 2386 : 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 : 2386 : if (type == IOPARM_common_iostat)
704 : 1832 : gfc_add_modify (block, se.expr,
705 : 1832 : 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 : 2791 : set_parameter_tree (block, var, type, addr);
728 : 2791 : 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 : 22598 : set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
824 : : enum iofield type, gfc_expr * e)
825 : : {
826 : 22598 : gfc_se se;
827 : 22598 : tree tmp;
828 : 22598 : tree io;
829 : 22598 : tree len;
830 : 22598 : gfc_st_parameter_field *p = &st_parameter_field[type];
831 : :
832 : 22598 : gfc_init_se (&se, NULL);
833 : :
834 : 22598 : if (p->param_type == IOPARM_ptype_common)
835 : 465 : var = fold_build3_loc (input_location, COMPONENT_REF,
836 : : st_parameter[IOPARM_ptype_common].type,
837 : 465 : var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
838 : 22598 : io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
839 : : var, p->field, NULL_TREE);
840 : 22598 : len = fold_build3_loc (input_location, COMPONENT_REF,
841 : 22598 : TREE_TYPE (p->field_len),
842 : : var, p->field_len, NULL_TREE);
843 : :
844 : : /* Integer variable assigned a format label. */
845 : 22598 : 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 : 22597 : if (e->ts.type == BT_CHARACTER && e->rank == 0)
871 : 22472 : 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 : 22597 : gfc_conv_string_parameter (&se);
879 : 22597 : gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
880 : 22597 : gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len),
881 : : se.string_length));
882 : : }
883 : :
884 : 22598 : gfc_add_block_to_block (block, &se.pre);
885 : 22598 : gfc_add_block_to_block (postblock, &se.post);
886 : 22598 : 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 : 8529 : set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
895 : : tree var, gfc_expr * e)
896 : : {
897 : 8529 : gfc_se se;
898 : 8529 : tree io;
899 : 8529 : tree len;
900 : 8529 : tree desc;
901 : 8529 : tree tmp;
902 : 8529 : gfc_st_parameter_field *p;
903 : 8529 : unsigned int mask;
904 : :
905 : 8529 : gfc_init_se (&se, NULL);
906 : :
907 : 8529 : p = &st_parameter_field[IOPARM_dt_internal_unit];
908 : 8529 : mask = p->mask;
909 : 8529 : io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
910 : : var, p->field, NULL_TREE);
911 : 8529 : len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len),
912 : : var, p->field_len, NULL_TREE);
913 : 8529 : p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
914 : 8529 : desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
915 : : var, p->field, NULL_TREE);
916 : :
917 : 8529 : gcc_assert (e->ts.type == BT_CHARACTER);
918 : :
919 : : /* Character scalars. */
920 : 8529 : if (e->rank == 0)
921 : : {
922 : 8023 : gfc_conv_expr (&se, e);
923 : 8023 : gfc_conv_string_parameter (&se);
924 : 8023 : tmp = se.expr;
925 : 8023 : 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 : 8529 : gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
956 : 8529 : gfc_add_modify (&se.pre, len,
957 : 8529 : fold_convert (TREE_TYPE (len), se.string_length));
958 : 8529 : gfc_add_modify (&se.pre, desc, se.expr);
959 : :
960 : 8529 : gfc_add_block_to_block (block, &se.pre);
961 : 8529 : gfc_add_block_to_block (post_block, &se.post);
962 : 8529 : 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 : 37637 : 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 : 37637 : stmtblock_t body;
1001 : 37637 : tree tmp, rc;
1002 : 37637 : 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 : 37637 : if (err_label == NULL
1007 : 37637 : && end_label == NULL
1008 : 36816 : && eor_label == NULL)
1009 : 36792 : 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 : 37721 : set_error_locus (stmtblock_t * block, tree var, locus * where)
1042 : : {
1043 : 37721 : gfc_file *f;
1044 : 37721 : tree str, locus_file;
1045 : 37721 : int line;
1046 : 37721 : gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
1047 : :
1048 : 37721 : locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1049 : : st_parameter[IOPARM_ptype_common].type,
1050 : 37721 : var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
1051 : 37721 : locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1052 : 37721 : TREE_TYPE (p->field), locus_file,
1053 : : p->field, NULL_TREE);
1054 : 37721 : f = where->lb->file;
1055 : 37721 : str = gfc_build_cstring_const (f->filename);
1056 : :
1057 : 37721 : str = gfc_build_addr_expr (pchar_type_node, str);
1058 : 37721 : gfc_add_modify (block, locus_file, str);
1059 : :
1060 : 37721 : line = LOCATION_LINE (where->lb->location);
1061 : 37721 : set_parameter_const (block, var, IOPARM_common_line, line);
1062 : 37721 : }
1063 : :
1064 : :
1065 : : /* Translate an OPEN statement. */
1066 : :
1067 : : tree
1068 : 3358 : gfc_trans_open (gfc_code * code)
1069 : : {
1070 : 3358 : stmtblock_t block, post_block;
1071 : 3358 : gfc_open *p;
1072 : 3358 : tree tmp, var;
1073 : 3358 : unsigned int mask = 0;
1074 : :
1075 : 3358 : gfc_start_block (&block);
1076 : 3358 : gfc_init_block (&post_block);
1077 : :
1078 : 3358 : var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
1079 : :
1080 : 3358 : set_error_locus (&block, var, &code->loc);
1081 : 3358 : p = code->ext.open;
1082 : :
1083 : 3358 : if (p->iomsg)
1084 : 42 : mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1085 : : p->iomsg);
1086 : :
1087 : 3358 : if (p->iostat)
1088 : 123 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1089 : : p->iostat);
1090 : :
1091 : 3358 : if (p->err)
1092 : 74 : mask |= IOPARM_common_err;
1093 : :
1094 : 3358 : if (p->file)
1095 : 1375 : mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
1096 : :
1097 : 3358 : if (p->status)
1098 : 2016 : mask |= set_string (&block, &post_block, var, IOPARM_open_status,
1099 : : p->status);
1100 : :
1101 : 3358 : if (p->access)
1102 : 730 : mask |= set_string (&block, &post_block, var, IOPARM_open_access,
1103 : : p->access);
1104 : :
1105 : 3358 : if (p->form)
1106 : 1040 : mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
1107 : :
1108 : 3358 : if (p->recl)
1109 : 240 : mask |= set_parameter_value (&block, var, IOPARM_open_recl_in,
1110 : : p->recl);
1111 : :
1112 : 3358 : if (p->blank)
1113 : 12 : mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
1114 : : p->blank);
1115 : :
1116 : 3358 : if (p->position)
1117 : 108 : mask |= set_string (&block, &post_block, var, IOPARM_open_position,
1118 : : p->position);
1119 : :
1120 : 3358 : if (p->action)
1121 : 224 : mask |= set_string (&block, &post_block, var, IOPARM_open_action,
1122 : : p->action);
1123 : :
1124 : 3358 : if (p->delim)
1125 : 114 : mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
1126 : : p->delim);
1127 : :
1128 : 3358 : if (p->pad)
1129 : 30 : mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
1130 : :
1131 : 3358 : if (p->decimal)
1132 : 24 : mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
1133 : : p->decimal);
1134 : :
1135 : 3358 : if (p->encoding)
1136 : 42 : mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
1137 : : p->encoding);
1138 : :
1139 : 3358 : if (p->round)
1140 : 0 : mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
1141 : :
1142 : 3358 : if (p->sign)
1143 : 18 : mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
1144 : :
1145 : 3358 : if (p->asynchronous)
1146 : 76 : mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
1147 : : p->asynchronous);
1148 : :
1149 : 3358 : if (p->convert)
1150 : 72 : mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
1151 : : p->convert);
1152 : :
1153 : 3358 : if (p->newunit)
1154 : 128 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
1155 : : p->newunit);
1156 : :
1157 : 3358 : if (p->cc)
1158 : 24 : mask |= set_string (&block, &post_block, var, IOPARM_open_cc, p->cc);
1159 : :
1160 : 3358 : if (p->share)
1161 : 24 : mask |= set_string (&block, &post_block, var, IOPARM_open_share, p->share);
1162 : :
1163 : 3358 : mask |= set_parameter_const (&block, var, IOPARM_open_readonly, p->readonly);
1164 : :
1165 : 3358 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
1166 : :
1167 : 3358 : if (p->unit)
1168 : 3230 : set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
1169 : : else
1170 : 128 : set_parameter_const (&block, var, IOPARM_common_unit, 0);
1171 : :
1172 : 3358 : tmp = gfc_build_addr_expr (NULL_TREE, var);
1173 : 3358 : tmp = build_call_expr_loc (input_location,
1174 : : iocall[IOCALL_OPEN], 1, tmp);
1175 : 3358 : gfc_add_expr_to_block (&block, tmp);
1176 : :
1177 : 3358 : gfc_add_block_to_block (&block, &post_block);
1178 : :
1179 : 3358 : io_result (&block, var, p->err, NULL, NULL);
1180 : :
1181 : 3358 : return gfc_finish_block (&block);
1182 : : }
1183 : :
1184 : :
1185 : : /* Translate a CLOSE statement. */
1186 : :
1187 : : tree
1188 : 2892 : gfc_trans_close (gfc_code * code)
1189 : : {
1190 : 2892 : stmtblock_t block, post_block;
1191 : 2892 : gfc_close *p;
1192 : 2892 : tree tmp, var;
1193 : 2892 : unsigned int mask = 0;
1194 : :
1195 : 2892 : gfc_start_block (&block);
1196 : 2892 : gfc_init_block (&post_block);
1197 : :
1198 : 2892 : var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
1199 : :
1200 : 2892 : set_error_locus (&block, var, &code->loc);
1201 : 2892 : p = code->ext.close;
1202 : :
1203 : 2892 : if (p->iomsg)
1204 : 12 : mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1205 : : p->iomsg);
1206 : :
1207 : 2892 : if (p->iostat)
1208 : 13 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1209 : : p->iostat);
1210 : :
1211 : 2892 : if (p->err)
1212 : 7 : mask |= IOPARM_common_err;
1213 : :
1214 : 2892 : if (p->status)
1215 : 1288 : mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1216 : : p->status);
1217 : :
1218 : 2892 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
1219 : :
1220 : 2892 : if (p->unit)
1221 : 2892 : 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 : 2892 : tmp = gfc_build_addr_expr (NULL_TREE, var);
1226 : 2892 : tmp = build_call_expr_loc (input_location,
1227 : : iocall[IOCALL_CLOSE], 1, tmp);
1228 : 2892 : gfc_add_expr_to_block (&block, tmp);
1229 : :
1230 : 2892 : gfc_add_block_to_block (&block, &post_block);
1231 : :
1232 : 2892 : io_result (&block, var, p->err, NULL, NULL);
1233 : :
1234 : 2892 : return gfc_finish_block (&block);
1235 : : }
1236 : :
1237 : :
1238 : : /* Common subroutine for building a file positioning statement. */
1239 : :
1240 : : static tree
1241 : 2466 : build_filepos (tree function, gfc_code * code)
1242 : : {
1243 : 2466 : stmtblock_t block, post_block;
1244 : 2466 : gfc_filepos *p;
1245 : 2466 : tree tmp, var;
1246 : 2466 : unsigned int mask = 0;
1247 : :
1248 : 2466 : p = code->ext.filepos;
1249 : :
1250 : 2466 : gfc_start_block (&block);
1251 : 2466 : gfc_init_block (&post_block);
1252 : :
1253 : 2466 : var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1254 : : "filepos_parm");
1255 : :
1256 : 2466 : set_error_locus (&block, var, &code->loc);
1257 : :
1258 : 2466 : if (p->iomsg)
1259 : 30 : mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1260 : : p->iomsg);
1261 : :
1262 : 2466 : if (p->iostat)
1263 : 63 : mask |= set_parameter_ref (&block, &post_block, var,
1264 : : IOPARM_common_iostat, p->iostat);
1265 : :
1266 : 2466 : if (p->err)
1267 : 16 : mask |= IOPARM_common_err;
1268 : :
1269 : 2466 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
1270 : :
1271 : 2466 : if (p->unit)
1272 : 2466 : 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 : 2466 : tmp = gfc_build_addr_expr (NULL_TREE, var);
1278 : 2466 : tmp = build_call_expr_loc (input_location,
1279 : : function, 1, tmp);
1280 : 2466 : gfc_add_expr_to_block (&block, tmp);
1281 : :
1282 : 2466 : gfc_add_block_to_block (&block, &post_block);
1283 : :
1284 : 2466 : io_result (&block, var, p->err, NULL, NULL);
1285 : :
1286 : 2466 : 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 : 50 : gfc_trans_endfile (gfc_code * code)
1303 : : {
1304 : 50 : return build_filepos (iocall[IOCALL_ENDFILE], code);
1305 : : }
1306 : :
1307 : :
1308 : : /* Translate a REWIND statement. */
1309 : :
1310 : : tree
1311 : 1954 : gfc_trans_rewind (gfc_code * code)
1312 : : {
1313 : 1954 : 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 : 753 : gfc_trans_inquire (gfc_code * code)
1330 : : {
1331 : 753 : stmtblock_t block, post_block;
1332 : 753 : gfc_inquire *p;
1333 : 753 : tree tmp, var;
1334 : 753 : unsigned int mask = 0, mask2 = 0;
1335 : :
1336 : 753 : gfc_start_block (&block);
1337 : 753 : gfc_init_block (&post_block);
1338 : :
1339 : 753 : var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1340 : : "inquire_parm");
1341 : :
1342 : 753 : set_error_locus (&block, var, &code->loc);
1343 : 753 : p = code->ext.inquire;
1344 : :
1345 : 753 : if (p->iomsg)
1346 : 12 : mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1347 : : p->iomsg);
1348 : :
1349 : 753 : if (p->iostat)
1350 : 31 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1351 : : p->iostat);
1352 : :
1353 : 753 : if (p->err)
1354 : 7 : mask |= IOPARM_common_err;
1355 : :
1356 : : /* Sanity check. */
1357 : 753 : if (p->unit && p->file)
1358 : 0 : gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1359 : :
1360 : 753 : if (p->file)
1361 : 189 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1362 : : p->file);
1363 : :
1364 : 753 : if (p->exist)
1365 : 136 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1366 : : p->exist);
1367 : :
1368 : 753 : if (p->opened)
1369 : 139 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1370 : : p->opened);
1371 : :
1372 : 753 : if (p->number)
1373 : 76 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1374 : : p->number);
1375 : :
1376 : 753 : if (p->named)
1377 : 13 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1378 : : p->named);
1379 : :
1380 : 753 : if (p->name)
1381 : 18 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1382 : : p->name);
1383 : :
1384 : 753 : if (p->access)
1385 : 141 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1386 : : p->access);
1387 : :
1388 : 753 : if (p->sequential)
1389 : 30 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1390 : : p->sequential);
1391 : :
1392 : 753 : if (p->direct)
1393 : 102 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1394 : : p->direct);
1395 : :
1396 : 753 : if (p->form)
1397 : 6 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1398 : : p->form);
1399 : :
1400 : 753 : if (p->formatted)
1401 : 36 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1402 : : p->formatted);
1403 : :
1404 : 753 : if (p->unformatted)
1405 : 30 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1406 : : p->unformatted);
1407 : :
1408 : 753 : if (p->recl)
1409 : 49 : mask |= set_parameter_ref (&block, &post_block, var,
1410 : : IOPARM_inquire_recl_out, p->recl);
1411 : :
1412 : 753 : if (p->nextrec)
1413 : 58 : mask |= set_parameter_ref (&block, &post_block, var,
1414 : : IOPARM_inquire_nextrec, p->nextrec);
1415 : :
1416 : 753 : if (p->blank)
1417 : 15 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1418 : : p->blank);
1419 : :
1420 : 753 : if (p->delim)
1421 : 30 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1422 : : p->delim);
1423 : :
1424 : 753 : if (p->position)
1425 : 48 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1426 : : p->position);
1427 : :
1428 : 753 : if (p->action)
1429 : 12 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1430 : : p->action);
1431 : :
1432 : 753 : if (p->read)
1433 : 24 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1434 : : p->read);
1435 : :
1436 : 753 : if (p->write)
1437 : 24 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1438 : : p->write);
1439 : :
1440 : 753 : if (p->readwrite)
1441 : 24 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1442 : : p->readwrite);
1443 : :
1444 : 753 : if (p->pad)
1445 : 30 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1446 : : p->pad);
1447 : :
1448 : 753 : if (p->convert)
1449 : 12 : mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1450 : : p->convert);
1451 : :
1452 : 753 : 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 : 753 : if (p->asynchronous)
1458 : 18 : mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1459 : : p->asynchronous);
1460 : :
1461 : 753 : if (p->decimal)
1462 : 12 : mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1463 : : p->decimal);
1464 : :
1465 : 753 : if (p->encoding)
1466 : 12 : mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1467 : : p->encoding);
1468 : :
1469 : 753 : if (p->round)
1470 : 12 : mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1471 : : p->round);
1472 : :
1473 : 753 : if (p->sign)
1474 : 12 : mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1475 : : p->sign);
1476 : :
1477 : 753 : if (p->pending)
1478 : 13 : mask2 |= set_parameter_ref (&block, &post_block, var,
1479 : : IOPARM_inquire_pending, p->pending);
1480 : :
1481 : 753 : if (p->size)
1482 : 42 : mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1483 : : p->size);
1484 : :
1485 : 753 : if (p->id)
1486 : 6 : mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1487 : : p->id);
1488 : 753 : if (p->iqstream)
1489 : 36 : mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream,
1490 : : p->iqstream);
1491 : :
1492 : 753 : if (p->share)
1493 : 6 : mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_share,
1494 : : p->share);
1495 : :
1496 : 753 : if (p->cc)
1497 : 6 : mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_cc, p->cc);
1498 : :
1499 : 753 : if (mask2)
1500 : 103 : mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
1501 : :
1502 : 753 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
1503 : :
1504 : 753 : 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 : 189 : set_parameter_const (&block, var, IOPARM_common_unit, 0);
1511 : :
1512 : 753 : tmp = gfc_build_addr_expr (NULL_TREE, var);
1513 : 753 : tmp = build_call_expr_loc (input_location,
1514 : : iocall[IOCALL_INQUIRE], 1, tmp);
1515 : 753 : gfc_add_expr_to_block (&block, tmp);
1516 : :
1517 : 753 : gfc_add_block_to_block (&block, &post_block);
1518 : :
1519 : 753 : io_result (&block, var, p->err, NULL, NULL);
1520 : :
1521 : 753 : return gfc_finish_block (&block);
1522 : : }
1523 : :
1524 : :
1525 : : tree
1526 : 68 : gfc_trans_wait (gfc_code * code)
1527 : : {
1528 : 68 : stmtblock_t block, post_block;
1529 : 68 : gfc_wait *p;
1530 : 68 : tree tmp, var;
1531 : 68 : unsigned int mask = 0;
1532 : :
1533 : 68 : gfc_start_block (&block);
1534 : 68 : gfc_init_block (&post_block);
1535 : :
1536 : 68 : var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1537 : : "wait_parm");
1538 : :
1539 : 68 : set_error_locus (&block, var, &code->loc);
1540 : 68 : p = code->ext.wait;
1541 : :
1542 : : /* Set parameters here. */
1543 : 68 : if (p->iomsg)
1544 : 14 : mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1545 : : p->iomsg);
1546 : :
1547 : 68 : if (p->iostat)
1548 : 20 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1549 : : p->iostat);
1550 : :
1551 : 68 : if (p->err)
1552 : 7 : mask |= IOPARM_common_err;
1553 : :
1554 : 68 : if (p->id)
1555 : 13 : mask |= set_parameter_ref (&block, &post_block, var, IOPARM_wait_id, p->id);
1556 : :
1557 : 68 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
1558 : :
1559 : 68 : if (p->unit)
1560 : 68 : set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
1561 : :
1562 : 68 : tmp = gfc_build_addr_expr (NULL_TREE, var);
1563 : 68 : tmp = build_call_expr_loc (input_location,
1564 : : iocall[IOCALL_WAIT], 1, tmp);
1565 : 68 : gfc_add_expr_to_block (&block, tmp);
1566 : :
1567 : 68 : gfc_add_block_to_block (&block, &post_block);
1568 : :
1569 : 68 : io_result (&block, var, p->err, NULL, NULL);
1570 : :
1571 : 68 : 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 : 4680 : nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1602 : : tree base_addr)
1603 : : {
1604 : 4680 : tree decl = NULL_TREE;
1605 : 4680 : tree tmp;
1606 : :
1607 : 4680 : if (sym)
1608 : : {
1609 : 2842 : sym->attr.referenced = 1;
1610 : 2842 : decl = gfc_get_symbol_decl (sym);
1611 : :
1612 : : /* If this is the enclosing function declaration, use
1613 : : the fake result instead. */
1614 : 2842 : if (decl == current_function_decl)
1615 : 12 : decl = gfc_get_fake_result_decl (sym, 0);
1616 : 2830 : 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 : 4680 : 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 : 4680 : tmp = decl;
1628 : :
1629 : : /* Build indirect reference, if dummy argument. */
1630 : :
1631 : 4680 : 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 : 4680 : 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 : 4680 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1642 : 4680 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp))))
1643 : 12 : tmp = gfc_class_data_get (tmp);
1644 : :
1645 : 4680 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1646 : 300 : tmp = gfc_conv_array_data (tmp);
1647 : : else
1648 : : {
1649 : 4380 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1650 : 4188 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1651 : :
1652 : 4380 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1653 : 0 : tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1654 : :
1655 : 4380 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1656 : 0 : tmp = build_fold_indirect_ref_loc (input_location,
1657 : : tmp);
1658 : : }
1659 : :
1660 : 4680 : gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1661 : :
1662 : 4680 : 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 : 4680 : transfer_namelist_element (stmtblock_t * block, const char * var_name,
1674 : : gfc_symbol * sym, gfc_component * c,
1675 : : tree base_addr)
1676 : : {
1677 : 4680 : gfc_typespec * ts = NULL;
1678 : 4680 : gfc_array_spec * as = NULL;
1679 : 4680 : tree addr_expr = NULL;
1680 : 4680 : tree dt = NULL;
1681 : 4680 : tree string;
1682 : 4680 : tree tmp;
1683 : 4680 : tree dtype;
1684 : 4680 : tree dt_parm_addr;
1685 : 4680 : tree decl = NULL_TREE;
1686 : 4680 : tree gfc_int4_type_node = gfc_get_int_type (4);
1687 : 4680 : tree dtio_proc = null_pointer_node;
1688 : 4680 : tree vtable = null_pointer_node;
1689 : 4680 : int n_dim;
1690 : 4680 : int rank = 0;
1691 : :
1692 : 4680 : gcc_assert (sym || c);
1693 : :
1694 : : /* Build the namelist object name. */
1695 : :
1696 : 4680 : string = gfc_build_cstring_const (var_name);
1697 : 4680 : string = gfc_build_addr_expr (pchar_type_node, string);
1698 : :
1699 : : /* Build ts, as and data address using symbol or component. */
1700 : :
1701 : 4680 : ts = sym ? &sym->ts : &c->ts;
1702 : :
1703 : 4680 : if (ts->type != BT_CLASS)
1704 : 4662 : as = sym ? sym->as : c->as;
1705 : : else
1706 : 18 : as = sym ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as;
1707 : :
1708 : 4680 : addr_expr = nml_get_addr_expr (sym, c, base_addr);
1709 : :
1710 : 4680 : if (as)
1711 : 1901 : rank = as->rank;
1712 : :
1713 : 1901 : if (rank)
1714 : : {
1715 : 1901 : decl = sym ? sym->backend_decl : c->backend_decl;
1716 : 1901 : if (sym && sym->attr.dummy)
1717 : 325 : decl = build_fold_indirect_ref_loc (input_location, decl);
1718 : :
1719 : 1901 : if (ts->type == BT_CLASS)
1720 : 12 : decl = gfc_class_data_get (decl);
1721 : 1901 : dt = TREE_TYPE (decl);
1722 : 1901 : dtype = gfc_get_dtype (dt);
1723 : : }
1724 : : else
1725 : : {
1726 : 2779 : dt = gfc_typenode_for_spec (ts);
1727 : 2779 : dtype = gfc_get_dtype_rank_type (0, dt);
1728 : : }
1729 : :
1730 : : /* Build up the arguments for the transfer call.
1731 : : The call for the scalar part transfers:
1732 : : (address, name, type, kind or string_length, dtype) */
1733 : :
1734 : 4680 : dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1735 : :
1736 : : /* Check if the derived type has a specific DTIO for the mode.
1737 : : Note that although namelist io is forbidden to have a format
1738 : : list, the specific subroutine is of the formatted kind. */
1739 : 4680 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
1740 : : {
1741 : 926 : gfc_symbol *derived;
1742 : 926 : if (ts->type==BT_CLASS)
1743 : 18 : derived = ts->u.derived->components->ts.u.derived;
1744 : : else
1745 : 908 : derived = ts->u.derived;
1746 : :
1747 : 926 : gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
1748 : : last_dt == WRITE, true);
1749 : :
1750 : 926 : if (ts->type == BT_CLASS && tb_io_st)
1751 : : {
1752 : : // polymorphic DTIO call (based on the dynamic type)
1753 : 18 : gfc_se se;
1754 : 18 : gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1755 : : // build vtable expr
1756 : 18 : gfc_expr *expr = gfc_get_variable_expr (st);
1757 : 18 : gfc_add_vptr_component (expr);
1758 : 18 : gfc_init_se (&se, NULL);
1759 : 18 : se.want_pointer = 1;
1760 : 18 : gfc_conv_expr (&se, expr);
1761 : 18 : vtable = se.expr;
1762 : : // build dtio expr
1763 : 18 : gfc_add_component_ref (expr,
1764 : 18 : tb_io_st->n.tb->u.generic->specific_st->name);
1765 : 18 : gfc_init_se (&se, NULL);
1766 : 18 : se.want_pointer = 1;
1767 : 18 : gfc_conv_expr (&se, expr);
1768 : 18 : gfc_free_expr (expr);
1769 : 18 : dtio_proc = se.expr;
1770 : 18 : }
1771 : : else
1772 : : {
1773 : : // non-polymorphic DTIO call (based on the declared type)
1774 : 908 : gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived,
1775 : : last_dt == WRITE, true);
1776 : 908 : if (dtio_sub != NULL)
1777 : : {
1778 : 54 : dtio_proc = gfc_get_symbol_decl (dtio_sub);
1779 : 54 : dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
1780 : 54 : gfc_symbol *vtab = gfc_find_derived_vtab (derived);
1781 : 54 : vtable = vtab->backend_decl;
1782 : 54 : if (vtable == NULL_TREE)
1783 : 0 : vtable = gfc_get_symbol_decl (vtab);
1784 : 54 : vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
1785 : : }
1786 : : }
1787 : : }
1788 : :
1789 : 4680 : if (ts->type == BT_CHARACTER)
1790 : 1561 : tmp = ts->u.cl->backend_decl;
1791 : : else
1792 : 3119 : tmp = build_int_cst (gfc_charlen_type_node, 0);
1793 : :
1794 : 4680 : int abi_kind = gfc_type_abi_kind (ts);
1795 : 4680 : if (dtio_proc == null_pointer_node)
1796 : 4608 : tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_VAL], 6,
1797 : : dt_parm_addr, addr_expr, string,
1798 : : build_int_cst (gfc_int4_type_node, abi_kind),
1799 : : tmp, dtype);
1800 : : else
1801 : 72 : tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_DTIO_VAL],
1802 : : 8, dt_parm_addr, addr_expr, string,
1803 : : build_int_cst (gfc_int4_type_node, abi_kind),
1804 : : tmp, dtype, dtio_proc, vtable);
1805 : 4680 : gfc_add_expr_to_block (block, tmp);
1806 : :
1807 : : /* If the object is an array, transfer rank times:
1808 : : (null pointer, name, stride, lbound, ubound) */
1809 : :
1810 : 11309 : for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1811 : : {
1812 : 1949 : tmp = build_call_expr_loc (input_location,
1813 : : iocall[IOCALL_SET_NML_VAL_DIM], 5,
1814 : : dt_parm_addr,
1815 : : build_int_cst (gfc_int4_type_node, n_dim),
1816 : : gfc_conv_array_stride (decl, n_dim),
1817 : : gfc_conv_array_lbound (decl, n_dim),
1818 : : gfc_conv_array_ubound (decl, n_dim));
1819 : 1949 : gfc_add_expr_to_block (block, tmp);
1820 : : }
1821 : :
1822 : 4680 : if (gfc_bt_struct (ts->type) && ts->u.derived->components
1823 : 908 : && dtio_proc == null_pointer_node)
1824 : : {
1825 : 854 : gfc_component *cmp;
1826 : :
1827 : : /* Provide the RECORD_TYPE to build component references. */
1828 : :
1829 : 854 : tree expr = build_fold_indirect_ref_loc (input_location,
1830 : : addr_expr);
1831 : :
1832 : 2692 : for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1833 : : {
1834 : 3676 : char *full_name = nml_full_name (var_name, cmp->name,
1835 : 1838 : ts->u.derived->attr.extension);
1836 : 1838 : transfer_namelist_element (block,
1837 : : full_name,
1838 : : NULL, cmp, expr);
1839 : 1838 : free (full_name);
1840 : : }
1841 : : }
1842 : 4680 : }
1843 : :
1844 : : #undef IARG
1845 : :
1846 : : /* Create a data transfer statement. Not all of the fields are valid
1847 : : for both reading and writing, but improper use has been filtered
1848 : : out by now. */
1849 : :
1850 : : static tree
1851 : 28184 : build_dt (tree function, gfc_code * code)
1852 : : {
1853 : 28184 : stmtblock_t block, post_block, post_end_block, post_iu_block;
1854 : 28184 : gfc_dt *dt;
1855 : 28184 : tree tmp, var;
1856 : 28184 : gfc_expr *nmlname;
1857 : 28184 : gfc_namelist *nml;
1858 : 28184 : unsigned int mask = 0;
1859 : :
1860 : 28184 : gfc_start_block (&block);
1861 : 28184 : gfc_init_block (&post_block);
1862 : 28184 : gfc_init_block (&post_end_block);
1863 : 28184 : gfc_init_block (&post_iu_block);
1864 : :
1865 : 28184 : var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1866 : :
1867 : 28184 : set_error_locus (&block, var, &code->loc);
1868 : :
1869 : 28184 : if (last_dt == IOLENGTH)
1870 : : {
1871 : 84 : gfc_inquire *inq;
1872 : :
1873 : 84 : inq = code->ext.inquire;
1874 : :
1875 : : /* First check that preconditions are met. */
1876 : 84 : gcc_assert (inq != NULL);
1877 : 84 : gcc_assert (inq->iolength != NULL);
1878 : :
1879 : : /* Connect to the iolength variable. */
1880 : 84 : mask |= set_parameter_ref (&block, &post_end_block, var,
1881 : : IOPARM_dt_iolength, inq->iolength);
1882 : 84 : dt = NULL;
1883 : : }
1884 : : else
1885 : : {
1886 : 28100 : dt = code->ext.dt;
1887 : 28100 : gcc_assert (dt != NULL);
1888 : : }
1889 : :
1890 : 28184 : if (dt && dt->io_unit)
1891 : : {
1892 : 28100 : if (dt->io_unit->ts.type == BT_CHARACTER)
1893 : : {
1894 : 8529 : mask |= set_internal_unit (&block, &post_iu_block,
1895 : : var, dt->io_unit);
1896 : 8529 : set_parameter_const (&block, var, IOPARM_common_unit,
1897 : 8529 : dt->io_unit->ts.kind == 1 ?
1898 : : GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4);
1899 : : }
1900 : : }
1901 : : else
1902 : 84 : set_parameter_const (&block, var, IOPARM_common_unit, 0);
1903 : :
1904 : 8613 : if (dt)
1905 : : {
1906 : 28100 : if (dt->iomsg)
1907 : 355 : mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1908 : : dt->iomsg);
1909 : :
1910 : 28100 : if (dt->iostat)
1911 : 1608 : mask |= set_parameter_ref (&block, &post_end_block, var,
1912 : : IOPARM_common_iostat, dt->iostat);
1913 : :
1914 : 28100 : if (dt->err)
1915 : 246 : mask |= IOPARM_common_err;
1916 : :
1917 : 28100 : if (dt->eor)
1918 : 30 : mask |= IOPARM_common_eor;
1919 : :
1920 : 28100 : if (dt->end)
1921 : 554 : mask |= IOPARM_common_end;
1922 : :
1923 : 28100 : if (dt->id)
1924 : 19 : mask |= set_parameter_ref (&block, &post_end_block, var,
1925 : : IOPARM_dt_id, dt->id);
1926 : :
1927 : 28100 : if (dt->pos)
1928 : 168 : mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1929 : :
1930 : 28100 : if (dt->asynchronous)
1931 : 163 : mask |= set_string (&block, &post_block, var,
1932 : : IOPARM_dt_asynchronous, dt->asynchronous);
1933 : :
1934 : 28100 : if (dt->blank)
1935 : 13 : mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1936 : : dt->blank);
1937 : :
1938 : 28100 : if (dt->decimal)
1939 : 75 : mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1940 : : dt->decimal);
1941 : :
1942 : 28100 : if (dt->delim)
1943 : 2 : mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1944 : : dt->delim);
1945 : :
1946 : 28100 : if (dt->pad)
1947 : 79 : mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1948 : : dt->pad);
1949 : :
1950 : 28100 : if (dt->round)
1951 : 25 : mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1952 : : dt->round);
1953 : :
1954 : 28100 : if (dt->sign)
1955 : 13 : mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1956 : : dt->sign);
1957 : :
1958 : 28100 : if (dt->rec)
1959 : 492 : mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1960 : :
1961 : 28100 : if (dt->advance)
1962 : 327 : mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1963 : : dt->advance);
1964 : :
1965 : 28100 : if (dt->format_expr)
1966 : 10474 : mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1967 : : dt->format_expr);
1968 : :
1969 : 28100 : if (dt->format_label)
1970 : : {
1971 : 14218 : if (dt->format_label == &format_asterisk)
1972 : 12429 : mask |= IOPARM_dt_list_format;
1973 : : else
1974 : 1789 : mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1975 : : dt->format_label->format);
1976 : : }
1977 : :
1978 : 28100 : if (dt->size)
1979 : 55 : mask |= set_parameter_ref (&block, &post_end_block, var,
1980 : : IOPARM_dt_size, dt->size);
1981 : :
1982 : 28100 : if (dt->udtio)
1983 : 315 : mask |= IOPARM_dt_dtio;
1984 : :
1985 : 28100 : if (dt->dec_ext)
1986 : 480 : mask |= IOPARM_dt_dec_ext;
1987 : :
1988 : 28100 : if (dt->namelist)
1989 : : {
1990 : 1071 : if (dt->format_expr || dt->format_label)
1991 : 0 : gfc_internal_error ("build_dt: format with namelist");
1992 : :
1993 : 2142 : nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1994 : : dt->namelist->name,
1995 : 1071 : strlen (dt->namelist->name));
1996 : :
1997 : 1071 : mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1998 : : nmlname);
1999 : :
2000 : 1071 : gfc_free_expr (nmlname);
2001 : :
2002 : 1071 : if (last_dt == READ)
2003 : 772 : mask |= IOPARM_dt_namelist_read_mode;
2004 : :
2005 : 1071 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
2006 : :
2007 : 1071 : dt_parm = var;
2008 : :
2009 : 3913 : for (nml = dt->namelist->namelist; nml; nml = nml->next)
2010 : 2842 : transfer_namelist_element (&block, nml->sym->name, nml->sym,
2011 : : NULL, NULL_TREE);
2012 : : }
2013 : : else
2014 : 27029 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
2015 : :
2016 : 28100 : if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
2017 : 19571 : set_parameter_value_chk (&block, dt->iostat, var,
2018 : : IOPARM_common_unit, dt->io_unit);
2019 : : }
2020 : : else
2021 : 84 : set_parameter_const (&block, var, IOPARM_common_flags, mask);
2022 : :
2023 : 28184 : tmp = gfc_build_addr_expr (NULL_TREE, var);
2024 : 28184 : tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2025 : : function, 1, tmp);
2026 : 28184 : gfc_add_expr_to_block (&block, tmp);
2027 : :
2028 : 28184 : gfc_add_block_to_block (&block, &post_block);
2029 : :
2030 : 28184 : dt_parm = var;
2031 : 28184 : dt_post_end_block = &post_end_block;
2032 : :
2033 : : /* Set implied do loop exit condition. */
2034 : 28184 : if (last_dt == READ || last_dt == WRITE)
2035 : : {
2036 : 28100 : gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
2037 : :
2038 : 28100 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
2039 : : st_parameter[IOPARM_ptype_common].type,
2040 : 28100 : dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
2041 : : NULL_TREE);
2042 : 28100 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
2043 : 28100 : TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
2044 : 28100 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
2045 : 28100 : tmp, build_int_cst (TREE_TYPE (tmp),
2046 : 28100 : IOPARM_common_libreturn_mask));
2047 : : }
2048 : : else /* IOLENGTH */
2049 : : tmp = NULL_TREE;
2050 : :
2051 : 28184 : gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
2052 : :
2053 : 28184 : gfc_add_block_to_block (&block, &post_iu_block);
2054 : :
2055 : 28184 : dt_parm = NULL;
2056 : 28184 : dt_post_end_block = NULL;
2057 : :
2058 : 28184 : return gfc_finish_block (&block);
2059 : : }
2060 : :
2061 : :
2062 : : /* Translate the IOLENGTH form of an INQUIRE statement. We treat
2063 : : this as a third sort of data transfer statement, except that
2064 : : lengths are summed instead of actually transferring any data. */
2065 : :
2066 : : tree
2067 : 84 : gfc_trans_iolength (gfc_code * code)
2068 : : {
2069 : 84 : last_dt = IOLENGTH;
2070 : 84 : return build_dt (iocall[IOCALL_IOLENGTH], code);
2071 : : }
2072 : :
2073 : :
2074 : : /* Translate a READ statement. */
2075 : :
2076 : : tree
2077 : 5622 : gfc_trans_read (gfc_code * code)
2078 : : {
2079 : 5622 : last_dt = READ;
2080 : 5622 : return build_dt (iocall[IOCALL_READ], code);
2081 : : }
2082 : :
2083 : :
2084 : : /* Translate a WRITE statement */
2085 : :
2086 : : tree
2087 : 22478 : gfc_trans_write (gfc_code * code)
2088 : : {
2089 : 22478 : last_dt = WRITE;
2090 : 22478 : return build_dt (iocall[IOCALL_WRITE], code);
2091 : : }
2092 : :
2093 : :
2094 : : /* Finish a data transfer statement. */
2095 : :
2096 : : tree
2097 : 28184 : gfc_trans_dt_end (gfc_code * code)
2098 : : {
2099 : 28184 : tree function, tmp;
2100 : 28184 : stmtblock_t block;
2101 : :
2102 : 28184 : gfc_init_block (&block);
2103 : :
2104 : 28184 : switch (last_dt)
2105 : : {
2106 : 5622 : case READ:
2107 : 5622 : function = iocall[IOCALL_READ_DONE];
2108 : 5622 : break;
2109 : :
2110 : 22478 : case WRITE:
2111 : 22478 : function = iocall[IOCALL_WRITE_DONE];
2112 : 22478 : break;
2113 : :
2114 : 84 : case IOLENGTH:
2115 : 84 : function = iocall[IOCALL_IOLENGTH_DONE];
2116 : 84 : break;
2117 : :
2118 : 0 : default:
2119 : 0 : gcc_unreachable ();
2120 : : }
2121 : :
2122 : 28184 : tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2123 : 28184 : tmp = build_call_expr_loc (input_location,
2124 : : function, 1, tmp);
2125 : 28184 : gfc_add_expr_to_block (&block, tmp);
2126 : 28184 : gfc_add_block_to_block (&block, dt_post_end_block);
2127 : 28184 : gfc_init_block (dt_post_end_block);
2128 : :
2129 : 28184 : if (last_dt != IOLENGTH)
2130 : : {
2131 : 28100 : gcc_assert (code->ext.dt != NULL);
2132 : 28100 : io_result (&block, dt_parm, code->ext.dt->err,
2133 : : code->ext.dt->end, code->ext.dt->eor);
2134 : : }
2135 : :
2136 : 28184 : return gfc_finish_block (&block);
2137 : : }
2138 : :
2139 : : static void
2140 : : transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2141 : : gfc_code * code, tree vptr);
2142 : :
2143 : : /* Given an array field in a derived type variable, generate the code
2144 : : for the loop that iterates over array elements, and the code that
2145 : : accesses those array elements. Use transfer_expr to generate code
2146 : : for transferring that element. Because elements may also be
2147 : : derived types, transfer_expr and transfer_array_component are mutually
2148 : : recursive. */
2149 : :
2150 : : static tree
2151 : 72 : transfer_array_component (tree expr, gfc_component * cm, locus * where)
2152 : : {
2153 : 72 : tree tmp;
2154 : 72 : stmtblock_t body;
2155 : 72 : stmtblock_t block;
2156 : 72 : gfc_loopinfo loop;
2157 : 72 : int n;
2158 : 72 : gfc_ss *ss;
2159 : 72 : gfc_se se;
2160 : 72 : gfc_array_info *ss_array;
2161 : :
2162 : 72 : gfc_start_block (&block);
2163 : 72 : gfc_init_se (&se, NULL);
2164 : :
2165 : : /* Create and initialize Scalarization Status. Unlike in
2166 : : gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2167 : : care of this task, because we don't have a gfc_expr at hand.
2168 : : Build one manually, as in gfc_trans_subarray_assign. */
2169 : :
2170 : 72 : ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
2171 : : GFC_SS_COMPONENT);
2172 : 72 : ss_array = &ss->info->data.array;
2173 : :
2174 : 72 : if (cm->attr.pdt_array)
2175 : 6 : ss_array->shape = NULL;
2176 : : else
2177 : 66 : ss_array->shape = gfc_get_shape (cm->as->rank);
2178 : :
2179 : 72 : ss_array->descriptor = expr;
2180 : 72 : ss_array->data = gfc_conv_array_data (expr);
2181 : 72 : ss_array->offset = gfc_conv_array_offset (expr);
2182 : 144 : for (n = 0; n < cm->as->rank; n++)
2183 : : {
2184 : 72 : ss_array->start[n] = gfc_conv_array_lbound (expr, n);
2185 : 72 : ss_array->stride[n] = gfc_index_one_node;
2186 : :
2187 : 72 : if (cm->attr.pdt_array)
2188 : 6 : ss_array->end[n] = gfc_conv_array_ubound (expr, n);
2189 : : else
2190 : : {
2191 : 66 : mpz_init (ss_array->shape[n]);
2192 : 66 : mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
2193 : 66 : cm->as->lower[n]->value.integer);
2194 : 66 : mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
2195 : : }
2196 : : }
2197 : :
2198 : : /* Once we got ss, we use scalarizer to create the loop. */
2199 : :
2200 : 72 : gfc_init_loopinfo (&loop);
2201 : 72 : gfc_add_ss_to_loop (&loop, ss);
2202 : 72 : gfc_conv_ss_startstride (&loop);
2203 : 72 : gfc_conv_loop_setup (&loop, where);
2204 : 72 : gfc_mark_ss_chain_used (ss, 1);
2205 : 72 : gfc_start_scalarized_body (&loop, &body);
2206 : :
2207 : 72 : gfc_copy_loopinfo_to_se (&se, &loop);
2208 : 72 : se.ss = ss;
2209 : :
2210 : : /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2211 : 72 : se.expr = expr;
2212 : 72 : gfc_conv_tmp_array_ref (&se);
2213 : :
2214 : : /* Now se.expr contains an element of the array. Take the address and pass
2215 : : it to the IO routines. */
2216 : 72 : tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2217 : 72 : transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
2218 : :
2219 : : /* We are done now with the loop body. Wrap up the scalarizer and
2220 : : return. */
2221 : :
2222 : 72 : gfc_add_block_to_block (&body, &se.pre);
2223 : 72 : gfc_add_block_to_block (&body, &se.post);
2224 : :
2225 : 72 : gfc_trans_scalarizing_loops (&loop, &body);
2226 : :
2227 : 72 : gfc_add_block_to_block (&block, &loop.pre);
2228 : 72 : gfc_add_block_to_block (&block, &loop.post);
2229 : :
2230 : 72 : if (!cm->attr.pdt_array)
2231 : : {
2232 : 66 : gcc_assert (ss_array->shape != NULL);
2233 : 66 : gfc_free_shape (&ss_array->shape, cm->as->rank);
2234 : : }
2235 : 72 : gfc_cleanup_loop (&loop);
2236 : :
2237 : 72 : return gfc_finish_block (&block);
2238 : : }
2239 : :
2240 : :
2241 : : /* Helper function for transfer_expr that looks for the DTIO procedure
2242 : : either as a typebound binding or in a generic interface. If present,
2243 : : the address expression of the procedure is returned. It is assumed
2244 : : that the procedure interface has been checked during resolution. */
2245 : :
2246 : : static tree
2247 : 431 : get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
2248 : : {
2249 : 431 : gfc_symbol *derived;
2250 : 431 : bool formatted = false;
2251 : 431 : gfc_dt *dt = code->ext.dt;
2252 : :
2253 : : /* Determine when to use the formatted DTIO procedure. */
2254 : 431 : if (dt && (dt->format_expr || dt->format_label))
2255 : 431 : formatted = true;
2256 : :
2257 : 431 : if (ts->type == BT_CLASS)
2258 : 48 : derived = ts->u.derived->components->ts.u.derived;
2259 : : else
2260 : 383 : derived = ts->u.derived;
2261 : :
2262 : 431 : gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
2263 : : last_dt == WRITE, formatted);
2264 : 431 : if (ts->type == BT_CLASS && tb_io_st)
2265 : : {
2266 : : // polymorphic DTIO call (based on the dynamic type)
2267 : 42 : gfc_se se;
2268 : 42 : gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1);
2269 : 42 : gfc_add_vptr_component (expr);
2270 : 42 : gfc_add_component_ref (expr,
2271 : 42 : tb_io_st->n.tb->u.generic->specific_st->name);
2272 : 42 : *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym;
2273 : 42 : gfc_init_se (&se, NULL);
2274 : 42 : se.want_pointer = 1;
2275 : 42 : gfc_conv_expr (&se, expr);
2276 : 42 : gfc_free_expr (expr);
2277 : 42 : return se.expr;
2278 : : }
2279 : : else
2280 : : {
2281 : : // non-polymorphic DTIO call (based on the declared type)
2282 : 389 : *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
2283 : : formatted);
2284 : :
2285 : 389 : if (*dtio_sub)
2286 : 389 : return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
2287 : : }
2288 : :
2289 : : return NULL_TREE;
2290 : : }
2291 : :
2292 : : /* Generate the call for a scalar transfer node. */
2293 : :
2294 : : static void
2295 : 38421 : transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2296 : : gfc_code * code, tree vptr)
2297 : : {
2298 : 38421 : tree tmp, function, arg2, arg3, field, expr;
2299 : 38421 : gfc_component *c;
2300 : 38421 : int kind;
2301 : :
2302 : : /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2303 : : the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2304 : : We need to translate the expression to a constant if it's either
2305 : : C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2306 : : type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2307 : : BT_DERIVED (could have been changed by gfc_conv_expr). */
2308 : 38421 : if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2309 : 12813 : && ts->u.derived != NULL
2310 : 639 : && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2311 : : {
2312 : 21 : ts->type = BT_INTEGER;
2313 : 21 : ts->kind = gfc_index_integer_kind;
2314 : : }
2315 : :
2316 : : /* gfortran reaches here for "print *, c_loc(xxx)". */
2317 : 38421 : if (ts->type == BT_VOID
2318 : 0 : && code->expr1 && code->expr1->ts.type == BT_VOID
2319 : 0 : && code->expr1->symtree
2320 : 0 : && strcmp (code->expr1->symtree->name, "c_loc") == 0)
2321 : : {
2322 : 0 : ts->type = BT_INTEGER;
2323 : 0 : ts->kind = gfc_index_integer_kind;
2324 : : }
2325 : :
2326 : 38421 : kind = gfc_type_abi_kind (ts);
2327 : 38421 : function = NULL;
2328 : 38421 : arg2 = NULL;
2329 : 38421 : arg3 = NULL;
2330 : :
2331 : 38421 : switch (ts->type)
2332 : : {
2333 : 12195 : case BT_INTEGER:
2334 : 12195 : arg2 = build_int_cst (integer_type_node, kind);
2335 : 12195 : if (last_dt == READ)
2336 : 2239 : function = iocall[IOCALL_X_INTEGER];
2337 : : else
2338 : 9956 : function = iocall[IOCALL_X_INTEGER_WRITE];
2339 : :
2340 : : break;
2341 : :
2342 : 7389 : case BT_REAL:
2343 : 7389 : arg2 = build_int_cst (integer_type_node, kind);
2344 : 7389 : if (last_dt == READ)
2345 : : {
2346 : 1395 : if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2347 : 66 : function = iocall[IOCALL_X_REAL128];
2348 : : else
2349 : 1329 : function = iocall[IOCALL_X_REAL];
2350 : : }
2351 : : else
2352 : : {
2353 : 5994 : if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2354 : 398 : function = iocall[IOCALL_X_REAL128_WRITE];
2355 : : else
2356 : 5596 : function = iocall[IOCALL_X_REAL_WRITE];
2357 : : }
2358 : :
2359 : : break;
2360 : :
2361 : 699 : case BT_COMPLEX:
2362 : 699 : arg2 = build_int_cst (integer_type_node, kind);
2363 : 699 : if (last_dt == READ)
2364 : : {
2365 : 331 : if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2366 : 0 : function = iocall[IOCALL_X_COMPLEX128];
2367 : : else
2368 : 331 : function = iocall[IOCALL_X_COMPLEX];
2369 : : }
2370 : : else
2371 : : {
2372 : 368 : if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2373 : 3 : function = iocall[IOCALL_X_COMPLEX128_WRITE];
2374 : : else
2375 : 365 : function = iocall[IOCALL_X_COMPLEX_WRITE];
2376 : : }
2377 : :
2378 : : break;
2379 : :
2380 : 974 : case BT_LOGICAL:
2381 : 974 : arg2 = build_int_cst (integer_type_node, kind);
2382 : 974 : if (last_dt == READ)
2383 : 120 : function = iocall[IOCALL_X_LOGICAL];
2384 : : else
2385 : 854 : function = iocall[IOCALL_X_LOGICAL_WRITE];
2386 : :
2387 : : break;
2388 : :
2389 : 16480 : case BT_CHARACTER:
2390 : 16480 : if (kind == 4)
2391 : : {
2392 : 353 : if (se->string_length)
2393 : : arg2 = se->string_length;
2394 : : else
2395 : : {
2396 : 0 : tmp = build_fold_indirect_ref_loc (input_location,
2397 : : addr_expr);
2398 : 0 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2399 : 0 : arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2400 : 0 : arg2 = fold_convert (gfc_charlen_type_node, arg2);
2401 : : }
2402 : 353 : arg3 = build_int_cst (integer_type_node, kind);
2403 : 353 : if (last_dt == READ)
2404 : 84 : function = iocall[IOCALL_X_CHARACTER_WIDE];
2405 : : else
2406 : 269 : function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
2407 : :
2408 : 353 : tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2409 : 353 : tmp = build_call_expr_loc (input_location,
2410 : : function, 4, tmp, addr_expr, arg2, arg3);
2411 : 353 : gfc_add_expr_to_block (&se->pre, tmp);
2412 : 353 : gfc_add_block_to_block (&se->pre, &se->post);
2413 : 353 : return;
2414 : : }
2415 : : /* Fall through. */
2416 : 16139 : case BT_HOLLERITH:
2417 : 16139 : if (se->string_length)
2418 : : arg2 = se->string_length;
2419 : : else
2420 : : {
2421 : 120 : tmp = build_fold_indirect_ref_loc (input_location,
2422 : : addr_expr);
2423 : 120 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2424 : 120 : arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2425 : : }
2426 : 16139 : if (last_dt == READ)
2427 : 1509 : function = iocall[IOCALL_X_CHARACTER];
2428 : : else
2429 : 14630 : function = iocall[IOCALL_X_CHARACTER_WRITE];
2430 : :
2431 : : break;
2432 : :
2433 : 672 : case_bt_struct:
2434 : 672 : case BT_CLASS:
2435 : 672 : if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS)
2436 : : {
2437 : 672 : gfc_symbol *derived;
2438 : 672 : gfc_symbol *dtio_sub = NULL;
2439 : : /* Test for a specific DTIO subroutine. */
2440 : 672 : if (ts->type == BT_DERIVED)
2441 : 618 : derived = ts->u.derived;
2442 : : else
2443 : 54 : derived = ts->u.derived->components->ts.u.derived;
2444 : :
2445 : 672 : if (derived->attr.has_dtio_procs)
2446 : 431 : arg2 = get_dtio_proc (ts, code, &dtio_sub);
2447 : :
2448 : 672 : if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
2449 : : {
2450 : 419 : tree decl;
2451 : 419 : decl = build_fold_indirect_ref_loc (input_location,
2452 : : se->expr);
2453 : : /* Remember that the first dummy of the DTIO subroutines
2454 : : is CLASS(derived) for extensible derived types, so the
2455 : : conversion must be done here for derived type and for
2456 : : scalarized CLASS array element io-list objects. */
2457 : 419 : if ((ts->type == BT_DERIVED
2458 : 371 : && !(ts->u.derived->attr.sequence
2459 : : || ts->u.derived->attr.is_bind_c))
2460 : 444 : || (ts->type == BT_CLASS
2461 : 48 : && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
2462 : 382 : gfc_conv_derived_to_class (se, code->expr1,
2463 : 382 : dtio_sub->formal->sym->ts,
2464 : : vptr, false, false);
2465 : 419 : addr_expr = se->expr;
2466 : 419 : function = iocall[IOCALL_X_DERIVED];
2467 : 419 : break;
2468 : : }
2469 : 253 : else if (gfc_bt_struct (ts->type))
2470 : : {
2471 : : /* Recurse into the elements of the derived type. */
2472 : 253 : expr = gfc_evaluate_now (addr_expr, &se->pre);
2473 : 253 : expr = build_fold_indirect_ref_loc (input_location, expr);
2474 : :
2475 : : /* Make sure that the derived type has been built. An external
2476 : : function, if only referenced in an io statement, requires this
2477 : : check (see PR58771). */
2478 : 253 : if (ts->u.derived->backend_decl == NULL_TREE)
2479 : 6 : (void) gfc_typenode_for_spec (ts);
2480 : :
2481 : 754 : for (c = ts->u.derived->components; c; c = c->next)
2482 : : {
2483 : : /* Ignore hidden string lengths. */
2484 : 501 : if (c->name[0] == '_')
2485 : 12 : continue;
2486 : :
2487 : 489 : field = c->backend_decl;
2488 : 489 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2489 : :
2490 : 489 : tmp = fold_build3_loc (UNKNOWN_LOCATION,
2491 : 489 : COMPONENT_REF, TREE_TYPE (field),
2492 : : expr, field, NULL_TREE);
2493 : :
2494 : 489 : if (c->attr.dimension)
2495 : : {
2496 : 72 : tmp = transfer_array_component (tmp, c, & code->loc);
2497 : 72 : gfc_add_expr_to_block (&se->pre, tmp);
2498 : : }
2499 : : else
2500 : : {
2501 : 417 : tree strlen = NULL_TREE;
2502 : :
2503 : 417 : if (!c->attr.pointer && !c->attr.pdt_string)
2504 : 405 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2505 : :
2506 : : /* Use the hidden string length for pdt strings. */
2507 : 417 : if (c->attr.pdt_string
2508 : 12 : && gfc_deferred_strlen (c, &strlen)
2509 : 429 : && strlen != NULL_TREE)
2510 : : {
2511 : 12 : strlen = fold_build3_loc (UNKNOWN_LOCATION,
2512 : : COMPONENT_REF,
2513 : 12 : TREE_TYPE (strlen),
2514 : : expr, strlen, NULL_TREE);
2515 : 12 : se->string_length = strlen;
2516 : : }
2517 : :
2518 : 417 : transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
2519 : :
2520 : : /* Reset so that the pdt string length does not propagate
2521 : : through to other strings. */
2522 : 417 : if (c->attr.pdt_string && strlen)
2523 : 12 : se->string_length = NULL_TREE;
2524 : : }
2525 : : }
2526 : 253 : return;
2527 : : }
2528 : : /* If a CLASS object gets through to here, fall through and ICE. */
2529 : : }
2530 : 0 : gcc_fallthrough ();
2531 : 0 : default:
2532 : 0 : gfc_internal_error ("Bad IO basetype (%d)", ts->type);
2533 : : }
2534 : :
2535 : 37815 : tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2536 : 37815 : tmp = build_call_expr_loc (input_location,
2537 : : function, 3, tmp, addr_expr, arg2);
2538 : 37815 : gfc_add_expr_to_block (&se->pre, tmp);
2539 : 37815 : gfc_add_block_to_block (&se->pre, &se->post);
2540 : :
2541 : : }
2542 : :
2543 : :
2544 : : /* Generate a call to pass an array descriptor to the IO library. The
2545 : : array should be of one of the intrinsic types. */
2546 : :
2547 : : static void
2548 : 3134 : transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2549 : : {
2550 : 3134 : tree tmp, charlen_arg, kind_arg, io_call;
2551 : :
2552 : 3134 : if (ts->type == BT_CHARACTER)
2553 : 515 : charlen_arg = se->string_length;
2554 : : else
2555 : 2619 : charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
2556 : :
2557 : 3134 : kind_arg = build_int_cst (integer_type_node, gfc_type_abi_kind (ts));
2558 : :
2559 : 3134 : tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2560 : 3134 : if (last_dt == READ)
2561 : 872 : io_call = iocall[IOCALL_X_ARRAY];
2562 : : else
2563 : 2262 : io_call = iocall[IOCALL_X_ARRAY_WRITE];
2564 : :
2565 : 3134 : tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2566 : : io_call, 4,
2567 : : tmp, addr_expr, kind_arg, charlen_arg);
2568 : 3134 : gfc_add_expr_to_block (&se->pre, tmp);
2569 : 3134 : gfc_add_block_to_block (&se->pre, &se->post);
2570 : 3134 : }
2571 : :
2572 : :
2573 : : /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2574 : :
2575 : : tree
2576 : 41066 : gfc_trans_transfer (gfc_code * code)
2577 : : {
2578 : 41066 : stmtblock_t block, body;
2579 : 41066 : gfc_loopinfo loop;
2580 : 41066 : gfc_expr *expr;
2581 : 41066 : gfc_ref *ref;
2582 : 41066 : gfc_ss *ss;
2583 : 41066 : gfc_se se;
2584 : 41066 : tree tmp;
2585 : 41066 : tree vptr;
2586 : 41066 : int n;
2587 : :
2588 : 41066 : gfc_start_block (&block);
2589 : 41066 : gfc_init_block (&body);
2590 : :
2591 : 41066 : expr = code->expr1;
2592 : 41066 : ref = NULL;
2593 : 41066 : gfc_init_se (&se, NULL);
2594 : :
2595 : 41066 : if (expr->rank == 0)
2596 : : {
2597 : : /* Transfer a scalar value. */
2598 : 35224 : if (expr->ts.type == BT_CLASS)
2599 : : {
2600 : 24 : se.want_pointer = 1;
2601 : 24 : gfc_conv_expr (&se, expr);
2602 : 24 : vptr = gfc_get_vptr_from_expr (se.expr);
2603 : : }
2604 : : else
2605 : : {
2606 : 35200 : vptr = NULL_TREE;
2607 : 35200 : gfc_conv_expr_reference (&se, expr);
2608 : : }
2609 : 35224 : transfer_expr (&se, &expr->ts, se.expr, code, vptr);
2610 : : }
2611 : : else
2612 : : {
2613 : : /* Transfer an array. If it is an array of an intrinsic
2614 : : type, pass the descriptor to the library. Otherwise
2615 : : scalarize the transfer. */
2616 : 5842 : if (expr->ref && !gfc_is_proc_ptr_comp (expr))
2617 : : {
2618 : 3815 : for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2619 : 149 : ref = ref->next);
2620 : 3666 : gcc_assert (ref && ref->type == REF_ARRAY);
2621 : : }
2622 : :
2623 : : /* These expressions don't always have the dtype element length set
2624 : : correctly, rendering them useless for array transfer. */
2625 : 5842 : if (expr->ts.type != BT_CLASS
2626 : 5818 : && expr->expr_type == EXPR_VARIABLE
2627 : 9484 : && ((expr->symtree->n.sym->ts.type == BT_DERIVED && expr->ts.deferred)
2628 : 3630 : || (expr->symtree->n.sym->assoc
2629 : 357 : && expr->symtree->n.sym->assoc->variable)
2630 : 3306 : || gfc_expr_attr (expr).pointer))
2631 : 356 : goto scalarize;
2632 : :
2633 : 5486 : if (!(gfc_bt_struct (expr->ts.type)
2634 : : || expr->ts.type == BT_CLASS)
2635 : 5395 : && ref && ref->next == NULL
2636 : 3134 : && !is_subref_array (expr))
2637 : : {
2638 : 3134 : bool seen_vector = false;
2639 : :
2640 : 3134 : if (ref && ref->u.ar.type == AR_SECTION)
2641 : : {
2642 : 2058 : for (n = 0; n < ref->u.ar.dimen; n++)
2643 : 1158 : if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2644 : : {
2645 : : seen_vector = true;
2646 : : break;
2647 : : }
2648 : : }
2649 : :
2650 : 910 : if (seen_vector && last_dt == READ)
2651 : : {
2652 : : /* Create a temp, read to that and copy it back. */
2653 : 6 : gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2654 : 6 : tmp = se.expr;
2655 : : }
2656 : : else
2657 : : {
2658 : : /* Get the descriptor. */
2659 : 3128 : gfc_conv_expr_descriptor (&se, expr);
2660 : 3128 : tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2661 : : }
2662 : :
2663 : 3134 : transfer_array_desc (&se, &expr->ts, tmp);
2664 : 3134 : goto finish_block_label;
2665 : : }
2666 : :
2667 : 2708 : scalarize:
2668 : : /* Initialize the scalarizer. */
2669 : 2708 : ss = gfc_walk_expr (expr);
2670 : 2708 : gfc_init_loopinfo (&loop);
2671 : 2708 : gfc_add_ss_to_loop (&loop, ss);
2672 : :
2673 : : /* Initialize the loop. */
2674 : 2708 : gfc_conv_ss_startstride (&loop);
2675 : 2708 : gfc_conv_loop_setup (&loop, &code->expr1->where);
2676 : :
2677 : : /* The main loop body. */
2678 : 2708 : gfc_mark_ss_chain_used (ss, 1);
2679 : 2708 : gfc_start_scalarized_body (&loop, &body);
2680 : :
2681 : 2708 : gfc_copy_loopinfo_to_se (&se, &loop);
2682 : 2708 : se.ss = ss;
2683 : :
2684 : 2708 : gfc_conv_expr_reference (&se, expr);
2685 : :
2686 : 2708 : if (expr->ts.type == BT_CLASS)
2687 : 24 : vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
2688 : : else
2689 : : vptr = NULL_TREE;
2690 : 2708 : transfer_expr (&se, &expr->ts, se.expr, code, vptr);
2691 : : }
2692 : :
2693 : 41066 : finish_block_label:
2694 : :
2695 : 41066 : gfc_add_block_to_block (&body, &se.pre);
2696 : 41066 : gfc_add_block_to_block (&body, &se.post);
2697 : 41066 : gfc_add_block_to_block (&body, &se.finalblock);
2698 : :
2699 : 41066 : if (se.ss == NULL)
2700 : 38358 : tmp = gfc_finish_block (&body);
2701 : : else
2702 : : {
2703 : 2708 : gcc_assert (expr->rank != 0);
2704 : 2708 : gcc_assert (se.ss == gfc_ss_terminator);
2705 : 2708 : gfc_trans_scalarizing_loops (&loop, &body);
2706 : :
2707 : 2708 : gfc_add_block_to_block (&loop.pre, &loop.post);
2708 : 2708 : tmp = gfc_finish_block (&loop.pre);
2709 : 2708 : gfc_cleanup_loop (&loop);
2710 : : }
2711 : :
2712 : 41066 : gfc_add_expr_to_block (&block, tmp);
2713 : :
2714 : 41066 : return gfc_finish_block (&block);
2715 : : }
2716 : :
2717 : : #include "gt-fortran-trans-io.h"
|
