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