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