?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2011-10-07 Janus Weil <janus@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / trans-io.c
blobbbf5a02eff4d9efc13bc54ed6f35fc706fde31bf
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, gfc_walk_expr (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 se.ss = gfc_walk_expr (e);
784
785 if (is_subref_array (e))
786 {
787 /* Use a temporary for components of arrays of derived types
788 or substring array references. */
789 gfc_conv_subref_array_arg (&se, e, 0,
790 last_dt == READ ? INTENT_IN : INTENT_OUT, false);
791 tmp = build_fold_indirect_ref_loc (input_location,
792 se.expr);
793 se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
794 tmp = gfc_conv_descriptor_data_get (tmp);
795 }
796 else
797 {
798 /* Return the data pointer and rank from the descriptor. */
799 gfc_conv_expr_descriptor (&se, e, se.ss);
800 tmp = gfc_conv_descriptor_data_get (se.expr);
801 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
802 }
803 }
804 else
805 gcc_unreachable ();
806
807 /* The cast is needed for character substrings and the descriptor
808 data. */
809 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
810 gfc_add_modify (&se.pre, len,
811 fold_convert (TREE_TYPE (len), se.string_length));
812 gfc_add_modify (&se.pre, desc, se.expr);
813
814 gfc_add_block_to_block (block, &se.pre);
815 gfc_add_block_to_block (post_block, &se.post);
816 return mask;
817 }
818
819 /* Add a case to a IO-result switch. */
820
821 static void
822 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
823 {
824 tree tmp, value;
825
826 if (label == NULL)
827 return; /* No label, no case */
828
829 value = build_int_cst (integer_type_node, label_value);
830
831 /* Make a backend label for this case. */
832 tmp = gfc_build_label_decl (NULL_TREE);
833
834 /* And the case itself. */
835 tmp = build_case_label (value, NULL_TREE, tmp);
836 gfc_add_expr_to_block (body, tmp);
837
838 /* Jump to the label. */
839 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
840 gfc_add_expr_to_block (body, tmp);
841 }
842
843
844 /* Generate a switch statement that branches to the correct I/O
845 result label. The last statement of an I/O call stores the
846 result into a variable because there is often cleanup that
847 must be done before the switch, so a temporary would have to
848 be created anyway. */
849
850 static void
851 io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
852 gfc_st_label * end_label, gfc_st_label * eor_label)
853 {
854 stmtblock_t body;
855 tree tmp, rc;
856 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
857
858 /* If no labels are specified, ignore the result instead
859 of building an empty switch. */
860 if (err_label == NULL
861 && end_label == NULL
862 && eor_label == NULL)
863 return;
864
865 /* Build a switch statement. */
866 gfc_start_block (&body);
867
868 /* The label values here must be the same as the values
869 in the library_return enum in the runtime library */
870 add_case (1, err_label, &body);
871 add_case (2, end_label, &body);
872 add_case (3, eor_label, &body);
873
874 tmp = gfc_finish_block (&body);
875
876 var = fold_build3_loc (input_location, COMPONENT_REF,
877 st_parameter[IOPARM_ptype_common].type,
878 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
879 rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
880 var, p->field, NULL_TREE);
881 rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc),
882 rc, build_int_cst (TREE_TYPE (rc),
883 IOPARM_common_libreturn_mask));
884
885 tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
886
887 gfc_add_expr_to_block (block, tmp);
888 }
889
890
891 /* Store the current file and line number to variables so that if a
892 library call goes awry, we can tell the user where the problem is. */
893
894 static void
895 set_error_locus (stmtblock_t * block, tree var, locus * where)
896 {
897 gfc_file *f;
898 tree str, locus_file;
899 int line;
900 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
901
902 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
903 st_parameter[IOPARM_ptype_common].type,
904 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
905 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
906 TREE_TYPE (p->field), locus_file,
907 p->field, NULL_TREE);
908 f = where->lb->file;
909 str = gfc_build_cstring_const (f->filename);
910
911 str = gfc_build_addr_expr (pchar_type_node, str);
912 gfc_add_modify (block, locus_file, str);
913
914 line = LOCATION_LINE (where->lb->location);
915 set_parameter_const (block, var, IOPARM_common_line, line);
916 }
917
918
919 /* Translate an OPEN statement. */
920
921 tree
922 gfc_trans_open (gfc_code * code)
923 {
924 stmtblock_t block, post_block;
925 gfc_open *p;
926 tree tmp, var;
927 unsigned int mask = 0;
928
929 gfc_start_block (&block);
930 gfc_init_block (&post_block);
931
932 var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
933
934 set_error_locus (&block, var, &code->loc);
935 p = code->ext.open;
936
937 if (p->iomsg)
938 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
939 p->iomsg);
940
941 if (p->iostat)
942 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
943 p->iostat);
944
945 if (p->err)
946 mask |= IOPARM_common_err;
947
948 if (p->file)
949 mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
950
951 if (p->status)
952 mask |= set_string (&block, &post_block, var, IOPARM_open_status,
953 p->status);
954
955 if (p->access)
956 mask |= set_string (&block, &post_block, var, IOPARM_open_access,
957 p->access);
958
959 if (p->form)
960 mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
961
962 if (p->recl)
963 mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
964
965 if (p->blank)
966 mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
967 p->blank);
968
969 if (p->position)
970 mask |= set_string (&block, &post_block, var, IOPARM_open_position,
971 p->position);
972
973 if (p->action)
974 mask |= set_string (&block, &post_block, var, IOPARM_open_action,
975 p->action);
976
977 if (p->delim)
978 mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
979 p->delim);
980
981 if (p->pad)
982 mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
983
984 if (p->decimal)
985 mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
986 p->decimal);
987
988 if (p->encoding)
989 mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
990 p->encoding);
991
992 if (p->round)
993 mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
994
995 if (p->sign)
996 mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
997
998 if (p->asynchronous)
999 mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
1000 p->asynchronous);
1001
1002 if (p->convert)
1003 mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
1004 p->convert);
1005
1006 if (p->newunit)
1007 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
1008 p->newunit);
1009
1010 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1011
1012 if (p->unit)
1013 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1014 else
1015 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1016
1017 tmp = gfc_build_addr_expr (NULL_TREE, var);
1018 tmp = build_call_expr_loc (input_location,
1019 iocall[IOCALL_OPEN], 1, tmp);
1020 gfc_add_expr_to_block (&block, tmp);
1021
1022 gfc_add_block_to_block (&block, &post_block);
1023
1024 io_result (&block, var, p->err, NULL, NULL);
1025
1026 return gfc_finish_block (&block);
1027 }
1028
1029
1030 /* Translate a CLOSE statement. */
1031
1032 tree
1033 gfc_trans_close (gfc_code * code)
1034 {
1035 stmtblock_t block, post_block;
1036 gfc_close *p;
1037 tree tmp, var;
1038 unsigned int mask = 0;
1039
1040 gfc_start_block (&block);
1041 gfc_init_block (&post_block);
1042
1043 var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
1044
1045 set_error_locus (&block, var, &code->loc);
1046 p = code->ext.close;
1047
1048 if (p->iomsg)
1049 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1050 p->iomsg);
1051
1052 if (p->iostat)
1053 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1054 p->iostat);
1055
1056 if (p->err)
1057 mask |= IOPARM_common_err;
1058
1059 if (p->status)
1060 mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1061 p->status);
1062
1063 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1064
1065 if (p->unit)
1066 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1067 else
1068 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1069
1070 tmp = gfc_build_addr_expr (NULL_TREE, var);
1071 tmp = build_call_expr_loc (input_location,
1072 iocall[IOCALL_CLOSE], 1, tmp);
1073 gfc_add_expr_to_block (&block, tmp);
1074
1075 gfc_add_block_to_block (&block, &post_block);
1076
1077 io_result (&block, var, p->err, NULL, NULL);
1078
1079 return gfc_finish_block (&block);
1080 }
1081
1082
1083 /* Common subroutine for building a file positioning statement. */
1084
1085 static tree
1086 build_filepos (tree function, gfc_code * code)
1087 {
1088 stmtblock_t block, post_block;
1089 gfc_filepos *p;
1090 tree tmp, var;
1091 unsigned int mask = 0;
1092
1093 p = code->ext.filepos;
1094
1095 gfc_start_block (&block);
1096 gfc_init_block (&post_block);
1097
1098 var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1099 "filepos_parm");
1100
1101 set_error_locus (&block, var, &code->loc);
1102
1103 if (p->iomsg)
1104 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1105 p->iomsg);
1106
1107 if (p->iostat)
1108 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1109 p->iostat);
1110
1111 if (p->err)
1112 mask |= IOPARM_common_err;
1113
1114 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1115
1116 if (p->unit)
1117 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1118 else
1119 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1120
1121 tmp = gfc_build_addr_expr (NULL_TREE, var);
1122 tmp = build_call_expr_loc (input_location,
1123 function, 1, tmp);
1124 gfc_add_expr_to_block (&block, tmp);
1125
1126 gfc_add_block_to_block (&block, &post_block);
1127
1128 io_result (&block, var, p->err, NULL, NULL);
1129
1130 return gfc_finish_block (&block);
1131 }
1132
1133
1134 /* Translate a BACKSPACE statement. */
1135
1136 tree
1137 gfc_trans_backspace (gfc_code * code)
1138 {
1139 return build_filepos (iocall[IOCALL_BACKSPACE], code);
1140 }
1141
1142
1143 /* Translate an ENDFILE statement. */
1144
1145 tree
1146 gfc_trans_endfile (gfc_code * code)
1147 {
1148 return build_filepos (iocall[IOCALL_ENDFILE], code);
1149 }
1150
1151
1152 /* Translate a REWIND statement. */
1153
1154 tree
1155 gfc_trans_rewind (gfc_code * code)
1156 {
1157 return build_filepos (iocall[IOCALL_REWIND], code);
1158 }
1159
1160
1161 /* Translate a FLUSH statement. */
1162
1163 tree
1164 gfc_trans_flush (gfc_code * code)
1165 {
1166 return build_filepos (iocall[IOCALL_FLUSH], code);
1167 }
1168
1169
1170 /* Create a dummy iostat variable to catch any error due to bad unit. */
1171
1172 static gfc_expr *
1173 create_dummy_iostat (void)
1174 {
1175 gfc_symtree *st;
1176 gfc_expr *e;
1177
1178 gfc_get_ha_sym_tree ("@iostat", &st);
1179 st->n.sym->ts.type = BT_INTEGER;
1180 st->n.sym->ts.kind = gfc_default_integer_kind;
1181 gfc_set_sym_referenced (st->n.sym);
1182 gfc_commit_symbol (st->n.sym);
1183 st->n.sym->backend_decl
1184 = gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind),
1185 st->n.sym->name);
1186
1187 e = gfc_get_expr ();
1188 e->expr_type = EXPR_VARIABLE;
1189 e->symtree = st;
1190 e->ts.type = BT_INTEGER;
1191 e->ts.kind = st->n.sym->ts.kind;
1192
1193 return e;
1194 }
1195
1196
1197 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1198
1199 tree
1200 gfc_trans_inquire (gfc_code * code)
1201 {
1202 stmtblock_t block, post_block;
1203 gfc_inquire *p;
1204 tree tmp, var;
1205 unsigned int mask = 0, mask2 = 0;
1206
1207 gfc_start_block (&block);
1208 gfc_init_block (&post_block);
1209
1210 var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1211 "inquire_parm");
1212
1213 set_error_locus (&block, var, &code->loc);
1214 p = code->ext.inquire;
1215
1216 if (p->iomsg)
1217 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1218 p->iomsg);
1219
1220 if (p->iostat)
1221 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1222 p->iostat);
1223
1224 if (p->err)
1225 mask |= IOPARM_common_err;
1226
1227 /* Sanity check. */
1228 if (p->unit && p->file)
1229 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1230
1231 if (p->file)
1232 mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1233 p->file);
1234
1235 if (p->exist)
1236 {
1237 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1238 p->exist);
1239
1240 if (p->unit && !p->iostat)
1241 {
1242 p->iostat = create_dummy_iostat ();
1243 mask |= set_parameter_ref (&block, &post_block, var,
1244 IOPARM_common_iostat, p->iostat);
1245 }
1246 }
1247
1248 if (p->opened)
1249 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1250 p->opened);
1251
1252 if (p->number)
1253 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1254 p->number);
1255
1256 if (p->named)
1257 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1258 p->named);
1259
1260 if (p->name)
1261 mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1262 p->name);
1263
1264 if (p->access)
1265 mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1266 p->access);
1267
1268 if (p->sequential)
1269 mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1270 p->sequential);
1271
1272 if (p->direct)
1273 mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1274 p->direct);
1275
1276 if (p->form)
1277 mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1278 p->form);
1279
1280 if (p->formatted)
1281 mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1282 p->formatted);
1283
1284 if (p->unformatted)
1285 mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1286 p->unformatted);
1287
1288 if (p->recl)
1289 mask |= set_parameter_ref (&block, &post_block, var,
1290 IOPARM_inquire_recl_out, p->recl);
1291
1292 if (p->nextrec)
1293 mask |= set_parameter_ref (&block, &post_block, var,
1294 IOPARM_inquire_nextrec, p->nextrec);
1295
1296 if (p->blank)
1297 mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1298 p->blank);
1299
1300 if (p->delim)
1301 mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1302 p->delim);
1303
1304 if (p->position)
1305 mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1306 p->position);
1307
1308 if (p->action)
1309 mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1310 p->action);
1311
1312 if (p->read)
1313 mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1314 p->read);
1315
1316 if (p->write)
1317 mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1318 p->write);
1319
1320 if (p->readwrite)
1321 mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1322 p->readwrite);
1323
1324 if (p->pad)
1325 mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1326 p->pad);
1327
1328 if (p->convert)
1329 mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1330 p->convert);
1331
1332 if (p->strm_pos)
1333 mask |= set_parameter_ref (&block, &post_block, var,
1334 IOPARM_inquire_strm_pos_out, p->strm_pos);
1335
1336 /* The second series of flags. */
1337 if (p->asynchronous)
1338 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1339 p->asynchronous);
1340
1341 if (p->decimal)
1342 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1343 p->decimal);
1344
1345 if (p->encoding)
1346 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1347 p->encoding);
1348
1349 if (p->round)
1350 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1351 p->round);
1352
1353 if (p->sign)
1354 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1355 p->sign);
1356
1357 if (p->pending)
1358 mask2 |= set_parameter_ref (&block, &post_block, var,
1359 IOPARM_inquire_pending, p->pending);
1360
1361 if (p->size)
1362 mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1363 p->size);
1364
1365 if (p->id)
1366 mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1367 p->id);
1368
1369 if (mask2)
1370 mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
1371
1372 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1373
1374 if (p->unit)
1375 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1376 else
1377 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1378
1379 tmp = gfc_build_addr_expr (NULL_TREE, var);
1380 tmp = build_call_expr_loc (input_location,
1381 iocall[IOCALL_INQUIRE], 1, tmp);
1382 gfc_add_expr_to_block (&block, tmp);
1383
1384 gfc_add_block_to_block (&block, &post_block);
1385
1386 io_result (&block, var, p->err, NULL, NULL);
1387
1388 return gfc_finish_block (&block);
1389 }
1390
1391
1392 tree
1393 gfc_trans_wait (gfc_code * code)
1394 {
1395 stmtblock_t block, post_block;
1396 gfc_wait *p;
1397 tree tmp, var;
1398 unsigned int mask = 0;
1399
1400 gfc_start_block (&block);
1401 gfc_init_block (&post_block);
1402
1403 var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1404 "wait_parm");
1405
1406 set_error_locus (&block, var, &code->loc);
1407 p = code->ext.wait;
1408
1409 /* Set parameters here. */
1410 if (p->iomsg)
1411 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1412 p->iomsg);
1413
1414 if (p->iostat)
1415 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1416 p->iostat);
1417
1418 if (p->err)
1419 mask |= IOPARM_common_err;
1420
1421 if (p->id)
1422 mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
1423
1424 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1425
1426 if (p->unit)
1427 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1428
1429 tmp = gfc_build_addr_expr (NULL_TREE, var);
1430 tmp = build_call_expr_loc (input_location,
1431 iocall[IOCALL_WAIT], 1, tmp);
1432 gfc_add_expr_to_block (&block, tmp);
1433
1434 gfc_add_block_to_block (&block, &post_block);
1435
1436 io_result (&block, var, p->err, NULL, NULL);
1437
1438 return gfc_finish_block (&block);
1439
1440 }
1441
1442
1443 /* nml_full_name builds up the fully qualified name of a
1444 derived type component. */
1445
1446 static char*
1447 nml_full_name (const char* var_name, const char* cmp_name)
1448 {
1449 int full_name_length;
1450 char * full_name;
1451
1452 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1453 full_name = XCNEWVEC (char, full_name_length + 1);
1454 strcpy (full_name, var_name);
1455 full_name = strcat (full_name, "%");
1456 full_name = strcat (full_name, cmp_name);
1457 return full_name;
1458 }
1459
1460
1461 /* nml_get_addr_expr builds an address expression from the
1462 gfc_symbol or gfc_component backend_decl's. An offset is
1463 provided so that the address of an element of an array of
1464 derived types is returned. This is used in the runtime to
1465 determine that span of the derived type. */
1466
1467 static tree
1468 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1469 tree base_addr)
1470 {
1471 tree decl = NULL_TREE;
1472 tree tmp;
1473
1474 if (sym)
1475 {
1476 sym->attr.referenced = 1;
1477 decl = gfc_get_symbol_decl (sym);
1478
1479 /* If this is the enclosing function declaration, use
1480 the fake result instead. */
1481 if (decl == current_function_decl)
1482 decl = gfc_get_fake_result_decl (sym, 0);
1483 else if (decl == DECL_CONTEXT (current_function_decl))
1484 decl = gfc_get_fake_result_decl (sym, 1);
1485 }
1486 else
1487 decl = c->backend_decl;
1488
1489 gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1490 || TREE_CODE (decl) == VAR_DECL
1491 || TREE_CODE (decl) == PARM_DECL)
1492 || TREE_CODE (decl) == COMPONENT_REF));
1493
1494 tmp = decl;
1495
1496 /* Build indirect reference, if dummy argument. */
1497
1498 if (POINTER_TYPE_P (TREE_TYPE(tmp)))
1499 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1500
1501 /* Treat the component of a derived type, using base_addr for
1502 the derived type. */
1503
1504 if (TREE_CODE (decl) == FIELD_DECL)
1505 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
1506 base_addr, tmp, NULL_TREE);
1507
1508 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1509 tmp = gfc_conv_array_data (tmp);
1510 else
1511 {
1512 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1513 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1514
1515 if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1516 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1517
1518 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1519 tmp = build_fold_indirect_ref_loc (input_location,
1520 tmp);
1521 }
1522
1523 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1524
1525 return tmp;
1526 }
1527
1528
1529 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1530 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1531 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1532
1533 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1534
1535 static void
1536 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1537 gfc_symbol * sym, gfc_component * c,
1538 tree base_addr)
1539 {
1540 gfc_typespec * ts = NULL;
1541 gfc_array_spec * as = NULL;
1542 tree addr_expr = NULL;
1543 tree dt = NULL;
1544 tree string;
1545 tree tmp;
1546 tree dtype;
1547 tree dt_parm_addr;
1548 tree decl = NULL_TREE;
1549 int n_dim;
1550 int itype;
1551 int rank = 0;
1552
1553 gcc_assert (sym || c);
1554
1555 /* Build the namelist object name. */
1556
1557 string = gfc_build_cstring_const (var_name);
1558 string = gfc_build_addr_expr (pchar_type_node, string);
1559
1560 /* Build ts, as and data address using symbol or component. */
1561
1562 ts = (sym) ? &sym->ts : &c->ts;
1563 as = (sym) ? sym->as : c->as;
1564
1565 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1566
1567 if (as)
1568 rank = as->rank;
1569
1570 if (rank)
1571 {
1572 decl = (sym) ? sym->backend_decl : c->backend_decl;
1573 if (sym && sym->attr.dummy)
1574 decl = build_fold_indirect_ref_loc (input_location, decl);
1575 dt = TREE_TYPE (decl);
1576 dtype = gfc_get_dtype (dt);
1577 }
1578 else
1579 {
1580 itype = ts->type;
1581 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1582 }
1583
1584 /* Build up the arguments for the transfer call.
1585 The call for the scalar part transfers:
1586 (address, name, type, kind or string_length, dtype) */
1587
1588 dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1589
1590 if (ts->type == BT_CHARACTER)
1591 tmp = ts->u.cl->backend_decl;
1592 else
1593 tmp = build_int_cst (gfc_charlen_type_node, 0);
1594 tmp = build_call_expr_loc (input_location,
1595 iocall[IOCALL_SET_NML_VAL], 6,
1596 dt_parm_addr, addr_expr, string,
1597 IARG (ts->kind), tmp, dtype);
1598 gfc_add_expr_to_block (block, tmp);
1599
1600 /* If the object is an array, transfer rank times:
1601 (null pointer, name, stride, lbound, ubound) */
1602
1603 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1604 {
1605 tmp = build_call_expr_loc (input_location,
1606 iocall[IOCALL_SET_NML_VAL_DIM], 5,
1607 dt_parm_addr,
1608 IARG (n_dim),
1609 gfc_conv_array_stride (decl, n_dim),
1610 gfc_conv_array_lbound (decl, n_dim),
1611 gfc_conv_array_ubound (decl, n_dim));
1612 gfc_add_expr_to_block (block, tmp);
1613 }
1614
1615 if (ts->type == BT_DERIVED)
1616 {
1617 gfc_component *cmp;
1618
1619 /* Provide the RECORD_TYPE to build component references. */
1620
1621 tree expr = build_fold_indirect_ref_loc (input_location,
1622 addr_expr);
1623
1624 for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1625 {
1626 char *full_name = nml_full_name (var_name, cmp->name);
1627 transfer_namelist_element (block,
1628 full_name,
1629 NULL, cmp, expr);
1630 free (full_name);
1631 }
1632 }
1633 }
1634
1635 #undef IARG
1636
1637 /* Create a data transfer statement. Not all of the fields are valid
1638 for both reading and writing, but improper use has been filtered
1639 out by now. */
1640
1641 static tree
1642 build_dt (tree function, gfc_code * code)
1643 {
1644 stmtblock_t block, post_block, post_end_block, post_iu_block;
1645 gfc_dt *dt;
1646 tree tmp, var;
1647 gfc_expr *nmlname;
1648 gfc_namelist *nml;
1649 unsigned int mask = 0;
1650
1651 gfc_start_block (&block);
1652 gfc_init_block (&post_block);
1653 gfc_init_block (&post_end_block);
1654 gfc_init_block (&post_iu_block);
1655
1656 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1657
1658 set_error_locus (&block, var, &code->loc);
1659
1660 if (last_dt == IOLENGTH)
1661 {
1662 gfc_inquire *inq;
1663
1664 inq = code->ext.inquire;
1665
1666 /* First check that preconditions are met. */
1667 gcc_assert (inq != NULL);
1668 gcc_assert (inq->iolength != NULL);
1669
1670 /* Connect to the iolength variable. */
1671 mask |= set_parameter_ref (&block, &post_end_block, var,
1672 IOPARM_dt_iolength, inq->iolength);
1673 dt = NULL;
1674 }
1675 else
1676 {
1677 dt = code->ext.dt;
1678 gcc_assert (dt != NULL);
1679 }
1680
1681 if (dt && dt->io_unit)
1682 {
1683 if (dt->io_unit->ts.type == BT_CHARACTER)
1684 {
1685 mask |= set_internal_unit (&block, &post_iu_block,
1686 var, dt->io_unit);
1687 set_parameter_const (&block, var, IOPARM_common_unit,
1688 dt->io_unit->ts.kind == 1 ? 0 : -1);
1689 }
1690 }
1691 else
1692 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1693
1694 if (dt)
1695 {
1696 if (dt->iomsg)
1697 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1698 dt->iomsg);
1699
1700 if (dt->iostat)
1701 mask |= set_parameter_ref (&block, &post_end_block, var,
1702 IOPARM_common_iostat, dt->iostat);
1703
1704 if (dt->err)
1705 mask |= IOPARM_common_err;
1706
1707 if (dt->eor)
1708 mask |= IOPARM_common_eor;
1709
1710 if (dt->end)
1711 mask |= IOPARM_common_end;
1712
1713 if (dt->id)
1714 mask |= set_parameter_ref (&block, &post_end_block, var,
1715 IOPARM_dt_id, dt->id);
1716
1717 if (dt->pos)
1718 mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1719
1720 if (dt->asynchronous)
1721 mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
1722 dt->asynchronous);
1723
1724 if (dt->blank)
1725 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1726 dt->blank);
1727
1728 if (dt->decimal)
1729 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1730 dt->decimal);
1731
1732 if (dt->delim)
1733 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1734 dt->delim);
1735
1736 if (dt->pad)
1737 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1738 dt->pad);
1739
1740 if (dt->round)
1741 mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1742 dt->round);
1743
1744 if (dt->sign)
1745 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1746 dt->sign);
1747
1748 if (dt->rec)
1749 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1750
1751 if (dt->advance)
1752 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1753 dt->advance);
1754
1755 if (dt->format_expr)
1756 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1757 dt->format_expr);
1758
1759 if (dt->format_label)
1760 {
1761 if (dt->format_label == &format_asterisk)
1762 mask |= IOPARM_dt_list_format;
1763 else
1764 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1765 dt->format_label->format);
1766 }
1767
1768 if (dt->size)
1769 mask |= set_parameter_ref (&block, &post_end_block, var,
1770 IOPARM_dt_size, dt->size);
1771
1772 if (dt->namelist)
1773 {
1774 if (dt->format_expr || dt->format_label)
1775 gfc_internal_error ("build_dt: format with namelist");
1776
1777 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1778 dt->namelist->name,
1779 strlen (dt->namelist->name));
1780
1781 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1782 nmlname);
1783
1784 if (last_dt == READ)
1785 mask |= IOPARM_dt_namelist_read_mode;
1786
1787 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1788
1789 dt_parm = var;
1790
1791 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1792 transfer_namelist_element (&block, nml->sym->name, nml->sym,
1793 NULL, NULL_TREE);
1794 }
1795 else
1796 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1797
1798 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1799 set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
1800 }
1801 else
1802 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1803
1804 tmp = gfc_build_addr_expr (NULL_TREE, var);
1805 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
1806 function, 1, tmp);
1807 gfc_add_expr_to_block (&block, tmp);
1808
1809 gfc_add_block_to_block (&block, &post_block);
1810
1811 dt_parm = var;
1812 dt_post_end_block = &post_end_block;
1813
1814 /* Set implied do loop exit condition. */
1815 if (last_dt == READ || last_dt == WRITE)
1816 {
1817 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
1818
1819 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1820 st_parameter[IOPARM_ptype_common].type,
1821 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
1822 NULL_TREE);
1823 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1824 TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
1825 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
1826 tmp, build_int_cst (TREE_TYPE (tmp),
1827 IOPARM_common_libreturn_mask));
1828 }
1829 else /* IOLENGTH */
1830 tmp = NULL_TREE;
1831
1832 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
1833
1834 gfc_add_block_to_block (&block, &post_iu_block);
1835
1836 dt_parm = NULL;
1837 dt_post_end_block = NULL;
1838
1839 return gfc_finish_block (&block);
1840 }
1841
1842
1843 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1844 this as a third sort of data transfer statement, except that
1845 lengths are summed instead of actually transferring any data. */
1846
1847 tree
1848 gfc_trans_iolength (gfc_code * code)
1849 {
1850 last_dt = IOLENGTH;
1851 return build_dt (iocall[IOCALL_IOLENGTH], code);
1852 }
1853
1854
1855 /* Translate a READ statement. */
1856
1857 tree
1858 gfc_trans_read (gfc_code * code)
1859 {
1860 last_dt = READ;
1861 return build_dt (iocall[IOCALL_READ], code);
1862 }
1863
1864
1865 /* Translate a WRITE statement */
1866
1867 tree
1868 gfc_trans_write (gfc_code * code)
1869 {
1870 last_dt = WRITE;
1871 return build_dt (iocall[IOCALL_WRITE], code);
1872 }
1873
1874
1875 /* Finish a data transfer statement. */
1876
1877 tree
1878 gfc_trans_dt_end (gfc_code * code)
1879 {
1880 tree function, tmp;
1881 stmtblock_t block;
1882
1883 gfc_init_block (&block);
1884
1885 switch (last_dt)
1886 {
1887 case READ:
1888 function = iocall[IOCALL_READ_DONE];
1889 break;
1890
1891 case WRITE:
1892 function = iocall[IOCALL_WRITE_DONE];
1893 break;
1894
1895 case IOLENGTH:
1896 function = iocall[IOCALL_IOLENGTH_DONE];
1897 break;
1898
1899 default:
1900 gcc_unreachable ();
1901 }
1902
1903 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
1904 tmp = build_call_expr_loc (input_location,
1905 function, 1, tmp);
1906 gfc_add_expr_to_block (&block, tmp);
1907 gfc_add_block_to_block (&block, dt_post_end_block);
1908 gfc_init_block (dt_post_end_block);
1909
1910 if (last_dt != IOLENGTH)
1911 {
1912 gcc_assert (code->ext.dt != NULL);
1913 io_result (&block, dt_parm, code->ext.dt->err,
1914 code->ext.dt->end, code->ext.dt->eor);
1915 }
1916
1917 return gfc_finish_block (&block);
1918 }
1919
1920 static void
1921 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
1922
1923 /* Given an array field in a derived type variable, generate the code
1924 for the loop that iterates over array elements, and the code that
1925 accesses those array elements. Use transfer_expr to generate code
1926 for transferring that element. Because elements may also be
1927 derived types, transfer_expr and transfer_array_component are mutually
1928 recursive. */
1929
1930 static tree
1931 transfer_array_component (tree expr, gfc_component * cm, locus * where)
1932 {
1933 tree tmp;
1934 stmtblock_t body;
1935 stmtblock_t block;
1936 gfc_loopinfo loop;
1937 int n;
1938 gfc_ss *ss;
1939 gfc_se se;
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->shape = gfc_get_shape (cm->as->rank);
1952 ss->data.info.descriptor = expr;
1953 ss->data.info.data = gfc_conv_array_data (expr);
1954 ss->data.info.offset = gfc_conv_array_offset (expr);
1955 for (n = 0; n < cm->as->rank; n++)
1956 {
1957 ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1958 ss->data.info.stride[n] = gfc_index_one_node;
1959
1960 mpz_init (ss->shape[n]);
1961 mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1962 cm->as->lower[n]->value.integer);
1963 mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1964 }
1965
1966 /* Once we got ss, we use scalarizer to create the loop. */
1967
1968 gfc_init_loopinfo (&loop);
1969 gfc_add_ss_to_loop (&loop, ss);
1970 gfc_conv_ss_startstride (&loop);
1971 gfc_conv_loop_setup (&loop, where);
1972 gfc_mark_ss_chain_used (ss, 1);
1973 gfc_start_scalarized_body (&loop, &body);
1974
1975 gfc_copy_loopinfo_to_se (&se, &loop);
1976 se.ss = ss;
1977
1978 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1979 se.expr = expr;
1980 gfc_conv_tmp_array_ref (&se);
1981
1982 /* Now se.expr contains an element of the array. Take the address and pass
1983 it to the IO routines. */
1984 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
1985 transfer_expr (&se, &cm->ts, tmp, NULL);
1986
1987 /* We are done now with the loop body. Wrap up the scalarizer and
1988 return. */
1989
1990 gfc_add_block_to_block (&body, &se.pre);
1991 gfc_add_block_to_block (&body, &se.post);
1992
1993 gfc_trans_scalarizing_loops (&loop, &body);
1994
1995 gfc_add_block_to_block (&block, &loop.pre);
1996 gfc_add_block_to_block (&block, &loop.post);
1997
1998 gcc_assert (ss->shape != NULL);
1999 gfc_free_shape (&ss->shape, cm->as->rank);
2000 gfc_cleanup_loop (&loop);
2001
2002 return gfc_finish_block (&block);
2003 }
2004
2005 /* Generate the call for a scalar transfer node. */
2006
2007 static void
2008 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
2009 {
2010 tree tmp, function, arg2, arg3, field, expr;
2011 gfc_component *c;
2012 int kind;
2013
2014 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2015 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2016 We need to translate the expression to a constant if it's either
2017 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2018 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2019 BT_DERIVED (could have been changed by gfc_conv_expr). */
2020 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2021 && ts->u.derived != NULL
2022 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2023 {
2024 /* C_PTR and C_FUNPTR have private components which means they can not
2025 be printed. However, if -std=gnu and not -pedantic, allow
2026 the component to be printed to help debugging. */
2027 if (gfc_notification_std (GFC_STD_GNU) != SILENT)
2028 {
2029 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
2030 ts->u.derived->name, code != NULL ? &(code->loc) :
2031 &gfc_current_locus);
2032 return;
2033 }
2034
2035 ts->type = ts->u.derived->ts.type;
2036 ts->kind = ts->u.derived->ts.kind;
2037 ts->f90_type = ts->u.derived->ts.f90_type;
2038 }
2039
2040 kind = ts->kind;
2041 function = NULL;
2042 arg2 = NULL;
2043 arg3 = NULL;
2044
2045 switch (ts->type)
2046 {
2047 case BT_INTEGER:
2048 arg2 = build_int_cst (integer_type_node, kind);
2049 if (last_dt == READ)
2050 function = iocall[IOCALL_X_INTEGER];
2051 else
2052 function = iocall[IOCALL_X_INTEGER_WRITE];
2053
2054 break;
2055
2056 case BT_REAL:
2057 arg2 = build_int_cst (integer_type_node, kind);
2058 if (last_dt == READ)
2059 {
2060 if (gfc_real16_is_float128 && ts->kind == 16)
2061 function = iocall[IOCALL_X_REAL128];
2062 else
2063 function = iocall[IOCALL_X_REAL];
2064 }
2065 else
2066 {
2067 if (gfc_real16_is_float128 && ts->kind == 16)
2068 function = iocall[IOCALL_X_REAL128_WRITE];
2069 else
2070 function = iocall[IOCALL_X_REAL_WRITE];
2071 }
2072
2073 break;
2074
2075 case BT_COMPLEX:
2076 arg2 = build_int_cst (integer_type_node, kind);
2077 if (last_dt == READ)
2078 {
2079 if (gfc_real16_is_float128 && ts->kind == 16)
2080 function = iocall[IOCALL_X_COMPLEX128];
2081 else
2082 function = iocall[IOCALL_X_COMPLEX];
2083 }
2084 else
2085 {
2086 if (gfc_real16_is_float128 && ts->kind == 16)
2087 function = iocall[IOCALL_X_COMPLEX128_WRITE];
2088 else
2089 function = iocall[IOCALL_X_COMPLEX_WRITE];
2090 }
2091
2092 break;
2093
2094 case BT_LOGICAL:
2095 arg2 = build_int_cst (integer_type_node, kind);
2096 if (last_dt == READ)
2097 function = iocall[IOCALL_X_LOGICAL];
2098 else
2099 function = iocall[IOCALL_X_LOGICAL_WRITE];
2100
2101 break;
2102
2103 case BT_CHARACTER:
2104 if (kind == 4)
2105 {
2106 if (se->string_length)
2107 arg2 = se->string_length;
2108 else
2109 {
2110 tmp = build_fold_indirect_ref_loc (input_location,
2111 addr_expr);
2112 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2113 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2114 arg2 = fold_convert (gfc_charlen_type_node, arg2);
2115 }
2116 arg3 = build_int_cst (integer_type_node, kind);
2117 if (last_dt == READ)
2118 function = iocall[IOCALL_X_CHARACTER_WIDE];
2119 else
2120 function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
2121
2122 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2123 tmp = build_call_expr_loc (input_location,
2124 function, 4, tmp, addr_expr, arg2, arg3);
2125 gfc_add_expr_to_block (&se->pre, tmp);
2126 gfc_add_block_to_block (&se->pre, &se->post);
2127 return;
2128 }
2129 /* Fall through. */
2130 case BT_HOLLERITH:
2131 if (se->string_length)
2132 arg2 = se->string_length;
2133 else
2134 {
2135 tmp = build_fold_indirect_ref_loc (input_location,
2136 addr_expr);
2137 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2138 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2139 }
2140 if (last_dt == READ)
2141 function = iocall[IOCALL_X_CHARACTER];
2142 else
2143 function = iocall[IOCALL_X_CHARACTER_WRITE];
2144
2145 break;
2146
2147 case BT_DERIVED:
2148 /* Recurse into the elements of the derived type. */
2149 expr = gfc_evaluate_now (addr_expr, &se->pre);
2150 expr = build_fold_indirect_ref_loc (input_location,
2151 expr);
2152
2153 for (c = ts->u.derived->components; c; c = c->next)
2154 {
2155 field = c->backend_decl;
2156 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2157
2158 tmp = fold_build3_loc (UNKNOWN_LOCATION,
2159 COMPONENT_REF, TREE_TYPE (field),
2160 expr, field, NULL_TREE);
2161
2162 if (c->attr.dimension)
2163 {
2164 tmp = transfer_array_component (tmp, c, & code->loc);
2165 gfc_add_expr_to_block (&se->pre, tmp);
2166 }
2167 else
2168 {
2169 if (!c->attr.pointer)
2170 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2171 transfer_expr (se, &c->ts, tmp, code);
2172 }
2173 }
2174 return;
2175
2176 default:
2177 internal_error ("Bad IO basetype (%d)", ts->type);
2178 }
2179
2180 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2181 tmp = build_call_expr_loc (input_location,
2182 function, 3, tmp, addr_expr, arg2);
2183 gfc_add_expr_to_block (&se->pre, tmp);
2184 gfc_add_block_to_block (&se->pre, &se->post);
2185
2186 }
2187
2188
2189 /* Generate a call to pass an array descriptor to the IO library. The
2190 array should be of one of the intrinsic types. */
2191
2192 static void
2193 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2194 {
2195 tree tmp, charlen_arg, kind_arg, io_call;
2196
2197 if (ts->type == BT_CHARACTER)
2198 charlen_arg = se->string_length;
2199 else
2200 charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
2201
2202 kind_arg = build_int_cst (integer_type_node, ts->kind);
2203
2204 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2205 if (last_dt == READ)
2206 io_call = iocall[IOCALL_X_ARRAY];
2207 else
2208 io_call = iocall[IOCALL_X_ARRAY_WRITE];
2209
2210 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2211 io_call, 4,
2212 tmp, addr_expr, kind_arg, charlen_arg);
2213 gfc_add_expr_to_block (&se->pre, tmp);
2214 gfc_add_block_to_block (&se->pre, &se->post);
2215 }
2216
2217
2218 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2219
2220 tree
2221 gfc_trans_transfer (gfc_code * code)
2222 {
2223 stmtblock_t block, body;
2224 gfc_loopinfo loop;
2225 gfc_expr *expr;
2226 gfc_ref *ref;
2227 gfc_ss *ss;
2228 gfc_se se;
2229 tree tmp;
2230 int n;
2231
2232 gfc_start_block (&block);
2233 gfc_init_block (&body);
2234
2235 expr = code->expr1;
2236 ss = gfc_walk_expr (expr);
2237
2238 ref = NULL;
2239 gfc_init_se (&se, NULL);
2240
2241 if (ss == gfc_ss_terminator)
2242 {
2243 /* Transfer a scalar value. */
2244 gfc_conv_expr_reference (&se, expr);
2245 transfer_expr (&se, &expr->ts, se.expr, code);
2246 }
2247 else
2248 {
2249 /* Transfer an array. If it is an array of an intrinsic
2250 type, pass the descriptor to the library. Otherwise
2251 scalarize the transfer. */
2252 if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
2253 {
2254 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2255 ref = ref->next);
2256 gcc_assert (ref->type == REF_ARRAY);
2257 }
2258
2259 if (expr->ts.type != BT_DERIVED
2260 && ref && ref->next == NULL
2261 && !is_subref_array (expr))
2262 {
2263 bool seen_vector = false;
2264
2265 if (ref && ref->u.ar.type == AR_SECTION)
2266 {
2267 for (n = 0; n < ref->u.ar.dimen; n++)
2268 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2269 seen_vector = true;
2270 }
2271
2272 if (seen_vector && last_dt == READ)
2273 {
2274 /* Create a temp, read to that and copy it back. */
2275 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2276 tmp = se.expr;
2277 }
2278 else
2279 {
2280 /* Get the descriptor. */
2281 gfc_conv_expr_descriptor (&se, expr, ss);
2282 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2283 }
2284
2285 transfer_array_desc (&se, &expr->ts, tmp);
2286 goto finish_block_label;
2287 }
2288
2289 /* Initialize the scalarizer. */
2290 gfc_init_loopinfo (&loop);
2291 gfc_add_ss_to_loop (&loop, ss);
2292
2293 /* Initialize the loop. */
2294 gfc_conv_ss_startstride (&loop);
2295 gfc_conv_loop_setup (&loop, &code->expr1->where);
2296
2297 /* The main loop body. */
2298 gfc_mark_ss_chain_used (ss, 1);
2299 gfc_start_scalarized_body (&loop, &body);
2300
2301 gfc_copy_loopinfo_to_se (&se, &loop);
2302 se.ss = ss;
2303
2304 gfc_conv_expr_reference (&se, expr);
2305 transfer_expr (&se, &expr->ts, se.expr, code);
2306 }
2307
2308 finish_block_label:
2309
2310 gfc_add_block_to_block (&body, &se.pre);
2311 gfc_add_block_to_block (&body, &se.post);
2312
2313 if (se.ss == NULL)
2314 tmp = gfc_finish_block (&body);
2315 else
2316 {
2317 gcc_assert (se.ss == gfc_ss_terminator);
2318 gfc_trans_scalarizing_loops (&loop, &body);
2319
2320 gfc_add_block_to_block (&loop.pre, &loop.post);
2321 tmp = gfc_finish_block (&loop.pre);
2322 gfc_cleanup_loop (&loop);
2323 }
2324
2325 gfc_add_expr_to_block (&block, tmp);
2326
2327 return gfc_finish_block (&block);
2328 }
2329
2330 #include "gt-fortran-trans-io.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org