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 "toplev.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 */
120 IOCALL_X_CHARACTER_WIDE,
128 IOCALL_IOLENGTH_DONE,
134 IOCALL_SET_NML_VAL_DIM,
139 static GTY(()) tree iocall[IOCALL_NUM];
141 /* Variable for keeping track of what the last data transfer statement
142 was. Used for deciding which subroutine to call when the data
143 transfer is complete. */
144 static enum { READ, WRITE, IOLENGTH } last_dt;
146 /* The data transfer parameter block that should be shared by all
147 data transfer calls belonging to the same read/write/iolength. */
148 static GTY(()) tree dt_parm;
149 static stmtblock_t *dt_post_end_block;
152 gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
155 gfc_st_parameter_field *p;
158 tree t = make_node (RECORD_TYPE);
160 len = strlen (st_parameter[ptype].name);
161 gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
162 memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
163 memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
165 TYPE_NAME (t) = get_identifier (name);
167 for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
168 if (p->param_type == ptype)
171 case IOPARM_type_int4:
172 case IOPARM_type_intio:
173 case IOPARM_type_pint4:
174 case IOPARM_type_pintio:
175 case IOPARM_type_parray:
176 case IOPARM_type_pchar:
177 case IOPARM_type_pad:
178 p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
179 get_identifier (p->name),
182 case IOPARM_type_char1:
183 p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
184 get_identifier (p->name),
187 case IOPARM_type_char2:
188 len = strlen (p->name);
189 gcc_assert (len <= sizeof (name) - sizeof ("_len"));
190 memcpy (name, p->name, len);
191 memcpy (name + len, "_len", sizeof ("_len"));
192 p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
193 get_identifier (name),
194 gfc_charlen_type_node);
195 if (p->type == IOPARM_type_char2)
196 p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
197 get_identifier (p->name),
200 case IOPARM_type_common:
202 = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
203 get_identifier (p->name),
204 st_parameter[IOPARM_ptype_common].type);
206 case IOPARM_type_num:
211 st_parameter[ptype].type = t;
215 /* Build code to test an error condition and call generate_error if needed.
216 Note: This builds calls to generate_error in the runtime library function.
217 The function generate_error is dependent on certain parameters in the
218 st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
219 Therefore, the code to set these flags must be generated before
220 this function is used. */
223 gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
224 const char * msgid, stmtblock_t * pblock)
229 tree arg1, arg2, arg3;
232 if (integer_zerop (cond))
235 /* The code to generate the error. */
236 gfc_start_block (&block);
238 arg1 = gfc_build_addr_expr (NULL_TREE, var);
240 arg2 = build_int_cst (integer_type_node, error_code),
242 asprintf (&message, "%s", _(msgid));
243 arg3 = gfc_build_addr_expr (pchar_type_node,
244 gfc_build_localized_cstring_const (message));
247 tmp = build_call_expr_loc (input_location,
248 gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
250 gfc_add_expr_to_block (&block, tmp);
252 body = gfc_finish_block (&block);
254 if (integer_onep (cond))
256 gfc_add_expr_to_block (pblock, body);
260 /* Tell the compiler that this isn't likely. */
261 cond = fold_convert (long_integer_type_node, cond);
262 tmp = build_int_cst (long_integer_type_node, 0);
263 cond = build_call_expr_loc (input_location,
264 built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
265 cond = fold_convert (boolean_type_node, cond);
267 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
268 gfc_add_expr_to_block (pblock, tmp);
273 /* Create function decls for IO library functions. */
276 gfc_build_io_library_fndecls (void)
278 tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
279 tree gfc_intio_type_node;
280 tree parm_type, dt_parm_type;
281 HOST_WIDE_INT pad_size;
284 types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
285 types[IOPARM_type_intio] = gfc_intio_type_node
286 = gfc_get_int_type (gfc_intio_kind);
287 types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
288 types[IOPARM_type_pintio]
289 = build_pointer_type (gfc_intio_type_node);
290 types[IOPARM_type_parray] = pchar_type_node;
291 types[IOPARM_type_pchar] = pchar_type_node;
292 pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
293 pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
294 pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size - 1));
295 types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
297 /* pad actually contains pointers and integers so it needs to have an
298 alignment that is at least as large as the needed alignment for those
299 types. See the st_parameter_dt structure in libgfortran/io/io.h for
300 what really goes into this space. */
301 TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
302 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)));
304 for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
305 gfc_build_st_parameter ((enum ioparam_type) ptype, types);
307 /* Define the transfer functions. */
309 dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
311 iocall[IOCALL_X_INTEGER] =
312 gfc_build_library_function_decl (get_identifier
313 (PREFIX("transfer_integer")),
314 void_type_node, 3, dt_parm_type,
315 pvoid_type_node, gfc_int4_type_node);
317 iocall[IOCALL_X_LOGICAL] =
318 gfc_build_library_function_decl (get_identifier
319 (PREFIX("transfer_logical")),
320 void_type_node, 3, dt_parm_type,
321 pvoid_type_node, gfc_int4_type_node);
323 iocall[IOCALL_X_CHARACTER] =
324 gfc_build_library_function_decl (get_identifier
325 (PREFIX("transfer_character")),
326 void_type_node, 3, dt_parm_type,
327 pvoid_type_node, gfc_int4_type_node);
329 iocall[IOCALL_X_CHARACTER_WIDE] =
330 gfc_build_library_function_decl (get_identifier
331 (PREFIX("transfer_character_wide")),
332 void_type_node, 4, dt_parm_type,
333 pvoid_type_node, gfc_charlen_type_node,
336 iocall[IOCALL_X_REAL] =
337 gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
338 void_type_node, 3, dt_parm_type,
339 pvoid_type_node, gfc_int4_type_node);
341 iocall[IOCALL_X_COMPLEX] =
342 gfc_build_library_function_decl (get_identifier
343 (PREFIX("transfer_complex")),
344 void_type_node, 3, dt_parm_type,
345 pvoid_type_node, gfc_int4_type_node);
347 iocall[IOCALL_X_ARRAY] =
348 gfc_build_library_function_decl (get_identifier
349 (PREFIX("transfer_array")),
350 void_type_node, 4, dt_parm_type,
351 pvoid_type_node, integer_type_node,
352 gfc_charlen_type_node);
354 /* Library entry points */
356 iocall[IOCALL_READ] =
357 gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
358 void_type_node, 1, dt_parm_type);
360 iocall[IOCALL_WRITE] =
361 gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
362 void_type_node, 1, dt_parm_type);
364 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
365 iocall[IOCALL_OPEN] =
366 gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
367 void_type_node, 1, parm_type);
370 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
371 iocall[IOCALL_CLOSE] =
372 gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
373 void_type_node, 1, parm_type);
375 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
376 iocall[IOCALL_INQUIRE] =
377 gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
378 gfc_int4_type_node, 1, parm_type);
380 iocall[IOCALL_IOLENGTH] =
381 gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
382 void_type_node, 1, dt_parm_type);
384 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
385 iocall[IOCALL_WAIT] =
386 gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")),
387 gfc_int4_type_node, 1, parm_type);
389 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
390 iocall[IOCALL_REWIND] =
391 gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
392 gfc_int4_type_node, 1, parm_type);
394 iocall[IOCALL_BACKSPACE] =
395 gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
396 gfc_int4_type_node, 1, parm_type);
398 iocall[IOCALL_ENDFILE] =
399 gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
400 gfc_int4_type_node, 1, parm_type);
402 iocall[IOCALL_FLUSH] =
403 gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
404 gfc_int4_type_node, 1, parm_type);
406 /* Library helpers */
408 iocall[IOCALL_READ_DONE] =
409 gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
410 gfc_int4_type_node, 1, dt_parm_type);
412 iocall[IOCALL_WRITE_DONE] =
413 gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
414 gfc_int4_type_node, 1, dt_parm_type);
416 iocall[IOCALL_IOLENGTH_DONE] =
417 gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
418 gfc_int4_type_node, 1, dt_parm_type);
421 iocall[IOCALL_SET_NML_VAL] =
422 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
423 void_type_node, 6, dt_parm_type,
424 pvoid_type_node, pvoid_type_node,
425 gfc_int4_type_node, gfc_charlen_type_node,
428 iocall[IOCALL_SET_NML_VAL_DIM] =
429 gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
430 void_type_node, 5, dt_parm_type,
431 gfc_int4_type_node, gfc_array_index_type,
432 gfc_array_index_type, gfc_array_index_type);
436 /* Generate code to store an integer constant into the
437 st_parameter_XXX structure. */
440 set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
444 gfc_st_parameter_field *p = &st_parameter_field[type];
446 if (p->param_type == IOPARM_ptype_common)
447 var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
448 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
449 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
451 gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
456 /* Generate code to store a non-string I/O parameter into the
457 st_parameter_XXX structure. This is a pass by value. */
460 set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
465 gfc_st_parameter_field *p = &st_parameter_field[type];
466 tree dest_type = TREE_TYPE (p->field);
468 gfc_init_se (&se, NULL);
469 gfc_conv_expr_val (&se, e);
471 /* If we're storing a UNIT number, we need to check it first. */
472 if (type == IOPARM_common_unit && e->ts.kind > 4)
477 /* Don't evaluate the UNIT number multiple times. */
478 se.expr = gfc_evaluate_now (se.expr, &se.pre);
480 /* UNIT numbers should be greater than the min. */
481 i = gfc_validate_kind (BT_INTEGER, 4, false);
482 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
483 cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr,
484 fold_convert (TREE_TYPE (se.expr), val));
485 gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
486 "Unit number in I/O statement too small",
489 /* UNIT numbers should be less than the max. */
490 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
491 cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr,
492 fold_convert (TREE_TYPE (se.expr), val));
493 gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
494 "Unit number in I/O statement too large",
499 se.expr = convert (dest_type, se.expr);
500 gfc_add_block_to_block (block, &se.pre);
502 if (p->param_type == IOPARM_ptype_common)
503 var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
504 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
506 tmp = fold_build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE);
507 gfc_add_modify (block, tmp, se.expr);
512 /* Generate code to store a non-string I/O parameter into the
513 st_parameter_XXX structure. This is pass by reference. */
516 set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
517 tree var, enum iofield type, gfc_expr *e)
521 gfc_st_parameter_field *p = &st_parameter_field[type];
523 gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
524 gfc_init_se (&se, NULL);
525 gfc_conv_expr_lhs (&se, e);
527 gfc_add_block_to_block (block, &se.pre);
529 if (TYPE_MODE (TREE_TYPE (se.expr))
530 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
532 addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
534 /* If this is for the iostat variable initialize the
535 user variable to LIBERROR_OK which is zero. */
536 if (type == IOPARM_common_iostat)
537 gfc_add_modify (block, se.expr,
538 build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
542 /* The type used by the library has different size
543 from the type of the variable supplied by the user.
544 Need to use a temporary. */
545 tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
546 st_parameter_field[type].name);
548 /* If this is for the iostat variable, initialize the
549 user variable to LIBERROR_OK which is zero. */
550 if (type == IOPARM_common_iostat)
551 gfc_add_modify (block, tmpvar,
552 build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
554 addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
555 /* After the I/O operation, we set the variable from the temporary. */
556 tmp = convert (TREE_TYPE (se.expr), tmpvar);
557 gfc_add_modify (postblock, se.expr, tmp);
560 if (p->param_type == IOPARM_ptype_common)
561 var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
562 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
563 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
564 var, p->field, NULL_TREE);
565 gfc_add_modify (block, tmp, addr);
569 /* Given an array expr, find its address and length to get a string. If the
570 array is full, the string's address is the address of array's first element
571 and the length is the size of the whole array. If it is an element, the
572 string's address is the element's address and the length is the rest size of
576 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
582 tree type, array, tmp;
586 /* If it is an element, we need its address and size of the rest. */
587 gcc_assert (e->expr_type == EXPR_VARIABLE);
588 gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
589 sym = e->symtree->n.sym;
590 rank = sym->as->rank - 1;
591 gfc_conv_expr (se, e);
593 array = sym->backend_decl;
594 type = TREE_TYPE (array);
596 if (GFC_ARRAY_TYPE_P (type))
597 size = GFC_TYPE_ARRAY_SIZE (type);
600 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
601 size = gfc_conv_array_stride (array, rank);
602 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
603 gfc_conv_array_ubound (array, rank),
604 gfc_conv_array_lbound (array, rank));
605 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
607 size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
611 size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
612 TREE_OPERAND (se->expr, 1));
613 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
614 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
615 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
616 fold_convert (gfc_array_index_type, tmp));
617 se->string_length = fold_convert (gfc_charlen_type_node, size);
621 gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);
622 se->string_length = fold_convert (gfc_charlen_type_node, size);
626 /* Generate code to store a string and its length into the
627 st_parameter_XXX structure. */
630 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
631 enum iofield type, gfc_expr * e)
637 gfc_st_parameter_field *p = &st_parameter_field[type];
639 gfc_init_se (&se, NULL);
641 if (p->param_type == IOPARM_ptype_common)
642 var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
643 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
644 io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
645 var, p->field, NULL_TREE);
646 len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
647 var, p->field_len, NULL_TREE);
649 /* Integer variable assigned a format label. */
650 if (e->ts.type == BT_INTEGER
652 && e->symtree->n.sym->attr.assign == 1)
657 gfc_conv_label_variable (&se, e);
658 tmp = GFC_DECL_STRING_LEN (se.expr);
659 cond = fold_build2 (LT_EXPR, boolean_type_node,
660 tmp, build_int_cst (TREE_TYPE (tmp), 0));
662 asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
663 "label", e->symtree->name);
664 gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
665 fold_convert (long_integer_type_node, tmp));
668 gfc_add_modify (&se.pre, io,
669 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
670 gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
674 /* General character. */
675 if (e->ts.type == BT_CHARACTER && e->rank == 0)
676 gfc_conv_expr (&se, e);
677 /* Array assigned Hollerith constant or character array. */
678 else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
679 gfc_convert_array_to_string (&se, e);
683 gfc_conv_string_parameter (&se);
684 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
685 gfc_add_modify (&se.pre, len, se.string_length);
688 gfc_add_block_to_block (block, &se.pre);
689 gfc_add_block_to_block (postblock, &se.post);
694 /* Generate code to store the character (array) and the character length
695 for an internal unit. */
698 set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
699 tree var, gfc_expr * e)
706 gfc_st_parameter_field *p;
709 gfc_init_se (&se, NULL);
711 p = &st_parameter_field[IOPARM_dt_internal_unit];
713 io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
714 var, p->field, NULL_TREE);
715 len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
716 var, p->field_len, NULL_TREE);
717 p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
718 desc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
719 var, p->field, NULL_TREE);
721 gcc_assert (e->ts.type == BT_CHARACTER);
723 /* Character scalars. */
726 gfc_conv_expr (&se, e);
727 gfc_conv_string_parameter (&se);
729 se.expr = build_int_cst (pchar_type_node, 0);
732 /* Character array. */
733 else if (e->rank > 0)
735 se.ss = gfc_walk_expr (e);
737 if (is_subref_array (e))
739 /* Use a temporary for components of arrays of derived types
740 or substring array references. */
741 gfc_conv_subref_array_arg (&se, e, 0,
742 last_dt == READ ? INTENT_IN : INTENT_OUT, false);
743 tmp = build_fold_indirect_ref_loc (input_location,
745 se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
746 tmp = gfc_conv_descriptor_data_get (tmp);
750 /* Return the data pointer and rank from the descriptor. */
751 gfc_conv_expr_descriptor (&se, e, se.ss);
752 tmp = gfc_conv_descriptor_data_get (se.expr);
753 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
759 /* The cast is needed for character substrings and the descriptor
761 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
762 gfc_add_modify (&se.pre, len,
763 fold_convert (TREE_TYPE (len), se.string_length));
764 gfc_add_modify (&se.pre, desc, se.expr);
766 gfc_add_block_to_block (block, &se.pre);
767 gfc_add_block_to_block (post_block, &se.post);
771 /* Add a case to a IO-result switch. */
774 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
779 return; /* No label, no case */
781 value = build_int_cst (NULL_TREE, label_value);
783 /* Make a backend label for this case. */
784 tmp = gfc_build_label_decl (NULL_TREE);
786 /* And the case itself. */
787 tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
788 gfc_add_expr_to_block (body, tmp);
790 /* Jump to the label. */
791 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
792 gfc_add_expr_to_block (body, tmp);
796 /* Generate a switch statement that branches to the correct I/O
797 result label. The last statement of an I/O call stores the
798 result into a variable because there is often cleanup that
799 must be done before the switch, so a temporary would have to
800 be created anyway. */
803 io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
804 gfc_st_label * end_label, gfc_st_label * eor_label)
808 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
810 /* If no labels are specified, ignore the result instead
811 of building an empty switch. */
812 if (err_label == NULL
814 && eor_label == NULL)
817 /* Build a switch statement. */
818 gfc_start_block (&body);
820 /* The label values here must be the same as the values
821 in the library_return enum in the runtime library */
822 add_case (1, err_label, &body);
823 add_case (2, end_label, &body);
824 add_case (3, eor_label, &body);
826 tmp = gfc_finish_block (&body);
828 var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
829 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
830 rc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
831 var, p->field, NULL_TREE);
832 rc = fold_build2 (BIT_AND_EXPR, TREE_TYPE (rc),
833 rc, build_int_cst (TREE_TYPE (rc),
834 IOPARM_common_libreturn_mask));
836 tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
838 gfc_add_expr_to_block (block, tmp);
842 /* Store the current file and line number to variables so that if a
843 library call goes awry, we can tell the user where the problem is. */
846 set_error_locus (stmtblock_t * block, tree var, locus * where)
849 tree str, locus_file;
851 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
853 locus_file = fold_build3 (COMPONENT_REF,
854 st_parameter[IOPARM_ptype_common].type,
855 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
856 locus_file = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
857 locus_file, p->field, NULL_TREE);
859 str = gfc_build_cstring_const (f->filename);
861 str = gfc_build_addr_expr (pchar_type_node, str);
862 gfc_add_modify (block, locus_file, str);
864 line = LOCATION_LINE (where->lb->location);
865 set_parameter_const (block, var, IOPARM_common_line, line);
869 /* Translate an OPEN statement. */
872 gfc_trans_open (gfc_code * code)
874 stmtblock_t block, post_block;
877 unsigned int mask = 0;
879 gfc_start_block (&block);
880 gfc_init_block (&post_block);
882 var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
884 set_error_locus (&block, var, &code->loc);
888 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
892 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
896 mask |= IOPARM_common_err;
899 mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
902 mask |= set_string (&block, &post_block, var, IOPARM_open_status,
906 mask |= set_string (&block, &post_block, var, IOPARM_open_access,
910 mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
913 mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
916 mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
920 mask |= set_string (&block, &post_block, var, IOPARM_open_position,
924 mask |= set_string (&block, &post_block, var, IOPARM_open_action,
928 mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
932 mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
935 mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
939 mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
943 mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
946 mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
949 mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
953 mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
957 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
960 set_parameter_const (&block, var, IOPARM_common_flags, mask);
963 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
965 set_parameter_const (&block, var, IOPARM_common_unit, 0);
967 tmp = gfc_build_addr_expr (NULL_TREE, var);
968 tmp = build_call_expr_loc (input_location,
969 iocall[IOCALL_OPEN], 1, tmp);
970 gfc_add_expr_to_block (&block, tmp);
972 gfc_add_block_to_block (&block, &post_block);
974 io_result (&block, var, p->err, NULL, NULL);
976 return gfc_finish_block (&block);
980 /* Translate a CLOSE statement. */
983 gfc_trans_close (gfc_code * code)
985 stmtblock_t block, post_block;
988 unsigned int mask = 0;
990 gfc_start_block (&block);
991 gfc_init_block (&post_block);
993 var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
995 set_error_locus (&block, var, &code->loc);
999 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1003 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1007 mask |= IOPARM_common_err;
1010 mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1013 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1016 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1018 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1020 tmp = gfc_build_addr_expr (NULL_TREE, var);
1021 tmp = build_call_expr_loc (input_location,
1022 iocall[IOCALL_CLOSE], 1, tmp);
1023 gfc_add_expr_to_block (&block, tmp);
1025 gfc_add_block_to_block (&block, &post_block);
1027 io_result (&block, var, p->err, NULL, NULL);
1029 return gfc_finish_block (&block);
1033 /* Common subroutine for building a file positioning statement. */
1036 build_filepos (tree function, gfc_code * code)
1038 stmtblock_t block, post_block;
1041 unsigned int mask = 0;
1043 p = code->ext.filepos;
1045 gfc_start_block (&block);
1046 gfc_init_block (&post_block);
1048 var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1051 set_error_locus (&block, var, &code->loc);
1054 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1058 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1062 mask |= IOPARM_common_err;
1064 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1067 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1069 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1071 tmp = gfc_build_addr_expr (NULL_TREE, var);
1072 tmp = build_call_expr_loc (input_location,
1074 gfc_add_expr_to_block (&block, tmp);
1076 gfc_add_block_to_block (&block, &post_block);
1078 io_result (&block, var, p->err, NULL, NULL);
1080 return gfc_finish_block (&block);
1084 /* Translate a BACKSPACE statement. */
1087 gfc_trans_backspace (gfc_code * code)
1089 return build_filepos (iocall[IOCALL_BACKSPACE], code);
1093 /* Translate an ENDFILE statement. */
1096 gfc_trans_endfile (gfc_code * code)
1098 return build_filepos (iocall[IOCALL_ENDFILE], code);
1102 /* Translate a REWIND statement. */
1105 gfc_trans_rewind (gfc_code * code)
1107 return build_filepos (iocall[IOCALL_REWIND], code);
1111 /* Translate a FLUSH statement. */
1114 gfc_trans_flush (gfc_code * code)
1116 return build_filepos (iocall[IOCALL_FLUSH], code);
1120 /* Create a dummy iostat variable to catch any error due to bad unit. */
1123 create_dummy_iostat (void)
1128 gfc_get_ha_sym_tree ("@iostat", &st);
1129 st->n.sym->ts.type = BT_INTEGER;
1130 st->n.sym->ts.kind = gfc_default_integer_kind;
1131 gfc_set_sym_referenced (st->n.sym);
1132 gfc_commit_symbol (st->n.sym);
1133 st->n.sym->backend_decl
1134 = gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind),
1137 e = gfc_get_expr ();
1138 e->expr_type = EXPR_VARIABLE;
1140 e->ts.type = BT_INTEGER;
1141 e->ts.kind = st->n.sym->ts.kind;
1147 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
1150 gfc_trans_inquire (gfc_code * code)
1152 stmtblock_t block, post_block;
1155 unsigned int mask = 0, mask2 = 0;
1157 gfc_start_block (&block);
1158 gfc_init_block (&post_block);
1160 var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1163 set_error_locus (&block, var, &code->loc);
1164 p = code->ext.inquire;
1167 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1171 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1175 mask |= IOPARM_common_err;
1178 if (p->unit && p->file)
1179 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1182 mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1187 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1190 if (p->unit && !p->iostat)
1192 p->iostat = create_dummy_iostat ();
1193 mask |= set_parameter_ref (&block, &post_block, var,
1194 IOPARM_common_iostat, p->iostat);
1199 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1203 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1207 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1211 mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1215 mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1219 mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1223 mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1227 mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1231 mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1235 mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1239 mask |= set_parameter_ref (&block, &post_block, var,
1240 IOPARM_inquire_recl_out, p->recl);
1243 mask |= set_parameter_ref (&block, &post_block, var,
1244 IOPARM_inquire_nextrec, p->nextrec);
1247 mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1251 mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1255 mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1259 mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1263 mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1267 mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1271 mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1275 mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1279 mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1283 mask |= set_parameter_ref (&block, &post_block, var,
1284 IOPARM_inquire_strm_pos_out, p->strm_pos);
1286 /* The second series of flags. */
1287 if (p->asynchronous)
1288 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1292 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1296 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1300 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1304 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1308 mask2 |= set_parameter_ref (&block, &post_block, var,
1309 IOPARM_inquire_pending, p->pending);
1312 mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1316 mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1320 mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
1322 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1325 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1327 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1329 tmp = gfc_build_addr_expr (NULL_TREE, var);
1330 tmp = build_call_expr_loc (input_location,
1331 iocall[IOCALL_INQUIRE], 1, tmp);
1332 gfc_add_expr_to_block (&block, tmp);
1334 gfc_add_block_to_block (&block, &post_block);
1336 io_result (&block, var, p->err, NULL, NULL);
1338 return gfc_finish_block (&block);
1343 gfc_trans_wait (gfc_code * code)
1345 stmtblock_t block, post_block;
1348 unsigned int mask = 0;
1350 gfc_start_block (&block);
1351 gfc_init_block (&post_block);
1353 var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1356 set_error_locus (&block, var, &code->loc);
1359 /* Set parameters here. */
1361 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1365 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1369 mask |= IOPARM_common_err;
1372 mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
1374 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1377 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1379 tmp = gfc_build_addr_expr (NULL_TREE, var);
1380 tmp = build_call_expr_loc (input_location,
1381 iocall[IOCALL_WAIT], 1, tmp);
1382 gfc_add_expr_to_block (&block, tmp);
1384 gfc_add_block_to_block (&block, &post_block);
1386 io_result (&block, var, p->err, NULL, NULL);
1388 return gfc_finish_block (&block);
1393 /* nml_full_name builds up the fully qualified name of a
1394 derived type component. */
1397 nml_full_name (const char* var_name, const char* cmp_name)
1399 int full_name_length;
1402 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1403 full_name = (char*)gfc_getmem (full_name_length + 1);
1404 strcpy (full_name, var_name);
1405 full_name = strcat (full_name, "%");
1406 full_name = strcat (full_name, cmp_name);
1410 /* nml_get_addr_expr builds an address expression from the
1411 gfc_symbol or gfc_component backend_decl's. An offset is
1412 provided so that the address of an element of an array of
1413 derived types is returned. This is used in the runtime to
1414 determine that span of the derived type. */
1417 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1420 tree decl = NULL_TREE;
1424 int dummy_arg_flagged;
1428 sym->attr.referenced = 1;
1429 decl = gfc_get_symbol_decl (sym);
1431 /* If this is the enclosing function declaration, use
1432 the fake result instead. */
1433 if (decl == current_function_decl)
1434 decl = gfc_get_fake_result_decl (sym, 0);
1435 else if (decl == DECL_CONTEXT (current_function_decl))
1436 decl = gfc_get_fake_result_decl (sym, 1);
1439 decl = c->backend_decl;
1441 gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1442 || TREE_CODE (decl) == VAR_DECL
1443 || TREE_CODE (decl) == PARM_DECL)
1444 || TREE_CODE (decl) == COMPONENT_REF));
1448 /* Build indirect reference, if dummy argument. */
1450 dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
1452 itmp = (dummy_arg_flagged) ? build_fold_indirect_ref_loc (input_location,
1455 /* If an array, set flag and use indirect ref. if built. */
1457 array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
1458 && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
1463 /* Treat the component of a derived type, using base_addr for
1464 the derived type. */
1466 if (TREE_CODE (decl) == FIELD_DECL)
1467 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
1468 base_addr, tmp, NULL_TREE);
1470 /* If we have a derived type component, a reference to the first
1471 element of the array is built. This is done so that base_addr,
1472 used in the build of the component reference, always points to
1476 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1478 /* Now build the address expression. */
1480 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1482 /* If scalar dummy, resolve indirect reference now. */
1484 if (dummy_arg_flagged && !array_flagged)
1485 tmp = build_fold_indirect_ref_loc (input_location,
1488 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1493 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1494 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
1495 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
1497 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1500 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1501 gfc_symbol * sym, gfc_component * c,
1504 gfc_typespec * ts = NULL;
1505 gfc_array_spec * as = NULL;
1506 tree addr_expr = NULL;
1516 gcc_assert (sym || c);
1518 /* Build the namelist object name. */
1520 string = gfc_build_cstring_const (var_name);
1521 string = gfc_build_addr_expr (pchar_type_node, string);
1523 /* Build ts, as and data address using symbol or component. */
1525 ts = (sym) ? &sym->ts : &c->ts;
1526 as = (sym) ? sym->as : c->as;
1528 addr_expr = nml_get_addr_expr (sym, c, base_addr);
1535 dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1536 dtype = gfc_get_dtype (dt);
1540 itype = GFC_DTYPE_UNKNOWN;
1546 itype = GFC_DTYPE_INTEGER;
1549 itype = GFC_DTYPE_LOGICAL;
1552 itype = GFC_DTYPE_REAL;
1555 itype = GFC_DTYPE_COMPLEX;
1558 itype = GFC_DTYPE_DERIVED;
1561 itype = GFC_DTYPE_CHARACTER;
1567 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1570 /* Build up the arguments for the transfer call.
1571 The call for the scalar part transfers:
1572 (address, name, type, kind or string_length, dtype) */
1574 dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1576 if (ts->type == BT_CHARACTER)
1577 tmp = ts->u.cl->backend_decl;
1579 tmp = build_int_cst (gfc_charlen_type_node, 0);
1580 tmp = build_call_expr_loc (input_location,
1581 iocall[IOCALL_SET_NML_VAL], 6,
1582 dt_parm_addr, addr_expr, string,
1583 IARG (ts->kind), tmp, dtype);
1584 gfc_add_expr_to_block (block, tmp);
1586 /* If the object is an array, transfer rank times:
1587 (null pointer, name, stride, lbound, ubound) */
1589 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1591 tmp = build_call_expr_loc (input_location,
1592 iocall[IOCALL_SET_NML_VAL_DIM], 5,
1595 GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
1596 GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
1597 GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1598 gfc_add_expr_to_block (block, tmp);
1601 if (ts->type == BT_DERIVED)
1605 /* Provide the RECORD_TYPE to build component references. */
1607 tree expr = build_fold_indirect_ref_loc (input_location,
1610 for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1612 char *full_name = nml_full_name (var_name, cmp->name);
1613 transfer_namelist_element (block,
1616 gfc_free (full_name);
1623 /* Create a data transfer statement. Not all of the fields are valid
1624 for both reading and writing, but improper use has been filtered
1628 build_dt (tree function, gfc_code * code)
1630 stmtblock_t block, post_block, post_end_block, post_iu_block;
1635 unsigned int mask = 0;
1637 gfc_start_block (&block);
1638 gfc_init_block (&post_block);
1639 gfc_init_block (&post_end_block);
1640 gfc_init_block (&post_iu_block);
1642 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1644 set_error_locus (&block, var, &code->loc);
1646 if (last_dt == IOLENGTH)
1650 inq = code->ext.inquire;
1652 /* First check that preconditions are met. */
1653 gcc_assert (inq != NULL);
1654 gcc_assert (inq->iolength != NULL);
1656 /* Connect to the iolength variable. */
1657 mask |= set_parameter_ref (&block, &post_end_block, var,
1658 IOPARM_dt_iolength, inq->iolength);
1664 gcc_assert (dt != NULL);
1667 if (dt && dt->io_unit)
1669 if (dt->io_unit->ts.type == BT_CHARACTER)
1671 mask |= set_internal_unit (&block, &post_iu_block,
1673 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1677 set_parameter_const (&block, var, IOPARM_common_unit, 0);
1682 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1686 mask |= set_parameter_ref (&block, &post_end_block, var,
1687 IOPARM_common_iostat, dt->iostat);
1690 mask |= IOPARM_common_err;
1693 mask |= IOPARM_common_eor;
1696 mask |= IOPARM_common_end;
1699 mask |= set_parameter_ref (&block, &post_end_block, var,
1700 IOPARM_dt_id, dt->id);
1703 mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1705 if (dt->asynchronous)
1706 mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
1710 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1714 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1718 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1722 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1726 mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1730 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1734 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1737 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1740 if (dt->format_expr)
1741 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1744 if (dt->format_label)
1746 if (dt->format_label == &format_asterisk)
1747 mask |= IOPARM_dt_list_format;
1749 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1750 dt->format_label->format);
1754 mask |= set_parameter_ref (&block, &post_end_block, var,
1755 IOPARM_dt_size, dt->size);
1759 if (dt->format_expr || dt->format_label)
1760 gfc_internal_error ("build_dt: format with namelist");
1762 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1764 strlen (dt->namelist->name));
1766 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1769 if (last_dt == READ)
1770 mask |= IOPARM_dt_namelist_read_mode;
1772 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1776 for (nml = dt->namelist->namelist; nml; nml = nml->next)
1777 transfer_namelist_element (&block, nml->sym->name, nml->sym,
1781 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1783 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1784 set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
1787 set_parameter_const (&block, var, IOPARM_common_flags, mask);
1789 tmp = gfc_build_addr_expr (NULL_TREE, var);
1790 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
1792 gfc_add_expr_to_block (&block, tmp);
1794 gfc_add_block_to_block (&block, &post_block);
1797 dt_post_end_block = &post_end_block;
1799 /* Set implied do loop exit condition. */
1800 if (last_dt == READ || last_dt == WRITE)
1802 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
1804 tmp = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
1805 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), NULL_TREE);
1806 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
1807 tmp, p->field, NULL_TREE);
1808 tmp = fold_build2 (BIT_AND_EXPR, TREE_TYPE (tmp),
1809 tmp, build_int_cst (TREE_TYPE (tmp),
1810 IOPARM_common_libreturn_mask));
1815 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
1817 gfc_add_block_to_block (&block, &post_iu_block);
1820 dt_post_end_block = NULL;
1822 return gfc_finish_block (&block);
1826 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
1827 this as a third sort of data transfer statement, except that
1828 lengths are summed instead of actually transferring any data. */
1831 gfc_trans_iolength (gfc_code * code)
1834 return build_dt (iocall[IOCALL_IOLENGTH], code);
1838 /* Translate a READ statement. */
1841 gfc_trans_read (gfc_code * code)
1844 return build_dt (iocall[IOCALL_READ], code);
1848 /* Translate a WRITE statement */
1851 gfc_trans_write (gfc_code * code)
1854 return build_dt (iocall[IOCALL_WRITE], code);
1858 /* Finish a data transfer statement. */
1861 gfc_trans_dt_end (gfc_code * code)
1866 gfc_init_block (&block);
1871 function = iocall[IOCALL_READ_DONE];
1875 function = iocall[IOCALL_WRITE_DONE];
1879 function = iocall[IOCALL_IOLENGTH_DONE];
1886 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
1887 tmp = build_call_expr_loc (input_location,
1889 gfc_add_expr_to_block (&block, tmp);
1890 gfc_add_block_to_block (&block, dt_post_end_block);
1891 gfc_init_block (dt_post_end_block);
1893 if (last_dt != IOLENGTH)
1895 gcc_assert (code->ext.dt != NULL);
1896 io_result (&block, dt_parm, code->ext.dt->err,
1897 code->ext.dt->end, code->ext.dt->eor);
1900 return gfc_finish_block (&block);
1904 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
1906 /* Given an array field in a derived type variable, generate the code
1907 for the loop that iterates over array elements, and the code that
1908 accesses those array elements. Use transfer_expr to generate code
1909 for transferring that element. Because elements may also be
1910 derived types, transfer_expr and transfer_array_component are mutually
1914 transfer_array_component (tree expr, gfc_component * cm, locus * where)
1924 gfc_start_block (&block);
1925 gfc_init_se (&se, NULL);
1927 /* Create and initialize Scalarization Status. Unlike in
1928 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1929 care of this task, because we don't have a gfc_expr at hand.
1930 Build one manually, as in gfc_trans_subarray_assign. */
1933 ss->type = GFC_SS_COMPONENT;
1935 ss->shape = gfc_get_shape (cm->as->rank);
1936 ss->next = gfc_ss_terminator;
1937 ss->data.info.dimen = cm->as->rank;
1938 ss->data.info.descriptor = expr;
1939 ss->data.info.data = gfc_conv_array_data (expr);
1940 ss->data.info.offset = gfc_conv_array_offset (expr);
1941 for (n = 0; n < cm->as->rank; n++)
1943 ss->data.info.dim[n] = n;
1944 ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1945 ss->data.info.stride[n] = gfc_index_one_node;
1947 mpz_init (ss->shape[n]);
1948 mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1949 cm->as->lower[n]->value.integer);
1950 mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1953 /* Once we got ss, we use scalarizer to create the loop. */
1955 gfc_init_loopinfo (&loop);
1956 gfc_add_ss_to_loop (&loop, ss);
1957 gfc_conv_ss_startstride (&loop);
1958 gfc_conv_loop_setup (&loop, where);
1959 gfc_mark_ss_chain_used (ss, 1);
1960 gfc_start_scalarized_body (&loop, &body);
1962 gfc_copy_loopinfo_to_se (&se, &loop);
1965 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
1967 gfc_conv_tmp_array_ref (&se);
1969 /* Now se.expr contains an element of the array. Take the address and pass
1970 it to the IO routines. */
1971 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
1972 transfer_expr (&se, &cm->ts, tmp, NULL);
1974 /* We are done now with the loop body. Wrap up the scalarizer and
1977 gfc_add_block_to_block (&body, &se.pre);
1978 gfc_add_block_to_block (&body, &se.post);
1980 gfc_trans_scalarizing_loops (&loop, &body);
1982 gfc_add_block_to_block (&block, &loop.pre);
1983 gfc_add_block_to_block (&block, &loop.post);
1985 for (n = 0; n < cm->as->rank; n++)
1986 mpz_clear (ss->shape[n]);
1987 gfc_free (ss->shape);
1989 gfc_cleanup_loop (&loop);
1991 return gfc_finish_block (&block);
1994 /* Generate the call for a scalar transfer node. */
1997 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
1999 tree tmp, function, arg2, arg3, field, expr;
2003 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2004 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2005 We need to translate the expression to a constant if it's either
2006 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
2007 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2008 BT_DERIVED (could have been changed by gfc_conv_expr). */
2009 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2010 && ts->u.derived != NULL
2011 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2013 /* C_PTR and C_FUNPTR have private components which means they can not
2014 be printed. However, if -std=gnu and not -pedantic, allow
2015 the component to be printed to help debugging. */
2016 if (gfc_notification_std (GFC_STD_GNU) != SILENT)
2018 gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
2019 ts->u.derived->name, code != NULL ? &(code->loc) :
2020 &gfc_current_locus);
2024 ts->type = ts->u.derived->ts.type;
2025 ts->kind = ts->u.derived->ts.kind;
2026 ts->f90_type = ts->u.derived->ts.f90_type;
2037 arg2 = build_int_cst (NULL_TREE, kind);
2038 function = iocall[IOCALL_X_INTEGER];
2042 arg2 = build_int_cst (NULL_TREE, kind);
2043 function = iocall[IOCALL_X_REAL];
2047 arg2 = build_int_cst (NULL_TREE, kind);
2048 function = iocall[IOCALL_X_COMPLEX];
2052 arg2 = build_int_cst (NULL_TREE, kind);
2053 function = iocall[IOCALL_X_LOGICAL];
2059 if (se->string_length)
2060 arg2 = se->string_length;
2063 tmp = build_fold_indirect_ref_loc (input_location,
2065 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2066 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2067 arg2 = fold_convert (gfc_charlen_type_node, arg2);
2069 arg3 = build_int_cst (NULL_TREE, kind);
2070 function = iocall[IOCALL_X_CHARACTER_WIDE];
2071 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2072 tmp = build_call_expr_loc (input_location,
2073 function, 4, tmp, addr_expr, arg2, arg3);
2074 gfc_add_expr_to_block (&se->pre, tmp);
2075 gfc_add_block_to_block (&se->pre, &se->post);
2080 if (se->string_length)
2081 arg2 = se->string_length;
2084 tmp = build_fold_indirect_ref_loc (input_location,
2086 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2087 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2089 function = iocall[IOCALL_X_CHARACTER];
2093 /* Recurse into the elements of the derived type. */
2094 expr = gfc_evaluate_now (addr_expr, &se->pre);
2095 expr = build_fold_indirect_ref_loc (input_location,
2098 for (c = ts->u.derived->components; c; c = c->next)
2100 field = c->backend_decl;
2101 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2103 tmp = fold_build3_loc (UNKNOWN_LOCATION,
2104 COMPONENT_REF, TREE_TYPE (field),
2105 expr, field, NULL_TREE);
2107 if (c->attr.dimension)
2109 tmp = transfer_array_component (tmp, c, & code->loc);
2110 gfc_add_expr_to_block (&se->pre, tmp);
2114 if (!c->attr.pointer)
2115 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2116 transfer_expr (se, &c->ts, tmp, code);
2122 internal_error ("Bad IO basetype (%d)", ts->type);
2125 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2126 tmp = build_call_expr_loc (input_location,
2127 function, 3, tmp, addr_expr, arg2);
2128 gfc_add_expr_to_block (&se->pre, tmp);
2129 gfc_add_block_to_block (&se->pre, &se->post);
2134 /* Generate a call to pass an array descriptor to the IO library. The
2135 array should be of one of the intrinsic types. */
2138 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2140 tree tmp, charlen_arg, kind_arg;
2142 if (ts->type == BT_CHARACTER)
2143 charlen_arg = se->string_length;
2145 charlen_arg = build_int_cst (NULL_TREE, 0);
2147 kind_arg = build_int_cst (NULL_TREE, ts->kind);
2149 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2150 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2151 iocall[IOCALL_X_ARRAY], 4,
2152 tmp, addr_expr, kind_arg, charlen_arg);
2153 gfc_add_expr_to_block (&se->pre, tmp);
2154 gfc_add_block_to_block (&se->pre, &se->post);
2158 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2161 gfc_trans_transfer (gfc_code * code)
2163 stmtblock_t block, body;
2172 gfc_start_block (&block);
2173 gfc_init_block (&body);
2176 ss = gfc_walk_expr (expr);
2179 gfc_init_se (&se, NULL);
2181 if (ss == gfc_ss_terminator)
2183 /* Transfer a scalar value. */
2184 gfc_conv_expr_reference (&se, expr);
2185 transfer_expr (&se, &expr->ts, se.expr, code);
2189 /* Transfer an array. If it is an array of an intrinsic
2190 type, pass the descriptor to the library. Otherwise
2191 scalarize the transfer. */
2192 if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
2194 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2196 gcc_assert (ref->type == REF_ARRAY);
2199 if (expr->ts.type != BT_DERIVED
2200 && ref && ref->next == NULL
2201 && !is_subref_array (expr))
2203 bool seen_vector = false;
2205 if (ref && ref->u.ar.type == AR_SECTION)
2207 for (n = 0; n < ref->u.ar.dimen; n++)
2208 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2212 if (seen_vector && last_dt == READ)
2214 /* Create a temp, read to that and copy it back. */
2215 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2220 /* Get the descriptor. */
2221 gfc_conv_expr_descriptor (&se, expr, ss);
2222 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2225 transfer_array_desc (&se, &expr->ts, tmp);
2226 goto finish_block_label;
2229 /* Initialize the scalarizer. */
2230 gfc_init_loopinfo (&loop);
2231 gfc_add_ss_to_loop (&loop, ss);
2233 /* Initialize the loop. */
2234 gfc_conv_ss_startstride (&loop);
2235 gfc_conv_loop_setup (&loop, &code->expr1->where);
2237 /* The main loop body. */
2238 gfc_mark_ss_chain_used (ss, 1);
2239 gfc_start_scalarized_body (&loop, &body);
2241 gfc_copy_loopinfo_to_se (&se, &loop);
2244 gfc_conv_expr_reference (&se, expr);
2245 transfer_expr (&se, &expr->ts, se.expr, code);
2250 gfc_add_block_to_block (&body, &se.pre);
2251 gfc_add_block_to_block (&body, &se.post);
2254 tmp = gfc_finish_block (&body);
2257 gcc_assert (se.ss == gfc_ss_terminator);
2258 gfc_trans_scalarizing_loops (&loop, &body);
2260 gfc_add_block_to_block (&loop.pre, &loop.post);
2261 tmp = gfc_finish_block (&loop.pre);
2262 gfc_cleanup_loop (&loop);
2265 gfc_add_expr_to_block (&block, tmp);
2267 return gfc_finish_block (&block);
2270 #include "gt-fortran-trans-io.h"