1 /* IO Code translation/library interface
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook
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
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
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/>. */
25 #include "coretypes.h"
28 #include "diagnostic-core.h" /* For internal_error. */
31 #include "trans-stmt.h"
32 #include "trans-array.h"
33 #include "trans-types.h"
34 #include "trans-const.h"
36 /* Members of the ioparm structure. */
65 typedef struct GTY(()) gfc_st_parameter_field {
68 enum ioparam_type param_type;
69 enum iofield_type type;
73 gfc_st_parameter_field;
75 typedef struct GTY(()) gfc_st_parameter {
83 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
89 static GTY(()) gfc_st_parameter st_parameter[] =
100 static GTY(()) gfc_st_parameter_field st_parameter_field[] =
102 #define IOPARM(param_type, name, mask, type) \
103 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
104 #include "ioparm.def"
106 { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL }
109 /* Library I/O subroutines */
118 IOCALL_X_INTEGER_WRITE,
120 IOCALL_X_LOGICAL_WRITE,
122 IOCALL_X_CHARACTER_WRITE,
123 IOCALL_X_CHARACTER_WIDE,
124 IOCALL_X_CHARACTER_WIDE_WRITE,
128 IOCALL_X_COMPLEX_WRITE,
130 IOCALL_X_ARRAY_WRITE,
135 IOCALL_IOLENGTH_DONE,
141 IOCALL_SET_NML_VAL_DIM,
146 static GTY(()) tree iocall[IOCALL_NUM];
148 /* Variable for keeping track of what the last data transfer statement
149 was. Used for deciding which subroutine to call when the data
150 transfer is complete. */
151 static enum { READ, WRITE, IOLENGTH } last_dt;
153 /* The data transfer parameter block that should be shared by all
154 data transfer calls belonging to the same read/write/iolength. */
155 static GTY(()) tree dt_parm;
156 static stmtblock_t *dt_post_end_block;
159 gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
162 gfc_st_parameter_field *p;
165 tree t = make_node (RECORD_TYPE);
168 len = strlen (st_parameter[ptype].name);
169 gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
170 memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
171 memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
173 TYPE_NAME (t) = get_identifier (name);
175 for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
176 if (p->param_type == ptype)
179 case IOPARM_type_int4:
180 case IOPARM_type_intio:
181 case IOPARM_type_pint4:
182 case IOPARM_type_pintio:
183 case IOPARM_type_parray:
184 case IOPARM_type_pchar:
185 case IOPARM_type_pad:
186 p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
187 types[p->type], &chain);
189 case IOPARM_type_char1:
190 p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
191 pchar_type_node, &chain);
193 case IOPARM_type_char2:
194 len = strlen (p->name);
195 gcc_assert (len <= sizeof (name) - sizeof ("_len"));
196 memcpy (name, p->name, len);
197 memcpy (name + len, "_len", sizeof ("_len"));
198 p->field_len = gfc_add_field_to_struct (t, get_identifier (name),
199 gfc_charlen_type_node,
201 if (p->type == IOPARM_type_char2)
202 p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
203 pchar_type_node, &chain);
205 case IOPARM_type_common:
207 = gfc_add_field_to_struct (t,
208 get_identifier (p->name),
209 st_parameter[IOPARM_ptype_common].type,
212 case IOPARM_type_num:
217 st_parameter[ptype].type = t;
221 /* Build code to test an error condition and call generate_error if needed.
222 Note: This builds calls to generate_error in the runtime library function.
223 The function generate_error is dependent on certain parameters in the
224 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
225 Therefore, the code to set these flags must be generated before
226 this function is used. */
229 gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
230 const char * msgid, stmtblock_t * pblock)
235 tree arg1, arg2, arg3;
238 if (integer_zerop (cond))
241 /* The code to generate the error. */
242 gfc_start_block (&block);
244 arg1 = gfc_build_addr_expr (NULL_TREE, var);
246 arg2 = build_int_cst (integer_type_node, error_code),
248 asprintf (&message, "%s", _(msgid));
249 arg3 = gfc_build_addr_expr (pchar_type_node,
250 gfc_build_localized_cstring_const (message));
253 tmp = build_call_expr_loc (input_location,
254 gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
256 gfc_add_expr_to_block (&block, tmp);
258 body = gfc_finish_block (&block);
260 if (integer_onep (cond))
262 gfc_add_expr_to_block (pblock, body);
266 /* Tell the compiler that this isn't likely. */
267 cond = fold_convert (long_integer_type_node, cond);
268 tmp = build_int_cst (long_integer_type_node, 0);
269 cond = build_call_expr_loc (input_location,
270 built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
271 cond = fold_convert (boolean_type_node, cond);
273 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
274 gfc_add_expr_to_block (pblock, tmp);
279 /* Create function decls for IO library functions. */
282 gfc_build_io_library_fndecls (void)
284 tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
285 tree gfc_intio_type_node;
286 tree parm_type, dt_parm_type;
287 HOST_WIDE_INT pad_size;
290 types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
291 types[IOPARM_type_intio] = gfc_intio_type_node
292 = gfc_get_int_type (gfc_intio_kind);
293 types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
294 types[IOPARM_type_pintio]
295 = build_pointer_type (gfc_intio_type_node);
296 types[IOPARM_type_parray] = pchar_type_node;
297 types[IOPARM_type_pchar] = pchar_type_node;
298 pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
299 pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
300 pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size - 1));
301 types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
303 /* pad actually contains pointers and integers so it needs to have an
304 alignment that is at least as large as the needed alignment for those
305 types. See the st_parameter_dt structure in libgfortran/io/io.h for
306 what really goes into this space. */
307 TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
308 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)));
310 for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
311 gfc_build_st_parameter ((enum ioparam_type) ptype, types);
313 /* Define the transfer functions. */
315 dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
317 iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec (
318 get_identifier (PREFIX("transfer_integer")), ".wW",
319 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
321 iocall[IOCALL_X_INTEGER_WRITE] = gfc_build_library_function_decl_with_spec (
322 get_identifier (PREFIX("transfer_integer_write")), ".wR",
323 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
325 iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec (
326 get_identifier (PREFIX("transfer_logical")), ".wW",
327 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
329 iocall[IOCALL_X_LOGICAL_WRITE] = gfc_build_library_function_decl_with_spec (
330 get_identifier (PREFIX("transfer_logical_write")), ".wR",
331 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
333 iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec (
334 get_identifier (PREFIX("transfer_character")), ".wW",
335 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
337 iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec (
338 get_identifier (PREFIX("transfer_character_write")), ".wR",
339 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
341 iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec (
342 get_identifier (PREFIX("transfer_character_wide")), ".wW",
343 void_type_node, 4, dt_parm_type, pvoid_type_node,
344 gfc_charlen_type_node, gfc_int4_type_node);
346 iocall[IOCALL_X_CHARACTER_WIDE_WRITE] =
347 gfc_build_library_function_decl_with_spec (
348 get_identifier (PREFIX("transfer_character_wide_write")), ".wR",
349 void_type_node, 4, dt_parm_type, pvoid_type_node,
350 gfc_charlen_type_node, gfc_int4_type_node);
352 iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec (
353 get_identifier (PREFIX("transfer_real")), ".wW",
354 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
356 iocall[IOCALL_X_REAL_WRITE] = gfc_build_library_function_decl_with_spec (
357 get_identifier (PREFIX("transfer_real_write")), ".wR",
358 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
360 iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec (
361 get_identifier (PREFIX("transfer_complex")), ".wW",
362 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
364 iocall[IOCALL_X_COMPLEX_WRITE] = gfc_build_library_function_decl_with_spec (
365 get_identifier (PREFIX("transfer_complex_write")), ".wR",
366 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
368 iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec (
369 get_identifier (PREFIX("transfer_array")), ".ww",
370 void_type_node, 4, dt_parm_type, pvoid_type_node,
371 integer_type_node, gfc_charlen_type_node);
373 iocall[IOCALL_X_ARRAY_WRITE] = gfc_build_library_function_decl_with_spec (
374 get_identifier (PREFIX("transfer_array_write")), ".wr",
375 void_type_node, 4, dt_parm_type, pvoid_type_node,
376 integer_type_node, gfc_charlen_type_node);
378 /* Library entry points */
380 iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
381 get_identifier (PREFIX("st_read")), ".w",
382 void_type_node, 1, dt_parm_type);
384 iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec (
385 get_identifier (PREFIX("st_write")), ".w",
386 void_type_node, 1, dt_parm_type);
388 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
389 iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec (
390 get_identifier (PREFIX("st_open")), ".w",
391 void_type_node, 1, parm_type);
393 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
394 iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec (
395 get_identifier (PREFIX("st_close")), ".w",
396 void_type_node, 1, parm_type);
398 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
399 iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec (
400 get_identifier (PREFIX("st_inquire")), ".w",
401 void_type_node, 1, parm_type);
403 iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec(
404 get_identifier (PREFIX("st_iolength")), ".w",
405 void_type_node, 1, dt_parm_type);
407 /* TODO: Change when asynchronous I/O is implemented. */
408 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
409 iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
410 get_identifier (PREFIX("st_wait")), ".X",
411 void_type_node, 1, parm_type);
413 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
414 iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec (
415 get_identifier (PREFIX("st_rewind")), ".w",
416 void_type_node, 1, parm_type);
418 iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec (
419 get_identifier (PREFIX("st_backspace")), ".w",
420 void_type_node, 1, parm_type);
422 iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec (
423 get_identifier (PREFIX("st_endfile")), ".w",
424 void_type_node, 1, parm_type);
426 iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec (
427 get_identifier (PREFIX("st_flush")), ".w",
428 void_type_node, 1, parm_type);
430 /* Library helpers */
432 iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec (
433 get_identifier (PREFIX("st_read_done")), ".w",
434 void_type_node, 1, dt_parm_type);
436 iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec (
437 get_identifier (PREFIX("st_write_done")), ".w",
438 void_type_node, 1, dt_parm_type);
440 iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec (
441 get_identifier (PREFIX("st_iolength_done")), ".w",
442 void_type_node, 1, dt_parm_type);
444 iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
445 get_identifier (PREFIX("st_set_nml_var")), ".w.R",
446 void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
447 void_type_node, gfc_charlen_type_node, gfc_int4_type_node);
449 iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
450 get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
451 void_type_node, 5, dt_parm_type, gfc_int4_type_node,
452 gfc_array_index_type, gfc_array_index_type, gfc_array_index_type);
456 /* Generate code to store an integer constant into the
457 st_parameter_XXX structure. */
460 set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
464 gfc_st_parameter_field *p = &st_parameter_field[type];
466 if (p->param_type == IOPARM_ptype_common)
467 var = fold_build3_loc (input_location, COMPONENT_REF,
468 st_parameter[IOPARM_ptype_common].type,
469 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
470 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
471 var, p->field, NULL_TREE);
472 gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
477 /* Generate code to store a non-string I/O parameter into the
478 st_parameter_XXX structure. This is a pass by value. */
481 set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
486 gfc_st_parameter_field *p = &st_parameter_field[type];
487 tree dest_type = TREE_TYPE (p->field);
489 gfc_init_se (&se, NULL);
490 gfc_conv_expr_val (&se, e);
492 /* If we're storing a UNIT number, we need to check it first. */
493 if (type == IOPARM_common_unit && e->ts.kind > 4)
498 /* Don't evaluate the UNIT number multiple times. */
499 se.expr = gfc_evaluate_now (se.expr, &se.pre);
501 /* UNIT numbers should be greater than the min. */
502 i = gfc_validate_kind (BT_INTEGER, 4, false);
503 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
504 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
506 fold_convert (TREE_TYPE (se.expr), val));
507 gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
508 "Unit number in I/O statement too small",
511 /* UNIT numbers should be less than the max. */
512 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
513 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
515 fold_convert (TREE_TYPE (se.expr), val));
516 gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
517 "Unit number in I/O statement too large",
522 se.expr = convert (dest_type, se.expr);
523 gfc_add_block_to_block (block, &se.pre);
525 if (p->param_type == IOPARM_ptype_common)
526 var = fold_build3_loc (input_location, COMPONENT_REF,
527 st_parameter[IOPARM_ptype_common].type,
528 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
530 tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
531 p->field, NULL_TREE);
532 gfc_add_modify (block, tmp, se.expr);
537 /* Generate code to store a non-string I/O parameter into the
538 st_parameter_XXX structure. This is pass by reference. */
541 set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
542 tree var, enum iofield type, gfc_expr *e)
546 gfc_st_parameter_field *p = &st_parameter_field[type];
548 gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
549 gfc_init_se (&se, NULL);
550 gfc_conv_expr_lhs (&se, e);
552 gfc_add_block_to_block (block, &se.pre);
554 if (TYPE_MODE (TREE_TYPE (se.expr))
555 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
557 addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
559 /* If this is for the iostat variable initialize the
560 user variable to LIBERROR_OK which is zero. */
561 if (type == IOPARM_common_iostat)
562 gfc_add_modify (block, se.expr,
563 build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
567 /* The type used by the library has different size
568 from the type of the variable supplied by the user.
569 Need to use a temporary. */
570 tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
571 st_parameter_field[type].name);
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, tmpvar,
577 build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
579 addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
580 /* After the I/O operation, we set the variable from the temporary. */
581 tmp = convert (TREE_TYPE (se.expr), tmpvar);
582 gfc_add_modify (postblock, se.expr, tmp);
585 if (p->param_type == IOPARM_ptype_common)
586 var = fold_build3_loc (input_location, COMPONENT_REF,
587 st_parameter[IOPARM_ptype_common].type,
588 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
589 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
590 var, p->field, NULL_TREE);
591 gfc_add_modify (block, tmp, addr);
595 /* Given an array expr, find its address and length to get a string. If the
596 array is full, the string's address is the address of array's first element
597 and the length is the size of the whole array. If it is an element, the
598 string's address is the element's address and the length is the rest size of
602 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
608 tree type, array, tmp;
612 /* If it is an element, we need its address and size of the rest. */
613 gcc_assert (e->expr_type == EXPR_VARIABLE);
614 gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
615 sym = e->symtree->n.sym;
616 rank = sym->as->rank - 1;
617 gfc_conv_expr (se, e);
619 array = sym->backend_decl;
620 type = TREE_TYPE (array);
622 if (GFC_ARRAY_TYPE_P (type))
623 size = GFC_TYPE_ARRAY_SIZE (type);
626 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
627 size = gfc_conv_array_stride (array, rank);
628 tmp = fold_build2_loc (input_location, MINUS_EXPR,
629 gfc_array_index_type,
630 gfc_conv_array_ubound (array, rank),
631 gfc_conv_array_lbound (array, rank));
632 tmp = fold_build2_loc (input_location, PLUS_EXPR,
633 gfc_array_index_type, tmp,
635 size = fold_build2_loc (input_location, MULT_EXPR,
636 gfc_array_index_type, tmp, size);
640 size = fold_build2_loc (input_location, MINUS_EXPR,
641 gfc_array_index_type, size,
642 TREE_OPERAND (se->expr, 1));
643 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
644 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
645 size = fold_build2_loc (input_location, MULT_EXPR,
646 gfc_array_index_type, size,
647 fold_convert (gfc_array_index_type, tmp));
648 se->string_length = fold_convert (gfc_charlen_type_node, size);
652 gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);
653 se->string_length = fold_convert (gfc_charlen_type_node, size);
657 /* Generate code to store a string and its length into the
658 st_parameter_XXX structure. */
661 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
662 enum iofield type, gfc_expr * e)
668 gfc_st_parameter_field *p = &st_parameter_field[type];
670 gfc_init_se (&se, NULL);
672 if (p->param_type == IOPARM_ptype_common)
673 var = fold_build3_loc (input_location, COMPONENT_REF,
674 st_parameter[IOPARM_ptype_common].type,
675 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
676 io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
677 var, p->field, NULL_TREE);
678 len = fold_build3_loc (input_location, COMPONENT_REF,
679 TREE_TYPE (p->field_len),
680 var, p->field_len, NULL_TREE);
682 /* Integer variable assigned a format label. */
683 if (e->ts.type == BT_INTEGER
685 && e->symtree->n.sym->attr.assign == 1)
690 gfc_conv_label_variable (&se, e);
691 tmp = GFC_DECL_STRING_LEN (se.expr);
692 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
693 tmp, build_int_cst (TREE_TYPE (tmp), 0));
695 asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
696 "label", e->symtree->name);
697 gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
698 fold_convert (long_integer_type_node, tmp));
701 gfc_add_modify (&se.pre, io,
702 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
703 gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
707 /* General character. */
708 if (e->ts.type == BT_CHARACTER && e->rank == 0)
709 gfc_conv_expr (&se, e);
710 /* Array assigned Hollerith constant or character array. */
711 else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
712 gfc_convert_array_to_string (&se, e);
716 gfc_conv_string_parameter (&se);
717 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
718 gfc_add_modify (&se.pre, len, se.string_length);
721 gfc_add_block_to_block (block, &se.pre);
722 gfc_add_block_to_block (postblock, &se.post);
727 /* Generate code to store the character (array) and the character length
728 for an internal unit. */
731 set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
732 tree var, gfc_expr * e)
739 gfc_st_parameter_field *p;
742 gfc_init_se (&se, NULL);
744 p = &st_parameter_field[IOPARM_dt_internal_unit];
746 io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
747 var, p->field, NULL_TREE);
748 len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len),
749 var, p->field_len, NULL_TREE);
750 p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
751 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
752 var, p->field, NULL_TREE);
754 gcc_assert (e->ts.type == BT_CHARACTER);
756 /* Character scalars. */
759 gfc_conv_expr (&se, e);
760 gfc_conv_string_parameter (&se);
762 se.expr = build_int_cst (pchar_type_node, 0);
765 /* Character array. */
766 else if (e->rank > 0)
768 se.ss = gfc_walk_expr (e);
770 if (is_subref_array (e))
772 /* Use a temporary for components of arrays of derived types
773 or substring array references. */
774 gfc_conv_subref_array_arg (&se, e, 0,
775 last_dt == READ ? INTENT_IN : INTENT_OUT, false);
776 tmp = build_fold_indirect_ref_loc (input_location,
778 se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
779 tmp = gfc_conv_descriptor_data_get (tmp);
783 /* Return the data pointer and rank from the descriptor. */
784 gfc_conv_expr_descriptor (&se, e, se.ss);
785 tmp = gfc_conv_descriptor_data_get (se.expr);
786 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
792 /* The cast is needed for character substrings and the descriptor
794 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
795 gfc_add_modify (&se.pre, len,
796 fold_convert (TREE_TYPE (len), se.string_length));
797 gfc_add_modify (&se.pre, desc, se.expr);
799 gfc_add_block_to_block (block, &se.pre);
800 gfc_add_block_to_block (post_block, &se.post);
804 /* Add a case to a IO-result switch. */
807 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
812 return; /* No label, no case */
814 value = build_int_cst (NULL_TREE, label_value);
816 /* Make a backend label for this case. */
817 tmp = gfc_build_label_decl (NULL_TREE);
819 /* And the case itself. */
820 tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
821 gfc_add_expr_to_block (body, tmp);
823 /* Jump to the label. */
824 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
825 gfc_add_expr_to_block (body, tmp);
829 /* Generate a switch statement that branches to the correct I/O
830 result label. The last statement of an I/O call stores the
831 result into a variable because there is often cleanup that
832 must be done before the switch, so a temporary would have to
833 be created anyway. */
836 io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
837 gfc_st_label * end_label, gfc_st_label * eor_label)
841 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
843 /* If no labels are specified, ignore the result instead
844 of building an empty switch. */
845 if (err_label == NULL
847 && eor_label == NULL)
850 /* Build a switch statement. */
851 gfc_start_block (&body);
853 /* The label values here must be the same as the values
854 in the library_return enum in the runtime library */
855 add_case (1, err_label, &body);
856 add_case (2, end_label, &body);
857 add_case (3, eor_label, &body);
859 tmp = gfc_finish_block (&body);
861 var = fold_build3_loc (input_location, COMPONENT_REF,
862 st_parameter[IOPARM_ptype_common].type,
863 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
864 rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
865 var, p->field, NULL_TREE);
866 rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc),
867 rc, build_int_cst (TREE_TYPE (rc),
868 IOPARM_common_libreturn_mask));
870 tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
872 gfc_add_expr_to_block (block, tmp);
876 /* Store the current file and line number to variables so that if a
877 library call goes awry, we can tell the user where the problem is. */
880 set_error_locus (stmtblock_t * block, tree var, locus * where)
883 tree str, locus_file;
885 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
887 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
888 st_parameter[IOPARM_ptype_common].type,
889 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
890 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
891 TREE_TYPE (p->field), locus_file,
892 p->field, NULL_TREE);
894 str = gfc_build_cstring_const (f->filename);
896 str = gfc_build_addr_expr (pchar_type_node, str);
897 gfc_add_modify (block, locus_file, str);
899 line = LOCATION_LINE (where->lb->location);
900 set_parameter_const (block, var, IOPARM_common_line, line);
904 /* Translate an OPEN statement. */
907 gfc_trans_open (gfc_code * code)
909 stmtblock_t block, post_block;
912 unsigned int mask = 0;
914 gfc_start_block (&block);
915 gfc_init_block (&post_block);
917 var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
919 set_error_locus (&block, var, &code->loc);
923 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
927 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
931 mask |= IOPARM_common_err;
934 mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
937 mask |= set_string (&block, &post_block, var, IOPARM_open_status,
941 mask |= set_string (&block, &post_block, var, IOPARM_open_access,
945 mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
948 mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
951 mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
955 mask |= set_string (&block, &post_block, var, IOPARM_open_position,
959 mask |= set_string (&block, &post_block, var, IOPARM_open_action,
963 mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
967 mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
970 mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
974 mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
978 mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
981 mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
984 mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
988 mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
992 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
995 set_parameter_const (&block, var, IOPARM_common_flags, mask);
998 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1000 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1002 tmp = gfc_build_addr_expr (NULL_TREE, var);
1003 tmp = build_call_expr_loc (input_location,
1004 iocall[IOCALL_OPEN], 1, tmp);
1005 gfc_add_expr_to_block (&block, tmp);
1007 gfc_add_block_to_block (&block, &post_block);
1009 io_result (&block, var, p->err, NULL, NULL);
1011 return gfc_finish_block (&block);
1015 /* Translate a CLOSE statement. */
1018 gfc_trans_close (gfc_code * code)
1020 stmtblock_t block, post_block;
1023 unsigned int mask = 0;
1025 gfc_start_block (&block);
1026 gfc_init_block (&post_block);
1028 var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
1030 set_error_locus (&block, var, &code->loc);
1031 p = code->ext.close;
1034 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1038 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1042 mask |= IOPARM_common_err;
1045 mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1048 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1051 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1053 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1055 tmp = gfc_build_addr_expr (NULL_TREE, var);
1056 tmp = build_call_expr_loc (input_location,
1057 iocall[IOCALL_CLOSE], 1, tmp);
1058 gfc_add_expr_to_block (&block, tmp);
1060 gfc_add_block_to_block (&block, &post_block);
1062 io_result (&block, var, p->err, NULL, NULL);
1064 return gfc_finish_block (&block);
1068 /* Common subroutine for building a file positioning statement. */
1071 build_filepos (tree function, gfc_code * code)
1073 stmtblock_t block, post_block;
1076 unsigned int mask = 0;
1078 p = code->ext.filepos;
1080 gfc_start_block (&block);
1081 gfc_init_block (&post_block);
1083 var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1086 set_error_locus (&block, var, &code->loc);
1089 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1093 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1097 mask |= IOPARM_common_err;
1099 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1102 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1104 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1106 tmp = gfc_build_addr_expr (NULL_TREE, var);
1107 tmp = build_call_expr_loc (input_location,
1109 gfc_add_expr_to_block (&block, tmp);
1111 gfc_add_block_to_block (&block, &post_block);
1113 io_result (&block, var, p->err, NULL, NULL);
1115 return gfc_finish_block (&block);
1119 /* Translate a BACKSPACE statement. */
1122 gfc_trans_backspace (gfc_code * code)
1124 return build_filepos (iocall[IOCALL_BACKSPACE], code);
1128 /* Translate an ENDFILE statement. */
1131 gfc_trans_endfile (gfc_code * code)
1133 return build_filepos (iocall[IOCALL_ENDFILE], code);
1137 /* Translate a REWIND statement. */
1140 gfc_trans_rewind (gfc_code * code)
1142 return build_filepos (iocall[IOCALL_REWIND], code);
1146 /* Translate a FLUSH statement. */
1149 gfc_trans_flush (gfc_code * code)
1151 return build_filepos (iocall[IOCALL_FLUSH], code);
1155 /* Create a dummy iostat variable to catch any error due to bad unit. */
1158 create_dummy_iostat (void)
1163 gfc_get_ha_sym_tree ("@iostat", &st);
1164 st->n.sym->ts.type = BT_INTEGER;
1165 st->n.sym->ts.kind = gfc_default_integer_kind;
1166 gfc_set_sym_referenced (st->n.sym);
1167 gfc_commit_symbol (st->n.sym);
1168 st->n.sym->backend_decl
1169 = gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind),
1172 e = gfc_get_expr ();
1173 e->expr_type = EXPR_VARIABLE;
1175 e->ts.type = BT_INTEGER;
1176 e->ts.kind = st->n.sym->ts.kind;
1182 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1185 gfc_trans_inquire (gfc_code * code)
1187 stmtblock_t block, post_block;
1190 unsigned int mask = 0, mask2 = 0;
1192 gfc_start_block (&block);
1193 gfc_init_block (&post_block);
1195 var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1198 set_error_locus (&block, var, &code->loc);
1199 p = code->ext.inquire;
1202 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1206 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1210 mask |= IOPARM_common_err;
1213 if (p->unit && p->file)
1214 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1217 mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1222 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1225 if (p->unit && !p->iostat)
1227 p->iostat = create_dummy_iostat ();
1228 mask |= set_parameter_ref (&block, &post_block, var,
1229 IOPARM_common_iostat, p->iostat);
1234 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1238 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1242 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1246 mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1250 mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1254 mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1258 mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1262 mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1266 mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1270 mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1274 mask |= set_parameter_ref (&block, &post_block, var,
1275 IOPARM_inquire_recl_out, p->recl);
1278 mask |= set_parameter_ref (&block, &post_block, var,
1279 IOPARM_inquire_nextrec, p->nextrec);
1282 mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1286 mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1290 mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1294 mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1298 mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1302 mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1306 mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1310 mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1314 mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1318 mask |= set_parameter_ref (&block, &post_block, var,
1319 IOPARM_inquire_strm_pos_out, p->strm_pos);
1321 /* The second series of flags. */
1322 if (p->asynchronous)
1323 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1327 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1331 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1335 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1339 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1343 mask2 |= set_parameter_ref (&block, &post_block, var,
1344 IOPARM_inquire_pending, p->pending);
1347 mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1351 mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1355 mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
1357 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1360 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1362 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1364 tmp = gfc_build_addr_expr (NULL_TREE, var);
1365 tmp = build_call_expr_loc (input_location,
1366 iocall[IOCALL_INQUIRE], 1, tmp);
1367 gfc_add_expr_to_block (&block, tmp);
1369 gfc_add_block_to_block (&block, &post_block);
1371 io_result (&block, var, p->err, NULL, NULL);
1373 return gfc_finish_block (&block);
1378 gfc_trans_wait (gfc_code * code)
1380 stmtblock_t block, post_block;
1383 unsigned int mask = 0;
1385 gfc_start_block (&block);
1386 gfc_init_block (&post_block);
1388 var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1391 set_error_locus (&block, var, &code->loc);
1394 /* Set parameters here. */
1396 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1400 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1404 mask |= IOPARM_common_err;
1407 mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
1409 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1412 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1414 tmp = gfc_build_addr_expr (NULL_TREE, var);
1415 tmp = build_call_expr_loc (input_location,
1416 iocall[IOCALL_WAIT], 1, tmp);
1417 gfc_add_expr_to_block (&block, tmp);
1419 gfc_add_block_to_block (&block, &post_block);
1421 io_result (&block, var, p->err, NULL, NULL);
1423 return gfc_finish_block (&block);
1428 /* nml_full_name builds up the fully qualified name of a
1429 derived type component. */
1432 nml_full_name (const char* var_name, const char* cmp_name)
1434 int full_name_length;
1437 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1438 full_name = (char*)gfc_getmem (full_name_length + 1);
1439 strcpy (full_name, var_name);
1440 full_name = strcat (full_name, "%");
1441 full_name = strcat (full_name, cmp_name);
1445 /* nml_get_addr_expr builds an address expression from the
1446 gfc_symbol or gfc_component backend_decl's. An offset is
1447 provided so that the address of an element of an array of
1448 derived types is returned. This is used in the runtime to
1449 determine that span of the derived type. */
1452 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1455 tree decl = NULL_TREE;
1459 int dummy_arg_flagged;
1463 sym->attr.referenced = 1;
1464 decl = gfc_get_symbol_decl (sym);
1466 /* If this is the enclosing function declaration, use
1467 the fake result instead. */
1468 if (decl == current_function_decl)
1469 decl = gfc_get_fake_result_decl (sym, 0);
1470 else if (decl == DECL_CONTEXT (current_function_decl))
1471 decl = gfc_get_fake_result_decl (sym, 1);
1474 decl = c->backend_decl;
1476 gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1477 || TREE_CODE (decl) == VAR_DECL
1478 || TREE_CODE (decl) == PARM_DECL)
1479 || TREE_CODE (decl) == COMPONENT_REF));
1483 /* Build indirect reference, if dummy argument. */
1485 dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
1487 itmp = (dummy_arg_flagged) ? build_fold_indirect_ref_loc (input_location,
1490 /* If an array, set flag and use indirect ref. if built. */
1492 array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
1493 && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
1498 /* Treat the component of a derived type, using base_addr for
1499 the derived type. */
1501 if (TREE_CODE (decl) == FIELD_DECL)
1502 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
1503 base_addr, tmp, NULL_TREE);
1505 /* If we have a derived type component, a reference to the first
1506 element of the array is built. This is done so that base_addr,
1507 used in the build of the component reference, always points to
1511 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1513 /* Now build the address expression. */
1515 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1517 /* If scalar dummy, resolve indirect reference now. */
1519 if (dummy_arg_flagged && !array_flagged)
1520 tmp = build_fold_indirect_ref_loc (input_location,
1523 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1528 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1529 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1530 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1532 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1535 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1536 gfc_symbol * sym, gfc_component * c,
1539 gfc_typespec * ts = NULL;
1540 gfc_array_spec * as = NULL;
1541 tree addr_expr = NULL;
1551 gcc_assert (sym || c);
1553 /* Build the namelist object name. */
1555 string = gfc_build_cstring_const (var_name);
1556 string = gfc_build_addr_expr (pchar_type_node, string);
1558 /* Build ts, as and data address using symbol or component. */
1560 ts = (sym) ? &sym->ts : &c->ts;
1561 as = (sym) ? sym->as : c->as;
1563 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1570 dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1571 dtype = gfc_get_dtype (dt);
1575 itype = GFC_DTYPE_UNKNOWN;
1581 itype = GFC_DTYPE_INTEGER;
1584 itype = GFC_DTYPE_LOGICAL;
1587 itype = GFC_DTYPE_REAL;
1590 itype = GFC_DTYPE_COMPLEX;
1593 itype = GFC_DTYPE_DERIVED;
1596 itype = GFC_DTYPE_CHARACTER;
1602 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1605 /* Build up the arguments for the transfer call.
1606 The call for the scalar part transfers:
1607 (address, name, type, kind or string_length, dtype) */
1609 dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1611 if (ts->type == BT_CHARACTER)
1612 tmp = ts->u.cl->backend_decl;
1614 tmp = build_int_cst (gfc_charlen_type_node, 0);
1615 tmp = build_call_expr_loc (input_location,
1616 iocall[IOCALL_SET_NML_VAL], 6,
1617 dt_parm_addr, addr_expr, string,
1618 IARG (ts->kind), tmp, dtype);
1619 gfc_add_expr_to_block (block, tmp);
1621 /* If the object is an array, transfer rank times:
1622 (null pointer, name, stride, lbound, ubound) */
1624 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1626 tmp = build_call_expr_loc (input_location,
1627 iocall[IOCALL_SET_NML_VAL_DIM], 5,
1630 GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
1631 GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
1632 GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1633 gfc_add_expr_to_block (block, tmp);
1636 if (ts->type == BT_DERIVED)
1640 /* Provide the RECORD_TYPE to build component references. */
1642 tree expr = build_fold_indirect_ref_loc (input_location,
1645 for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1647 char *full_name = nml_full_name (var_name, cmp->name);
1648 transfer_namelist_element (block,
1651 gfc_free (full_name);
1658 /* Create a data transfer statement. Not all of the fields are valid
1659 for both reading and writing, but improper use has been filtered
1663 build_dt (tree function, gfc_code * code)
1665 stmtblock_t block, post_block, post_end_block, post_iu_block;
1670 unsigned int mask = 0;
1672 gfc_start_block (&block);
1673 gfc_init_block (&post_block);
1674 gfc_init_block (&post_end_block);
1675 gfc_init_block (&post_iu_block);
1677 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1679 set_error_locus (&block, var, &code->loc);
1681 if (last_dt == IOLENGTH)
1685 inq = code->ext.inquire;
1687 /* First check that preconditions are met. */
1688 gcc_assert (inq != NULL);
1689 gcc_assert (inq->iolength != NULL);
1691 /* Connect to the iolength variable. */
1692 mask |= set_parameter_ref (&block, &post_end_block, var,
1693 IOPARM_dt_iolength, inq->iolength);
1699 gcc_assert (dt != NULL);
1702 if (dt && dt->io_unit)
1704 if (dt->io_unit->ts.type == BT_CHARACTER)
1706 mask |= set_internal_unit (&block, &post_iu_block,
1708 set_parameter_const (&block, var, IOPARM_common_unit,
1709 dt->io_unit->ts.kind == 1 ? 0 : -1);
1713 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1718 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1722 mask |= set_parameter_ref (&block, &post_end_block, var,
1723 IOPARM_common_iostat, dt->iostat);
1726 mask |= IOPARM_common_err;
1729 mask |= IOPARM_common_eor;
1732 mask |= IOPARM_common_end;
1735 mask |= set_parameter_ref (&block, &post_end_block, var,
1736 IOPARM_dt_id, dt->id);
1739 mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1741 if (dt->asynchronous)
1742 mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
1746 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1750 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1754 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1758 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1762 mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1766 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1770 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1773 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1776 if (dt->format_expr)
1777 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1780 if (dt->format_label)
1782 if (dt->format_label == &format_asterisk)
1783 mask |= IOPARM_dt_list_format;
1785 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1786 dt->format_label->format);
1790 mask |= set_parameter_ref (&block, &post_end_block, var,
1791 IOPARM_dt_size, dt->size);
1795 if (dt->format_expr || dt->format_label)
1796 gfc_internal_error ("build_dt: format with namelist");
1798 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1800 strlen (dt->namelist->name));
1802 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1805 if (last_dt == READ)
1806 mask |= IOPARM_dt_namelist_read_mode;
1808 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1812 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1813 transfer_namelist_element (&block, nml->sym->name, nml->sym,
1817 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1819 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1820 set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
1823 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1825 tmp = gfc_build_addr_expr (NULL_TREE, var);
1826 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
1828 gfc_add_expr_to_block (&block, tmp);
1830 gfc_add_block_to_block (&block, &post_block);
1833 dt_post_end_block = &post_end_block;
1835 /* Set implied do loop exit condition. */
1836 if (last_dt == READ || last_dt == WRITE)
1838 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
1840 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1841 st_parameter[IOPARM_ptype_common].type,
1842 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
1844 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1845 TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
1846 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
1847 tmp, build_int_cst (TREE_TYPE (tmp),
1848 IOPARM_common_libreturn_mask));
1853 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
1855 gfc_add_block_to_block (&block, &post_iu_block);
1858 dt_post_end_block = NULL;
1860 return gfc_finish_block (&block);
1864 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1865 this as a third sort of data transfer statement, except that
1866 lengths are summed instead of actually transferring any data. */
1869 gfc_trans_iolength (gfc_code * code)
1872 return build_dt (iocall[IOCALL_IOLENGTH], code);
1876 /* Translate a READ statement. */
1879 gfc_trans_read (gfc_code * code)
1882 return build_dt (iocall[IOCALL_READ], code);
1886 /* Translate a WRITE statement */
1889 gfc_trans_write (gfc_code * code)
1892 return build_dt (iocall[IOCALL_WRITE], code);
1896 /* Finish a data transfer statement. */
1899 gfc_trans_dt_end (gfc_code * code)
1904 gfc_init_block (&block);
1909 function = iocall[IOCALL_READ_DONE];
1913 function = iocall[IOCALL_WRITE_DONE];
1917 function = iocall[IOCALL_IOLENGTH_DONE];
1924 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
1925 tmp = build_call_expr_loc (input_location,
1927 gfc_add_expr_to_block (&block, tmp);
1928 gfc_add_block_to_block (&block, dt_post_end_block);
1929 gfc_init_block (dt_post_end_block);
1931 if (last_dt != IOLENGTH)
1933 gcc_assert (code->ext.dt != NULL);
1934 io_result (&block, dt_parm, code->ext.dt->err,
1935 code->ext.dt->end, code->ext.dt->eor);
1938 return gfc_finish_block (&block);
1942 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
1944 /* Given an array field in a derived type variable, generate the code
1945 for the loop that iterates over array elements, and the code that
1946 accesses those array elements. Use transfer_expr to generate code
1947 for transferring that element. Because elements may also be
1948 derived types, transfer_expr and transfer_array_component are mutually
1952 transfer_array_component (tree expr, gfc_component * cm, locus * where)
1962 gfc_start_block (&block);
1963 gfc_init_se (&se, NULL);
1965 /* Create and initialize Scalarization Status. Unlike in
1966 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1967 care of this task, because we don't have a gfc_expr at hand.
1968 Build one manually, as in gfc_trans_subarray_assign. */
1971 ss->type = GFC_SS_COMPONENT;
1973 ss->shape = gfc_get_shape (cm->as->rank);
1974 ss->next = gfc_ss_terminator;
1975 ss->data.info.dimen = cm->as->rank;
1976 ss->data.info.descriptor = expr;
1977 ss->data.info.data = gfc_conv_array_data (expr);
1978 ss->data.info.offset = gfc_conv_array_offset (expr);
1979 for (n = 0; n < cm->as->rank; n++)
1981 ss->data.info.dim[n] = n;
1982 ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1983 ss->data.info.stride[n] = gfc_index_one_node;
1985 mpz_init (ss->shape[n]);
1986 mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1987 cm->as->lower[n]->value.integer);
1988 mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1991 /* Once we got ss, we use scalarizer to create the loop. */
1993 gfc_init_loopinfo (&loop);
1994 gfc_add_ss_to_loop (&loop, ss);
1995 gfc_conv_ss_startstride (&loop);
1996 gfc_conv_loop_setup (&loop, where);
1997 gfc_mark_ss_chain_used (ss, 1);
1998 gfc_start_scalarized_body (&loop, &body);
2000 gfc_copy_loopinfo_to_se (&se, &loop);
2003 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
2005 gfc_conv_tmp_array_ref (&se);
2007 /* Now se.expr contains an element of the array. Take the address and pass
2008 it to the IO routines. */
2009 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2010 transfer_expr (&se, &cm->ts, tmp, NULL);
2012 /* We are done now with the loop body. Wrap up the scalarizer and
2015 gfc_add_block_to_block (&body, &se.pre);
2016 gfc_add_block_to_block (&body, &se.post);
2018 gfc_trans_scalarizing_loops (&loop, &body);
2020 gfc_add_block_to_block (&block, &loop.pre);
2021 gfc_add_block_to_block (&block, &loop.post);
2023 for (n = 0; n < cm->as->rank; n++)
2024 mpz_clear (ss->shape[n]);
2025 gfc_free (ss->shape);
2027 gfc_cleanup_loop (&loop);
2029 return gfc_finish_block (&block);
2032 /* Generate the call for a scalar transfer node. */
2035 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
2037 tree tmp, function, arg2, arg3, field, expr;
2041 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2042 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2043 We need to translate the expression to a constant if it's either
2044 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2045 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2046 BT_DERIVED (could have been changed by gfc_conv_expr). */
2047 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2048 && ts->u.derived != NULL
2049 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2051 /* C_PTR and C_FUNPTR have private components which means they can not
2052 be printed. However, if -std=gnu and not -pedantic, allow
2053 the component to be printed to help debugging. */
2054 if (gfc_notification_std (GFC_STD_GNU) != SILENT)
2056 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
2057 ts->u.derived->name, code != NULL ? &(code->loc) :
2058 &gfc_current_locus);
2062 ts->type = ts->u.derived->ts.type;
2063 ts->kind = ts->u.derived->ts.kind;
2064 ts->f90_type = ts->u.derived->ts.f90_type;
2075 arg2 = build_int_cst (NULL_TREE, kind);
2076 if (last_dt == READ)
2077 function = iocall[IOCALL_X_INTEGER];
2079 function = iocall[IOCALL_X_INTEGER_WRITE];
2084 arg2 = build_int_cst (NULL_TREE, kind);
2085 if (last_dt == READ)
2086 function = iocall[IOCALL_X_REAL];
2088 function = iocall[IOCALL_X_REAL_WRITE];
2093 arg2 = build_int_cst (NULL_TREE, kind);
2094 if (last_dt == READ)
2095 function = iocall[IOCALL_X_COMPLEX];
2097 function = iocall[IOCALL_X_COMPLEX_WRITE];
2102 arg2 = build_int_cst (NULL_TREE, kind);
2103 if (last_dt == READ)
2104 function = iocall[IOCALL_X_LOGICAL];
2106 function = iocall[IOCALL_X_LOGICAL_WRITE];
2113 if (se->string_length)
2114 arg2 = se->string_length;
2117 tmp = build_fold_indirect_ref_loc (input_location,
2119 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2120 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2121 arg2 = fold_convert (gfc_charlen_type_node, arg2);
2123 arg3 = build_int_cst (NULL_TREE, kind);
2124 if (last_dt == READ)
2125 function = iocall[IOCALL_X_CHARACTER_WIDE];
2127 function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
2129 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2130 tmp = build_call_expr_loc (input_location,
2131 function, 4, tmp, addr_expr, arg2, arg3);
2132 gfc_add_expr_to_block (&se->pre, tmp);
2133 gfc_add_block_to_block (&se->pre, &se->post);
2138 if (se->string_length)
2139 arg2 = se->string_length;
2142 tmp = build_fold_indirect_ref_loc (input_location,
2144 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2145 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2147 if (last_dt == READ)
2148 function = iocall[IOCALL_X_CHARACTER];
2150 function = iocall[IOCALL_X_CHARACTER_WRITE];
2155 /* Recurse into the elements of the derived type. */
2156 expr = gfc_evaluate_now (addr_expr, &se->pre);
2157 expr = build_fold_indirect_ref_loc (input_location,
2160 for (c = ts->u.derived->components; c; c = c->next)
2162 field = c->backend_decl;
2163 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2165 tmp = fold_build3_loc (UNKNOWN_LOCATION,
2166 COMPONENT_REF, TREE_TYPE (field),
2167 expr, field, NULL_TREE);
2169 if (c->attr.dimension)
2171 tmp = transfer_array_component (tmp, c, & code->loc);
2172 gfc_add_expr_to_block (&se->pre, tmp);
2176 if (!c->attr.pointer)
2177 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2178 transfer_expr (se, &c->ts, tmp, code);
2184 internal_error ("Bad IO basetype (%d)", ts->type);
2187 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2188 tmp = build_call_expr_loc (input_location,
2189 function, 3, tmp, addr_expr, arg2);
2190 gfc_add_expr_to_block (&se->pre, tmp);
2191 gfc_add_block_to_block (&se->pre, &se->post);
2196 /* Generate a call to pass an array descriptor to the IO library. The
2197 array should be of one of the intrinsic types. */
2200 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2202 tree tmp, charlen_arg, kind_arg, io_call;
2204 if (ts->type == BT_CHARACTER)
2205 charlen_arg = se->string_length;
2207 charlen_arg = build_int_cst (NULL_TREE, 0);
2209 kind_arg = build_int_cst (NULL_TREE, ts->kind);
2211 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2212 if (last_dt == READ)
2213 io_call = iocall[IOCALL_X_ARRAY];
2215 io_call = iocall[IOCALL_X_ARRAY_WRITE];
2217 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2219 tmp, addr_expr, kind_arg, charlen_arg);
2220 gfc_add_expr_to_block (&se->pre, tmp);
2221 gfc_add_block_to_block (&se->pre, &se->post);
2225 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2228 gfc_trans_transfer (gfc_code * code)
2230 stmtblock_t block, body;
2239 gfc_start_block (&block);
2240 gfc_init_block (&body);
2243 ss = gfc_walk_expr (expr);
2246 gfc_init_se (&se, NULL);
2248 if (ss == gfc_ss_terminator)
2250 /* Transfer a scalar value. */
2251 gfc_conv_expr_reference (&se, expr);
2252 transfer_expr (&se, &expr->ts, se.expr, code);
2256 /* Transfer an array. If it is an array of an intrinsic
2257 type, pass the descriptor to the library. Otherwise
2258 scalarize the transfer. */
2259 if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
2261 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2263 gcc_assert (ref->type == REF_ARRAY);
2266 if (expr->ts.type != BT_DERIVED
2267 && ref && ref->next == NULL
2268 && !is_subref_array (expr))
2270 bool seen_vector = false;
2272 if (ref && ref->u.ar.type == AR_SECTION)
2274 for (n = 0; n < ref->u.ar.dimen; n++)
2275 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2279 if (seen_vector && last_dt == READ)
2281 /* Create a temp, read to that and copy it back. */
2282 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2287 /* Get the descriptor. */
2288 gfc_conv_expr_descriptor (&se, expr, ss);
2289 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2292 transfer_array_desc (&se, &expr->ts, tmp);
2293 goto finish_block_label;
2296 /* Initialize the scalarizer. */
2297 gfc_init_loopinfo (&loop);
2298 gfc_add_ss_to_loop (&loop, ss);
2300 /* Initialize the loop. */
2301 gfc_conv_ss_startstride (&loop);
2302 gfc_conv_loop_setup (&loop, &code->expr1->where);
2304 /* The main loop body. */
2305 gfc_mark_ss_chain_used (ss, 1);
2306 gfc_start_scalarized_body (&loop, &body);
2308 gfc_copy_loopinfo_to_se (&se, &loop);
2311 gfc_conv_expr_reference (&se, expr);
2312 transfer_expr (&se, &expr->ts, se.expr, code);
2317 gfc_add_block_to_block (&body, &se.pre);
2318 gfc_add_block_to_block (&body, &se.post);
2321 tmp = gfc_finish_block (&body);
2324 gcc_assert (se.ss == gfc_ss_terminator);
2325 gfc_trans_scalarizing_loops (&loop, &body);
2327 gfc_add_block_to_block (&loop.pre, &loop.post);
2328 tmp = gfc_finish_block (&loop.pre);
2329 gfc_cleanup_loop (&loop);
2332 gfc_add_expr_to_block (&block, tmp);
2334 return gfc_finish_block (&block);
2337 #include "gt-fortran-trans-io.h"