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