?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
aix: Fix building fat library for AIX
[official-gcc.git] / gcc / fortran / trans-io.cc
blobee2cc560cdfade98ed56ef9ca7fe8b2df6294cee
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 if (sym && !sym->attr.use_only && sym->attr.use_rename)
1696 string = gfc_build_cstring_const (sym->ns->use_stmts->rename->local_name);
1697 else
1698 string = gfc_build_cstring_const (var_name);
1699 string = gfc_build_addr_expr (pchar_type_node, string);
1700
1701 /* Build ts, as and data address using symbol or component. */
1702
1703 ts = sym ? &sym->ts : &c->ts;
1704
1705 if (ts->type != BT_CLASS)
1706 as = sym ? sym->as : c->as;
1707 else
1708 as = sym ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as;
1709
1710 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1711
1712 if (as)
1713 rank = as->rank;
1714
1715 if (rank)
1716 {
1717 decl = sym ? sym->backend_decl : c->backend_decl;
1718 if (sym && sym->attr.dummy)
1719 decl = build_fold_indirect_ref_loc (input_location, decl);
1720
1721 if (ts->type == BT_CLASS)
1722 decl = gfc_class_data_get (decl);
1723 dt = TREE_TYPE (decl);
1724 dtype = gfc_get_dtype (dt);
1725 }
1726 else
1727 {
1728 dt = gfc_typenode_for_spec (ts);
1729 dtype = gfc_get_dtype_rank_type (0, dt);
1730 }
1731
1732 /* Build up the arguments for the transfer call.
1733 The call for the scalar part transfers:
1734 (address, name, type, kind or string_length, dtype) */
1735
1736 dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1737
1738 /* Check if the derived type has a specific DTIO for the mode.
1739 Note that although namelist io is forbidden to have a format
1740 list, the specific subroutine is of the formatted kind. */
1741 if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
1742 {
1743 gfc_symbol *derived;
1744 if (ts->type==BT_CLASS)
1745 derived = ts->u.derived->components->ts.u.derived;
1746 else
1747 derived = ts->u.derived;
1748
1749 gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
1750 last_dt == WRITE, true);
1751
1752 if (ts->type == BT_CLASS && tb_io_st)
1753 {
1754 // polymorphic DTIO call (based on the dynamic type)
1755 gfc_se se;
1756 gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1757 // build vtable expr
1758 gfc_expr *expr = gfc_get_variable_expr (st);
1759 gfc_add_vptr_component (expr);
1760 gfc_init_se (&se, NULL);
1761 se.want_pointer = 1;
1762 gfc_conv_expr (&se, expr);
1763 vtable = se.expr;
1764 // build dtio expr
1765 gfc_add_component_ref (expr,
1766 tb_io_st->n.tb->u.generic->specific_st->name);
1767 gfc_init_se (&se, NULL);
1768 se.want_pointer = 1;
1769 gfc_conv_expr (&se, expr);
1770 gfc_free_expr (expr);
1771 dtio_proc = se.expr;
1772 }
1773 else
1774 {
1775 // non-polymorphic DTIO call (based on the declared type)
1776 gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived,
1777 last_dt == WRITE, true);
1778 if (dtio_sub != NULL)
1779 {
1780 dtio_proc = gfc_get_symbol_decl (dtio_sub);
1781 dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
1782 gfc_symbol *vtab = gfc_find_derived_vtab (derived);
1783 vtable = vtab->backend_decl;
1784 if (vtable == NULL_TREE)
1785 vtable = gfc_get_symbol_decl (vtab);
1786 vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
1787 }
1788 }
1789 }
1790
1791 if (ts->type == BT_CHARACTER)
1792 tmp = ts->u.cl->backend_decl;
1793 else
1794 tmp = build_int_cst (gfc_charlen_type_node, 0);
1795
1796 int abi_kind = gfc_type_abi_kind (ts);
1797 if (dtio_proc == null_pointer_node)
1798 tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_VAL], 6,
1799 dt_parm_addr, addr_expr, string,
1800 build_int_cst (gfc_int4_type_node, abi_kind),
1801 tmp, dtype);
1802 else
1803 tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_DTIO_VAL],
1804 8, dt_parm_addr, addr_expr, string,
1805 build_int_cst (gfc_int4_type_node, abi_kind),
1806 tmp, dtype, dtio_proc, vtable);
1807 gfc_add_expr_to_block (block, tmp);
1808
1809 /* If the object is an array, transfer rank times:
1810 (null pointer, name, stride, lbound, ubound) */
1811
1812 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1813 {
1814 tmp = build_call_expr_loc (input_location,
1815 iocall[IOCALL_SET_NML_VAL_DIM], 5,
1816 dt_parm_addr,
1817 build_int_cst (gfc_int4_type_node, n_dim),
1818 gfc_conv_array_stride (decl, n_dim),
1819 gfc_conv_array_lbound (decl, n_dim),
1820 gfc_conv_array_ubound (decl, n_dim));
1821 gfc_add_expr_to_block (block, tmp);
1822 }
1823
1824 if (gfc_bt_struct (ts->type) && ts->u.derived->components
1825 && dtio_proc == null_pointer_node)
1826 {
1827 gfc_component *cmp;
1828
1829 /* Provide the RECORD_TYPE to build component references. */
1830
1831 tree expr = build_fold_indirect_ref_loc (input_location,
1832 addr_expr);
1833
1834 for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1835 {
1836 char *full_name = nml_full_name (var_name, cmp->name,
1837 ts->u.derived->attr.extension);
1838 transfer_namelist_element (block,
1839 full_name,
1840 NULL, cmp, expr);
1841 free (full_name);
1842 }
1843 }
1844 }
1845
1846 #undef IARG
1847
1848 /* Create a data transfer statement. Not all of the fields are valid
1849 for both reading and writing, but improper use has been filtered
1850 out by now. */
1851
1852 static tree
1853 build_dt (tree function, gfc_code * code)
1854 {
1855 stmtblock_t block, post_block, post_end_block, post_iu_block;
1856 gfc_dt *dt;
1857 tree tmp, var;
1858 gfc_expr *nmlname;
1859 gfc_namelist *nml;
1860 unsigned int mask = 0;
1861
1862 gfc_start_block (&block);
1863 gfc_init_block (&post_block);
1864 gfc_init_block (&post_end_block);
1865 gfc_init_block (&post_iu_block);
1866
1867 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1868
1869 set_error_locus (&block, var, &code->loc);
1870
1871 if (last_dt == IOLENGTH)
1872 {
1873 gfc_inquire *inq;
1874
1875 inq = code->ext.inquire;
1876
1877 /* First check that preconditions are met. */
1878 gcc_assert (inq != NULL);
1879 gcc_assert (inq->iolength != NULL);
1880
1881 /* Connect to the iolength variable. */
1882 mask |= set_parameter_ref (&block, &post_end_block, var,
1883 IOPARM_dt_iolength, inq->iolength);
1884 dt = NULL;
1885 }
1886 else
1887 {
1888 dt = code->ext.dt;
1889 gcc_assert (dt != NULL);
1890 }
1891
1892 if (dt && dt->io_unit)
1893 {
1894 if (dt->io_unit->ts.type == BT_CHARACTER)
1895 {
1896 mask |= set_internal_unit (&block, &post_iu_block,
1897 var, dt->io_unit);
1898 set_parameter_const (&block, var, IOPARM_common_unit,
1899 dt->io_unit->ts.kind == 1 ?
1900 GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4);
1901 }
1902 }
1903 else
1904 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1905
1906 if (dt)
1907 {
1908 if (dt->iomsg)
1909 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1910 dt->iomsg);
1911
1912 if (dt->iostat)
1913 mask |= set_parameter_ref (&block, &post_end_block, var,
1914 IOPARM_common_iostat, dt->iostat);
1915
1916 if (dt->err)
1917 mask |= IOPARM_common_err;
1918
1919 if (dt->eor)
1920 mask |= IOPARM_common_eor;
1921
1922 if (dt->end)
1923 mask |= IOPARM_common_end;
1924
1925 if (dt->id)
1926 mask |= set_parameter_ref (&block, &post_end_block, var,
1927 IOPARM_dt_id, dt->id);
1928
1929 if (dt->pos)
1930 mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1931
1932 if (dt->asynchronous)
1933 mask |= set_string (&block, &post_block, var,
1934 IOPARM_dt_asynchronous, dt->asynchronous);
1935
1936 if (dt->blank)
1937 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1938 dt->blank);
1939
1940 if (dt->decimal)
1941 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1942 dt->decimal);
1943
1944 if (dt->delim)
1945 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1946 dt->delim);
1947
1948 if (dt->pad)
1949 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1950 dt->pad);
1951
1952 if (dt->round)
1953 mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1954 dt->round);
1955
1956 if (dt->sign)
1957 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1958 dt->sign);
1959
1960 if (dt->rec)
1961 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1962
1963 if (dt->advance)
1964 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1965 dt->advance);
1966
1967 if (dt->format_expr)
1968 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1969 dt->format_expr);
1970
1971 if (dt->format_label)
1972 {
1973 if (dt->format_label == &format_asterisk)
1974 mask |= IOPARM_dt_list_format;
1975 else
1976 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1977 dt->format_label->format);
1978 }
1979
1980 if (dt->size)
1981 mask |= set_parameter_ref (&block, &post_end_block, var,
1982 IOPARM_dt_size, dt->size);
1983
1984 if (dt->udtio)
1985 mask |= IOPARM_dt_dtio;
1986
1987 if (dt->dec_ext)
1988 mask |= IOPARM_dt_dec_ext;
1989
1990 if (dt->namelist)
1991 {
1992 if (dt->format_expr || dt->format_label)
1993 gfc_internal_error ("build_dt: format with namelist");
1994
1995 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1996 dt->namelist->name,
1997 strlen (dt->namelist->name));
1998
1999 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
2000 nmlname);
2001
2002 gfc_free_expr (nmlname);
2003
2004 if (last_dt == READ)
2005 mask |= IOPARM_dt_namelist_read_mode;
2006
2007 set_parameter_const (&block, var, IOPARM_common_flags, mask);
2008
2009 dt_parm = var;
2010
2011 for (nml = dt->namelist->namelist; nml; nml = nml->next)
2012 transfer_namelist_element (&block, nml->sym->name, nml->sym,
2013 NULL, NULL_TREE);
2014 }
2015 else
2016 set_parameter_const (&block, var, IOPARM_common_flags, mask);
2017
2018 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
2019 set_parameter_value_chk (&block, dt->iostat, var,
2020 IOPARM_common_unit, dt->io_unit);
2021 }
2022 else
2023 set_parameter_const (&block, var, IOPARM_common_flags, mask);
2024
2025 tmp = gfc_build_addr_expr (NULL_TREE, var);
2026 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2027 function, 1, tmp);
2028 gfc_add_expr_to_block (&block, tmp);
2029
2030 gfc_add_block_to_block (&block, &post_block);
2031
2032 dt_parm = var;
2033 dt_post_end_block = &post_end_block;
2034
2035 /* Set implied do loop exit condition. */
2036 if (last_dt == READ || last_dt == WRITE)
2037 {
2038 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
2039
2040 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2041 st_parameter[IOPARM_ptype_common].type,
2042 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
2043 NULL_TREE);
2044 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2045 TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
2046 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
2047 tmp, build_int_cst (TREE_TYPE (tmp),
2048 IOPARM_common_libreturn_mask));
2049 }
2050 else /* IOLENGTH */
2051 tmp = NULL_TREE;
2052
2053 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
2054
2055 gfc_add_block_to_block (&block, &post_iu_block);
2056
2057 dt_parm = NULL;
2058 dt_post_end_block = NULL;
2059
2060 return gfc_finish_block (&block);
2061 }
2062
2063
2064 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
2065 this as a third sort of data transfer statement, except that
2066 lengths are summed instead of actually transferring any data. */
2067
2068 tree
2069 gfc_trans_iolength (gfc_code * code)
2070 {
2071 last_dt = IOLENGTH;
2072 return build_dt (iocall[IOCALL_IOLENGTH], code);
2073 }
2074
2075
2076 /* Translate a READ statement. */
2077
2078 tree
2079 gfc_trans_read (gfc_code * code)
2080 {
2081 last_dt = READ;
2082 return build_dt (iocall[IOCALL_READ], code);
2083 }
2084
2085
2086 /* Translate a WRITE statement */
2087
2088 tree
2089 gfc_trans_write (gfc_code * code)
2090 {
2091 last_dt = WRITE;
2092 return build_dt (iocall[IOCALL_WRITE], code);
2093 }
2094
2095
2096 /* Finish a data transfer statement. */
2097
2098 tree
2099 gfc_trans_dt_end (gfc_code * code)
2100 {
2101 tree function, tmp;
2102 stmtblock_t block;
2103
2104 gfc_init_block (&block);
2105
2106 switch (last_dt)
2107 {
2108 case READ:
2109 function = iocall[IOCALL_READ_DONE];
2110 break;
2111
2112 case WRITE:
2113 function = iocall[IOCALL_WRITE_DONE];
2114 break;
2115
2116 case IOLENGTH:
2117 function = iocall[IOCALL_IOLENGTH_DONE];
2118 break;
2119
2120 default:
2121 gcc_unreachable ();
2122 }
2123
2124 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2125 tmp = build_call_expr_loc (input_location,
2126 function, 1, tmp);
2127 gfc_add_expr_to_block (&block, tmp);
2128 gfc_add_block_to_block (&block, dt_post_end_block);
2129 gfc_init_block (dt_post_end_block);
2130
2131 if (last_dt != IOLENGTH)
2132 {
2133 gcc_assert (code->ext.dt != NULL);
2134 io_result (&block, dt_parm, code->ext.dt->err,
2135 code->ext.dt->end, code->ext.dt->eor);
2136 }
2137
2138 return gfc_finish_block (&block);
2139 }
2140
2141 static void
2142 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2143 gfc_code * code, tree vptr);
2144
2145 /* Given an array field in a derived type variable, generate the code
2146 for the loop that iterates over array elements, and the code that
2147 accesses those array elements. Use transfer_expr to generate code
2148 for transferring that element. Because elements may also be
2149 derived types, transfer_expr and transfer_array_component are mutually
2150 recursive. */
2151
2152 static tree
2153 transfer_array_component (tree expr, gfc_component * cm, locus * where)
2154 {
2155 tree tmp;
2156 stmtblock_t body;
2157 stmtblock_t block;
2158 gfc_loopinfo loop;
2159 int n;
2160 gfc_ss *ss;
2161 gfc_se se;
2162 gfc_array_info *ss_array;
2163
2164 gfc_start_block (&block);
2165 gfc_init_se (&se, NULL);
2166
2167 /* Create and initialize Scalarization Status. Unlike in
2168 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2169 care of this task, because we don't have a gfc_expr at hand.
2170 Build one manually, as in gfc_trans_subarray_assign. */
2171
2172 ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
2173 GFC_SS_COMPONENT);
2174 ss_array = &ss->info->data.array;
2175
2176 if (cm->attr.pdt_array)
2177 ss_array->shape = NULL;
2178 else
2179 ss_array->shape = gfc_get_shape (cm->as->rank);
2180
2181 ss_array->descriptor = expr;
2182 ss_array->data = gfc_conv_array_data (expr);
2183 ss_array->offset = gfc_conv_array_offset (expr);
2184 for (n = 0; n < cm->as->rank; n++)
2185 {
2186 ss_array->start[n] = gfc_conv_array_lbound (expr, n);
2187 ss_array->stride[n] = gfc_index_one_node;
2188
2189 if (cm->attr.pdt_array)
2190 ss_array->end[n] = gfc_conv_array_ubound (expr, n);
2191 else
2192 {
2193 mpz_init (ss_array->shape[n]);
2194 mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
2195 cm->as->lower[n]->value.integer);
2196 mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
2197 }
2198 }
2199
2200 /* Once we got ss, we use scalarizer to create the loop. */
2201
2202 gfc_init_loopinfo (&loop);
2203 gfc_add_ss_to_loop (&loop, ss);
2204 gfc_conv_ss_startstride (&loop);
2205 gfc_conv_loop_setup (&loop, where);
2206 gfc_mark_ss_chain_used (ss, 1);
2207 gfc_start_scalarized_body (&loop, &body);
2208
2209 gfc_copy_loopinfo_to_se (&se, &loop);
2210 se.ss = ss;
2211
2212 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2213 se.expr = expr;
2214 gfc_conv_tmp_array_ref (&se);
2215
2216 /* Now se.expr contains an element of the array. Take the address and pass
2217 it to the IO routines. */
2218 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2219 transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
2220
2221 /* We are done now with the loop body. Wrap up the scalarizer and
2222 return. */
2223
2224 gfc_add_block_to_block (&body, &se.pre);
2225 gfc_add_block_to_block (&body, &se.post);
2226
2227 gfc_trans_scalarizing_loops (&loop, &body);
2228
2229 gfc_add_block_to_block (&block, &loop.pre);
2230 gfc_add_block_to_block (&block, &loop.post);
2231
2232 if (!cm->attr.pdt_array)
2233 {
2234 gcc_assert (ss_array->shape != NULL);
2235 gfc_free_shape (&ss_array->shape, cm->as->rank);
2236 }
2237 gfc_cleanup_loop (&loop);
2238
2239 return gfc_finish_block (&block);
2240 }
2241
2242
2243 /* Helper function for transfer_expr that looks for the DTIO procedure
2244 either as a typebound binding or in a generic interface. If present,
2245 the address expression of the procedure is returned. It is assumed
2246 that the procedure interface has been checked during resolution. */
2247
2248 static tree
2249 get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
2250 {
2251 gfc_symbol *derived;
2252 bool formatted = false;
2253 gfc_dt *dt = code->ext.dt;
2254
2255 /* Determine when to use the formatted DTIO procedure. */
2256 if (dt && (dt->format_expr || dt->format_label))
2257 formatted = true;
2258
2259 if (ts->type == BT_CLASS)
2260 derived = ts->u.derived->components->ts.u.derived;
2261 else
2262 derived = ts->u.derived;
2263
2264 gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
2265 last_dt == WRITE, formatted);
2266 if (ts->type == BT_CLASS && tb_io_st)
2267 {
2268 // polymorphic DTIO call (based on the dynamic type)
2269 gfc_se se;
2270 gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1);
2271 gfc_add_vptr_component (expr);
2272 gfc_add_component_ref (expr,
2273 tb_io_st->n.tb->u.generic->specific_st->name);
2274 *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym;
2275 gfc_init_se (&se, NULL);
2276 se.want_pointer = 1;
2277 gfc_conv_expr (&se, expr);
2278 gfc_free_expr (expr);
2279 return se.expr;
2280 }
2281 else
2282 {
2283 // non-polymorphic DTIO call (based on the declared type)
2284 *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
2285 formatted);
2286
2287 if (*dtio_sub)
2288 return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
2289 }
2290
2291 return NULL_TREE;
2292 }
2293
2294 /* Generate the call for a scalar transfer node. */
2295
2296 static void
2297 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2298 gfc_code * code, tree vptr)
2299 {
2300 tree tmp, function, arg2, arg3, field, expr;
2301 gfc_component *c;
2302 int kind;
2303
2304 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2305 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2306 We need to translate the expression to a constant if it's either
2307 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2308 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2309 BT_DERIVED (could have been changed by gfc_conv_expr). */
2310 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2311 && ts->u.derived != NULL
2312 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2313 {
2314 ts->type = BT_INTEGER;
2315 ts->kind = gfc_index_integer_kind;
2316 }
2317
2318 /* gfortran reaches here for "print *, c_loc(xxx)". */
2319 if (ts->type == BT_VOID
2320 && code->expr1 && code->expr1->ts.type == BT_VOID
2321 && code->expr1->symtree
2322 && strcmp (code->expr1->symtree->name, "c_loc") == 0)
2323 {
2324 ts->type = BT_INTEGER;
2325 ts->kind = gfc_index_integer_kind;
2326 }
2327
2328 kind = gfc_type_abi_kind (ts);
2329 function = NULL;
2330 arg2 = NULL;
2331 arg3 = NULL;
2332
2333 switch (ts->type)
2334 {
2335 case BT_INTEGER:
2336 arg2 = build_int_cst (integer_type_node, kind);
2337 if (last_dt == READ)
2338 function = iocall[IOCALL_X_INTEGER];
2339 else
2340 function = iocall[IOCALL_X_INTEGER_WRITE];
2341
2342 break;
2343
2344 case BT_REAL:
2345 arg2 = build_int_cst (integer_type_node, kind);
2346 if (last_dt == READ)
2347 {
2348 if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2349 function = iocall[IOCALL_X_REAL128];
2350 else
2351 function = iocall[IOCALL_X_REAL];
2352 }
2353 else
2354 {
2355 if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2356 function = iocall[IOCALL_X_REAL128_WRITE];
2357 else
2358 function = iocall[IOCALL_X_REAL_WRITE];
2359 }
2360
2361 break;
2362
2363 case BT_COMPLEX:
2364 arg2 = build_int_cst (integer_type_node, kind);
2365 if (last_dt == READ)
2366 {
2367 if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2368 function = iocall[IOCALL_X_COMPLEX128];
2369 else
2370 function = iocall[IOCALL_X_COMPLEX];
2371 }
2372 else
2373 {
2374 if ((gfc_real16_is_float128 && kind == 16) || kind == 17)
2375 function = iocall[IOCALL_X_COMPLEX128_WRITE];
2376 else
2377 function = iocall[IOCALL_X_COMPLEX_WRITE];
2378 }
2379
2380 break;
2381
2382 case BT_LOGICAL:
2383 arg2 = build_int_cst (integer_type_node, kind);
2384 if (last_dt == READ)
2385 function = iocall[IOCALL_X_LOGICAL];
2386 else
2387 function = iocall[IOCALL_X_LOGICAL_WRITE];
2388
2389 break;
2390
2391 case BT_CHARACTER:
2392 if (kind == 4)
2393 {
2394 if (se->string_length)
2395 arg2 = se->string_length;
2396 else
2397 {
2398 tmp = build_fold_indirect_ref_loc (input_location,
2399 addr_expr);
2400 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2401 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2402 arg2 = fold_convert (gfc_charlen_type_node, arg2);
2403 }
2404 arg3 = build_int_cst (integer_type_node, kind);
2405 if (last_dt == READ)
2406 function = iocall[IOCALL_X_CHARACTER_WIDE];
2407 else
2408 function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
2409
2410 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2411 tmp = build_call_expr_loc (input_location,
2412 function, 4, tmp, addr_expr, arg2, arg3);
2413 gfc_add_expr_to_block (&se->pre, tmp);
2414 gfc_add_block_to_block (&se->pre, &se->post);
2415 return;
2416 }
2417 /* Fall through. */
2418 case BT_HOLLERITH:
2419 if (se->string_length)
2420 arg2 = se->string_length;
2421 else
2422 {
2423 tmp = build_fold_indirect_ref_loc (input_location,
2424 addr_expr);
2425 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2426 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2427 }
2428 if (last_dt == READ)
2429 function = iocall[IOCALL_X_CHARACTER];
2430 else
2431 function = iocall[IOCALL_X_CHARACTER_WRITE];
2432
2433 break;
2434
2435 case_bt_struct:
2436 case BT_CLASS:
2437 if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS)
2438 {
2439 gfc_symbol *derived;
2440 gfc_symbol *dtio_sub = NULL;
2441 /* Test for a specific DTIO subroutine. */
2442 if (ts->type == BT_DERIVED)
2443 derived = ts->u.derived;
2444 else
2445 derived = ts->u.derived->components->ts.u.derived;
2446
2447 if (derived->attr.has_dtio_procs)
2448 arg2 = get_dtio_proc (ts, code, &dtio_sub);
2449
2450 if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
2451 {
2452 tree decl;
2453 decl = build_fold_indirect_ref_loc (input_location,
2454 se->expr);
2455 /* Remember that the first dummy of the DTIO subroutines
2456 is CLASS(derived) for extensible derived types, so the
2457 conversion must be done here for derived type and for
2458 scalarized CLASS array element io-list objects. */
2459 if ((ts->type == BT_DERIVED
2460 && !(ts->u.derived->attr.sequence
2461 || ts->u.derived->attr.is_bind_c))
2462 || (ts->type == BT_CLASS
2463 && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
2464 gfc_conv_derived_to_class (se, code->expr1,
2465 dtio_sub->formal->sym->ts,
2466 vptr, false, false);
2467 addr_expr = se->expr;
2468 function = iocall[IOCALL_X_DERIVED];
2469 break;
2470 }
2471 else if (gfc_bt_struct (ts->type))
2472 {
2473 /* Recurse into the elements of the derived type. */
2474 expr = gfc_evaluate_now (addr_expr, &se->pre);
2475 expr = build_fold_indirect_ref_loc (input_location, expr);
2476
2477 /* Make sure that the derived type has been built. An external
2478 function, if only referenced in an io statement, requires this
2479 check (see PR58771). */
2480 if (ts->u.derived->backend_decl == NULL_TREE)
2481 (void) gfc_typenode_for_spec (ts);
2482
2483 for (c = ts->u.derived->components; c; c = c->next)
2484 {
2485 /* Ignore hidden string lengths. */
2486 if (c->name[0] == '_')
2487 continue;
2488
2489 field = c->backend_decl;
2490 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2491
2492 tmp = fold_build3_loc (UNKNOWN_LOCATION,
2493 COMPONENT_REF, TREE_TYPE (field),
2494 expr, field, NULL_TREE);
2495
2496 if (c->attr.dimension)
2497 {
2498 tmp = transfer_array_component (tmp, c, & code->loc);
2499 gfc_add_expr_to_block (&se->pre, tmp);
2500 }
2501 else
2502 {
2503 tree strlen = NULL_TREE;
2504
2505 if (!c->attr.pointer && !c->attr.pdt_string)
2506 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2507
2508 /* Use the hidden string length for pdt strings. */
2509 if (c->attr.pdt_string
2510 && gfc_deferred_strlen (c, &strlen)
2511 && strlen != NULL_TREE)
2512 {
2513 strlen = fold_build3_loc (UNKNOWN_LOCATION,
2514 COMPONENT_REF,
2515 TREE_TYPE (strlen),
2516 expr, strlen, NULL_TREE);
2517 se->string_length = strlen;
2518 }
2519
2520 transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
2521
2522 /* Reset so that the pdt string length does not propagate
2523 through to other strings. */
2524 if (c->attr.pdt_string && strlen)
2525 se->string_length = NULL_TREE;
2526 }
2527 }
2528 return;
2529 }
2530 /* If a CLASS object gets through to here, fall through and ICE. */
2531 }
2532 gcc_fallthrough ();
2533 default:
2534 gfc_internal_error ("Bad IO basetype (%d)", ts->type);
2535 }
2536
2537 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2538 tmp = build_call_expr_loc (input_location,
2539 function, 3, tmp, addr_expr, arg2);
2540 gfc_add_expr_to_block (&se->pre, tmp);
2541 gfc_add_block_to_block (&se->pre, &se->post);
2542
2543 }
2544
2545
2546 /* Generate a call to pass an array descriptor to the IO library. The
2547 array should be of one of the intrinsic types. */
2548
2549 static void
2550 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2551 {
2552 tree tmp, charlen_arg, kind_arg, io_call;
2553
2554 if (ts->type == BT_CHARACTER)
2555 charlen_arg = se->string_length;
2556 else
2557 charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
2558
2559 kind_arg = build_int_cst (integer_type_node, gfc_type_abi_kind (ts));
2560
2561 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2562 if (last_dt == READ)
2563 io_call = iocall[IOCALL_X_ARRAY];
2564 else
2565 io_call = iocall[IOCALL_X_ARRAY_WRITE];
2566
2567 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2568 io_call, 4,
2569 tmp, addr_expr, kind_arg, charlen_arg);
2570 gfc_add_expr_to_block (&se->pre, tmp);
2571 gfc_add_block_to_block (&se->pre, &se->post);
2572 }
2573
2574
2575 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2576
2577 tree
2578 gfc_trans_transfer (gfc_code * code)
2579 {
2580 stmtblock_t block, body;
2581 gfc_loopinfo loop;
2582 gfc_expr *expr;
2583 gfc_ref *ref;
2584 gfc_ss *ss;
2585 gfc_se se;
2586 tree tmp;
2587 tree vptr;
2588 int n;
2589
2590 gfc_start_block (&block);
2591 gfc_init_block (&body);
2592
2593 expr = code->expr1;
2594 ref = NULL;
2595 gfc_init_se (&se, NULL);
2596
2597 if (expr->rank == 0)
2598 {
2599 /* Transfer a scalar value. */
2600 if (expr->ts.type == BT_CLASS)
2601 {
2602 se.want_pointer = 1;
2603 gfc_conv_expr (&se, expr);
2604 vptr = gfc_get_vptr_from_expr (se.expr);
2605 }
2606 else
2607 {
2608 vptr = NULL_TREE;
2609 gfc_conv_expr_reference (&se, expr);
2610 }
2611 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
2612 }
2613 else
2614 {
2615 /* Transfer an array. If it is an array of an intrinsic
2616 type, pass the descriptor to the library. Otherwise
2617 scalarize the transfer. */
2618 if (expr->ref && !gfc_is_proc_ptr_comp (expr))
2619 {
2620 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2621 ref = ref->next);
2622 gcc_assert (ref && ref->type == REF_ARRAY);
2623 }
2624
2625 /* These expressions don't always have the dtype element length set
2626 correctly, rendering them useless for array transfer. */
2627 if (expr->ts.type != BT_CLASS
2628 && expr->expr_type == EXPR_VARIABLE
2629 && ((expr->symtree->n.sym->ts.type == BT_DERIVED && expr->ts.deferred)
2630 || (expr->symtree->n.sym->assoc
2631 && expr->symtree->n.sym->assoc->variable)
2632 || gfc_expr_attr (expr).pointer))
2633 goto scalarize;
2634
2635 if (!(gfc_bt_struct (expr->ts.type)
2636 || expr->ts.type == BT_CLASS)
2637 && ref && ref->next == NULL
2638 && !is_subref_array (expr))
2639 {
2640 bool seen_vector = false;
2641
2642 if (ref && ref->u.ar.type == AR_SECTION)
2643 {
2644 for (n = 0; n < ref->u.ar.dimen; n++)
2645 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2646 {
2647 seen_vector = true;
2648 break;
2649 }
2650 }
2651
2652 if (seen_vector && last_dt == READ)
2653 {
2654 /* Create a temp, read to that and copy it back. */
2655 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2656 tmp = se.expr;
2657 }
2658 else
2659 {
2660 /* Get the descriptor. */
2661 gfc_conv_expr_descriptor (&se, expr);
2662 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2663 }
2664
2665 transfer_array_desc (&se, &expr->ts, tmp);
2666 goto finish_block_label;
2667 }
2668
2669 scalarize:
2670 /* Initialize the scalarizer. */
2671 ss = gfc_walk_expr (expr);
2672 gfc_init_loopinfo (&loop);
2673 gfc_add_ss_to_loop (&loop, ss);
2674
2675 /* Initialize the loop. */
2676 gfc_conv_ss_startstride (&loop);
2677 gfc_conv_loop_setup (&loop, &code->expr1->where);
2678
2679 /* The main loop body. */
2680 gfc_mark_ss_chain_used (ss, 1);
2681 gfc_start_scalarized_body (&loop, &body);
2682
2683 gfc_copy_loopinfo_to_se (&se, &loop);
2684 se.ss = ss;
2685
2686 gfc_conv_expr_reference (&se, expr);
2687
2688 if (expr->ts.type == BT_CLASS)
2689 vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
2690 else
2691 vptr = NULL_TREE;
2692 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
2693 }
2694
2695 finish_block_label:
2696
2697 gfc_add_block_to_block (&body, &se.pre);
2698 gfc_add_block_to_block (&body, &se.post);
2699 gfc_add_block_to_block (&body, &se.finalblock);
2700
2701 if (se.ss == NULL)
2702 tmp = gfc_finish_block (&body);
2703 else
2704 {
2705 gcc_assert (expr->rank != 0);
2706 gcc_assert (se.ss == gfc_ss_terminator);
2707 gfc_trans_scalarizing_loops (&loop, &body);
2708
2709 gfc_add_block_to_block (&loop.pre, &loop.post);
2710 tmp = gfc_finish_block (&loop.pre);
2711 gfc_cleanup_loop (&loop);
2712 }
2713
2714 gfc_add_expr_to_block (&block, tmp);
2715
2716 return gfc_finish_block (&block);
2717 }
2718
2719 #include "gt-fortran-trans-io.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org