From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/fortran/trans-io.c | 2340 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2340 insertions(+) create mode 100644 gcc/fortran/trans-io.c (limited to 'gcc/fortran/trans-io.c') diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c new file mode 100644 index 000000000..53ff1f4a4 --- /dev/null +++ b/gcc/fortran/trans-io.c @@ -0,0 +1,2340 @@ +/* IO Code translation/library interface + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "ggc.h" +#include "diagnostic-core.h" /* For internal_error. */ +#include "gfortran.h" +#include "trans.h" +#include "trans-stmt.h" +#include "trans-array.h" +#include "trans-types.h" +#include "trans-const.h" + +/* Members of the ioparm structure. */ + +enum ioparam_type +{ + IOPARM_ptype_common, + IOPARM_ptype_open, + IOPARM_ptype_close, + IOPARM_ptype_filepos, + IOPARM_ptype_inquire, + IOPARM_ptype_dt, + IOPARM_ptype_wait, + IOPARM_ptype_num +}; + +enum iofield_type +{ + IOPARM_type_int4, + IOPARM_type_intio, + IOPARM_type_pint4, + IOPARM_type_pintio, + IOPARM_type_pchar, + IOPARM_type_parray, + IOPARM_type_pad, + IOPARM_type_char1, + IOPARM_type_char2, + IOPARM_type_common, + IOPARM_type_num +}; + +typedef struct GTY(()) gfc_st_parameter_field { + const char *name; + unsigned int mask; + enum ioparam_type param_type; + enum iofield_type type; + tree field; + tree field_len; +} +gfc_st_parameter_field; + +typedef struct GTY(()) gfc_st_parameter { + const char *name; + tree type; +} +gfc_st_parameter; + +enum iofield +{ +#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name, +#include "ioparm.def" +#undef IOPARM + IOPARM_field_num +}; + +static GTY(()) gfc_st_parameter st_parameter[] = +{ + { "common", NULL }, + { "open", NULL }, + { "close", NULL }, + { "filepos", NULL }, + { "inquire", NULL }, + { "dt", NULL }, + { "wait", NULL } +}; + +static GTY(()) gfc_st_parameter_field st_parameter_field[] = +{ +#define IOPARM(param_type, name, mask, type) \ + { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL }, +#include "ioparm.def" +#undef IOPARM + { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL } +}; + +/* Library I/O subroutines */ + +enum iocall +{ + IOCALL_READ, + IOCALL_READ_DONE, + IOCALL_WRITE, + IOCALL_WRITE_DONE, + IOCALL_X_INTEGER, + IOCALL_X_INTEGER_WRITE, + IOCALL_X_LOGICAL, + IOCALL_X_LOGICAL_WRITE, + IOCALL_X_CHARACTER, + IOCALL_X_CHARACTER_WRITE, + IOCALL_X_CHARACTER_WIDE, + IOCALL_X_CHARACTER_WIDE_WRITE, + IOCALL_X_REAL, + IOCALL_X_REAL_WRITE, + IOCALL_X_COMPLEX, + IOCALL_X_COMPLEX_WRITE, + IOCALL_X_REAL128, + IOCALL_X_REAL128_WRITE, + IOCALL_X_COMPLEX128, + IOCALL_X_COMPLEX128_WRITE, + IOCALL_X_ARRAY, + IOCALL_X_ARRAY_WRITE, + IOCALL_OPEN, + IOCALL_CLOSE, + IOCALL_INQUIRE, + IOCALL_IOLENGTH, + IOCALL_IOLENGTH_DONE, + IOCALL_REWIND, + IOCALL_BACKSPACE, + IOCALL_ENDFILE, + IOCALL_FLUSH, + IOCALL_SET_NML_VAL, + IOCALL_SET_NML_VAL_DIM, + IOCALL_WAIT, + IOCALL_NUM +}; + +static GTY(()) tree iocall[IOCALL_NUM]; + +/* Variable for keeping track of what the last data transfer statement + was. Used for deciding which subroutine to call when the data + transfer is complete. */ +static enum { READ, WRITE, IOLENGTH } last_dt; + +/* The data transfer parameter block that should be shared by all + data transfer calls belonging to the same read/write/iolength. */ +static GTY(()) tree dt_parm; +static stmtblock_t *dt_post_end_block; + +static void +gfc_build_st_parameter (enum ioparam_type ptype, tree *types) +{ + unsigned int type; + gfc_st_parameter_field *p; + char name[64]; + size_t len; + tree t = make_node (RECORD_TYPE); + tree *chain = NULL; + + len = strlen (st_parameter[ptype].name); + gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_")); + memcpy (name, "__st_parameter_", sizeof ("__st_parameter_")); + memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name, + len + 1); + TYPE_NAME (t) = get_identifier (name); + + for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++) + if (p->param_type == ptype) + switch (p->type) + { + case IOPARM_type_int4: + case IOPARM_type_intio: + case IOPARM_type_pint4: + case IOPARM_type_pintio: + case IOPARM_type_parray: + case IOPARM_type_pchar: + case IOPARM_type_pad: + p->field = gfc_add_field_to_struct (t, get_identifier (p->name), + types[p->type], &chain); + break; + case IOPARM_type_char1: + p->field = gfc_add_field_to_struct (t, get_identifier (p->name), + pchar_type_node, &chain); + /* FALLTHROUGH */ + case IOPARM_type_char2: + len = strlen (p->name); + gcc_assert (len <= sizeof (name) - sizeof ("_len")); + memcpy (name, p->name, len); + memcpy (name + len, "_len", sizeof ("_len")); + p->field_len = gfc_add_field_to_struct (t, get_identifier (name), + gfc_charlen_type_node, + &chain); + if (p->type == IOPARM_type_char2) + p->field = gfc_add_field_to_struct (t, get_identifier (p->name), + pchar_type_node, &chain); + break; + case IOPARM_type_common: + p->field + = gfc_add_field_to_struct (t, + get_identifier (p->name), + st_parameter[IOPARM_ptype_common].type, + &chain); + break; + case IOPARM_type_num: + gcc_unreachable (); + } + + gfc_finish_type (t); + st_parameter[ptype].type = t; +} + + +/* Build code to test an error condition and call generate_error if needed. + Note: This builds calls to generate_error in the runtime library function. + The function generate_error is dependent on certain parameters in the + st_parameter_common flags to be set. (See libgfortran/runtime/error.c) + Therefore, the code to set these flags must be generated before + this function is used. */ + +void +gfc_trans_io_runtime_check (tree cond, tree var, int error_code, + const char * msgid, stmtblock_t * pblock) +{ + stmtblock_t block; + tree body; + tree tmp; + tree arg1, arg2, arg3; + char *message; + + if (integer_zerop (cond)) + return; + + /* The code to generate the error. */ + gfc_start_block (&block); + + arg1 = gfc_build_addr_expr (NULL_TREE, var); + + arg2 = build_int_cst (integer_type_node, error_code), + + asprintf (&message, "%s", _(msgid)); + arg3 = gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const (message)); + gfc_free(message); + + tmp = build_call_expr_loc (input_location, + gfor_fndecl_generate_error, 3, arg1, arg2, arg3); + + gfc_add_expr_to_block (&block, tmp); + + body = gfc_finish_block (&block); + + if (integer_onep (cond)) + { + gfc_add_expr_to_block (pblock, body); + } + else + { + /* Tell the compiler that this isn't likely. */ + cond = fold_convert (long_integer_type_node, cond); + tmp = build_int_cst (long_integer_type_node, 0); + cond = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); + cond = fold_convert (boolean_type_node, cond); + + tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location)); + gfc_add_expr_to_block (pblock, tmp); + } +} + + +/* Create function decls for IO library functions. */ + +void +gfc_build_io_library_fndecls (void) +{ + tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node; + tree gfc_intio_type_node; + tree parm_type, dt_parm_type; + HOST_WIDE_INT pad_size; + unsigned int ptype; + + types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4); + types[IOPARM_type_intio] = gfc_intio_type_node + = gfc_get_int_type (gfc_intio_kind); + types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node); + types[IOPARM_type_pintio] + = build_pointer_type (gfc_intio_type_node); + types[IOPARM_type_parray] = pchar_type_node; + types[IOPARM_type_pchar] = pchar_type_node; + pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node)); + pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node)); + pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size - 1)); + types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx); + + /* pad actually contains pointers and integers so it needs to have an + alignment that is at least as large as the needed alignment for those + types. See the st_parameter_dt structure in libgfortran/io/io.h for + what really goes into this space. */ + TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node), + TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind))); + + for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++) + gfc_build_st_parameter ((enum ioparam_type) ptype, types); + + /* Define the transfer functions. */ + + dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type); + + iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_integer")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_INTEGER_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_integer_write")), ".wR", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_logical")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_LOGICAL_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_logical_write")), ".wR", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_character")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_character_write")), ".wR", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_character_wide")), ".wW", + void_type_node, 4, dt_parm_type, pvoid_type_node, + gfc_charlen_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_CHARACTER_WIDE_WRITE] = + gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_character_wide_write")), ".wR", + void_type_node, 4, dt_parm_type, pvoid_type_node, + gfc_charlen_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_real")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_REAL_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_real_write")), ".wR", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_complex")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_COMPLEX_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_complex_write")), ".wR", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + /* Version for __float128. */ + iocall[IOCALL_X_REAL128] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_real128")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_REAL128_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_real128_write")), ".wR", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_COMPLEX128] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_complex128")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_COMPLEX128_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_complex128_write")), ".wR", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_array")), ".ww", + void_type_node, 4, dt_parm_type, pvoid_type_node, + integer_type_node, gfc_charlen_type_node); + + iocall[IOCALL_X_ARRAY_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_array_write")), ".wr", + void_type_node, 4, dt_parm_type, pvoid_type_node, + integer_type_node, gfc_charlen_type_node); + + /* Library entry points */ + + iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_read")), ".w", + void_type_node, 1, dt_parm_type); + + iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_write")), ".w", + void_type_node, 1, dt_parm_type); + + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type); + iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_open")), ".w", + void_type_node, 1, parm_type); + + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type); + iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_close")), ".w", + void_type_node, 1, parm_type); + + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type); + iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_inquire")), ".w", + void_type_node, 1, parm_type); + + iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec( + get_identifier (PREFIX("st_iolength")), ".w", + void_type_node, 1, dt_parm_type); + + /* TODO: Change when asynchronous I/O is implemented. */ + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type); + iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_wait")), ".X", + void_type_node, 1, parm_type); + + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type); + iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_rewind")), ".w", + void_type_node, 1, parm_type); + + iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_backspace")), ".w", + void_type_node, 1, parm_type); + + iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_endfile")), ".w", + void_type_node, 1, parm_type); + + iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_flush")), ".w", + void_type_node, 1, parm_type); + + /* Library helpers */ + + iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_read_done")), ".w", + void_type_node, 1, dt_parm_type); + + iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_write_done")), ".w", + void_type_node, 1, dt_parm_type); + + iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_iolength_done")), ".w", + void_type_node, 1, dt_parm_type); + + iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_set_nml_var")), ".w.R", + void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node, + void_type_node, gfc_charlen_type_node, gfc_int4_type_node); + + iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_set_nml_var_dim")), ".w", + void_type_node, 5, dt_parm_type, gfc_int4_type_node, + gfc_array_index_type, gfc_array_index_type, gfc_array_index_type); +} + + +/* Generate code to store an integer constant into the + st_parameter_XXX structure. */ + +static unsigned int +set_parameter_const (stmtblock_t *block, tree var, enum iofield type, + unsigned int val) +{ + tree tmp; + gfc_st_parameter_field *p = &st_parameter_field[type]; + + if (p->param_type == IOPARM_ptype_common) + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val)); + return p->mask; +} + + +/* Generate code to store a non-string I/O parameter into the + st_parameter_XXX structure. This is a pass by value. */ + +static unsigned int +set_parameter_value (stmtblock_t *block, tree var, enum iofield type, + gfc_expr *e) +{ + gfc_se se; + tree tmp; + gfc_st_parameter_field *p = &st_parameter_field[type]; + tree dest_type = TREE_TYPE (p->field); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, e); + + /* If we're storing a UNIT number, we need to check it first. */ + if (type == IOPARM_common_unit && e->ts.kind > 4) + { + tree cond, val; + int i; + + /* Don't evaluate the UNIT number multiple times. */ + se.expr = gfc_evaluate_now (se.expr, &se.pre); + + /* UNIT numbers should be greater than the min. */ + i = gfc_validate_kind (BT_INTEGER, 4, false); + val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4); + cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + se.expr, + fold_convert (TREE_TYPE (se.expr), val)); + gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT, + "Unit number in I/O statement too small", + &se.pre); + + /* UNIT numbers should be less than the max. */ + val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + se.expr, + fold_convert (TREE_TYPE (se.expr), val)); + gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT, + "Unit number in I/O statement too large", + &se.pre); + + } + + se.expr = convert (dest_type, se.expr); + gfc_add_block_to_block (block, &se.pre); + + if (p->param_type == IOPARM_ptype_common) + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + + tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var, + p->field, NULL_TREE); + gfc_add_modify (block, tmp, se.expr); + return p->mask; +} + + +/* Generate code to store a non-string I/O parameter into the + st_parameter_XXX structure. This is pass by reference. */ + +static unsigned int +set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, + tree var, enum iofield type, gfc_expr *e) +{ + gfc_se se; + tree tmp, addr; + gfc_st_parameter_field *p = &st_parameter_field[type]; + + gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL); + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, e); + + gfc_add_block_to_block (block, &se.pre); + + if (TYPE_MODE (TREE_TYPE (se.expr)) + == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field)))) + { + addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr)); + + /* If this is for the iostat variable initialize the + user variable to LIBERROR_OK which is zero. */ + if (type == IOPARM_common_iostat) + gfc_add_modify (block, se.expr, + build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK)); + } + else + { + /* The type used by the library has different size + from the type of the variable supplied by the user. + Need to use a temporary. */ + tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)), + st_parameter_field[type].name); + + /* If this is for the iostat variable, initialize the + user variable to LIBERROR_OK which is zero. */ + if (type == IOPARM_common_iostat) + gfc_add_modify (block, tmpvar, + build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK)); + + addr = gfc_build_addr_expr (NULL_TREE, tmpvar); + /* After the I/O operation, we set the variable from the temporary. */ + tmp = convert (TREE_TYPE (se.expr), tmpvar); + gfc_add_modify (postblock, se.expr, tmp); + } + + if (p->param_type == IOPARM_ptype_common) + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + gfc_add_modify (block, tmp, addr); + return p->mask; +} + +/* Given an array expr, find its address and length to get a string. If the + array is full, the string's address is the address of array's first element + and the length is the size of the whole array. If it is an element, the + string's address is the element's address and the length is the rest size of + the array. */ + +static void +gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) +{ + tree size; + + if (e->rank == 0) + { + tree type, array, tmp; + gfc_symbol *sym; + int rank; + + /* If it is an element, we need its address and size of the rest. */ + gcc_assert (e->expr_type == EXPR_VARIABLE); + gcc_assert (e->ref->u.ar.type == AR_ELEMENT); + sym = e->symtree->n.sym; + rank = sym->as->rank - 1; + gfc_conv_expr (se, e); + + array = sym->backend_decl; + type = TREE_TYPE (array); + + if (GFC_ARRAY_TYPE_P (type)) + size = GFC_TYPE_ARRAY_SIZE (type); + else + { + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + size = gfc_conv_array_stride (array, rank); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_array_ubound (array, rank), + gfc_conv_array_lbound (array, rank)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, size); + } + gcc_assert (size); + + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, size, + TREE_OPERAND (se->expr, 1)); + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + fold_convert (gfc_array_index_type, tmp)); + se->string_length = fold_convert (gfc_charlen_type_node, size); + return; + } + + gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size); + se->string_length = fold_convert (gfc_charlen_type_node, size); +} + + +/* Generate code to store a string and its length into the + st_parameter_XXX structure. */ + +static unsigned int +set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, + enum iofield type, gfc_expr * e) +{ + gfc_se se; + tree tmp; + tree io; + tree len; + gfc_st_parameter_field *p = &st_parameter_field[type]; + + gfc_init_se (&se, NULL); + + if (p->param_type == IOPARM_ptype_common) + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + len = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (p->field_len), + var, p->field_len, NULL_TREE); + + /* Integer variable assigned a format label. */ + if (e->ts.type == BT_INTEGER + && e->rank == 0 + && e->symtree->n.sym->attr.assign == 1) + { + char * msg; + tree cond; + + gfc_conv_label_variable (&se, e); + tmp = GFC_DECL_STRING_LEN (se.expr); + cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); + + asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format " + "label", e->symtree->name); + gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg, + fold_convert (long_integer_type_node, tmp)); + gfc_free (msg); + + gfc_add_modify (&se.pre, io, + fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr))); + gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr)); + } + else + { + /* General character. */ + if (e->ts.type == BT_CHARACTER && e->rank == 0) + gfc_conv_expr (&se, e); + /* Array assigned Hollerith constant or character array. */ + else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0)) + gfc_convert_array_to_string (&se, e); + else + gcc_unreachable (); + + gfc_conv_string_parameter (&se); + gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr)); + gfc_add_modify (&se.pre, len, se.string_length); + } + + gfc_add_block_to_block (block, &se.pre); + gfc_add_block_to_block (postblock, &se.post); + return p->mask; +} + + +/* Generate code to store the character (array) and the character length + for an internal unit. */ + +static unsigned int +set_internal_unit (stmtblock_t * block, stmtblock_t * post_block, + tree var, gfc_expr * e) +{ + gfc_se se; + tree io; + tree len; + tree desc; + tree tmp; + gfc_st_parameter_field *p; + unsigned int mask; + + gfc_init_se (&se, NULL); + + p = &st_parameter_field[IOPARM_dt_internal_unit]; + mask = p->mask; + io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len), + var, p->field_len, NULL_TREE); + p = &st_parameter_field[IOPARM_dt_internal_unit_desc]; + desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + + gcc_assert (e->ts.type == BT_CHARACTER); + + /* Character scalars. */ + if (e->rank == 0) + { + gfc_conv_expr (&se, e); + gfc_conv_string_parameter (&se); + tmp = se.expr; + se.expr = build_int_cst (pchar_type_node, 0); + } + + /* Character array. */ + else if (e->rank > 0) + { + se.ss = gfc_walk_expr (e); + + if (is_subref_array (e)) + { + /* Use a temporary for components of arrays of derived types + or substring array references. */ + gfc_conv_subref_array_arg (&se, e, 0, + last_dt == READ ? INTENT_IN : INTENT_OUT, false); + tmp = build_fold_indirect_ref_loc (input_location, + se.expr); + se.expr = gfc_build_addr_expr (pchar_type_node, tmp); + tmp = gfc_conv_descriptor_data_get (tmp); + } + else + { + /* Return the data pointer and rank from the descriptor. */ + gfc_conv_expr_descriptor (&se, e, se.ss); + tmp = gfc_conv_descriptor_data_get (se.expr); + se.expr = gfc_build_addr_expr (pchar_type_node, se.expr); + } + } + else + gcc_unreachable (); + + /* The cast is needed for character substrings and the descriptor + data. */ + gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp)); + gfc_add_modify (&se.pre, len, + fold_convert (TREE_TYPE (len), se.string_length)); + gfc_add_modify (&se.pre, desc, se.expr); + + gfc_add_block_to_block (block, &se.pre); + gfc_add_block_to_block (post_block, &se.post); + return mask; +} + +/* Add a case to a IO-result switch. */ + +static void +add_case (int label_value, gfc_st_label * label, stmtblock_t * body) +{ + tree tmp, value; + + if (label == NULL) + return; /* No label, no case */ + + value = build_int_cst (NULL_TREE, label_value); + + /* Make a backend label for this case. */ + tmp = gfc_build_label_decl (NULL_TREE); + + /* And the case itself. */ + tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp); + gfc_add_expr_to_block (body, tmp); + + /* Jump to the label. */ + tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label)); + gfc_add_expr_to_block (body, tmp); +} + + +/* Generate a switch statement that branches to the correct I/O + result label. The last statement of an I/O call stores the + result into a variable because there is often cleanup that + must be done before the switch, so a temporary would have to + be created anyway. */ + +static void +io_result (stmtblock_t * block, tree var, gfc_st_label * err_label, + gfc_st_label * end_label, gfc_st_label * eor_label) +{ + stmtblock_t body; + tree tmp, rc; + gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags]; + + /* If no labels are specified, ignore the result instead + of building an empty switch. */ + if (err_label == NULL + && end_label == NULL + && eor_label == NULL) + return; + + /* Build a switch statement. */ + gfc_start_block (&body); + + /* The label values here must be the same as the values + in the library_return enum in the runtime library */ + add_case (1, err_label, &body); + add_case (2, end_label, &body); + add_case (3, eor_label, &body); + + tmp = gfc_finish_block (&body); + + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc), + rc, build_int_cst (TREE_TYPE (rc), + IOPARM_common_libreturn_mask)); + + tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE); + + gfc_add_expr_to_block (block, tmp); +} + + +/* Store the current file and line number to variables so that if a + library call goes awry, we can tell the user where the problem is. */ + +static void +set_error_locus (stmtblock_t * block, tree var, locus * where) +{ + gfc_file *f; + tree str, locus_file; + int line; + gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename]; + + locus_file = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + locus_file = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (p->field), locus_file, + p->field, NULL_TREE); + f = where->lb->file; + str = gfc_build_cstring_const (f->filename); + + str = gfc_build_addr_expr (pchar_type_node, str); + gfc_add_modify (block, locus_file, str); + + line = LOCATION_LINE (where->lb->location); + set_parameter_const (block, var, IOPARM_common_line, line); +} + + +/* Translate an OPEN statement. */ + +tree +gfc_trans_open (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_open *p; + tree tmp, var; + unsigned int mask = 0; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm"); + + set_error_locus (&block, var, &code->loc); + p = code->ext.open; + + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); + + if (p->err) + mask |= IOPARM_common_err; + + if (p->file) + mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file); + + if (p->status) + mask |= set_string (&block, &post_block, var, IOPARM_open_status, + p->status); + + if (p->access) + mask |= set_string (&block, &post_block, var, IOPARM_open_access, + p->access); + + if (p->form) + mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form); + + if (p->recl) + mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl); + + if (p->blank) + mask |= set_string (&block, &post_block, var, IOPARM_open_blank, + p->blank); + + if (p->position) + mask |= set_string (&block, &post_block, var, IOPARM_open_position, + p->position); + + if (p->action) + mask |= set_string (&block, &post_block, var, IOPARM_open_action, + p->action); + + if (p->delim) + mask |= set_string (&block, &post_block, var, IOPARM_open_delim, + p->delim); + + if (p->pad) + mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad); + + if (p->decimal) + mask |= set_string (&block, &post_block, var, IOPARM_open_decimal, + p->decimal); + + if (p->encoding) + mask |= set_string (&block, &post_block, var, IOPARM_open_encoding, + p->encoding); + + if (p->round) + mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round); + + if (p->sign) + mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign); + + if (p->asynchronous) + mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous, + p->asynchronous); + + if (p->convert) + mask |= set_string (&block, &post_block, var, IOPARM_open_convert, + p->convert); + + if (p->newunit) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit, + p->newunit); + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (p->unit) + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_OPEN], 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, var, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +/* Translate a CLOSE statement. */ + +tree +gfc_trans_close (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_close *p; + tree tmp, var; + unsigned int mask = 0; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm"); + + set_error_locus (&block, var, &code->loc); + p = code->ext.close; + + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); + + if (p->err) + mask |= IOPARM_common_err; + + if (p->status) + mask |= set_string (&block, &post_block, var, IOPARM_close_status, + p->status); + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (p->unit) + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_CLOSE], 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, var, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +/* Common subroutine for building a file positioning statement. */ + +static tree +build_filepos (tree function, gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_filepos *p; + tree tmp, var; + unsigned int mask = 0; + + p = code->ext.filepos; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type, + "filepos_parm"); + + set_error_locus (&block, var, &code->loc); + + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); + + if (p->err) + mask |= IOPARM_common_err; + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (p->unit) + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (input_location, + function, 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, var, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +/* Translate a BACKSPACE statement. */ + +tree +gfc_trans_backspace (gfc_code * code) +{ + return build_filepos (iocall[IOCALL_BACKSPACE], code); +} + + +/* Translate an ENDFILE statement. */ + +tree +gfc_trans_endfile (gfc_code * code) +{ + return build_filepos (iocall[IOCALL_ENDFILE], code); +} + + +/* Translate a REWIND statement. */ + +tree +gfc_trans_rewind (gfc_code * code) +{ + return build_filepos (iocall[IOCALL_REWIND], code); +} + + +/* Translate a FLUSH statement. */ + +tree +gfc_trans_flush (gfc_code * code) +{ + return build_filepos (iocall[IOCALL_FLUSH], code); +} + + +/* Create a dummy iostat variable to catch any error due to bad unit. */ + +static gfc_expr * +create_dummy_iostat (void) +{ + gfc_symtree *st; + gfc_expr *e; + + gfc_get_ha_sym_tree ("@iostat", &st); + st->n.sym->ts.type = BT_INTEGER; + st->n.sym->ts.kind = gfc_default_integer_kind; + gfc_set_sym_referenced (st->n.sym); + gfc_commit_symbol (st->n.sym); + st->n.sym->backend_decl + = gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind), + st->n.sym->name); + + e = gfc_get_expr (); + e->expr_type = EXPR_VARIABLE; + e->symtree = st; + e->ts.type = BT_INTEGER; + e->ts.kind = st->n.sym->ts.kind; + + return e; +} + + +/* Translate the non-IOLENGTH form of an INQUIRE statement. */ + +tree +gfc_trans_inquire (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_inquire *p; + tree tmp, var; + unsigned int mask = 0, mask2 = 0; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type, + "inquire_parm"); + + set_error_locus (&block, var, &code->loc); + p = code->ext.inquire; + + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); + + if (p->err) + mask |= IOPARM_common_err; + + /* Sanity check. */ + if (p->unit && p->file) + gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc); + + if (p->file) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_file, + p->file); + + if (p->exist) + { + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist, + p->exist); + + if (p->unit && !p->iostat) + { + p->iostat = create_dummy_iostat (); + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_common_iostat, p->iostat); + } + } + + if (p->opened) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened, + p->opened); + + if (p->number) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number, + p->number); + + if (p->named) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named, + p->named); + + if (p->name) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_name, + p->name); + + if (p->access) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_access, + p->access); + + if (p->sequential) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential, + p->sequential); + + if (p->direct) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct, + p->direct); + + if (p->form) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_form, + p->form); + + if (p->formatted) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted, + p->formatted); + + if (p->unformatted) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted, + p->unformatted); + + if (p->recl) + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_inquire_recl_out, p->recl); + + if (p->nextrec) + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_inquire_nextrec, p->nextrec); + + if (p->blank) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank, + p->blank); + + if (p->delim) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim, + p->delim); + + if (p->position) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_position, + p->position); + + if (p->action) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_action, + p->action); + + if (p->read) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_read, + p->read); + + if (p->write) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_write, + p->write); + + if (p->readwrite) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite, + p->readwrite); + + if (p->pad) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad, + p->pad); + + if (p->convert) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert, + p->convert); + + if (p->strm_pos) + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_inquire_strm_pos_out, p->strm_pos); + + /* The second series of flags. */ + if (p->asynchronous) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous, + p->asynchronous); + + if (p->decimal) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal, + p->decimal); + + if (p->encoding) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding, + p->encoding); + + if (p->round) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round, + p->round); + + if (p->sign) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign, + p->sign); + + if (p->pending) + mask2 |= set_parameter_ref (&block, &post_block, var, + IOPARM_inquire_pending, p->pending); + + if (p->size) + mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size, + p->size); + + if (p->id) + mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id, + p->id); + + if (mask2) + mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2); + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (p->unit) + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_INQUIRE], 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, var, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +tree +gfc_trans_wait (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_wait *p; + tree tmp, var; + unsigned int mask = 0; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type, + "wait_parm"); + + set_error_locus (&block, var, &code->loc); + p = code->ext.wait; + + /* Set parameters here. */ + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); + + if (p->err) + mask |= IOPARM_common_err; + + if (p->id) + mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id); + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (p->unit) + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_WAIT], 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, var, p->err, NULL, NULL); + + return gfc_finish_block (&block); + +} + + +/* nml_full_name builds up the fully qualified name of a + derived type component. */ + +static char* +nml_full_name (const char* var_name, const char* cmp_name) +{ + int full_name_length; + char * full_name; + + full_name_length = strlen (var_name) + strlen (cmp_name) + 1; + full_name = (char*)gfc_getmem (full_name_length + 1); + strcpy (full_name, var_name); + full_name = strcat (full_name, "%"); + full_name = strcat (full_name, cmp_name); + return full_name; +} + + +/* nml_get_addr_expr builds an address expression from the + gfc_symbol or gfc_component backend_decl's. An offset is + provided so that the address of an element of an array of + derived types is returned. This is used in the runtime to + determine that span of the derived type. */ + +static tree +nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, + tree base_addr) +{ + tree decl = NULL_TREE; + tree tmp; + + if (sym) + { + sym->attr.referenced = 1; + decl = gfc_get_symbol_decl (sym); + + /* If this is the enclosing function declaration, use + the fake result instead. */ + if (decl == current_function_decl) + decl = gfc_get_fake_result_decl (sym, 0); + else if (decl == DECL_CONTEXT (current_function_decl)) + decl = gfc_get_fake_result_decl (sym, 1); + } + else + decl = c->backend_decl; + + gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL + || TREE_CODE (decl) == VAR_DECL + || TREE_CODE (decl) == PARM_DECL) + || TREE_CODE (decl) == COMPONENT_REF)); + + tmp = decl; + + /* Build indirect reference, if dummy argument. */ + + if (POINTER_TYPE_P (TREE_TYPE(tmp))) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + + /* Treat the component of a derived type, using base_addr for + the derived type. */ + + if (TREE_CODE (decl) == FIELD_DECL) + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + base_addr, tmp, NULL_TREE); + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_array_data (tmp); + else + { + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + + if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) + tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL); + + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = build_fold_indirect_ref_loc (input_location, + tmp); + } + + gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp))); + + return tmp; +} + + +/* For an object VAR_NAME whose base address is BASE_ADDR, generate a + call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively + generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */ + +#define IARG(i) build_int_cst (gfc_array_index_type, i) + +static void +transfer_namelist_element (stmtblock_t * block, const char * var_name, + gfc_symbol * sym, gfc_component * c, + tree base_addr) +{ + gfc_typespec * ts = NULL; + gfc_array_spec * as = NULL; + tree addr_expr = NULL; + tree dt = NULL; + tree string; + tree tmp; + tree dtype; + tree dt_parm_addr; + tree decl = NULL_TREE; + int n_dim; + int itype; + int rank = 0; + + gcc_assert (sym || c); + + /* Build the namelist object name. */ + + string = gfc_build_cstring_const (var_name); + string = gfc_build_addr_expr (pchar_type_node, string); + + /* Build ts, as and data address using symbol or component. */ + + ts = (sym) ? &sym->ts : &c->ts; + as = (sym) ? sym->as : c->as; + + addr_expr = nml_get_addr_expr (sym, c, base_addr); + + if (as) + rank = as->rank; + + if (rank) + { + decl = (sym) ? sym->backend_decl : c->backend_decl; + if (sym && sym->attr.dummy) + decl = build_fold_indirect_ref_loc (input_location, decl); + dt = TREE_TYPE (decl); + dtype = gfc_get_dtype (dt); + } + else + { + itype = ts->type; + dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT); + } + + /* Build up the arguments for the transfer call. + The call for the scalar part transfers: + (address, name, type, kind or string_length, dtype) */ + + dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm); + + if (ts->type == BT_CHARACTER) + tmp = ts->u.cl->backend_decl; + else + tmp = build_int_cst (gfc_charlen_type_node, 0); + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_SET_NML_VAL], 6, + dt_parm_addr, addr_expr, string, + IARG (ts->kind), tmp, dtype); + gfc_add_expr_to_block (block, tmp); + + /* If the object is an array, transfer rank times: + (null pointer, name, stride, lbound, ubound) */ + + for ( n_dim = 0 ; n_dim < rank ; n_dim++ ) + { + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_SET_NML_VAL_DIM], 5, + dt_parm_addr, + IARG (n_dim), + gfc_conv_array_stride (decl, n_dim), + gfc_conv_array_lbound (decl, n_dim), + gfc_conv_array_ubound (decl, n_dim)); + gfc_add_expr_to_block (block, tmp); + } + + if (ts->type == BT_DERIVED) + { + gfc_component *cmp; + + /* Provide the RECORD_TYPE to build component references. */ + + tree expr = build_fold_indirect_ref_loc (input_location, + addr_expr); + + for (cmp = ts->u.derived->components; cmp; cmp = cmp->next) + { + char *full_name = nml_full_name (var_name, cmp->name); + transfer_namelist_element (block, + full_name, + NULL, cmp, expr); + gfc_free (full_name); + } + } +} + +#undef IARG + +/* Create a data transfer statement. Not all of the fields are valid + for both reading and writing, but improper use has been filtered + out by now. */ + +static tree +build_dt (tree function, gfc_code * code) +{ + stmtblock_t block, post_block, post_end_block, post_iu_block; + gfc_dt *dt; + tree tmp, var; + gfc_expr *nmlname; + gfc_namelist *nml; + unsigned int mask = 0; + + gfc_start_block (&block); + gfc_init_block (&post_block); + gfc_init_block (&post_end_block); + gfc_init_block (&post_iu_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm"); + + set_error_locus (&block, var, &code->loc); + + if (last_dt == IOLENGTH) + { + gfc_inquire *inq; + + inq = code->ext.inquire; + + /* First check that preconditions are met. */ + gcc_assert (inq != NULL); + gcc_assert (inq->iolength != NULL); + + /* Connect to the iolength variable. */ + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_dt_iolength, inq->iolength); + dt = NULL; + } + else + { + dt = code->ext.dt; + gcc_assert (dt != NULL); + } + + if (dt && dt->io_unit) + { + if (dt->io_unit->ts.type == BT_CHARACTER) + { + mask |= set_internal_unit (&block, &post_iu_block, + var, dt->io_unit); + set_parameter_const (&block, var, IOPARM_common_unit, + dt->io_unit->ts.kind == 1 ? 0 : -1); + } + } + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + + if (dt) + { + if (dt->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + dt->iomsg); + + if (dt->iostat) + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_common_iostat, dt->iostat); + + if (dt->err) + mask |= IOPARM_common_err; + + if (dt->eor) + mask |= IOPARM_common_eor; + + if (dt->end) + mask |= IOPARM_common_end; + + if (dt->id) + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_dt_id, dt->id); + + if (dt->pos) + mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos); + + if (dt->asynchronous) + mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous, + dt->asynchronous); + + if (dt->blank) + mask |= set_string (&block, &post_block, var, IOPARM_dt_blank, + dt->blank); + + if (dt->decimal) + mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal, + dt->decimal); + + if (dt->delim) + mask |= set_string (&block, &post_block, var, IOPARM_dt_delim, + dt->delim); + + if (dt->pad) + mask |= set_string (&block, &post_block, var, IOPARM_dt_pad, + dt->pad); + + if (dt->round) + mask |= set_string (&block, &post_block, var, IOPARM_dt_round, + dt->round); + + if (dt->sign) + mask |= set_string (&block, &post_block, var, IOPARM_dt_sign, + dt->sign); + + if (dt->rec) + mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec); + + if (dt->advance) + mask |= set_string (&block, &post_block, var, IOPARM_dt_advance, + dt->advance); + + if (dt->format_expr) + mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format, + dt->format_expr); + + if (dt->format_label) + { + if (dt->format_label == &format_asterisk) + mask |= IOPARM_dt_list_format; + else + mask |= set_string (&block, &post_block, var, IOPARM_dt_format, + dt->format_label->format); + } + + if (dt->size) + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_dt_size, dt->size); + + if (dt->namelist) + { + if (dt->format_expr || dt->format_label) + gfc_internal_error ("build_dt: format with namelist"); + + nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL, + dt->namelist->name, + strlen (dt->namelist->name)); + + mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name, + nmlname); + + if (last_dt == READ) + mask |= IOPARM_dt_namelist_read_mode; + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + dt_parm = var; + + for (nml = dt->namelist->namelist; nml; nml = nml->next) + transfer_namelist_element (&block, nml->sym->name, nml->sym, + NULL, NULL_TREE); + } + else + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER) + set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit); + } + else + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (UNKNOWN_LOCATION, + function, 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + dt_parm = var; + dt_post_end_block = &post_end_block; + + /* Set implied do loop exit condition. */ + if (last_dt == READ || last_dt == WRITE) + { + gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags]; + + tmp = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), + NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (p->field), tmp, p->field, NULL_TREE); + tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp), + tmp, build_int_cst (TREE_TYPE (tmp), + IOPARM_common_libreturn_mask)); + } + else /* IOLENGTH */ + tmp = NULL_TREE; + + gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp)); + + gfc_add_block_to_block (&block, &post_iu_block); + + dt_parm = NULL; + dt_post_end_block = NULL; + + return gfc_finish_block (&block); +} + + +/* Translate the IOLENGTH form of an INQUIRE statement. We treat + this as a third sort of data transfer statement, except that + lengths are summed instead of actually transferring any data. */ + +tree +gfc_trans_iolength (gfc_code * code) +{ + last_dt = IOLENGTH; + return build_dt (iocall[IOCALL_IOLENGTH], code); +} + + +/* Translate a READ statement. */ + +tree +gfc_trans_read (gfc_code * code) +{ + last_dt = READ; + return build_dt (iocall[IOCALL_READ], code); +} + + +/* Translate a WRITE statement */ + +tree +gfc_trans_write (gfc_code * code) +{ + last_dt = WRITE; + return build_dt (iocall[IOCALL_WRITE], code); +} + + +/* Finish a data transfer statement. */ + +tree +gfc_trans_dt_end (gfc_code * code) +{ + tree function, tmp; + stmtblock_t block; + + gfc_init_block (&block); + + switch (last_dt) + { + case READ: + function = iocall[IOCALL_READ_DONE]; + break; + + case WRITE: + function = iocall[IOCALL_WRITE_DONE]; + break; + + case IOLENGTH: + function = iocall[IOCALL_IOLENGTH_DONE]; + break; + + default: + gcc_unreachable (); + } + + tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); + tmp = build_call_expr_loc (input_location, + function, 1, tmp); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, dt_post_end_block); + gfc_init_block (dt_post_end_block); + + if (last_dt != IOLENGTH) + { + gcc_assert (code->ext.dt != NULL); + io_result (&block, dt_parm, code->ext.dt->err, + code->ext.dt->end, code->ext.dt->eor); + } + + return gfc_finish_block (&block); +} + +static void +transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code); + +/* Given an array field in a derived type variable, generate the code + for the loop that iterates over array elements, and the code that + accesses those array elements. Use transfer_expr to generate code + for transferring that element. Because elements may also be + derived types, transfer_expr and transfer_array_component are mutually + recursive. */ + +static tree +transfer_array_component (tree expr, gfc_component * cm, locus * where) +{ + tree tmp; + stmtblock_t body; + stmtblock_t block; + gfc_loopinfo loop; + int n; + gfc_ss *ss; + gfc_se se; + + gfc_start_block (&block); + gfc_init_se (&se, NULL); + + /* Create and initialize Scalarization Status. Unlike in + gfc_trans_transfer, we can't simply use gfc_walk_expr to take + care of this task, because we don't have a gfc_expr at hand. + Build one manually, as in gfc_trans_subarray_assign. */ + + ss = gfc_get_ss (); + ss->type = GFC_SS_COMPONENT; + ss->expr = NULL; + ss->shape = gfc_get_shape (cm->as->rank); + ss->next = gfc_ss_terminator; + ss->data.info.dimen = cm->as->rank; + ss->data.info.descriptor = expr; + ss->data.info.data = gfc_conv_array_data (expr); + ss->data.info.offset = gfc_conv_array_offset (expr); + for (n = 0; n < cm->as->rank; n++) + { + ss->data.info.dim[n] = n; + ss->data.info.start[n] = gfc_conv_array_lbound (expr, n); + ss->data.info.stride[n] = gfc_index_one_node; + + mpz_init (ss->shape[n]); + mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer, + cm->as->lower[n]->value.integer); + mpz_add_ui (ss->shape[n], ss->shape[n], 1); + } + + /* Once we got ss, we use scalarizer to create the loop. */ + + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, ss); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, where); + gfc_mark_ss_chain_used (ss, 1); + gfc_start_scalarized_body (&loop, &body); + + gfc_copy_loopinfo_to_se (&se, &loop); + se.ss = ss; + + /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */ + se.expr = expr; + gfc_conv_tmp_array_ref (&se); + + /* Now se.expr contains an element of the array. Take the address and pass + it to the IO routines. */ + tmp = gfc_build_addr_expr (NULL_TREE, se.expr); + transfer_expr (&se, &cm->ts, tmp, NULL); + + /* We are done now with the loop body. Wrap up the scalarizer and + return. */ + + gfc_add_block_to_block (&body, &se.pre); + gfc_add_block_to_block (&body, &se.post); + + gfc_trans_scalarizing_loops (&loop, &body); + + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + + gcc_assert (ss->shape != NULL); + gfc_free_shape (&ss->shape, cm->as->rank); + gfc_cleanup_loop (&loop); + + return gfc_finish_block (&block); +} + +/* Generate the call for a scalar transfer node. */ + +static void +transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) +{ + tree tmp, function, arg2, arg3, field, expr; + gfc_component *c; + int kind; + + /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if + the user says something like: print *, 'c_null_ptr: ', c_null_ptr + We need to translate the expression to a constant if it's either + C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of + type C_PTR or C_FUNPTR, in which case the ts->type may no longer be + BT_DERIVED (could have been changed by gfc_conv_expr). */ + if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER) + && ts->u.derived != NULL + && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1)) + { + /* C_PTR and C_FUNPTR have private components which means they can not + be printed. However, if -std=gnu and not -pedantic, allow + the component to be printed to help debugging. */ + if (gfc_notification_std (GFC_STD_GNU) != SILENT) + { + gfc_error_now ("Derived type '%s' at %L has PRIVATE components", + ts->u.derived->name, code != NULL ? &(code->loc) : + &gfc_current_locus); + return; + } + + ts->type = ts->u.derived->ts.type; + ts->kind = ts->u.derived->ts.kind; + ts->f90_type = ts->u.derived->ts.f90_type; + } + + kind = ts->kind; + function = NULL; + arg2 = NULL; + arg3 = NULL; + + switch (ts->type) + { + case BT_INTEGER: + arg2 = build_int_cst (NULL_TREE, kind); + if (last_dt == READ) + function = iocall[IOCALL_X_INTEGER]; + else + function = iocall[IOCALL_X_INTEGER_WRITE]; + + break; + + case BT_REAL: + arg2 = build_int_cst (NULL_TREE, kind); + if (last_dt == READ) + { + if (gfc_real16_is_float128 && ts->kind == 16) + function = iocall[IOCALL_X_REAL128]; + else + function = iocall[IOCALL_X_REAL]; + } + else + { + if (gfc_real16_is_float128 && ts->kind == 16) + function = iocall[IOCALL_X_REAL128_WRITE]; + else + function = iocall[IOCALL_X_REAL_WRITE]; + } + + break; + + case BT_COMPLEX: + arg2 = build_int_cst (NULL_TREE, kind); + if (last_dt == READ) + { + if (gfc_real16_is_float128 && ts->kind == 16) + function = iocall[IOCALL_X_COMPLEX128]; + else + function = iocall[IOCALL_X_COMPLEX]; + } + else + { + if (gfc_real16_is_float128 && ts->kind == 16) + function = iocall[IOCALL_X_COMPLEX128_WRITE]; + else + function = iocall[IOCALL_X_COMPLEX_WRITE]; + } + + break; + + case BT_LOGICAL: + arg2 = build_int_cst (NULL_TREE, kind); + if (last_dt == READ) + function = iocall[IOCALL_X_LOGICAL]; + else + function = iocall[IOCALL_X_LOGICAL_WRITE]; + + break; + + case BT_CHARACTER: + if (kind == 4) + { + if (se->string_length) + arg2 = se->string_length; + else + { + tmp = build_fold_indirect_ref_loc (input_location, + addr_expr); + gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); + arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); + arg2 = fold_convert (gfc_charlen_type_node, arg2); + } + arg3 = build_int_cst (NULL_TREE, kind); + if (last_dt == READ) + function = iocall[IOCALL_X_CHARACTER_WIDE]; + else + function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE]; + + tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); + tmp = build_call_expr_loc (input_location, + function, 4, tmp, addr_expr, arg2, arg3); + gfc_add_expr_to_block (&se->pre, tmp); + gfc_add_block_to_block (&se->pre, &se->post); + return; + } + /* Fall through. */ + case BT_HOLLERITH: + if (se->string_length) + arg2 = se->string_length; + else + { + tmp = build_fold_indirect_ref_loc (input_location, + addr_expr); + gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); + arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); + } + if (last_dt == READ) + function = iocall[IOCALL_X_CHARACTER]; + else + function = iocall[IOCALL_X_CHARACTER_WRITE]; + + break; + + case BT_DERIVED: + /* Recurse into the elements of the derived type. */ + expr = gfc_evaluate_now (addr_expr, &se->pre); + expr = build_fold_indirect_ref_loc (input_location, + expr); + + for (c = ts->u.derived->components; c; c = c->next) + { + field = c->backend_decl; + gcc_assert (field && TREE_CODE (field) == FIELD_DECL); + + tmp = fold_build3_loc (UNKNOWN_LOCATION, + COMPONENT_REF, TREE_TYPE (field), + expr, field, NULL_TREE); + + if (c->attr.dimension) + { + tmp = transfer_array_component (tmp, c, & code->loc); + gfc_add_expr_to_block (&se->pre, tmp); + } + else + { + if (!c->attr.pointer) + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + transfer_expr (se, &c->ts, tmp, code); + } + } + return; + + default: + internal_error ("Bad IO basetype (%d)", ts->type); + } + + tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); + tmp = build_call_expr_loc (input_location, + function, 3, tmp, addr_expr, arg2); + gfc_add_expr_to_block (&se->pre, tmp); + gfc_add_block_to_block (&se->pre, &se->post); + +} + + +/* Generate a call to pass an array descriptor to the IO library. The + array should be of one of the intrinsic types. */ + +static void +transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr) +{ + tree tmp, charlen_arg, kind_arg, io_call; + + if (ts->type == BT_CHARACTER) + charlen_arg = se->string_length; + else + charlen_arg = build_int_cst (NULL_TREE, 0); + + kind_arg = build_int_cst (NULL_TREE, ts->kind); + + tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); + if (last_dt == READ) + io_call = iocall[IOCALL_X_ARRAY]; + else + io_call = iocall[IOCALL_X_ARRAY_WRITE]; + + tmp = build_call_expr_loc (UNKNOWN_LOCATION, + io_call, 4, + tmp, addr_expr, kind_arg, charlen_arg); + gfc_add_expr_to_block (&se->pre, tmp); + gfc_add_block_to_block (&se->pre, &se->post); +} + + +/* gfc_trans_transfer()-- Translate a TRANSFER code node */ + +tree +gfc_trans_transfer (gfc_code * code) +{ + stmtblock_t block, body; + gfc_loopinfo loop; + gfc_expr *expr; + gfc_ref *ref; + gfc_ss *ss; + gfc_se se; + tree tmp; + int n; + + gfc_start_block (&block); + gfc_init_block (&body); + + expr = code->expr1; + ss = gfc_walk_expr (expr); + + ref = NULL; + gfc_init_se (&se, NULL); + + if (ss == gfc_ss_terminator) + { + /* Transfer a scalar value. */ + gfc_conv_expr_reference (&se, expr); + transfer_expr (&se, &expr->ts, se.expr, code); + } + else + { + /* Transfer an array. If it is an array of an intrinsic + type, pass the descriptor to the library. Otherwise + scalarize the transfer. */ + if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL)) + { + for (ref = expr->ref; ref && ref->type != REF_ARRAY; + ref = ref->next); + gcc_assert (ref->type == REF_ARRAY); + } + + if (expr->ts.type != BT_DERIVED + && ref && ref->next == NULL + && !is_subref_array (expr)) + { + bool seen_vector = false; + + if (ref && ref->u.ar.type == AR_SECTION) + { + for (n = 0; n < ref->u.ar.dimen; n++) + if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) + seen_vector = true; + } + + if (seen_vector && last_dt == READ) + { + /* Create a temp, read to that and copy it back. */ + gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false); + tmp = se.expr; + } + else + { + /* Get the descriptor. */ + gfc_conv_expr_descriptor (&se, expr, ss); + tmp = gfc_build_addr_expr (NULL_TREE, se.expr); + } + + transfer_array_desc (&se, &expr->ts, tmp); + goto finish_block_label; + } + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, ss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &code->expr1->where); + + /* The main loop body. */ + gfc_mark_ss_chain_used (ss, 1); + gfc_start_scalarized_body (&loop, &body); + + gfc_copy_loopinfo_to_se (&se, &loop); + se.ss = ss; + + gfc_conv_expr_reference (&se, expr); + transfer_expr (&se, &expr->ts, se.expr, code); + } + + finish_block_label: + + gfc_add_block_to_block (&body, &se.pre); + gfc_add_block_to_block (&body, &se.post); + + if (se.ss == NULL) + tmp = gfc_finish_block (&body); + else + { + gcc_assert (se.ss == gfc_ss_terminator); + gfc_trans_scalarizing_loops (&loop, &body); + + gfc_add_block_to_block (&loop.pre, &loop.post); + tmp = gfc_finish_block (&loop.pre); + gfc_cleanup_loop (&loop); + } + + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + +#include "gt-fortran-trans-io.h" -- cgit v1.2.3