?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* gimple-ssa-store-merging.c (struct store_immediate_info): Add
[official-gcc.git] / gcc / fortran / trans-io.c
blob9cd33b331e19d2b76faba4ae31ca5db13133dd95
1 /* IO Code translation/library interface
2 Copyright (C) 2002-2017 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_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
1006 rc, tmp, NULL_TREE);
1007
1008 gfc_add_expr_to_block (block, tmp);
1009 }
1010
1011
1012 /* Store the current file and line number to variables so that if a
1013 library call goes awry, we can tell the user where the problem is. */
1014
1015 static void
1016 set_error_locus (stmtblock_t * block, tree var, locus * where)
1017 {
1018 gfc_file *f;
1019 tree str, locus_file;
1020 int line;
1021 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
1022
1023 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1024 st_parameter[IOPARM_ptype_common].type,
1025 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
1026 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1027 TREE_TYPE (p->field), locus_file,
1028 p->field, NULL_TREE);
1029 f = where->lb->file;
1030 str = gfc_build_cstring_const (f->filename);
1031
1032 str = gfc_build_addr_expr (pchar_type_node, str);
1033 gfc_add_modify (block, locus_file, str);
1034
1035 line = LOCATION_LINE (where->lb->location);
1036 set_parameter_const (block, var, IOPARM_common_line, line);
1037 }
1038
1039
1040 /* Translate an OPEN statement. */
1041
1042 tree
1043 gfc_trans_open (gfc_code * code)
1044 {
1045 stmtblock_t block, post_block;
1046 gfc_open *p;
1047 tree tmp, var;
1048 unsigned int mask = 0;
1049
1050 gfc_start_block (&block);
1051 gfc_init_block (&post_block);
1052
1053 var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
1054
1055 set_error_locus (&block, var, &code->loc);
1056 p = code->ext.open;
1057
1058 if (p->iomsg)
1059 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1060 p->iomsg);
1061
1062 if (p->iostat)
1063 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1064 p->iostat);
1065
1066 if (p->err)
1067 mask |= IOPARM_common_err;
1068
1069 if (p->file)
1070 mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
1071
1072 if (p->status)
1073 mask |= set_string (&block, &post_block, var, IOPARM_open_status,
1074 p->status);
1075
1076 if (p->access)
1077 mask |= set_string (&block, &post_block, var, IOPARM_open_access,
1078 p->access);
1079
1080 if (p->form)
1081 mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
1082
1083 if (p->recl)
1084 mask |= set_parameter_value (&block, var, IOPARM_open_recl_in,
1085 p->recl);
1086
1087 if (p->blank)
1088 mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
1089 p->blank);
1090
1091 if (p->position)
1092 mask |= set_string (&block, &post_block, var, IOPARM_open_position,
1093 p->position);
1094
1095 if (p->action)
1096 mask |= set_string (&block, &post_block, var, IOPARM_open_action,
1097 p->action);
1098
1099 if (p->delim)
1100 mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
1101 p->delim);
1102
1103 if (p->pad)
1104 mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
1105
1106 if (p->decimal)
1107 mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
1108 p->decimal);
1109
1110 if (p->encoding)
1111 mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
1112 p->encoding);
1113
1114 if (p->round)
1115 mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
1116
1117 if (p->sign)
1118 mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
1119
1120 if (p->asynchronous)
1121 mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
1122 p->asynchronous);
1123
1124 if (p->convert)
1125 mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
1126 p->convert);
1127
1128 if (p->newunit)
1129 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
1130 p->newunit);
1131
1132 if (p->cc)
1133 mask |= set_string (&block, &post_block, var, IOPARM_open_cc, p->cc);
1134
1135 if (p->share)
1136 mask |= set_string (&block, &post_block, var, IOPARM_open_share, p->share);
1137
1138 mask |= set_parameter_const (&block, var, IOPARM_open_readonly, p->readonly);
1139
1140 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1141
1142 if (p->unit)
1143 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
1144 else
1145 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1146
1147 tmp = gfc_build_addr_expr (NULL_TREE, var);
1148 tmp = build_call_expr_loc (input_location,
1149 iocall[IOCALL_OPEN], 1, tmp);
1150 gfc_add_expr_to_block (&block, tmp);
1151
1152 gfc_add_block_to_block (&block, &post_block);
1153
1154 io_result (&block, var, p->err, NULL, NULL);
1155
1156 return gfc_finish_block (&block);
1157 }
1158
1159
1160 /* Translate a CLOSE statement. */
1161
1162 tree
1163 gfc_trans_close (gfc_code * code)
1164 {
1165 stmtblock_t block, post_block;
1166 gfc_close *p;
1167 tree tmp, var;
1168 unsigned int mask = 0;
1169
1170 gfc_start_block (&block);
1171 gfc_init_block (&post_block);
1172
1173 var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
1174
1175 set_error_locus (&block, var, &code->loc);
1176 p = code->ext.close;
1177
1178 if (p->iomsg)
1179 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1180 p->iomsg);
1181
1182 if (p->iostat)
1183 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1184 p->iostat);
1185
1186 if (p->err)
1187 mask |= IOPARM_common_err;
1188
1189 if (p->status)
1190 mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1191 p->status);
1192
1193 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1194
1195 if (p->unit)
1196 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
1197 else
1198 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1199
1200 tmp = gfc_build_addr_expr (NULL_TREE, var);
1201 tmp = build_call_expr_loc (input_location,
1202 iocall[IOCALL_CLOSE], 1, tmp);
1203 gfc_add_expr_to_block (&block, tmp);
1204
1205 gfc_add_block_to_block (&block, &post_block);
1206
1207 io_result (&block, var, p->err, NULL, NULL);
1208
1209 return gfc_finish_block (&block);
1210 }
1211
1212
1213 /* Common subroutine for building a file positioning statement. */
1214
1215 static tree
1216 build_filepos (tree function, gfc_code * code)
1217 {
1218 stmtblock_t block, post_block;
1219 gfc_filepos *p;
1220 tree tmp, var;
1221 unsigned int mask = 0;
1222
1223 p = code->ext.filepos;
1224
1225 gfc_start_block (&block);
1226 gfc_init_block (&post_block);
1227
1228 var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1229 "filepos_parm");
1230
1231 set_error_locus (&block, var, &code->loc);
1232
1233 if (p->iomsg)
1234 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1235 p->iomsg);
1236
1237 if (p->iostat)
1238 mask |= set_parameter_ref (&block, &post_block, var,
1239 IOPARM_common_iostat, p->iostat);
1240
1241 if (p->err)
1242 mask |= IOPARM_common_err;
1243
1244 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1245
1246 if (p->unit)
1247 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit,
1248 p->unit);
1249 else
1250 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1251
1252 tmp = gfc_build_addr_expr (NULL_TREE, var);
1253 tmp = build_call_expr_loc (input_location,
1254 function, 1, tmp);
1255 gfc_add_expr_to_block (&block, tmp);
1256
1257 gfc_add_block_to_block (&block, &post_block);
1258
1259 io_result (&block, var, p->err, NULL, NULL);
1260
1261 return gfc_finish_block (&block);
1262 }
1263
1264
1265 /* Translate a BACKSPACE statement. */
1266
1267 tree
1268 gfc_trans_backspace (gfc_code * code)
1269 {
1270 return build_filepos (iocall[IOCALL_BACKSPACE], code);
1271 }
1272
1273
1274 /* Translate an ENDFILE statement. */
1275
1276 tree
1277 gfc_trans_endfile (gfc_code * code)
1278 {
1279 return build_filepos (iocall[IOCALL_ENDFILE], code);
1280 }
1281
1282
1283 /* Translate a REWIND statement. */
1284
1285 tree
1286 gfc_trans_rewind (gfc_code * code)
1287 {
1288 return build_filepos (iocall[IOCALL_REWIND], code);
1289 }
1290
1291
1292 /* Translate a FLUSH statement. */
1293
1294 tree
1295 gfc_trans_flush (gfc_code * code)
1296 {
1297 return build_filepos (iocall[IOCALL_FLUSH], code);
1298 }
1299
1300
1301 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1302
1303 tree
1304 gfc_trans_inquire (gfc_code * code)
1305 {
1306 stmtblock_t block, post_block;
1307 gfc_inquire *p;
1308 tree tmp, var;
1309 unsigned int mask = 0, mask2 = 0;
1310
1311 gfc_start_block (&block);
1312 gfc_init_block (&post_block);
1313
1314 var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1315 "inquire_parm");
1316
1317 set_error_locus (&block, var, &code->loc);
1318 p = code->ext.inquire;
1319
1320 if (p->iomsg)
1321 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1322 p->iomsg);
1323
1324 if (p->iostat)
1325 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1326 p->iostat);
1327
1328 if (p->err)
1329 mask |= IOPARM_common_err;
1330
1331 /* Sanity check. */
1332 if (p->unit && p->file)
1333 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1334
1335 if (p->file)
1336 mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1337 p->file);
1338
1339 if (p->exist)
1340 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1341 p->exist);
1342
1343 if (p->opened)
1344 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1345 p->opened);
1346
1347 if (p->number)
1348 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1349 p->number);
1350
1351 if (p->named)
1352 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1353 p->named);
1354
1355 if (p->name)
1356 mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1357 p->name);
1358
1359 if (p->access)
1360 mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1361 p->access);
1362
1363 if (p->sequential)
1364 mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1365 p->sequential);
1366
1367 if (p->direct)
1368 mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1369 p->direct);
1370
1371 if (p->form)
1372 mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1373 p->form);
1374
1375 if (p->formatted)
1376 mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1377 p->formatted);
1378
1379 if (p->unformatted)
1380 mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1381 p->unformatted);
1382
1383 if (p->recl)
1384 mask |= set_parameter_ref (&block, &post_block, var,
1385 IOPARM_inquire_recl_out, p->recl);
1386
1387 if (p->nextrec)
1388 mask |= set_parameter_ref (&block, &post_block, var,
1389 IOPARM_inquire_nextrec, p->nextrec);
1390
1391 if (p->blank)
1392 mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1393 p->blank);
1394
1395 if (p->delim)
1396 mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1397 p->delim);
1398
1399 if (p->position)
1400 mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1401 p->position);
1402
1403 if (p->action)
1404 mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1405 p->action);
1406
1407 if (p->read)
1408 mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1409 p->read);
1410
1411 if (p->write)
1412 mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1413 p->write);
1414
1415 if (p->readwrite)
1416 mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1417 p->readwrite);
1418
1419 if (p->pad)
1420 mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1421 p->pad);
1422
1423 if (p->convert)
1424 mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1425 p->convert);
1426
1427 if (p->strm_pos)
1428 mask |= set_parameter_ref (&block, &post_block, var,
1429 IOPARM_inquire_strm_pos_out, p->strm_pos);
1430
1431 /* The second series of flags. */
1432 if (p->asynchronous)
1433 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1434 p->asynchronous);
1435
1436 if (p->decimal)
1437 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1438 p->decimal);
1439
1440 if (p->encoding)
1441 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1442 p->encoding);
1443
1444 if (p->round)
1445 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1446 p->round);
1447
1448 if (p->sign)
1449 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1450 p->sign);
1451
1452 if (p->pending)
1453 mask2 |= set_parameter_ref (&block, &post_block, var,
1454 IOPARM_inquire_pending, p->pending);
1455
1456 if (p->size)
1457 mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1458 p->size);
1459
1460 if (p->id)
1461 mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1462 p->id);
1463 if (p->iqstream)
1464 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream,
1465 p->iqstream);
1466
1467 if (p->share)
1468 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_share,
1469 p->share);
1470
1471 if (p->cc)
1472 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_cc, p->cc);
1473
1474 if (mask2)
1475 mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
1476
1477 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1478
1479 if (p->unit)
1480 {
1481 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1482 set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit);
1483 }
1484 else
1485 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1486
1487 tmp = gfc_build_addr_expr (NULL_TREE, var);
1488 tmp = build_call_expr_loc (input_location,
1489 iocall[IOCALL_INQUIRE], 1, tmp);
1490 gfc_add_expr_to_block (&block, tmp);
1491
1492 gfc_add_block_to_block (&block, &post_block);
1493
1494 io_result (&block, var, p->err, NULL, NULL);
1495
1496 return gfc_finish_block (&block);
1497 }
1498
1499
1500 tree
1501 gfc_trans_wait (gfc_code * code)
1502 {
1503 stmtblock_t block, post_block;
1504 gfc_wait *p;
1505 tree tmp, var;
1506 unsigned int mask = 0;
1507
1508 gfc_start_block (&block);
1509 gfc_init_block (&post_block);
1510
1511 var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1512 "wait_parm");
1513
1514 set_error_locus (&block, var, &code->loc);
1515 p = code->ext.wait;
1516
1517 /* Set parameters here. */
1518 if (p->iomsg)
1519 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1520 p->iomsg);
1521
1522 if (p->iostat)
1523 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1524 p->iostat);
1525
1526 if (p->err)
1527 mask |= IOPARM_common_err;
1528
1529 if (p->id)
1530 mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
1531
1532 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1533
1534 if (p->unit)
1535 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
1536
1537 tmp = gfc_build_addr_expr (NULL_TREE, var);
1538 tmp = build_call_expr_loc (input_location,
1539 iocall[IOCALL_WAIT], 1, tmp);
1540 gfc_add_expr_to_block (&block, tmp);
1541
1542 gfc_add_block_to_block (&block, &post_block);
1543
1544 io_result (&block, var, p->err, NULL, NULL);
1545
1546 return gfc_finish_block (&block);
1547
1548 }
1549
1550
1551 /* nml_full_name builds up the fully qualified name of a
1552 derived type component. '+' is used to denote a type extension. */
1553
1554 static char*
1555 nml_full_name (const char* var_name, const char* cmp_name, bool parent)
1556 {
1557 int full_name_length;
1558 char * full_name;
1559
1560 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1561 full_name = XCNEWVEC (char, full_name_length + 1);
1562 strcpy (full_name, var_name);
1563 full_name = strcat (full_name, parent ? "+" : "%");
1564 full_name = strcat (full_name, cmp_name);
1565 return full_name;
1566 }
1567
1568
1569 /* nml_get_addr_expr builds an address expression from the
1570 gfc_symbol or gfc_component backend_decl's. An offset is
1571 provided so that the address of an element of an array of
1572 derived types is returned. This is used in the runtime to
1573 determine that span of the derived type. */
1574
1575 static tree
1576 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1577 tree base_addr)
1578 {
1579 tree decl = NULL_TREE;
1580 tree tmp;
1581
1582 if (sym)
1583 {
1584 sym->attr.referenced = 1;
1585 decl = gfc_get_symbol_decl (sym);
1586
1587 /* If this is the enclosing function declaration, use
1588 the fake result instead. */
1589 if (decl == current_function_decl)
1590 decl = gfc_get_fake_result_decl (sym, 0);
1591 else if (decl == DECL_CONTEXT (current_function_decl))
1592 decl = gfc_get_fake_result_decl (sym, 1);
1593 }
1594 else
1595 decl = c->backend_decl;
1596
1597 gcc_assert (decl && (TREE_CODE (decl) == FIELD_DECL
1598 || VAR_P (decl)
1599 || TREE_CODE (decl) == PARM_DECL
1600 || TREE_CODE (decl) == COMPONENT_REF));
1601
1602 tmp = decl;
1603
1604 /* Build indirect reference, if dummy argument. */
1605
1606 if (POINTER_TYPE_P (TREE_TYPE(tmp)))
1607 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1608
1609 /* Treat the component of a derived type, using base_addr for
1610 the derived type. */
1611
1612 if (TREE_CODE (decl) == FIELD_DECL)
1613 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
1614 base_addr, tmp, NULL_TREE);
1615
1616 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1617 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp))))
1618 tmp = gfc_class_data_get (tmp);
1619
1620 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1621 tmp = gfc_conv_array_data (tmp);
1622 else
1623 {
1624 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1625 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1626
1627 if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1628 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1629
1630 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1631 tmp = build_fold_indirect_ref_loc (input_location,
1632 tmp);
1633 }
1634
1635 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1636
1637 return tmp;
1638 }
1639
1640
1641 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1642 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1643 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1644
1645 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1646
1647 static void
1648 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1649 gfc_symbol * sym, gfc_component * c,
1650 tree base_addr)
1651 {
1652 gfc_typespec * ts = NULL;
1653 gfc_array_spec * as = NULL;
1654 tree addr_expr = NULL;
1655 tree dt = NULL;
1656 tree string;
1657 tree tmp;
1658 tree dtype;
1659 tree dt_parm_addr;
1660 tree decl = NULL_TREE;
1661 tree gfc_int4_type_node = gfc_get_int_type (4);
1662 tree dtio_proc = null_pointer_node;
1663 tree vtable = null_pointer_node;
1664 int n_dim;
1665 int itype;
1666 int rank = 0;
1667
1668 gcc_assert (sym || c);
1669
1670 /* Build the namelist object name. */
1671
1672 string = gfc_build_cstring_const (var_name);
1673 string = gfc_build_addr_expr (pchar_type_node, string);
1674
1675 /* Build ts, as and data address using symbol or component. */
1676
1677 ts = sym ? &sym->ts : &c->ts;
1678
1679 if (ts->type != BT_CLASS)
1680 as = sym ? sym->as : c->as;
1681 else
1682 as = sym ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as;
1683
1684 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1685
1686 if (as)
1687 rank = as->rank;
1688
1689 if (rank)
1690 {
1691 decl = sym ? sym->backend_decl : c->backend_decl;
1692 if (sym && sym->attr.dummy)
1693 decl = build_fold_indirect_ref_loc (input_location, decl);
1694
1695 if (ts->type == BT_CLASS)
1696 decl = gfc_class_data_get (decl);
1697 dt = TREE_TYPE (decl);
1698 dtype = gfc_get_dtype (dt);
1699 }
1700 else
1701 {
1702 itype = ts->type;
1703 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1704 }
1705
1706 /* Build up the arguments for the transfer call.
1707 The call for the scalar part transfers:
1708 (address, name, type, kind or string_length, dtype) */
1709
1710 dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1711
1712 /* Check if the derived type has a specific DTIO for the mode.
1713 Note that although namelist io is forbidden to have a format
1714 list, the specific subroutine is of the formatted kind. */
1715 if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
1716 {
1717 gfc_symbol *derived;
1718 if (ts->type==BT_CLASS)
1719 derived = ts->u.derived->components->ts.u.derived;
1720 else
1721 derived = ts->u.derived;
1722
1723 gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
1724 last_dt == WRITE, true);
1725
1726 if (ts->type == BT_CLASS && tb_io_st)
1727 {
1728 // polymorphic DTIO call (based on the dynamic type)
1729 gfc_se se;
1730 gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1731 // build vtable expr
1732 gfc_expr *expr = gfc_get_variable_expr (st);
1733 gfc_add_vptr_component (expr);
1734 gfc_init_se (&se, NULL);
1735 se.want_pointer = 1;
1736 gfc_conv_expr (&se, expr);
1737 vtable = se.expr;
1738 // build dtio expr
1739 gfc_add_component_ref (expr,
1740 tb_io_st->n.tb->u.generic->specific_st->name);
1741 gfc_init_se (&se, NULL);
1742 se.want_pointer = 1;
1743 gfc_conv_expr (&se, expr);
1744 gfc_free_expr (expr);
1745 dtio_proc = se.expr;
1746 }
1747 else
1748 {
1749 // non-polymorphic DTIO call (based on the declared type)
1750 gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived,
1751 last_dt == WRITE, true);
1752 if (dtio_sub != NULL)
1753 {
1754 dtio_proc = gfc_get_symbol_decl (dtio_sub);
1755 dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
1756 gfc_symbol *vtab = gfc_find_derived_vtab (derived);
1757 vtable = vtab->backend_decl;
1758 if (vtable == NULL_TREE)
1759 vtable = gfc_get_symbol_decl (vtab);
1760 vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
1761 }
1762 }
1763 }
1764
1765 if (ts->type == BT_CHARACTER)
1766 tmp = ts->u.cl->backend_decl;
1767 else
1768 tmp = build_int_cst (gfc_charlen_type_node, 0);
1769
1770 if (dtio_proc == null_pointer_node)
1771 tmp = build_call_expr_loc (input_location,
1772 iocall[IOCALL_SET_NML_VAL], 6,
1773 dt_parm_addr, addr_expr, string,
1774 build_int_cst (gfc_int4_type_node, ts->kind),
1775 tmp, dtype);
1776 else
1777 tmp = build_call_expr_loc (input_location,
1778 iocall[IOCALL_SET_NML_DTIO_VAL], 8,
1779 dt_parm_addr, addr_expr, string,
1780 build_int_cst (gfc_int4_type_node, ts->kind),
1781 tmp, dtype, dtio_proc, vtable);
1782 gfc_add_expr_to_block (block, tmp);
1783
1784 /* If the object is an array, transfer rank times:
1785 (null pointer, name, stride, lbound, ubound) */
1786
1787 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1788 {
1789 tmp = build_call_expr_loc (input_location,
1790 iocall[IOCALL_SET_NML_VAL_DIM], 5,
1791 dt_parm_addr,
1792 build_int_cst (gfc_int4_type_node, n_dim),
1793 gfc_conv_array_stride (decl, n_dim),
1794 gfc_conv_array_lbound (decl, n_dim),
1795 gfc_conv_array_ubound (decl, n_dim));
1796 gfc_add_expr_to_block (block, tmp);
1797 }
1798
1799 if (gfc_bt_struct (ts->type) && ts->u.derived->components
1800 && dtio_proc == null_pointer_node)
1801 {
1802 gfc_component *cmp;
1803
1804 /* Provide the RECORD_TYPE to build component references. */
1805
1806 tree expr = build_fold_indirect_ref_loc (input_location,
1807 addr_expr);
1808
1809 for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1810 {
1811 char *full_name = nml_full_name (var_name, cmp->name,
1812 ts->u.derived->attr.extension);
1813 transfer_namelist_element (block,
1814 full_name,
1815 NULL, cmp, expr);
1816 free (full_name);
1817 }
1818 }
1819 }
1820
1821 #undef IARG
1822
1823 /* Create a data transfer statement. Not all of the fields are valid
1824 for both reading and writing, but improper use has been filtered
1825 out by now. */
1826
1827 static tree
1828 build_dt (tree function, gfc_code * code)
1829 {
1830 stmtblock_t block, post_block, post_end_block, post_iu_block;
1831 gfc_dt *dt;
1832 tree tmp, var;
1833 gfc_expr *nmlname;
1834 gfc_namelist *nml;
1835 unsigned int mask = 0;
1836
1837 gfc_start_block (&block);
1838 gfc_init_block (&post_block);
1839 gfc_init_block (&post_end_block);
1840 gfc_init_block (&post_iu_block);
1841
1842 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1843
1844 set_error_locus (&block, var, &code->loc);
1845
1846 if (last_dt == IOLENGTH)
1847 {
1848 gfc_inquire *inq;
1849
1850 inq = code->ext.inquire;
1851
1852 /* First check that preconditions are met. */
1853 gcc_assert (inq != NULL);
1854 gcc_assert (inq->iolength != NULL);
1855
1856 /* Connect to the iolength variable. */
1857 mask |= set_parameter_ref (&block, &post_end_block, var,
1858 IOPARM_dt_iolength, inq->iolength);
1859 dt = NULL;
1860 }
1861 else
1862 {
1863 dt = code->ext.dt;
1864 gcc_assert (dt != NULL);
1865 }
1866
1867 if (dt && dt->io_unit)
1868 {
1869 if (dt->io_unit->ts.type == BT_CHARACTER)
1870 {
1871 mask |= set_internal_unit (&block, &post_iu_block,
1872 var, dt->io_unit);
1873 set_parameter_const (&block, var, IOPARM_common_unit,
1874 dt->io_unit->ts.kind == 1 ?
1875 GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4);
1876 }
1877 }
1878 else
1879 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1880
1881 if (dt)
1882 {
1883 if (dt->iomsg)
1884 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1885 dt->iomsg);
1886
1887 if (dt->iostat)
1888 mask |= set_parameter_ref (&block, &post_end_block, var,
1889 IOPARM_common_iostat, dt->iostat);
1890
1891 if (dt->err)
1892 mask |= IOPARM_common_err;
1893
1894 if (dt->eor)
1895 mask |= IOPARM_common_eor;
1896
1897 if (dt->end)
1898 mask |= IOPARM_common_end;
1899
1900 if (dt->id)
1901 mask |= set_parameter_ref (&block, &post_end_block, var,
1902 IOPARM_dt_id, dt->id);
1903
1904 if (dt->pos)
1905 mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1906
1907 if (dt->asynchronous)
1908 mask |= set_string (&block, &post_block, var,
1909 IOPARM_dt_asynchronous, dt->asynchronous);
1910
1911 if (dt->blank)
1912 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1913 dt->blank);
1914
1915 if (dt->decimal)
1916 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1917 dt->decimal);
1918
1919 if (dt->delim)
1920 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1921 dt->delim);
1922
1923 if (dt->pad)
1924 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1925 dt->pad);
1926
1927 if (dt->round)
1928 mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1929 dt->round);
1930
1931 if (dt->sign)
1932 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1933 dt->sign);
1934
1935 if (dt->rec)
1936 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1937
1938 if (dt->advance)
1939 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1940 dt->advance);
1941
1942 if (dt->format_expr)
1943 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1944 dt->format_expr);
1945
1946 if (dt->format_label)
1947 {
1948 if (dt->format_label == &format_asterisk)
1949 mask |= IOPARM_dt_list_format;
1950 else
1951 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1952 dt->format_label->format);
1953 }
1954
1955 if (dt->size)
1956 mask |= set_parameter_ref (&block, &post_end_block, var,
1957 IOPARM_dt_size, dt->size);
1958
1959 if (dt->udtio)
1960 mask |= IOPARM_dt_dtio;
1961
1962 if (dt->default_exp)
1963 mask |= IOPARM_dt_default_exp;
1964
1965 if (dt->namelist)
1966 {
1967 if (dt->format_expr || dt->format_label)
1968 gfc_internal_error ("build_dt: format with namelist");
1969
1970 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1971 dt->namelist->name,
1972 strlen (dt->namelist->name));
1973
1974 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1975 nmlname);
1976
1977 gfc_free_expr (nmlname);
1978
1979 if (last_dt == READ)
1980 mask |= IOPARM_dt_namelist_read_mode;
1981
1982 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1983
1984 dt_parm = var;
1985
1986 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1987 transfer_namelist_element (&block, nml->sym->name, nml->sym,
1988 NULL, NULL_TREE);
1989 }
1990 else
1991 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1992
1993 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1994 set_parameter_value_chk (&block, dt->iostat, var,
1995 IOPARM_common_unit, dt->io_unit);
1996 }
1997 else
1998 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1999
2000 tmp = gfc_build_addr_expr (NULL_TREE, var);
2001 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2002 function, 1, tmp);
2003 gfc_add_expr_to_block (&block, tmp);
2004
2005 gfc_add_block_to_block (&block, &post_block);
2006
2007 dt_parm = var;
2008 dt_post_end_block = &post_end_block;
2009
2010 /* Set implied do loop exit condition. */
2011 if (last_dt == READ || last_dt == WRITE)
2012 {
2013 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
2014
2015 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2016 st_parameter[IOPARM_ptype_common].type,
2017 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
2018 NULL_TREE);
2019 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2020 TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
2021 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
2022 tmp, build_int_cst (TREE_TYPE (tmp),
2023 IOPARM_common_libreturn_mask));
2024 }
2025 else /* IOLENGTH */
2026 tmp = NULL_TREE;
2027
2028 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
2029
2030 gfc_add_block_to_block (&block, &post_iu_block);
2031
2032 dt_parm = NULL;
2033 dt_post_end_block = NULL;
2034
2035 return gfc_finish_block (&block);
2036 }
2037
2038
2039 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
2040 this as a third sort of data transfer statement, except that
2041 lengths are summed instead of actually transferring any data. */
2042
2043 tree
2044 gfc_trans_iolength (gfc_code * code)
2045 {
2046 last_dt = IOLENGTH;
2047 return build_dt (iocall[IOCALL_IOLENGTH], code);
2048 }
2049
2050
2051 /* Translate a READ statement. */
2052
2053 tree
2054 gfc_trans_read (gfc_code * code)
2055 {
2056 last_dt = READ;
2057 return build_dt (iocall[IOCALL_READ], code);
2058 }
2059
2060
2061 /* Translate a WRITE statement */
2062
2063 tree
2064 gfc_trans_write (gfc_code * code)
2065 {
2066 last_dt = WRITE;
2067 return build_dt (iocall[IOCALL_WRITE], code);
2068 }
2069
2070
2071 /* Finish a data transfer statement. */
2072
2073 tree
2074 gfc_trans_dt_end (gfc_code * code)
2075 {
2076 tree function, tmp;
2077 stmtblock_t block;
2078
2079 gfc_init_block (&block);
2080
2081 switch (last_dt)
2082 {
2083 case READ:
2084 function = iocall[IOCALL_READ_DONE];
2085 break;
2086
2087 case WRITE:
2088 function = iocall[IOCALL_WRITE_DONE];
2089 break;
2090
2091 case IOLENGTH:
2092 function = iocall[IOCALL_IOLENGTH_DONE];
2093 break;
2094
2095 default:
2096 gcc_unreachable ();
2097 }
2098
2099 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2100 tmp = build_call_expr_loc (input_location,
2101 function, 1, tmp);
2102 gfc_add_expr_to_block (&block, tmp);
2103 gfc_add_block_to_block (&block, dt_post_end_block);
2104 gfc_init_block (dt_post_end_block);
2105
2106 if (last_dt != IOLENGTH)
2107 {
2108 gcc_assert (code->ext.dt != NULL);
2109 io_result (&block, dt_parm, code->ext.dt->err,
2110 code->ext.dt->end, code->ext.dt->eor);
2111 }
2112
2113 return gfc_finish_block (&block);
2114 }
2115
2116 static void
2117 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2118 gfc_code * code, tree vptr);
2119
2120 /* Given an array field in a derived type variable, generate the code
2121 for the loop that iterates over array elements, and the code that
2122 accesses those array elements. Use transfer_expr to generate code
2123 for transferring that element. Because elements may also be
2124 derived types, transfer_expr and transfer_array_component are mutually
2125 recursive. */
2126
2127 static tree
2128 transfer_array_component (tree expr, gfc_component * cm, locus * where)
2129 {
2130 tree tmp;
2131 stmtblock_t body;
2132 stmtblock_t block;
2133 gfc_loopinfo loop;
2134 int n;
2135 gfc_ss *ss;
2136 gfc_se se;
2137 gfc_array_info *ss_array;
2138
2139 gfc_start_block (&block);
2140 gfc_init_se (&se, NULL);
2141
2142 /* Create and initialize Scalarization Status. Unlike in
2143 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2144 care of this task, because we don't have a gfc_expr at hand.
2145 Build one manually, as in gfc_trans_subarray_assign. */
2146
2147 ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
2148 GFC_SS_COMPONENT);
2149 ss_array = &ss->info->data.array;
2150 ss_array->shape = gfc_get_shape (cm->as->rank);
2151 ss_array->descriptor = expr;
2152 ss_array->data = gfc_conv_array_data (expr);
2153 ss_array->offset = gfc_conv_array_offset (expr);
2154 for (n = 0; n < cm->as->rank; n++)
2155 {
2156 ss_array->start[n] = gfc_conv_array_lbound (expr, n);
2157 ss_array->stride[n] = gfc_index_one_node;
2158
2159 mpz_init (ss_array->shape[n]);
2160 mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
2161 cm->as->lower[n]->value.integer);
2162 mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
2163 }
2164
2165 /* Once we got ss, we use scalarizer to create the loop. */
2166
2167 gfc_init_loopinfo (&loop);
2168 gfc_add_ss_to_loop (&loop, ss);
2169 gfc_conv_ss_startstride (&loop);
2170 gfc_conv_loop_setup (&loop, where);
2171 gfc_mark_ss_chain_used (ss, 1);
2172 gfc_start_scalarized_body (&loop, &body);
2173
2174 gfc_copy_loopinfo_to_se (&se, &loop);
2175 se.ss = ss;
2176
2177 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2178 se.expr = expr;
2179 gfc_conv_tmp_array_ref (&se);
2180
2181 /* Now se.expr contains an element of the array. Take the address and pass
2182 it to the IO routines. */
2183 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2184 transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
2185
2186 /* We are done now with the loop body. Wrap up the scalarizer and
2187 return. */
2188
2189 gfc_add_block_to_block (&body, &se.pre);
2190 gfc_add_block_to_block (&body, &se.post);
2191
2192 gfc_trans_scalarizing_loops (&loop, &body);
2193
2194 gfc_add_block_to_block (&block, &loop.pre);
2195 gfc_add_block_to_block (&block, &loop.post);
2196
2197 gcc_assert (ss_array->shape != NULL);
2198 gfc_free_shape (&ss_array->shape, cm->as->rank);
2199 gfc_cleanup_loop (&loop);
2200
2201 return gfc_finish_block (&block);
2202 }
2203
2204
2205 /* Helper function for transfer_expr that looks for the DTIO procedure
2206 either as a typebound binding or in a generic interface. If present,
2207 the address expression of the procedure is returned. It is assumed
2208 that the procedure interface has been checked during resolution. */
2209
2210 static tree
2211 get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
2212 {
2213 gfc_symbol *derived;
2214 bool formatted = false;
2215 gfc_dt *dt = code->ext.dt;
2216
2217 if (dt)
2218 {
2219 char *fmt = NULL;
2220
2221 if (dt->format_label == &format_asterisk)
2222 {
2223 /* List directed io must call the formatted DTIO procedure. */
2224 formatted = true;
2225 }
2226 else if (dt->format_expr)
2227 fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
2228 -1);
2229 else if (dt->format_label)
2230 fmt = gfc_widechar_to_char (dt->format_label->format->value.character.string,
2231 -1);
2232 if (fmt && strtok (fmt, "DT") != NULL)
2233 formatted = true;
2234
2235 }
2236
2237 if (ts->type == BT_CLASS)
2238 derived = ts->u.derived->components->ts.u.derived;
2239 else
2240 derived = ts->u.derived;
2241
2242 gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
2243 last_dt == WRITE, formatted);
2244 if (ts->type == BT_CLASS && tb_io_st)
2245 {
2246 // polymorphic DTIO call (based on the dynamic type)
2247 gfc_se se;
2248 gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1);
2249 gfc_add_vptr_component (expr);
2250 gfc_add_component_ref (expr,
2251 tb_io_st->n.tb->u.generic->specific_st->name);
2252 *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym;
2253 gfc_init_se (&se, NULL);
2254 se.want_pointer = 1;
2255 gfc_conv_expr (&se, expr);
2256 gfc_free_expr (expr);
2257 return se.expr;
2258 }
2259 else
2260 {
2261 // non-polymorphic DTIO call (based on the declared type)
2262 *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
2263 formatted);
2264
2265 if (*dtio_sub)
2266 return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
2267 }
2268
2269 return NULL_TREE;
2270 }
2271
2272 /* Generate the call for a scalar transfer node. */
2273
2274 static void
2275 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
2276 gfc_code * code, tree vptr)
2277 {
2278 tree tmp, function, arg2, arg3, field, expr;
2279 gfc_component *c;
2280 int kind;
2281
2282 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2283 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2284 We need to translate the expression to a constant if it's either
2285 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2286 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2287 BT_DERIVED (could have been changed by gfc_conv_expr). */
2288 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2289 && ts->u.derived != NULL
2290 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2291 {
2292 ts->type = BT_INTEGER;
2293 ts->kind = gfc_index_integer_kind;
2294 }
2295
2296 kind = ts->kind;
2297 function = NULL;
2298 arg2 = NULL;
2299 arg3 = NULL;
2300
2301 switch (ts->type)
2302 {
2303 case BT_INTEGER:
2304 arg2 = build_int_cst (integer_type_node, kind);
2305 if (last_dt == READ)
2306 function = iocall[IOCALL_X_INTEGER];
2307 else
2308 function = iocall[IOCALL_X_INTEGER_WRITE];
2309
2310 break;
2311
2312 case BT_REAL:
2313 arg2 = build_int_cst (integer_type_node, kind);
2314 if (last_dt == READ)
2315 {
2316 if (gfc_real16_is_float128 && ts->kind == 16)
2317 function = iocall[IOCALL_X_REAL128];
2318 else
2319 function = iocall[IOCALL_X_REAL];
2320 }
2321 else
2322 {
2323 if (gfc_real16_is_float128 && ts->kind == 16)
2324 function = iocall[IOCALL_X_REAL128_WRITE];
2325 else
2326 function = iocall[IOCALL_X_REAL_WRITE];
2327 }
2328
2329 break;
2330
2331 case BT_COMPLEX:
2332 arg2 = build_int_cst (integer_type_node, kind);
2333 if (last_dt == READ)
2334 {
2335 if (gfc_real16_is_float128 && ts->kind == 16)
2336 function = iocall[IOCALL_X_COMPLEX128];
2337 else
2338 function = iocall[IOCALL_X_COMPLEX];
2339 }
2340 else
2341 {
2342 if (gfc_real16_is_float128 && ts->kind == 16)
2343 function = iocall[IOCALL_X_COMPLEX128_WRITE];
2344 else
2345 function = iocall[IOCALL_X_COMPLEX_WRITE];
2346 }
2347
2348 break;
2349
2350 case BT_LOGICAL:
2351 arg2 = build_int_cst (integer_type_node, kind);
2352 if (last_dt == READ)
2353 function = iocall[IOCALL_X_LOGICAL];
2354 else
2355 function = iocall[IOCALL_X_LOGICAL_WRITE];
2356
2357 break;
2358
2359 case BT_CHARACTER:
2360 if (kind == 4)
2361 {
2362 if (se->string_length)
2363 arg2 = se->string_length;
2364 else
2365 {
2366 tmp = build_fold_indirect_ref_loc (input_location,
2367 addr_expr);
2368 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2369 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2370 arg2 = fold_convert (gfc_charlen_type_node, arg2);
2371 }
2372 arg3 = build_int_cst (integer_type_node, kind);
2373 if (last_dt == READ)
2374 function = iocall[IOCALL_X_CHARACTER_WIDE];
2375 else
2376 function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
2377
2378 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2379 tmp = build_call_expr_loc (input_location,
2380 function, 4, tmp, addr_expr, arg2, arg3);
2381 gfc_add_expr_to_block (&se->pre, tmp);
2382 gfc_add_block_to_block (&se->pre, &se->post);
2383 return;
2384 }
2385 /* Fall through. */
2386 case BT_HOLLERITH:
2387 if (se->string_length)
2388 arg2 = se->string_length;
2389 else
2390 {
2391 tmp = build_fold_indirect_ref_loc (input_location,
2392 addr_expr);
2393 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2394 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2395 }
2396 if (last_dt == READ)
2397 function = iocall[IOCALL_X_CHARACTER];
2398 else
2399 function = iocall[IOCALL_X_CHARACTER_WRITE];
2400
2401 break;
2402
2403 case_bt_struct:
2404 case BT_CLASS:
2405 if (ts->u.derived->components == NULL)
2406 return;
2407 if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS)
2408 {
2409 gfc_symbol *derived;
2410 gfc_symbol *dtio_sub = NULL;
2411 /* Test for a specific DTIO subroutine. */
2412 if (ts->type == BT_DERIVED)
2413 derived = ts->u.derived;
2414 else
2415 derived = ts->u.derived->components->ts.u.derived;
2416
2417 if (derived->attr.has_dtio_procs)
2418 arg2 = get_dtio_proc (ts, code, &dtio_sub);
2419
2420 if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
2421 {
2422 tree decl;
2423 decl = build_fold_indirect_ref_loc (input_location,
2424 se->expr);
2425 /* Remember that the first dummy of the DTIO subroutines
2426 is CLASS(derived) for extensible derived types, so the
2427 conversion must be done here for derived type and for
2428 scalarized CLASS array element io-list objects. */
2429 if ((ts->type == BT_DERIVED
2430 && !(ts->u.derived->attr.sequence
2431 || ts->u.derived->attr.is_bind_c))
2432 || (ts->type == BT_CLASS
2433 && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
2434 gfc_conv_derived_to_class (se, code->expr1,
2435 dtio_sub->formal->sym->ts,
2436 vptr, false, false);
2437 addr_expr = se->expr;
2438 function = iocall[IOCALL_X_DERIVED];
2439 break;
2440 }
2441 else if (gfc_bt_struct (ts->type))
2442 {
2443 /* Recurse into the elements of the derived type. */
2444 expr = gfc_evaluate_now (addr_expr, &se->pre);
2445 expr = build_fold_indirect_ref_loc (input_location,
2446 expr);
2447
2448 /* Make sure that the derived type has been built. An external
2449 function, if only referenced in an io statement, requires this
2450 check (see PR58771). */
2451 if (ts->u.derived->backend_decl == NULL_TREE)
2452 (void) gfc_typenode_for_spec (ts);
2453
2454 for (c = ts->u.derived->components; c; c = c->next)
2455 {
2456 field = c->backend_decl;
2457 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2458
2459 tmp = fold_build3_loc (UNKNOWN_LOCATION,
2460 COMPONENT_REF, TREE_TYPE (field),
2461 expr, field, NULL_TREE);
2462
2463 if (c->attr.dimension)
2464 {
2465 tmp = transfer_array_component (tmp, c, & code->loc);
2466 gfc_add_expr_to_block (&se->pre, tmp);
2467 }
2468 else
2469 {
2470 if (!c->attr.pointer)
2471 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2472 transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
2473 }
2474 }
2475 return;
2476 }
2477 /* If a CLASS object gets through to here, fall through and ICE. */
2478 }
2479 gcc_fallthrough ();
2480 default:
2481 gfc_internal_error ("Bad IO basetype (%d)", ts->type);
2482 }
2483
2484 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2485 tmp = build_call_expr_loc (input_location,
2486 function, 3, tmp, addr_expr, arg2);
2487 gfc_add_expr_to_block (&se->pre, tmp);
2488 gfc_add_block_to_block (&se->pre, &se->post);
2489
2490 }
2491
2492
2493 /* Generate a call to pass an array descriptor to the IO library. The
2494 array should be of one of the intrinsic types. */
2495
2496 static void
2497 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2498 {
2499 tree tmp, charlen_arg, kind_arg, io_call;
2500
2501 if (ts->type == BT_CHARACTER)
2502 charlen_arg = se->string_length;
2503 else
2504 charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
2505
2506 kind_arg = build_int_cst (integer_type_node, ts->kind);
2507
2508 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2509 if (last_dt == READ)
2510 io_call = iocall[IOCALL_X_ARRAY];
2511 else
2512 io_call = iocall[IOCALL_X_ARRAY_WRITE];
2513
2514 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2515 io_call, 4,
2516 tmp, addr_expr, kind_arg, charlen_arg);
2517 gfc_add_expr_to_block (&se->pre, tmp);
2518 gfc_add_block_to_block (&se->pre, &se->post);
2519 }
2520
2521
2522 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2523
2524 tree
2525 gfc_trans_transfer (gfc_code * code)
2526 {
2527 stmtblock_t block, body;
2528 gfc_loopinfo loop;
2529 gfc_expr *expr;
2530 gfc_ref *ref;
2531 gfc_ss *ss;
2532 gfc_se se;
2533 tree tmp;
2534 tree vptr;
2535 int n;
2536
2537 gfc_start_block (&block);
2538 gfc_init_block (&body);
2539
2540 expr = code->expr1;
2541 ref = NULL;
2542 gfc_init_se (&se, NULL);
2543
2544 if (expr->rank == 0)
2545 {
2546 /* Transfer a scalar value. */
2547 if (expr->ts.type == BT_CLASS)
2548 {
2549 se.want_pointer = 1;
2550 gfc_conv_expr (&se, expr);
2551 vptr = gfc_get_vptr_from_expr (se.expr);
2552 }
2553 else
2554 {
2555 vptr = NULL_TREE;
2556 gfc_conv_expr_reference (&se, expr);
2557 }
2558 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
2559 }
2560 else
2561 {
2562 /* Transfer an array. If it is an array of an intrinsic
2563 type, pass the descriptor to the library. Otherwise
2564 scalarize the transfer. */
2565 if (expr->ref && !gfc_is_proc_ptr_comp (expr))
2566 {
2567 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2568 ref = ref->next);
2569 gcc_assert (ref && ref->type == REF_ARRAY);
2570 }
2571
2572 if (expr->ts.type != BT_CLASS
2573 && expr->expr_type == EXPR_VARIABLE
2574 && gfc_expr_attr (expr).pointer)
2575 goto scalarize;
2576
2577
2578 if (!(gfc_bt_struct (expr->ts.type)
2579 || expr->ts.type == BT_CLASS)
2580 && ref && ref->next == NULL
2581 && !is_subref_array (expr))
2582 {
2583 bool seen_vector = false;
2584
2585 if (ref && ref->u.ar.type == AR_SECTION)
2586 {
2587 for (n = 0; n < ref->u.ar.dimen; n++)
2588 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2589 {
2590 seen_vector = true;
2591 break;
2592 }
2593 }
2594
2595 if (seen_vector && last_dt == READ)
2596 {
2597 /* Create a temp, read to that and copy it back. */
2598 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2599 tmp = se.expr;
2600 }
2601 else
2602 {
2603 /* Get the descriptor. */
2604 gfc_conv_expr_descriptor (&se, expr);
2605 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2606 }
2607
2608 transfer_array_desc (&se, &expr->ts, tmp);
2609 goto finish_block_label;
2610 }
2611
2612 scalarize:
2613 /* Initialize the scalarizer. */
2614 ss = gfc_walk_expr (expr);
2615 gfc_init_loopinfo (&loop);
2616 gfc_add_ss_to_loop (&loop, ss);
2617
2618 /* Initialize the loop. */
2619 gfc_conv_ss_startstride (&loop);
2620 gfc_conv_loop_setup (&loop, &code->expr1->where);
2621
2622 /* The main loop body. */
2623 gfc_mark_ss_chain_used (ss, 1);
2624 gfc_start_scalarized_body (&loop, &body);
2625
2626 gfc_copy_loopinfo_to_se (&se, &loop);
2627 se.ss = ss;
2628
2629 gfc_conv_expr_reference (&se, expr);
2630
2631 if (expr->ts.type == BT_CLASS)
2632 vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
2633 else
2634 vptr = NULL_TREE;
2635 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
2636 }
2637
2638 finish_block_label:
2639
2640 gfc_add_block_to_block (&body, &se.pre);
2641 gfc_add_block_to_block (&body, &se.post);
2642
2643 if (se.ss == NULL)
2644 tmp = gfc_finish_block (&body);
2645 else
2646 {
2647 gcc_assert (expr->rank != 0);
2648 gcc_assert (se.ss == gfc_ss_terminator);
2649 gfc_trans_scalarizing_loops (&loop, &body);
2650
2651 gfc_add_block_to_block (&loop.pre, &loop.post);
2652 tmp = gfc_finish_block (&loop.pre);
2653 gfc_cleanup_loop (&loop);
2654 }
2655
2656 gfc_add_expr_to_block (&block, tmp);
2657
2658 return gfc_finish_block (&block);
2659 }
2660
2661 #include "gt-fortran-trans-io.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org