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