?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2014-12-12 Richard Biener <rguenther@suse.de>
[official-gcc.git] / gcc / fortran / trans-io.c
blobe1b7eb9d10e606f6ad1b1a46d2a95eea02c6f493
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 "gfortran.h"
30 #include "diagnostic-core.h" /* For internal_error. */
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 gfc_int4_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 tree gfc_int4_type_node = gfc_get_int_type (4);
1561 int n_dim;
1562 int itype;
1563 int rank = 0;
1564
1565 gcc_assert (sym || c);
1566
1567 /* Build the namelist object name. */
1568
1569 string = gfc_build_cstring_const (var_name);
1570 string = gfc_build_addr_expr (pchar_type_node, string);
1571
1572 /* Build ts, as and data address using symbol or component. */
1573
1574 ts = (sym) ? &sym->ts : &c->ts;
1575 as = (sym) ? sym->as : c->as;
1576
1577 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1578
1579 if (as)
1580 rank = as->rank;
1581
1582 if (rank)
1583 {
1584 decl = (sym) ? sym->backend_decl : c->backend_decl;
1585 if (sym && sym->attr.dummy)
1586 decl = build_fold_indirect_ref_loc (input_location, decl);
1587 dt = TREE_TYPE (decl);
1588 dtype = gfc_get_dtype (dt);
1589 }
1590 else
1591 {
1592 itype = ts->type;
1593 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1594 }
1595
1596 /* Build up the arguments for the transfer call.
1597 The call for the scalar part transfers:
1598 (address, name, type, kind or string_length, dtype) */
1599
1600 dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1601
1602 if (ts->type == BT_CHARACTER)
1603 tmp = ts->u.cl->backend_decl;
1604 else
1605 tmp = build_int_cst (gfc_charlen_type_node, 0);
1606 tmp = build_call_expr_loc (input_location,
1607 iocall[IOCALL_SET_NML_VAL], 6,
1608 dt_parm_addr, addr_expr, string,
1609 build_int_cst (gfc_int4_type_node, ts->kind),
1610 tmp, dtype);
1611 gfc_add_expr_to_block (block, tmp);
1612
1613 /* If the object is an array, transfer rank times:
1614 (null pointer, name, stride, lbound, ubound) */
1615
1616 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1617 {
1618 tmp = build_call_expr_loc (input_location,
1619 iocall[IOCALL_SET_NML_VAL_DIM], 5,
1620 dt_parm_addr,
1621 build_int_cst (gfc_int4_type_node, n_dim),
1622 gfc_conv_array_stride (decl, n_dim),
1623 gfc_conv_array_lbound (decl, n_dim),
1624 gfc_conv_array_ubound (decl, n_dim));
1625 gfc_add_expr_to_block (block, tmp);
1626 }
1627
1628 if (ts->type == BT_DERIVED && ts->u.derived->components)
1629 {
1630 gfc_component *cmp;
1631
1632 /* Provide the RECORD_TYPE to build component references. */
1633
1634 tree expr = build_fold_indirect_ref_loc (input_location,
1635 addr_expr);
1636
1637 for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1638 {
1639 char *full_name = nml_full_name (var_name, cmp->name,
1640 ts->u.derived->attr.extension);
1641 transfer_namelist_element (block,
1642 full_name,
1643 NULL, cmp, expr);
1644 free (full_name);
1645 }
1646 }
1647 }
1648
1649 #undef IARG
1650
1651 /* Create a data transfer statement. Not all of the fields are valid
1652 for both reading and writing, but improper use has been filtered
1653 out by now. */
1654
1655 static tree
1656 build_dt (tree function, gfc_code * code)
1657 {
1658 stmtblock_t block, post_block, post_end_block, post_iu_block;
1659 gfc_dt *dt;
1660 tree tmp, var;
1661 gfc_expr *nmlname;
1662 gfc_namelist *nml;
1663 unsigned int mask = 0;
1664
1665 gfc_start_block (&block);
1666 gfc_init_block (&post_block);
1667 gfc_init_block (&post_end_block);
1668 gfc_init_block (&post_iu_block);
1669
1670 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1671
1672 set_error_locus (&block, var, &code->loc);
1673
1674 if (last_dt == IOLENGTH)
1675 {
1676 gfc_inquire *inq;
1677
1678 inq = code->ext.inquire;
1679
1680 /* First check that preconditions are met. */
1681 gcc_assert (inq != NULL);
1682 gcc_assert (inq->iolength != NULL);
1683
1684 /* Connect to the iolength variable. */
1685 mask |= set_parameter_ref (&block, &post_end_block, var,
1686 IOPARM_dt_iolength, inq->iolength);
1687 dt = NULL;
1688 }
1689 else
1690 {
1691 dt = code->ext.dt;
1692 gcc_assert (dt != NULL);
1693 }
1694
1695 if (dt && dt->io_unit)
1696 {
1697 if (dt->io_unit->ts.type == BT_CHARACTER)
1698 {
1699 mask |= set_internal_unit (&block, &post_iu_block,
1700 var, dt->io_unit);
1701 set_parameter_const (&block, var, IOPARM_common_unit,
1702 dt->io_unit->ts.kind == 1 ? 0 : -1);
1703 }
1704 }
1705 else
1706 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1707
1708 if (dt)
1709 {
1710 if (dt->iomsg)
1711 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1712 dt->iomsg);
1713
1714 if (dt->iostat)
1715 mask |= set_parameter_ref (&block, &post_end_block, var,
1716 IOPARM_common_iostat, dt->iostat);
1717
1718 if (dt->err)
1719 mask |= IOPARM_common_err;
1720
1721 if (dt->eor)
1722 mask |= IOPARM_common_eor;
1723
1724 if (dt->end)
1725 mask |= IOPARM_common_end;
1726
1727 if (dt->id)
1728 mask |= set_parameter_ref (&block, &post_end_block, var,
1729 IOPARM_dt_id, dt->id);
1730
1731 if (dt->pos)
1732 mask |= set_parameter_value (&block, dt->iostat, var, IOPARM_dt_pos,
1733 dt->pos);
1734
1735 if (dt->asynchronous)
1736 mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
1737 dt->asynchronous);
1738
1739 if (dt->blank)
1740 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1741 dt->blank);
1742
1743 if (dt->decimal)
1744 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1745 dt->decimal);
1746
1747 if (dt->delim)
1748 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1749 dt->delim);
1750
1751 if (dt->pad)
1752 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1753 dt->pad);
1754
1755 if (dt->round)
1756 mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1757 dt->round);
1758
1759 if (dt->sign)
1760 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1761 dt->sign);
1762
1763 if (dt->rec)
1764 mask |= set_parameter_value (&block, dt->iostat, var, IOPARM_dt_rec,
1765 dt->rec);
1766
1767 if (dt->advance)
1768 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1769 dt->advance);
1770
1771 if (dt->format_expr)
1772 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1773 dt->format_expr);
1774
1775 if (dt->format_label)
1776 {
1777 if (dt->format_label == &format_asterisk)
1778 mask |= IOPARM_dt_list_format;
1779 else
1780 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1781 dt->format_label->format);
1782 }
1783
1784 if (dt->size)
1785 mask |= set_parameter_ref (&block, &post_end_block, var,
1786 IOPARM_dt_size, dt->size);
1787
1788 if (dt->namelist)
1789 {
1790 if (dt->format_expr || dt->format_label)
1791 gfc_internal_error ("build_dt: format with namelist");
1792
1793 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1794 dt->namelist->name,
1795 strlen (dt->namelist->name));
1796
1797 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1798 nmlname);
1799
1800 gfc_free_expr (nmlname);
1801
1802 if (last_dt == READ)
1803 mask |= IOPARM_dt_namelist_read_mode;
1804
1805 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1806
1807 dt_parm = var;
1808
1809 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1810 transfer_namelist_element (&block, nml->sym->name, nml->sym,
1811 NULL, NULL_TREE);
1812 }
1813 else
1814 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1815
1816 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1817 set_parameter_value (&block, dt->iostat, var, IOPARM_common_unit,
1818 dt->io_unit);
1819 }
1820 else
1821 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1822
1823 tmp = gfc_build_addr_expr (NULL_TREE, var);
1824 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
1825 function, 1, tmp);
1826 gfc_add_expr_to_block (&block, tmp);
1827
1828 gfc_add_block_to_block (&block, &post_block);
1829
1830 dt_parm = var;
1831 dt_post_end_block = &post_end_block;
1832
1833 /* Set implied do loop exit condition. */
1834 if (last_dt == READ || last_dt == WRITE)
1835 {
1836 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
1837
1838 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1839 st_parameter[IOPARM_ptype_common].type,
1840 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
1841 NULL_TREE);
1842 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1843 TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
1844 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
1845 tmp, build_int_cst (TREE_TYPE (tmp),
1846 IOPARM_common_libreturn_mask));
1847 }
1848 else /* IOLENGTH */
1849 tmp = NULL_TREE;
1850
1851 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
1852
1853 gfc_add_block_to_block (&block, &post_iu_block);
1854
1855 dt_parm = NULL;
1856 dt_post_end_block = NULL;
1857
1858 return gfc_finish_block (&block);
1859 }
1860
1861
1862 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1863 this as a third sort of data transfer statement, except that
1864 lengths are summed instead of actually transferring any data. */
1865
1866 tree
1867 gfc_trans_iolength (gfc_code * code)
1868 {
1869 last_dt = IOLENGTH;
1870 return build_dt (iocall[IOCALL_IOLENGTH], code);
1871 }
1872
1873
1874 /* Translate a READ statement. */
1875
1876 tree
1877 gfc_trans_read (gfc_code * code)
1878 {
1879 last_dt = READ;
1880 return build_dt (iocall[IOCALL_READ], code);
1881 }
1882
1883
1884 /* Translate a WRITE statement */
1885
1886 tree
1887 gfc_trans_write (gfc_code * code)
1888 {
1889 last_dt = WRITE;
1890 return build_dt (iocall[IOCALL_WRITE], code);
1891 }
1892
1893
1894 /* Finish a data transfer statement. */
1895
1896 tree
1897 gfc_trans_dt_end (gfc_code * code)
1898 {
1899 tree function, tmp;
1900 stmtblock_t block;
1901
1902 gfc_init_block (&block);
1903
1904 switch (last_dt)
1905 {
1906 case READ:
1907 function = iocall[IOCALL_READ_DONE];
1908 break;
1909
1910 case WRITE:
1911 function = iocall[IOCALL_WRITE_DONE];
1912 break;
1913
1914 case IOLENGTH:
1915 function = iocall[IOCALL_IOLENGTH_DONE];
1916 break;
1917
1918 default:
1919 gcc_unreachable ();
1920 }
1921
1922 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
1923 tmp = build_call_expr_loc (input_location,
1924 function, 1, tmp);
1925 gfc_add_expr_to_block (&block, tmp);
1926 gfc_add_block_to_block (&block, dt_post_end_block);
1927 gfc_init_block (dt_post_end_block);
1928
1929 if (last_dt != IOLENGTH)
1930 {
1931 gcc_assert (code->ext.dt != NULL);
1932 io_result (&block, dt_parm, code->ext.dt->err,
1933 code->ext.dt->end, code->ext.dt->eor);
1934 }
1935
1936 return gfc_finish_block (&block);
1937 }
1938
1939 static void
1940 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
1941
1942 /* Given an array field in a derived type variable, generate the code
1943 for the loop that iterates over array elements, and the code that
1944 accesses those array elements. Use transfer_expr to generate code
1945 for transferring that element. Because elements may also be
1946 derived types, transfer_expr and transfer_array_component are mutually
1947 recursive. */
1948
1949 static tree
1950 transfer_array_component (tree expr, gfc_component * cm, locus * where)
1951 {
1952 tree tmp;
1953 stmtblock_t body;
1954 stmtblock_t block;
1955 gfc_loopinfo loop;
1956 int n;
1957 gfc_ss *ss;
1958 gfc_se se;
1959 gfc_array_info *ss_array;
1960
1961 gfc_start_block (&block);
1962 gfc_init_se (&se, NULL);
1963
1964 /* Create and initialize Scalarization Status. Unlike in
1965 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1966 care of this task, because we don't have a gfc_expr at hand.
1967 Build one manually, as in gfc_trans_subarray_assign. */
1968
1969 ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
1970 GFC_SS_COMPONENT);
1971 ss_array = &ss->info->data.array;
1972 ss_array->shape = gfc_get_shape (cm->as->rank);
1973 ss_array->descriptor = expr;
1974 ss_array->data = gfc_conv_array_data (expr);
1975 ss_array->offset = gfc_conv_array_offset (expr);
1976 for (n = 0; n < cm->as->rank; n++)
1977 {
1978 ss_array->start[n] = gfc_conv_array_lbound (expr, n);
1979 ss_array->stride[n] = gfc_index_one_node;
1980
1981 mpz_init (ss_array->shape[n]);
1982 mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
1983 cm->as->lower[n]->value.integer);
1984 mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
1985 }
1986
1987 /* Once we got ss, we use scalarizer to create the loop. */
1988
1989 gfc_init_loopinfo (&loop);
1990 gfc_add_ss_to_loop (&loop, ss);
1991 gfc_conv_ss_startstride (&loop);
1992 gfc_conv_loop_setup (&loop, where);
1993 gfc_mark_ss_chain_used (ss, 1);
1994 gfc_start_scalarized_body (&loop, &body);
1995
1996 gfc_copy_loopinfo_to_se (&se, &loop);
1997 se.ss = ss;
1998
1999 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2000 se.expr = expr;
2001 gfc_conv_tmp_array_ref (&se);
2002
2003 /* Now se.expr contains an element of the array. Take the address and pass
2004 it to the IO routines. */
2005 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2006 transfer_expr (&se, &cm->ts, tmp, NULL);
2007
2008 /* We are done now with the loop body. Wrap up the scalarizer and
2009 return. */
2010
2011 gfc_add_block_to_block (&body, &se.pre);
2012 gfc_add_block_to_block (&body, &se.post);
2013
2014 gfc_trans_scalarizing_loops (&loop, &body);
2015
2016 gfc_add_block_to_block (&block, &loop.pre);
2017 gfc_add_block_to_block (&block, &loop.post);
2018
2019 gcc_assert (ss_array->shape != NULL);
2020 gfc_free_shape (&ss_array->shape, cm->as->rank);
2021 gfc_cleanup_loop (&loop);
2022
2023 return gfc_finish_block (&block);
2024 }
2025
2026 /* Generate the call for a scalar transfer node. */
2027
2028 static void
2029 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
2030 {
2031 tree tmp, function, arg2, arg3, field, expr;
2032 gfc_component *c;
2033 int kind;
2034
2035 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2036 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2037 We need to translate the expression to a constant if it's either
2038 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2039 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2040 BT_DERIVED (could have been changed by gfc_conv_expr). */
2041 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2042 && ts->u.derived != NULL
2043 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2044 {
2045 ts->type = BT_INTEGER;
2046 ts->kind = gfc_index_integer_kind;
2047 }
2048
2049 kind = ts->kind;
2050 function = NULL;
2051 arg2 = NULL;
2052 arg3 = NULL;
2053
2054 switch (ts->type)
2055 {
2056 case BT_INTEGER:
2057 arg2 = build_int_cst (integer_type_node, kind);
2058 if (last_dt == READ)
2059 function = iocall[IOCALL_X_INTEGER];
2060 else
2061 function = iocall[IOCALL_X_INTEGER_WRITE];
2062
2063 break;
2064
2065 case BT_REAL:
2066 arg2 = build_int_cst (integer_type_node, kind);
2067 if (last_dt == READ)
2068 {
2069 if (gfc_real16_is_float128 && ts->kind == 16)
2070 function = iocall[IOCALL_X_REAL128];
2071 else
2072 function = iocall[IOCALL_X_REAL];
2073 }
2074 else
2075 {
2076 if (gfc_real16_is_float128 && ts->kind == 16)
2077 function = iocall[IOCALL_X_REAL128_WRITE];
2078 else
2079 function = iocall[IOCALL_X_REAL_WRITE];
2080 }
2081
2082 break;
2083
2084 case BT_COMPLEX:
2085 arg2 = build_int_cst (integer_type_node, kind);
2086 if (last_dt == READ)
2087 {
2088 if (gfc_real16_is_float128 && ts->kind == 16)
2089 function = iocall[IOCALL_X_COMPLEX128];
2090 else
2091 function = iocall[IOCALL_X_COMPLEX];
2092 }
2093 else
2094 {
2095 if (gfc_real16_is_float128 && ts->kind == 16)
2096 function = iocall[IOCALL_X_COMPLEX128_WRITE];
2097 else
2098 function = iocall[IOCALL_X_COMPLEX_WRITE];
2099 }
2100
2101 break;
2102
2103 case BT_LOGICAL:
2104 arg2 = build_int_cst (integer_type_node, kind);
2105 if (last_dt == READ)
2106 function = iocall[IOCALL_X_LOGICAL];
2107 else
2108 function = iocall[IOCALL_X_LOGICAL_WRITE];
2109
2110 break;
2111
2112 case BT_CHARACTER:
2113 if (kind == 4)
2114 {
2115 if (se->string_length)
2116 arg2 = se->string_length;
2117 else
2118 {
2119 tmp = build_fold_indirect_ref_loc (input_location,
2120 addr_expr);
2121 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2122 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2123 arg2 = fold_convert (gfc_charlen_type_node, arg2);
2124 }
2125 arg3 = build_int_cst (integer_type_node, kind);
2126 if (last_dt == READ)
2127 function = iocall[IOCALL_X_CHARACTER_WIDE];
2128 else
2129 function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
2130
2131 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2132 tmp = build_call_expr_loc (input_location,
2133 function, 4, tmp, addr_expr, arg2, arg3);
2134 gfc_add_expr_to_block (&se->pre, tmp);
2135 gfc_add_block_to_block (&se->pre, &se->post);
2136 return;
2137 }
2138 /* Fall through. */
2139 case BT_HOLLERITH:
2140 if (se->string_length)
2141 arg2 = se->string_length;
2142 else
2143 {
2144 tmp = build_fold_indirect_ref_loc (input_location,
2145 addr_expr);
2146 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2147 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2148 }
2149 if (last_dt == READ)
2150 function = iocall[IOCALL_X_CHARACTER];
2151 else
2152 function = iocall[IOCALL_X_CHARACTER_WRITE];
2153
2154 break;
2155
2156 case BT_DERIVED:
2157 if (ts->u.derived->components == NULL)
2158 return;
2159
2160 /* Recurse into the elements of the derived type. */
2161 expr = gfc_evaluate_now (addr_expr, &se->pre);
2162 expr = build_fold_indirect_ref_loc (input_location,
2163 expr);
2164
2165 /* Make sure that the derived type has been built. An external
2166 function, if only referenced in an io statement, requires this
2167 check (see PR58771). */
2168 if (ts->u.derived->backend_decl == NULL_TREE)
2169 (void) gfc_typenode_for_spec (ts);
2170
2171 for (c = ts->u.derived->components; c; c = c->next)
2172 {
2173 field = c->backend_decl;
2174 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2175
2176 tmp = fold_build3_loc (UNKNOWN_LOCATION,
2177 COMPONENT_REF, TREE_TYPE (field),
2178 expr, field, NULL_TREE);
2179
2180 if (c->attr.dimension)
2181 {
2182 tmp = transfer_array_component (tmp, c, & code->loc);
2183 gfc_add_expr_to_block (&se->pre, tmp);
2184 }
2185 else
2186 {
2187 if (!c->attr.pointer)
2188 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2189 transfer_expr (se, &c->ts, tmp, code);
2190 }
2191 }
2192 return;
2193
2194 default:
2195 gfc_internal_error ("Bad IO basetype (%d)", ts->type);
2196 }
2197
2198 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2199 tmp = build_call_expr_loc (input_location,
2200 function, 3, tmp, addr_expr, arg2);
2201 gfc_add_expr_to_block (&se->pre, tmp);
2202 gfc_add_block_to_block (&se->pre, &se->post);
2203
2204 }
2205
2206
2207 /* Generate a call to pass an array descriptor to the IO library. The
2208 array should be of one of the intrinsic types. */
2209
2210 static void
2211 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2212 {
2213 tree tmp, charlen_arg, kind_arg, io_call;
2214
2215 if (ts->type == BT_CHARACTER)
2216 charlen_arg = se->string_length;
2217 else
2218 charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
2219
2220 kind_arg = build_int_cst (integer_type_node, ts->kind);
2221
2222 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2223 if (last_dt == READ)
2224 io_call = iocall[IOCALL_X_ARRAY];
2225 else
2226 io_call = iocall[IOCALL_X_ARRAY_WRITE];
2227
2228 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2229 io_call, 4,
2230 tmp, addr_expr, kind_arg, charlen_arg);
2231 gfc_add_expr_to_block (&se->pre, tmp);
2232 gfc_add_block_to_block (&se->pre, &se->post);
2233 }
2234
2235
2236 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2237
2238 tree
2239 gfc_trans_transfer (gfc_code * code)
2240 {
2241 stmtblock_t block, body;
2242 gfc_loopinfo loop;
2243 gfc_expr *expr;
2244 gfc_ref *ref;
2245 gfc_ss *ss;
2246 gfc_se se;
2247 tree tmp;
2248 int n;
2249
2250 gfc_start_block (&block);
2251 gfc_init_block (&body);
2252
2253 expr = code->expr1;
2254 ref = NULL;
2255 gfc_init_se (&se, NULL);
2256
2257 if (expr->rank == 0)
2258 {
2259 /* Transfer a scalar value. */
2260 gfc_conv_expr_reference (&se, expr);
2261 transfer_expr (&se, &expr->ts, se.expr, code);
2262 }
2263 else
2264 {
2265 /* Transfer an array. If it is an array of an intrinsic
2266 type, pass the descriptor to the library. Otherwise
2267 scalarize the transfer. */
2268 if (expr->ref && !gfc_is_proc_ptr_comp (expr))
2269 {
2270 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2271 ref = ref->next);
2272 gcc_assert (ref && ref->type == REF_ARRAY);
2273 }
2274
2275 if (expr->ts.type != BT_DERIVED
2276 && ref && ref->next == NULL
2277 && !is_subref_array (expr))
2278 {
2279 bool seen_vector = false;
2280
2281 if (ref && ref->u.ar.type == AR_SECTION)
2282 {
2283 for (n = 0; n < ref->u.ar.dimen; n++)
2284 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2285 {
2286 seen_vector = true;
2287 break;
2288 }
2289 }
2290
2291 if (seen_vector && last_dt == READ)
2292 {
2293 /* Create a temp, read to that and copy it back. */
2294 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2295 tmp = se.expr;
2296 }
2297 else
2298 {
2299 /* Get the descriptor. */
2300 gfc_conv_expr_descriptor (&se, expr);
2301 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2302 }
2303
2304 transfer_array_desc (&se, &expr->ts, tmp);
2305 goto finish_block_label;
2306 }
2307
2308 /* Initialize the scalarizer. */
2309 ss = gfc_walk_expr (expr);
2310 gfc_init_loopinfo (&loop);
2311 gfc_add_ss_to_loop (&loop, ss);
2312
2313 /* Initialize the loop. */
2314 gfc_conv_ss_startstride (&loop);
2315 gfc_conv_loop_setup (&loop, &code->expr1->where);
2316
2317 /* The main loop body. */
2318 gfc_mark_ss_chain_used (ss, 1);
2319 gfc_start_scalarized_body (&loop, &body);
2320
2321 gfc_copy_loopinfo_to_se (&se, &loop);
2322 se.ss = ss;
2323
2324 gfc_conv_expr_reference (&se, expr);
2325 transfer_expr (&se, &expr->ts, se.expr, code);
2326 }
2327
2328 finish_block_label:
2329
2330 gfc_add_block_to_block (&body, &se.pre);
2331 gfc_add_block_to_block (&body, &se.post);
2332
2333 if (se.ss == NULL)
2334 tmp = gfc_finish_block (&body);
2335 else
2336 {
2337 gcc_assert (expr->rank != 0);
2338 gcc_assert (se.ss == gfc_ss_terminator);
2339 gfc_trans_scalarizing_loops (&loop, &body);
2340
2341 gfc_add_block_to_block (&loop.pre, &loop.post);
2342 tmp = gfc_finish_block (&loop.pre);
2343 gfc_cleanup_loop (&loop);
2344 }
2345
2346 gfc_add_expr_to_block (&block, tmp);
2347
2348 return gfc_finish_block (&block);
2349 }
2350
2351 #include "gt-fortran-trans-io.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org