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