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