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