Fix ChangeLog
[official-gcc.git] / gcc / fortran / trans-io.c
blob2f35002a5ac06904bb6e20eed99219b0067f2825
1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
3 Foundation, Inc.
4 Contributed by Paul Brook
6 This file is part of GCC.
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.
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.
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/>. */
23 #include "config.h"
24 #include "system.h"
25 #include "coretypes.h"
26 #include "tree.h"
27 #include "tree-gimple.h"
28 #include "ggc.h"
29 #include "toplev.h"
30 #include "real.h"
31 #include "gfortran.h"
32 #include "trans.h"
33 #include "trans-stmt.h"
34 #include "trans-array.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
38 /* Members of the ioparm structure. */
40 enum ioparam_type
42 IOPARM_ptype_common,
43 IOPARM_ptype_open,
44 IOPARM_ptype_close,
45 IOPARM_ptype_filepos,
46 IOPARM_ptype_inquire,
47 IOPARM_ptype_dt,
48 IOPARM_ptype_wait,
49 IOPARM_ptype_num
52 enum iofield_type
54 IOPARM_type_int4,
55 IOPARM_type_intio,
56 IOPARM_type_pint4,
57 IOPARM_type_pintio,
58 IOPARM_type_pchar,
59 IOPARM_type_parray,
60 IOPARM_type_pad,
61 IOPARM_type_char1,
62 IOPARM_type_char2,
63 IOPARM_type_common,
64 IOPARM_type_num
67 typedef struct gfc_st_parameter_field GTY(())
69 const char *name;
70 unsigned int mask;
71 enum ioparam_type param_type;
72 enum iofield_type type;
73 tree field;
74 tree field_len;
76 gfc_st_parameter_field;
78 typedef struct gfc_st_parameter GTY(())
80 const char *name;
81 tree type;
83 gfc_st_parameter;
85 enum iofield
87 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
88 #include "ioparm.def"
89 #undef IOPARM
90 IOPARM_field_num
93 static GTY(()) gfc_st_parameter st_parameter[] =
95 { "common", NULL },
96 { "open", NULL },
97 { "close", NULL },
98 { "filepos", NULL },
99 { "inquire", NULL },
100 { "dt", NULL },
101 { "wait", NULL }
104 static GTY(()) gfc_st_parameter_field st_parameter_field[] =
106 #define IOPARM(param_type, name, mask, type) \
107 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
108 #include "ioparm.def"
109 #undef IOPARM
110 { NULL, 0, 0, 0, NULL, NULL }
113 /* Library I/O subroutines */
115 enum iocall
117 IOCALL_READ,
118 IOCALL_READ_DONE,
119 IOCALL_WRITE,
120 IOCALL_WRITE_DONE,
121 IOCALL_X_INTEGER,
122 IOCALL_X_LOGICAL,
123 IOCALL_X_CHARACTER,
124 IOCALL_X_REAL,
125 IOCALL_X_COMPLEX,
126 IOCALL_X_ARRAY,
127 IOCALL_OPEN,
128 IOCALL_CLOSE,
129 IOCALL_INQUIRE,
130 IOCALL_IOLENGTH,
131 IOCALL_IOLENGTH_DONE,
132 IOCALL_REWIND,
133 IOCALL_BACKSPACE,
134 IOCALL_ENDFILE,
135 IOCALL_FLUSH,
136 IOCALL_SET_NML_VAL,
137 IOCALL_SET_NML_VAL_DIM,
138 IOCALL_WAIT,
139 IOCALL_NUM
142 static GTY(()) tree iocall[IOCALL_NUM];
144 /* Variable for keeping track of what the last data transfer statement
145 was. Used for deciding which subroutine to call when the data
146 transfer is complete. */
147 static enum { READ, WRITE, IOLENGTH } last_dt;
149 /* The data transfer parameter block that should be shared by all
150 data transfer calls belonging to the same read/write/iolength. */
151 static GTY(()) tree dt_parm;
152 static stmtblock_t *dt_post_end_block;
154 static void
155 gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
157 enum iofield type;
158 gfc_st_parameter_field *p;
159 char name[64];
160 size_t len;
161 tree t = make_node (RECORD_TYPE);
163 len = strlen (st_parameter[ptype].name);
164 gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
165 memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
166 memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
167 len + 1);
168 TYPE_NAME (t) = get_identifier (name);
170 for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
171 if (p->param_type == ptype)
172 switch (p->type)
174 case IOPARM_type_int4:
175 case IOPARM_type_intio:
176 case IOPARM_type_pint4:
177 case IOPARM_type_pintio:
178 case IOPARM_type_parray:
179 case IOPARM_type_pchar:
180 case IOPARM_type_pad:
181 p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
182 get_identifier (p->name),
183 types[p->type]);
184 break;
185 case IOPARM_type_char1:
186 p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
187 get_identifier (p->name),
188 pchar_type_node);
189 /* FALLTHROUGH */
190 case IOPARM_type_char2:
191 len = strlen (p->name);
192 gcc_assert (len <= sizeof (name) - sizeof ("_len"));
193 memcpy (name, p->name, len);
194 memcpy (name + len, "_len", sizeof ("_len"));
195 p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
196 get_identifier (name),
197 gfc_charlen_type_node);
198 if (p->type == IOPARM_type_char2)
199 p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
200 get_identifier (p->name),
201 pchar_type_node);
202 break;
203 case IOPARM_type_common:
204 p->field
205 = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
206 get_identifier (p->name),
207 st_parameter[IOPARM_ptype_common].type);
208 break;
209 case IOPARM_type_num:
210 gcc_unreachable ();
213 gfc_finish_type (t);
214 st_parameter[ptype].type = t;
218 /* Build code to test an error condition and call generate_error if needed.
219 Note: This builds calls to generate_error in the runtime library function.
220 The function generate_error is dependent on certain parameters in the
221 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
222 Therefore, the code to set these flags must be generated before
223 this function is used. */
225 void
226 gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
227 const char * msgid, stmtblock_t * pblock)
229 stmtblock_t block;
230 tree body;
231 tree tmp;
232 tree arg1, arg2, arg3;
233 char *message;
235 if (integer_zerop (cond))
236 return;
238 /* The code to generate the error. */
239 gfc_start_block (&block);
241 arg1 = build_fold_addr_expr (var);
243 arg2 = build_int_cst (integer_type_node, error_code),
245 asprintf (&message, "%s", _(msgid));
246 arg3 = gfc_build_addr_expr (pchar_type_node,
247 gfc_build_localized_cstring_const (message));
248 gfc_free(message);
250 tmp = build_call_expr (gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
252 gfc_add_expr_to_block (&block, tmp);
254 body = gfc_finish_block (&block);
256 if (integer_onep (cond))
258 gfc_add_expr_to_block (pblock, body);
260 else
262 /* Tell the compiler that this isn't likely. */
263 cond = fold_convert (long_integer_type_node, cond);
264 tmp = build_int_cst (long_integer_type_node, 0);
265 cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
266 cond = fold_convert (boolean_type_node, cond);
268 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
269 gfc_add_expr_to_block (pblock, tmp);
274 /* Create function decls for IO library functions. */
276 void
277 gfc_build_io_library_fndecls (void)
279 tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
280 tree gfc_intio_type_node;
281 tree parm_type, dt_parm_type;
282 HOST_WIDE_INT pad_size;
283 enum ioparam_type ptype;
285 types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
286 types[IOPARM_type_intio] = gfc_intio_type_node
287 = gfc_get_int_type (gfc_intio_kind);
288 types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
289 types[IOPARM_type_pintio]
290 = build_pointer_type (gfc_intio_type_node);
291 types[IOPARM_type_parray] = pchar_type_node;
292 types[IOPARM_type_pchar] = pchar_type_node;
293 pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
294 pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
295 pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
296 types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
298 /* pad actually contains pointers and integers so it needs to have an
299 alignment that is at least as large as the needed alignment for those
300 types. See the st_parameter_dt structure in libgfortran/io/io.h for
301 what really goes into this space. */
302 TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
303 TYPE_ALIGN (gfc_get_int_type (gfc_max_integer_kind)));
305 for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
306 gfc_build_st_parameter (ptype, types);
308 /* Define the transfer functions. */
310 dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
312 iocall[IOCALL_X_INTEGER] =
313 gfc_build_library_function_decl (get_identifier
314 (PREFIX("transfer_integer")),
315 void_type_node, 3, dt_parm_type,
316 pvoid_type_node, gfc_int4_type_node);
318 iocall[IOCALL_X_LOGICAL] =
319 gfc_build_library_function_decl (get_identifier
320 (PREFIX("transfer_logical")),
321 void_type_node, 3, dt_parm_type,
322 pvoid_type_node, gfc_int4_type_node);
324 iocall[IOCALL_X_CHARACTER] =
325 gfc_build_library_function_decl (get_identifier
326 (PREFIX("transfer_character")),
327 void_type_node, 3, dt_parm_type,
328 pvoid_type_node, gfc_int4_type_node);
330 iocall[IOCALL_X_REAL] =
331 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
332 void_type_node, 3, dt_parm_type,
333 pvoid_type_node, gfc_int4_type_node);
335 iocall[IOCALL_X_COMPLEX] =
336 gfc_build_library_function_decl (get_identifier
337 (PREFIX("transfer_complex")),
338 void_type_node, 3, dt_parm_type,
339 pvoid_type_node, gfc_int4_type_node);
341 iocall[IOCALL_X_ARRAY] =
342 gfc_build_library_function_decl (get_identifier
343 (PREFIX("transfer_array")),
344 void_type_node, 4, dt_parm_type,
345 pvoid_type_node, integer_type_node,
346 gfc_charlen_type_node);
348 /* Library entry points */
350 iocall[IOCALL_READ] =
351 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
352 void_type_node, 1, dt_parm_type);
354 iocall[IOCALL_WRITE] =
355 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
356 void_type_node, 1, dt_parm_type);
358 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
359 iocall[IOCALL_OPEN] =
360 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
361 void_type_node, 1, parm_type);
364 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
365 iocall[IOCALL_CLOSE] =
366 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
367 void_type_node, 1, parm_type);
369 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
370 iocall[IOCALL_INQUIRE] =
371 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
372 gfc_int4_type_node, 1, parm_type);
374 iocall[IOCALL_IOLENGTH] =
375 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
376 void_type_node, 1, dt_parm_type);
378 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
379 iocall[IOCALL_WAIT] =
380 gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")),
381 gfc_int4_type_node, 1, parm_type);
383 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
384 iocall[IOCALL_REWIND] =
385 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
386 gfc_int4_type_node, 1, parm_type);
388 iocall[IOCALL_BACKSPACE] =
389 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
390 gfc_int4_type_node, 1, parm_type);
392 iocall[IOCALL_ENDFILE] =
393 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
394 gfc_int4_type_node, 1, parm_type);
396 iocall[IOCALL_FLUSH] =
397 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
398 gfc_int4_type_node, 1, parm_type);
400 /* Library helpers */
402 iocall[IOCALL_READ_DONE] =
403 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
404 gfc_int4_type_node, 1, dt_parm_type);
406 iocall[IOCALL_WRITE_DONE] =
407 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
408 gfc_int4_type_node, 1, dt_parm_type);
410 iocall[IOCALL_IOLENGTH_DONE] =
411 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
412 gfc_int4_type_node, 1, dt_parm_type);
415 iocall[IOCALL_SET_NML_VAL] =
416 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
417 void_type_node, 6, dt_parm_type,
418 pvoid_type_node, pvoid_type_node,
419 gfc_int4_type_node, gfc_charlen_type_node,
420 gfc_int4_type_node);
422 iocall[IOCALL_SET_NML_VAL_DIM] =
423 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
424 void_type_node, 5, dt_parm_type,
425 gfc_int4_type_node, gfc_array_index_type,
426 gfc_array_index_type, gfc_array_index_type);
430 /* Generate code to store an integer constant into the
431 st_parameter_XXX structure. */
433 static unsigned int
434 set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
435 unsigned int val)
437 tree tmp;
438 gfc_st_parameter_field *p = &st_parameter_field[type];
440 if (p->param_type == IOPARM_ptype_common)
441 var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
442 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
443 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
444 NULL_TREE);
445 gfc_add_modify_expr (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
446 return p->mask;
450 /* Generate code to store a non-string I/O parameter into the
451 st_parameter_XXX structure. This is a pass by value. */
453 static unsigned int
454 set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
455 gfc_expr *e)
457 gfc_se se;
458 tree tmp;
459 gfc_st_parameter_field *p = &st_parameter_field[type];
460 tree dest_type = TREE_TYPE (p->field);
462 gfc_init_se (&se, NULL);
463 gfc_conv_expr_val (&se, e);
465 /* If we're storing a UNIT number, we need to check it first. */
466 if (type == IOPARM_common_unit && e->ts.kind != 4)
468 tree cond, max;
469 int i;
471 /* Don't evaluate the UNIT number multiple times. */
472 se.expr = gfc_evaluate_now (se.expr, &se.pre);
474 /* UNIT numbers should be nonnegative. */
475 cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr,
476 build_int_cst (TREE_TYPE (se.expr),0));
477 gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
478 "Negative unit number in I/O statement",
479 &se.pre);
481 /* UNIT numbers should be less than the max. */
482 i = gfc_validate_kind (BT_INTEGER, 4, false);
483 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
484 cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr,
485 fold_convert (TREE_TYPE (se.expr), max));
486 gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
487 "Unit number in I/O statement too large",
488 &se.pre);
492 se.expr = convert (dest_type, se.expr);
493 gfc_add_block_to_block (block, &se.pre);
495 if (p->param_type == IOPARM_ptype_common)
496 var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
497 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
499 tmp = fold_build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE);
500 gfc_add_modify_expr (block, tmp, se.expr);
501 return p->mask;
505 /* Generate code to store a non-string I/O parameter into the
506 st_parameter_XXX structure. This is pass by reference. */
508 static unsigned int
509 set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
510 tree var, enum iofield type, gfc_expr *e)
512 gfc_se se;
513 tree tmp, addr;
514 gfc_st_parameter_field *p = &st_parameter_field[type];
516 gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
517 gfc_init_se (&se, NULL);
518 gfc_conv_expr_lhs (&se, e);
520 gfc_add_block_to_block (block, &se.pre);
522 if (TYPE_MODE (TREE_TYPE (se.expr))
523 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
525 addr = convert (TREE_TYPE (p->field), build_fold_addr_expr (se.expr));
527 /* If this is for the iostat variable initialize the
528 user variable to LIBERROR_OK which is zero. */
529 if (type == IOPARM_common_iostat)
530 gfc_add_modify_expr (block, se.expr,
531 build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
533 else
535 /* The type used by the library has different size
536 from the type of the variable supplied by the user.
537 Need to use a temporary. */
538 tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
539 st_parameter_field[type].name);
541 /* If this is for the iostat variable, initialize the
542 user variable to LIBERROR_OK which is zero. */
543 if (type == IOPARM_common_iostat)
544 gfc_add_modify_expr (block, tmpvar,
545 build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
547 addr = build_fold_addr_expr (tmpvar);
548 /* After the I/O operation, we set the variable from the temporary. */
549 tmp = convert (TREE_TYPE (se.expr), tmpvar);
550 gfc_add_modify_expr (postblock, se.expr, tmp);
553 if (p->param_type == IOPARM_ptype_common)
554 var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
555 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
556 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
557 var, p->field, NULL_TREE);
558 gfc_add_modify_expr (block, tmp, addr);
559 return p->mask;
562 /* Given an array expr, find its address and length to get a string. If the
563 array is full, the string's address is the address of array's first element
564 and the length is the size of the whole array. If it is an element, the
565 string's address is the element's address and the length is the rest size of
566 the array.
569 static void
570 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
572 tree tmp;
573 tree array;
574 tree type;
575 tree size;
576 int rank;
577 gfc_symbol *sym;
579 sym = e->symtree->n.sym;
580 rank = sym->as->rank - 1;
582 if (e->ref->u.ar.type == AR_FULL)
584 se->expr = gfc_get_symbol_decl (sym);
585 se->expr = gfc_conv_array_data (se->expr);
587 else
589 gfc_conv_expr (se, e);
592 array = sym->backend_decl;
593 type = TREE_TYPE (array);
595 if (GFC_ARRAY_TYPE_P (type))
596 size = GFC_TYPE_ARRAY_SIZE (type);
597 else
599 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
600 size = gfc_conv_array_stride (array, rank);
601 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
602 gfc_conv_array_ubound (array, rank),
603 gfc_conv_array_lbound (array, rank));
604 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
605 gfc_index_one_node);
606 size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
609 gcc_assert (size);
611 /* If it is an element, we need the its address and size of the rest. */
612 if (e->ref->u.ar.type == AR_ELEMENT)
614 size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
615 TREE_OPERAND (se->expr, 1));
616 se->expr = build_fold_addr_expr (se->expr);
619 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
620 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
621 fold_convert (gfc_array_index_type, tmp));
623 se->string_length = fold_convert (gfc_charlen_type_node, size);
627 /* Generate code to store a string and its length into the
628 st_parameter_XXX structure. */
630 static unsigned int
631 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
632 enum iofield type, gfc_expr * e)
634 gfc_se se;
635 tree tmp;
636 tree io;
637 tree len;
638 gfc_st_parameter_field *p = &st_parameter_field[type];
640 gfc_init_se (&se, NULL);
642 if (p->param_type == IOPARM_ptype_common)
643 var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
644 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
645 io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
646 var, p->field, NULL_TREE);
647 len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
648 var, p->field_len, NULL_TREE);
650 /* Integer variable assigned a format label. */
651 if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
653 char * msg;
654 tree cond;
656 gfc_conv_label_variable (&se, e);
657 tmp = GFC_DECL_STRING_LEN (se.expr);
658 cond = fold_build2 (LT_EXPR, boolean_type_node,
659 tmp, build_int_cst (TREE_TYPE (tmp), 0));
661 asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
662 "label", e->symtree->name);
663 gfc_trans_runtime_check (cond, &se.pre, &e->where, msg,
664 fold_convert (long_integer_type_node, tmp));
665 gfc_free (msg);
667 gfc_add_modify_expr (&se.pre, io,
668 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
669 gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
671 else
673 /* General character. */
674 if (e->ts.type == BT_CHARACTER && e->rank == 0)
675 gfc_conv_expr (&se, e);
676 /* Array assigned Hollerith constant or character array. */
677 else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
678 gfc_convert_array_to_string (&se, e);
679 else
680 gcc_unreachable ();
682 gfc_conv_string_parameter (&se);
683 gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
684 gfc_add_modify_expr (&se.pre, len, se.string_length);
687 gfc_add_block_to_block (block, &se.pre);
688 gfc_add_block_to_block (postblock, &se.post);
689 return p->mask;
693 /* Generate code to store the character (array) and the character length
694 for an internal unit. */
696 static unsigned int
697 set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
698 tree var, gfc_expr * e)
700 gfc_se se;
701 tree io;
702 tree len;
703 tree desc;
704 tree tmp;
705 gfc_st_parameter_field *p;
706 unsigned int mask;
708 gfc_init_se (&se, NULL);
710 p = &st_parameter_field[IOPARM_dt_internal_unit];
711 mask = p->mask;
712 io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
713 var, p->field, NULL_TREE);
714 len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
715 var, p->field_len, NULL_TREE);
716 p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
717 desc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
718 var, p->field, NULL_TREE);
720 gcc_assert (e->ts.type == BT_CHARACTER);
722 /* Character scalars. */
723 if (e->rank == 0)
725 gfc_conv_expr (&se, e);
726 gfc_conv_string_parameter (&se);
727 tmp = se.expr;
728 se.expr = build_int_cst (pchar_type_node, 0);
731 /* Character array. */
732 else if (e->rank > 0)
734 se.ss = gfc_walk_expr (e);
736 if (is_subref_array (e))
738 /* Use a temporary for components of arrays of derived types
739 or substring array references. */
740 gfc_conv_subref_array_arg (&se, e, 0,
741 last_dt == READ ? INTENT_IN : INTENT_OUT);
742 tmp = build_fold_indirect_ref (se.expr);
743 se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
744 tmp = gfc_conv_descriptor_data_get (tmp);
746 else
748 /* Return the data pointer and rank from the descriptor. */
749 gfc_conv_expr_descriptor (&se, e, se.ss);
750 tmp = gfc_conv_descriptor_data_get (se.expr);
751 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
754 else
755 gcc_unreachable ();
757 /* The cast is needed for character substrings and the descriptor
758 data. */
759 gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
760 gfc_add_modify_expr (&se.pre, len,
761 fold_convert (TREE_TYPE (len), se.string_length));
762 gfc_add_modify_expr (&se.pre, desc, se.expr);
764 gfc_add_block_to_block (block, &se.pre);
765 gfc_add_block_to_block (post_block, &se.post);
766 return mask;
769 /* Add a case to a IO-result switch. */
771 static void
772 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
774 tree tmp, value;
776 if (label == NULL)
777 return; /* No label, no case */
779 value = build_int_cst (NULL_TREE, label_value);
781 /* Make a backend label for this case. */
782 tmp = gfc_build_label_decl (NULL_TREE);
784 /* And the case itself. */
785 tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
786 gfc_add_expr_to_block (body, tmp);
788 /* Jump to the label. */
789 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
790 gfc_add_expr_to_block (body, tmp);
794 /* Generate a switch statement that branches to the correct I/O
795 result label. The last statement of an I/O call stores the
796 result into a variable because there is often cleanup that
797 must be done before the switch, so a temporary would have to
798 be created anyway. */
800 static void
801 io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
802 gfc_st_label * end_label, gfc_st_label * eor_label)
804 stmtblock_t body;
805 tree tmp, rc;
806 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
808 /* If no labels are specified, ignore the result instead
809 of building an empty switch. */
810 if (err_label == NULL
811 && end_label == NULL
812 && eor_label == NULL)
813 return;
815 /* Build a switch statement. */
816 gfc_start_block (&body);
818 /* The label values here must be the same as the values
819 in the library_return enum in the runtime library */
820 add_case (1, err_label, &body);
821 add_case (2, end_label, &body);
822 add_case (3, eor_label, &body);
824 tmp = gfc_finish_block (&body);
826 var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
827 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
828 rc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
829 var, p->field, NULL_TREE);
830 rc = fold_build2 (BIT_AND_EXPR, TREE_TYPE (rc),
831 rc, build_int_cst (TREE_TYPE (rc),
832 IOPARM_common_libreturn_mask));
834 tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
836 gfc_add_expr_to_block (block, tmp);
840 /* Store the current file and line number to variables so that if a
841 library call goes awry, we can tell the user where the problem is. */
843 static void
844 set_error_locus (stmtblock_t * block, tree var, locus * where)
846 gfc_file *f;
847 tree str, locus_file;
848 int line;
849 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
851 locus_file = fold_build3 (COMPONENT_REF,
852 st_parameter[IOPARM_ptype_common].type,
853 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
854 locus_file = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
855 locus_file, p->field, NULL_TREE);
856 f = where->lb->file;
857 str = gfc_build_cstring_const (f->filename);
859 str = gfc_build_addr_expr (pchar_type_node, str);
860 gfc_add_modify_expr (block, locus_file, str);
862 line = LOCATION_LINE (where->lb->location);
863 set_parameter_const (block, var, IOPARM_common_line, line);
867 /* Translate an OPEN statement. */
869 tree
870 gfc_trans_open (gfc_code * code)
872 stmtblock_t block, post_block;
873 gfc_open *p;
874 tree tmp, var;
875 unsigned int mask = 0;
877 gfc_start_block (&block);
878 gfc_init_block (&post_block);
880 var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
882 set_error_locus (&block, var, &code->loc);
883 p = code->ext.open;
885 if (p->iomsg)
886 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
887 p->iomsg);
889 if (p->iostat)
890 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
891 p->iostat);
893 if (p->err)
894 mask |= IOPARM_common_err;
896 if (p->file)
897 mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
899 if (p->status)
900 mask |= set_string (&block, &post_block, var, IOPARM_open_status,
901 p->status);
903 if (p->access)
904 mask |= set_string (&block, &post_block, var, IOPARM_open_access,
905 p->access);
907 if (p->form)
908 mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
910 if (p->recl)
911 mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
913 if (p->blank)
914 mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
915 p->blank);
917 if (p->position)
918 mask |= set_string (&block, &post_block, var, IOPARM_open_position,
919 p->position);
921 if (p->action)
922 mask |= set_string (&block, &post_block, var, IOPARM_open_action,
923 p->action);
925 if (p->delim)
926 mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
927 p->delim);
929 if (p->pad)
930 mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
932 if (p->decimal)
933 mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
934 p->decimal);
936 if (p->encoding)
937 mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
938 p->encoding);
940 if (p->round)
941 mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
943 if (p->sign)
944 mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
946 if (p->asynchronous)
947 mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
948 p->asynchronous);
950 if (p->convert)
951 mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
952 p->convert);
954 set_parameter_const (&block, var, IOPARM_common_flags, mask);
956 if (p->unit)
957 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
958 else
959 set_parameter_const (&block, var, IOPARM_common_unit, 0);
961 tmp = build_fold_addr_expr (var);
962 tmp = build_call_expr (iocall[IOCALL_OPEN], 1, tmp);
963 gfc_add_expr_to_block (&block, tmp);
965 gfc_add_block_to_block (&block, &post_block);
967 io_result (&block, var, p->err, NULL, NULL);
969 return gfc_finish_block (&block);
973 /* Translate a CLOSE statement. */
975 tree
976 gfc_trans_close (gfc_code * code)
978 stmtblock_t block, post_block;
979 gfc_close *p;
980 tree tmp, var;
981 unsigned int mask = 0;
983 gfc_start_block (&block);
984 gfc_init_block (&post_block);
986 var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
988 set_error_locus (&block, var, &code->loc);
989 p = code->ext.close;
991 if (p->iomsg)
992 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
993 p->iomsg);
995 if (p->iostat)
996 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
997 p->iostat);
999 if (p->err)
1000 mask |= IOPARM_common_err;
1002 if (p->status)
1003 mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1004 p->status);
1006 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1008 if (p->unit)
1009 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1010 else
1011 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1013 tmp = build_fold_addr_expr (var);
1014 tmp = build_call_expr (iocall[IOCALL_CLOSE], 1, tmp);
1015 gfc_add_expr_to_block (&block, tmp);
1017 gfc_add_block_to_block (&block, &post_block);
1019 io_result (&block, var, p->err, NULL, NULL);
1021 return gfc_finish_block (&block);
1025 /* Common subroutine for building a file positioning statement. */
1027 static tree
1028 build_filepos (tree function, gfc_code * code)
1030 stmtblock_t block, post_block;
1031 gfc_filepos *p;
1032 tree tmp, var;
1033 unsigned int mask = 0;
1035 p = code->ext.filepos;
1037 gfc_start_block (&block);
1038 gfc_init_block (&post_block);
1040 var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1041 "filepos_parm");
1043 set_error_locus (&block, var, &code->loc);
1045 if (p->iomsg)
1046 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1047 p->iomsg);
1049 if (p->iostat)
1050 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1051 p->iostat);
1053 if (p->err)
1054 mask |= IOPARM_common_err;
1056 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1058 if (p->unit)
1059 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1060 else
1061 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1063 tmp = build_fold_addr_expr (var);
1064 tmp = build_call_expr (function, 1, tmp);
1065 gfc_add_expr_to_block (&block, tmp);
1067 gfc_add_block_to_block (&block, &post_block);
1069 io_result (&block, var, p->err, NULL, NULL);
1071 return gfc_finish_block (&block);
1075 /* Translate a BACKSPACE statement. */
1077 tree
1078 gfc_trans_backspace (gfc_code * code)
1080 return build_filepos (iocall[IOCALL_BACKSPACE], code);
1084 /* Translate an ENDFILE statement. */
1086 tree
1087 gfc_trans_endfile (gfc_code * code)
1089 return build_filepos (iocall[IOCALL_ENDFILE], code);
1093 /* Translate a REWIND statement. */
1095 tree
1096 gfc_trans_rewind (gfc_code * code)
1098 return build_filepos (iocall[IOCALL_REWIND], code);
1102 /* Translate a FLUSH statement. */
1104 tree
1105 gfc_trans_flush (gfc_code * code)
1107 return build_filepos (iocall[IOCALL_FLUSH], code);
1111 /* Create a dummy iostat variable to catch any error due to bad unit. */
1113 static gfc_expr *
1114 create_dummy_iostat (void)
1116 gfc_symtree *st;
1117 gfc_expr *e;
1119 gfc_get_ha_sym_tree ("@iostat", &st);
1120 st->n.sym->ts.type = BT_INTEGER;
1121 st->n.sym->ts.kind = gfc_default_integer_kind;
1122 gfc_set_sym_referenced (st->n.sym);
1123 gfc_commit_symbol (st->n.sym);
1124 st->n.sym->backend_decl
1125 = gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind),
1126 st->n.sym->name);
1128 e = gfc_get_expr ();
1129 e->expr_type = EXPR_VARIABLE;
1130 e->symtree = st;
1131 e->ts.type = BT_INTEGER;
1132 e->ts.kind = st->n.sym->ts.kind;
1134 return e;
1138 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1140 tree
1141 gfc_trans_inquire (gfc_code * code)
1143 stmtblock_t block, post_block;
1144 gfc_inquire *p;
1145 tree tmp, var;
1146 unsigned int mask = 0, mask2 = 0;
1148 gfc_start_block (&block);
1149 gfc_init_block (&post_block);
1151 var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1152 "inquire_parm");
1154 set_error_locus (&block, var, &code->loc);
1155 p = code->ext.inquire;
1157 if (p->iomsg)
1158 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1159 p->iomsg);
1161 if (p->iostat)
1162 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1163 p->iostat);
1165 if (p->err)
1166 mask |= IOPARM_common_err;
1168 /* Sanity check. */
1169 if (p->unit && p->file)
1170 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1172 if (p->file)
1173 mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1174 p->file);
1176 if (p->exist)
1178 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1179 p->exist);
1181 if (p->unit && !p->iostat)
1183 p->iostat = create_dummy_iostat ();
1184 mask |= set_parameter_ref (&block, &post_block, var,
1185 IOPARM_common_iostat, p->iostat);
1189 if (p->opened)
1190 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1191 p->opened);
1193 if (p->number)
1194 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1195 p->number);
1197 if (p->named)
1198 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1199 p->named);
1201 if (p->name)
1202 mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1203 p->name);
1205 if (p->access)
1206 mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1207 p->access);
1209 if (p->sequential)
1210 mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1211 p->sequential);
1213 if (p->direct)
1214 mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1215 p->direct);
1217 if (p->form)
1218 mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1219 p->form);
1221 if (p->formatted)
1222 mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1223 p->formatted);
1225 if (p->unformatted)
1226 mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1227 p->unformatted);
1229 if (p->recl)
1230 mask |= set_parameter_ref (&block, &post_block, var,
1231 IOPARM_inquire_recl_out, p->recl);
1233 if (p->nextrec)
1234 mask |= set_parameter_ref (&block, &post_block, var,
1235 IOPARM_inquire_nextrec, p->nextrec);
1237 if (p->blank)
1238 mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1239 p->blank);
1241 if (p->delim)
1242 mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1243 p->delim);
1245 if (p->position)
1246 mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1247 p->position);
1249 if (p->action)
1250 mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1251 p->action);
1253 if (p->read)
1254 mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1255 p->read);
1257 if (p->write)
1258 mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1259 p->write);
1261 if (p->readwrite)
1262 mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1263 p->readwrite);
1265 if (p->pad)
1266 mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1267 p->pad);
1269 if (p->convert)
1270 mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1271 p->convert);
1273 if (p->strm_pos)
1274 mask |= set_parameter_ref (&block, &post_block, var,
1275 IOPARM_inquire_strm_pos_out, p->strm_pos);
1277 /* The second series of flags. */
1278 if (p->asynchronous)
1279 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1280 p->asynchronous);
1282 if (p->decimal)
1283 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1284 p->decimal);
1286 if (p->encoding)
1287 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1288 p->encoding);
1290 if (p->round)
1291 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1292 p->round);
1294 if (p->sign)
1295 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1296 p->sign);
1298 if (p->pending)
1299 mask2 |= set_parameter_ref (&block, &post_block, var,
1300 IOPARM_inquire_pending, p->pending);
1302 if (p->size)
1303 mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1304 p->size);
1306 if (p->id)
1307 mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1308 p->id);
1310 set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
1312 if (mask2)
1313 mask |= IOPARM_inquire_flags2;
1315 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1317 if (p->unit)
1318 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1319 else
1320 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1322 tmp = build_fold_addr_expr (var);
1323 tmp = build_call_expr (iocall[IOCALL_INQUIRE], 1, tmp);
1324 gfc_add_expr_to_block (&block, tmp);
1326 gfc_add_block_to_block (&block, &post_block);
1328 io_result (&block, var, p->err, NULL, NULL);
1330 return gfc_finish_block (&block);
1334 tree
1335 gfc_trans_wait (gfc_code * code)
1337 stmtblock_t block, post_block;
1338 gfc_wait *p;
1339 tree tmp, var;
1340 unsigned int mask = 0;
1342 gfc_start_block (&block);
1343 gfc_init_block (&post_block);
1345 var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1346 "wait_parm");
1348 set_error_locus (&block, var, &code->loc);
1349 p = code->ext.wait;
1351 /* Set parameters here. */
1352 if (p->iomsg)
1353 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1354 p->iomsg);
1356 if (p->iostat)
1357 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1358 p->iostat);
1360 if (p->err)
1361 mask |= IOPARM_common_err;
1363 if (p->id)
1364 mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
1366 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1368 if (p->unit)
1369 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1371 tmp = build_fold_addr_expr (var);
1372 tmp = build_call_expr (iocall[IOCALL_WAIT], 1, tmp);
1373 gfc_add_expr_to_block (&block, tmp);
1375 gfc_add_block_to_block (&block, &post_block);
1377 io_result (&block, var, p->err, NULL, NULL);
1379 return gfc_finish_block (&block);
1383 static gfc_expr *
1384 gfc_new_nml_name_expr (const char * name)
1386 gfc_expr * nml_name;
1388 nml_name = gfc_get_expr();
1389 nml_name->ref = NULL;
1390 nml_name->expr_type = EXPR_CONSTANT;
1391 nml_name->ts.kind = gfc_default_character_kind;
1392 nml_name->ts.type = BT_CHARACTER;
1393 nml_name->value.character.length = strlen(name);
1394 nml_name->value.character.string = gfc_char_to_widechar (name);
1396 return nml_name;
1399 /* nml_full_name builds up the fully qualified name of a
1400 derived type component. */
1402 static char*
1403 nml_full_name (const char* var_name, const char* cmp_name)
1405 int full_name_length;
1406 char * full_name;
1408 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1409 full_name = (char*)gfc_getmem (full_name_length + 1);
1410 strcpy (full_name, var_name);
1411 full_name = strcat (full_name, "%");
1412 full_name = strcat (full_name, cmp_name);
1413 return full_name;
1416 /* nml_get_addr_expr builds an address expression from the
1417 gfc_symbol or gfc_component backend_decl's. An offset is
1418 provided so that the address of an element of an array of
1419 derived types is returned. This is used in the runtime to
1420 determine that span of the derived type. */
1422 static tree
1423 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1424 tree base_addr)
1426 tree decl = NULL_TREE;
1427 tree tmp;
1428 tree itmp;
1429 int array_flagged;
1430 int dummy_arg_flagged;
1432 if (sym)
1434 sym->attr.referenced = 1;
1435 decl = gfc_get_symbol_decl (sym);
1437 /* If this is the enclosing function declaration, use
1438 the fake result instead. */
1439 if (decl == current_function_decl)
1440 decl = gfc_get_fake_result_decl (sym, 0);
1441 else if (decl == DECL_CONTEXT (current_function_decl))
1442 decl = gfc_get_fake_result_decl (sym, 1);
1444 else
1445 decl = c->backend_decl;
1447 gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1448 || TREE_CODE (decl) == VAR_DECL
1449 || TREE_CODE (decl) == PARM_DECL)
1450 || TREE_CODE (decl) == COMPONENT_REF));
1452 tmp = decl;
1454 /* Build indirect reference, if dummy argument. */
1456 dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
1458 itmp = (dummy_arg_flagged) ? build_fold_indirect_ref (tmp) : tmp;
1460 /* If an array, set flag and use indirect ref. if built. */
1462 array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
1463 && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
1465 if (array_flagged)
1466 tmp = itmp;
1468 /* Treat the component of a derived type, using base_addr for
1469 the derived type. */
1471 if (TREE_CODE (decl) == FIELD_DECL)
1472 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
1473 base_addr, tmp, NULL_TREE);
1475 /* If we have a derived type component, a reference to the first
1476 element of the array is built. This is done so that base_addr,
1477 used in the build of the component reference, always points to
1478 a RECORD_TYPE. */
1480 if (array_flagged)
1481 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1483 /* Now build the address expression. */
1485 tmp = build_fold_addr_expr (tmp);
1487 /* If scalar dummy, resolve indirect reference now. */
1489 if (dummy_arg_flagged && !array_flagged)
1490 tmp = build_fold_indirect_ref (tmp);
1492 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1494 return tmp;
1497 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1498 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1499 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1501 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1503 static void
1504 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1505 gfc_symbol * sym, gfc_component * c,
1506 tree base_addr)
1508 gfc_typespec * ts = NULL;
1509 gfc_array_spec * as = NULL;
1510 tree addr_expr = NULL;
1511 tree dt = NULL;
1512 tree string;
1513 tree tmp;
1514 tree dtype;
1515 tree dt_parm_addr;
1516 int n_dim;
1517 int itype;
1518 int rank = 0;
1520 gcc_assert (sym || c);
1522 /* Build the namelist object name. */
1524 string = gfc_build_cstring_const (var_name);
1525 string = gfc_build_addr_expr (pchar_type_node, string);
1527 /* Build ts, as and data address using symbol or component. */
1529 ts = (sym) ? &sym->ts : &c->ts;
1530 as = (sym) ? sym->as : c->as;
1532 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1534 if (as)
1535 rank = as->rank;
1537 if (rank)
1539 dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1540 dtype = gfc_get_dtype (dt);
1542 else
1544 itype = GFC_DTYPE_UNKNOWN;
1546 switch (ts->type)
1549 case BT_INTEGER:
1550 itype = GFC_DTYPE_INTEGER;
1551 break;
1552 case BT_LOGICAL:
1553 itype = GFC_DTYPE_LOGICAL;
1554 break;
1555 case BT_REAL:
1556 itype = GFC_DTYPE_REAL;
1557 break;
1558 case BT_COMPLEX:
1559 itype = GFC_DTYPE_COMPLEX;
1560 break;
1561 case BT_DERIVED:
1562 itype = GFC_DTYPE_DERIVED;
1563 break;
1564 case BT_CHARACTER:
1565 itype = GFC_DTYPE_CHARACTER;
1566 break;
1567 default:
1568 gcc_unreachable ();
1571 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1574 /* Build up the arguments for the transfer call.
1575 The call for the scalar part transfers:
1576 (address, name, type, kind or string_length, dtype) */
1578 dt_parm_addr = build_fold_addr_expr (dt_parm);
1580 if (ts->type == BT_CHARACTER)
1581 tmp = ts->cl->backend_decl;
1582 else
1583 tmp = build_int_cst (gfc_charlen_type_node, 0);
1584 tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL], 6,
1585 dt_parm_addr, addr_expr, string,
1586 IARG (ts->kind), tmp, dtype);
1587 gfc_add_expr_to_block (block, tmp);
1589 /* If the object is an array, transfer rank times:
1590 (null pointer, name, stride, lbound, ubound) */
1592 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1594 tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL_DIM], 5,
1595 dt_parm_addr,
1596 IARG (n_dim),
1597 GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
1598 GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
1599 GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1600 gfc_add_expr_to_block (block, tmp);
1603 if (ts->type == BT_DERIVED)
1605 gfc_component *cmp;
1607 /* Provide the RECORD_TYPE to build component references. */
1609 tree expr = build_fold_indirect_ref (addr_expr);
1611 for (cmp = ts->derived->components; cmp; cmp = cmp->next)
1613 char *full_name = nml_full_name (var_name, cmp->name);
1614 transfer_namelist_element (block,
1615 full_name,
1616 NULL, cmp, expr);
1617 gfc_free (full_name);
1622 #undef IARG
1624 /* Create a data transfer statement. Not all of the fields are valid
1625 for both reading and writing, but improper use has been filtered
1626 out by now. */
1628 static tree
1629 build_dt (tree function, gfc_code * code)
1631 stmtblock_t block, post_block, post_end_block, post_iu_block;
1632 gfc_dt *dt;
1633 tree tmp, var;
1634 gfc_expr *nmlname;
1635 gfc_namelist *nml;
1636 unsigned int mask = 0;
1638 gfc_start_block (&block);
1639 gfc_init_block (&post_block);
1640 gfc_init_block (&post_end_block);
1641 gfc_init_block (&post_iu_block);
1643 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1645 set_error_locus (&block, var, &code->loc);
1647 if (last_dt == IOLENGTH)
1649 gfc_inquire *inq;
1651 inq = code->ext.inquire;
1653 /* First check that preconditions are met. */
1654 gcc_assert (inq != NULL);
1655 gcc_assert (inq->iolength != NULL);
1657 /* Connect to the iolength variable. */
1658 mask |= set_parameter_ref (&block, &post_end_block, var,
1659 IOPARM_dt_iolength, inq->iolength);
1660 dt = NULL;
1662 else
1664 dt = code->ext.dt;
1665 gcc_assert (dt != NULL);
1668 if (dt && dt->io_unit)
1670 if (dt->io_unit->ts.type == BT_CHARACTER)
1672 mask |= set_internal_unit (&block, &post_iu_block,
1673 var, dt->io_unit);
1674 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1677 else
1678 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1680 if (dt)
1682 if (dt->iomsg)
1683 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1684 dt->iomsg);
1686 if (dt->iostat)
1687 mask |= set_parameter_ref (&block, &post_end_block, var,
1688 IOPARM_common_iostat, dt->iostat);
1690 if (dt->err)
1691 mask |= IOPARM_common_err;
1693 if (dt->eor)
1694 mask |= IOPARM_common_eor;
1696 if (dt->end)
1697 mask |= IOPARM_common_end;
1699 if (dt->id)
1700 mask |= set_parameter_ref (&block, &post_end_block, var,
1701 IOPARM_dt_id, dt->id);
1703 if (dt->pos)
1704 mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1706 if (dt->asynchronous)
1707 mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
1708 dt->asynchronous);
1710 if (dt->blank)
1711 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1712 dt->blank);
1714 if (dt->decimal)
1715 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1716 dt->decimal);
1718 if (dt->delim)
1719 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1720 dt->delim);
1722 if (dt->pad)
1723 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1724 dt->pad);
1726 if (dt->round)
1727 mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1728 dt->round);
1730 if (dt->sign)
1731 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1732 dt->sign);
1734 if (dt->rec)
1735 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1737 if (dt->advance)
1738 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1739 dt->advance);
1741 if (dt->format_expr)
1742 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1743 dt->format_expr);
1745 if (dt->format_label)
1747 if (dt->format_label == &format_asterisk)
1748 mask |= IOPARM_dt_list_format;
1749 else
1750 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1751 dt->format_label->format);
1754 if (dt->size)
1755 mask |= set_parameter_ref (&block, &post_end_block, var,
1756 IOPARM_dt_size, dt->size);
1758 if (dt->namelist)
1760 if (dt->format_expr || dt->format_label)
1761 gfc_internal_error ("build_dt: format with namelist");
1763 nmlname = gfc_new_nml_name_expr (dt->namelist->name);
1765 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1766 nmlname);
1768 if (last_dt == READ)
1769 mask |= IOPARM_dt_namelist_read_mode;
1771 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1773 dt_parm = var;
1775 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1776 transfer_namelist_element (&block, nml->sym->name, nml->sym,
1777 NULL, NULL);
1779 else
1780 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1782 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1783 set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
1785 else
1786 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1788 tmp = build_fold_addr_expr (var);
1789 tmp = build_call_expr (function, 1, tmp);
1790 gfc_add_expr_to_block (&block, tmp);
1792 gfc_add_block_to_block (&block, &post_block);
1794 dt_parm = var;
1795 dt_post_end_block = &post_end_block;
1797 gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
1799 gfc_add_block_to_block (&block, &post_iu_block);
1801 dt_parm = NULL;
1802 dt_post_end_block = NULL;
1804 return gfc_finish_block (&block);
1808 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1809 this as a third sort of data transfer statement, except that
1810 lengths are summed instead of actually transferring any data. */
1812 tree
1813 gfc_trans_iolength (gfc_code * code)
1815 last_dt = IOLENGTH;
1816 return build_dt (iocall[IOCALL_IOLENGTH], code);
1820 /* Translate a READ statement. */
1822 tree
1823 gfc_trans_read (gfc_code * code)
1825 last_dt = READ;
1826 return build_dt (iocall[IOCALL_READ], code);
1830 /* Translate a WRITE statement */
1832 tree
1833 gfc_trans_write (gfc_code * code)
1835 last_dt = WRITE;
1836 return build_dt (iocall[IOCALL_WRITE], code);
1840 /* Finish a data transfer statement. */
1842 tree
1843 gfc_trans_dt_end (gfc_code * code)
1845 tree function, tmp;
1846 stmtblock_t block;
1848 gfc_init_block (&block);
1850 switch (last_dt)
1852 case READ:
1853 function = iocall[IOCALL_READ_DONE];
1854 break;
1856 case WRITE:
1857 function = iocall[IOCALL_WRITE_DONE];
1858 break;
1860 case IOLENGTH:
1861 function = iocall[IOCALL_IOLENGTH_DONE];
1862 break;
1864 default:
1865 gcc_unreachable ();
1868 tmp = build_fold_addr_expr (dt_parm);
1869 tmp = build_call_expr (function, 1, tmp);
1870 gfc_add_expr_to_block (&block, tmp);
1871 gfc_add_block_to_block (&block, dt_post_end_block);
1872 gfc_init_block (dt_post_end_block);
1874 if (last_dt != IOLENGTH)
1876 gcc_assert (code->ext.dt != NULL);
1877 io_result (&block, dt_parm, code->ext.dt->err,
1878 code->ext.dt->end, code->ext.dt->eor);
1881 return gfc_finish_block (&block);
1884 static void
1885 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
1887 /* Given an array field in a derived type variable, generate the code
1888 for the loop that iterates over array elements, and the code that
1889 accesses those array elements. Use transfer_expr to generate code
1890 for transferring that element. Because elements may also be
1891 derived types, transfer_expr and transfer_array_component are mutually
1892 recursive. */
1894 static tree
1895 transfer_array_component (tree expr, gfc_component * cm)
1897 tree tmp;
1898 stmtblock_t body;
1899 stmtblock_t block;
1900 gfc_loopinfo loop;
1901 int n;
1902 gfc_ss *ss;
1903 gfc_se se;
1905 gfc_start_block (&block);
1906 gfc_init_se (&se, NULL);
1908 /* Create and initialize Scalarization Status. Unlike in
1909 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1910 care of this task, because we don't have a gfc_expr at hand.
1911 Build one manually, as in gfc_trans_subarray_assign. */
1913 ss = gfc_get_ss ();
1914 ss->type = GFC_SS_COMPONENT;
1915 ss->expr = NULL;
1916 ss->shape = gfc_get_shape (cm->as->rank);
1917 ss->next = gfc_ss_terminator;
1918 ss->data.info.dimen = cm->as->rank;
1919 ss->data.info.descriptor = expr;
1920 ss->data.info.data = gfc_conv_array_data (expr);
1921 ss->data.info.offset = gfc_conv_array_offset (expr);
1922 for (n = 0; n < cm->as->rank; n++)
1924 ss->data.info.dim[n] = n;
1925 ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1926 ss->data.info.stride[n] = gfc_index_one_node;
1928 mpz_init (ss->shape[n]);
1929 mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1930 cm->as->lower[n]->value.integer);
1931 mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1934 /* Once we got ss, we use scalarizer to create the loop. */
1936 gfc_init_loopinfo (&loop);
1937 gfc_add_ss_to_loop (&loop, ss);
1938 gfc_conv_ss_startstride (&loop);
1939 gfc_conv_loop_setup (&loop);
1940 gfc_mark_ss_chain_used (ss, 1);
1941 gfc_start_scalarized_body (&loop, &body);
1943 gfc_copy_loopinfo_to_se (&se, &loop);
1944 se.ss = ss;
1946 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1947 se.expr = expr;
1948 gfc_conv_tmp_array_ref (&se);
1950 /* Now se.expr contains an element of the array. Take the address and pass
1951 it to the IO routines. */
1952 tmp = build_fold_addr_expr (se.expr);
1953 transfer_expr (&se, &cm->ts, tmp, NULL);
1955 /* We are done now with the loop body. Wrap up the scalarizer and
1956 return. */
1958 gfc_add_block_to_block (&body, &se.pre);
1959 gfc_add_block_to_block (&body, &se.post);
1961 gfc_trans_scalarizing_loops (&loop, &body);
1963 gfc_add_block_to_block (&block, &loop.pre);
1964 gfc_add_block_to_block (&block, &loop.post);
1966 for (n = 0; n < cm->as->rank; n++)
1967 mpz_clear (ss->shape[n]);
1968 gfc_free (ss->shape);
1970 gfc_cleanup_loop (&loop);
1972 return gfc_finish_block (&block);
1975 /* Generate the call for a scalar transfer node. */
1977 static void
1978 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
1980 tree tmp, function, arg2, field, expr;
1981 gfc_component *c;
1982 int kind;
1984 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
1985 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
1986 We need to translate the expression to a constant if it's either
1987 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
1988 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
1989 BT_DERIVED (could have been changed by gfc_conv_expr). */
1990 if ((ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL)
1991 || (ts->derived != NULL && ts->derived->ts.is_iso_c == 1))
1993 /* C_PTR and C_FUNPTR have private components which means they can not
1994 be printed. However, if -std=gnu and not -pedantic, allow
1995 the component to be printed to help debugging. */
1996 if (gfc_notification_std (GFC_STD_GNU) != SILENT)
1998 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
1999 ts->derived->name, code != NULL ? &(code->loc) :
2000 &gfc_current_locus);
2001 return;
2004 ts->type = ts->derived->ts.type;
2005 ts->kind = ts->derived->ts.kind;
2006 ts->f90_type = ts->derived->ts.f90_type;
2009 kind = ts->kind;
2010 function = NULL;
2011 arg2 = NULL;
2013 switch (ts->type)
2015 case BT_INTEGER:
2016 arg2 = build_int_cst (NULL_TREE, kind);
2017 function = iocall[IOCALL_X_INTEGER];
2018 break;
2020 case BT_REAL:
2021 arg2 = build_int_cst (NULL_TREE, kind);
2022 function = iocall[IOCALL_X_REAL];
2023 break;
2025 case BT_COMPLEX:
2026 arg2 = build_int_cst (NULL_TREE, kind);
2027 function = iocall[IOCALL_X_COMPLEX];
2028 break;
2030 case BT_LOGICAL:
2031 arg2 = build_int_cst (NULL_TREE, kind);
2032 function = iocall[IOCALL_X_LOGICAL];
2033 break;
2035 case BT_CHARACTER:
2036 case BT_HOLLERITH:
2037 if (se->string_length)
2038 arg2 = se->string_length;
2039 else
2041 tmp = build_fold_indirect_ref (addr_expr);
2042 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2043 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2045 function = iocall[IOCALL_X_CHARACTER];
2046 break;
2048 case BT_DERIVED:
2049 /* Recurse into the elements of the derived type. */
2050 expr = gfc_evaluate_now (addr_expr, &se->pre);
2051 expr = build_fold_indirect_ref (expr);
2053 for (c = ts->derived->components; c; c = c->next)
2055 field = c->backend_decl;
2056 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2058 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2059 expr, field, NULL_TREE);
2061 if (c->dimension)
2063 tmp = transfer_array_component (tmp, c);
2064 gfc_add_expr_to_block (&se->pre, tmp);
2066 else
2068 if (!c->pointer)
2069 tmp = build_fold_addr_expr (tmp);
2070 transfer_expr (se, &c->ts, tmp, code);
2073 return;
2075 default:
2076 internal_error ("Bad IO basetype (%d)", ts->type);
2079 tmp = build_fold_addr_expr (dt_parm);
2080 tmp = build_call_expr (function, 3, tmp, addr_expr, arg2);
2081 gfc_add_expr_to_block (&se->pre, tmp);
2082 gfc_add_block_to_block (&se->pre, &se->post);
2087 /* Generate a call to pass an array descriptor to the IO library. The
2088 array should be of one of the intrinsic types. */
2090 static void
2091 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2093 tree tmp, charlen_arg, kind_arg;
2095 if (ts->type == BT_CHARACTER)
2096 charlen_arg = se->string_length;
2097 else
2098 charlen_arg = build_int_cst (NULL_TREE, 0);
2100 kind_arg = build_int_cst (NULL_TREE, ts->kind);
2102 tmp = build_fold_addr_expr (dt_parm);
2103 tmp = build_call_expr (iocall[IOCALL_X_ARRAY], 4,
2104 tmp, addr_expr, kind_arg, charlen_arg);
2105 gfc_add_expr_to_block (&se->pre, tmp);
2106 gfc_add_block_to_block (&se->pre, &se->post);
2110 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2112 tree
2113 gfc_trans_transfer (gfc_code * code)
2115 stmtblock_t block, body;
2116 gfc_loopinfo loop;
2117 gfc_expr *expr;
2118 gfc_ref *ref;
2119 gfc_ss *ss;
2120 gfc_se se;
2121 tree tmp;
2122 int n;
2124 gfc_start_block (&block);
2125 gfc_init_block (&body);
2127 expr = code->expr;
2128 ss = gfc_walk_expr (expr);
2130 ref = NULL;
2131 gfc_init_se (&se, NULL);
2133 if (ss == gfc_ss_terminator)
2135 /* Transfer a scalar value. */
2136 gfc_conv_expr_reference (&se, expr);
2137 transfer_expr (&se, &expr->ts, se.expr, code);
2139 else
2141 /* Transfer an array. If it is an array of an intrinsic
2142 type, pass the descriptor to the library. Otherwise
2143 scalarize the transfer. */
2144 if (expr->ref)
2146 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2147 ref = ref->next);
2148 gcc_assert (ref->type == REF_ARRAY);
2151 if (expr->ts.type != BT_DERIVED
2152 && ref && ref->next == NULL
2153 && !is_subref_array (expr))
2155 bool seen_vector = false;
2157 if (ref && ref->u.ar.type == AR_SECTION)
2159 for (n = 0; n < ref->u.ar.dimen; n++)
2160 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2161 seen_vector = true;
2164 if (seen_vector && last_dt == READ)
2166 /* Create a temp, read to that and copy it back. */
2167 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT);
2168 tmp = se.expr;
2170 else
2172 /* Get the descriptor. */
2173 gfc_conv_expr_descriptor (&se, expr, ss);
2174 tmp = build_fold_addr_expr (se.expr);
2177 transfer_array_desc (&se, &expr->ts, tmp);
2178 goto finish_block_label;
2181 /* Initialize the scalarizer. */
2182 gfc_init_loopinfo (&loop);
2183 gfc_add_ss_to_loop (&loop, ss);
2185 /* Initialize the loop. */
2186 gfc_conv_ss_startstride (&loop);
2187 gfc_conv_loop_setup (&loop);
2189 /* The main loop body. */
2190 gfc_mark_ss_chain_used (ss, 1);
2191 gfc_start_scalarized_body (&loop, &body);
2193 gfc_copy_loopinfo_to_se (&se, &loop);
2194 se.ss = ss;
2196 gfc_conv_expr_reference (&se, expr);
2197 transfer_expr (&se, &expr->ts, se.expr, code);
2200 finish_block_label:
2202 gfc_add_block_to_block (&body, &se.pre);
2203 gfc_add_block_to_block (&body, &se.post);
2205 if (se.ss == NULL)
2206 tmp = gfc_finish_block (&body);
2207 else
2209 gcc_assert (se.ss == gfc_ss_terminator);
2210 gfc_trans_scalarizing_loops (&loop, &body);
2212 gfc_add_block_to_block (&loop.pre, &loop.post);
2213 tmp = gfc_finish_block (&loop.pre);
2214 gfc_cleanup_loop (&loop);
2217 gfc_add_expr_to_block (&block, tmp);
2219 return gfc_finish_block (&block);
2222 #include "gt-fortran-trans-io.h"