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