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