X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-io.c;h=e304d1687bfc9674c4f820c9e4e5a66b28a5bf17;hp=b24a2f262bf4e32bfcd32efc912ebcd8e3dd569a;hb=75a70cf95f65fe9204b15ad9aba31c571381d224;hpb=c1f61f139695bc18ddd7c9a665f6e814ac0732d5 diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index b24a2f262bf..e304d1687bf 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -1,5 +1,5 @@ /* IO Code translation/library interface - Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Contributed by Paul Brook @@ -7,7 +7,7 @@ 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 2, or (at your option) any later +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 @@ -16,16 +16,15 @@ 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 COPYING. If not, write to the Free -Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA -02110-1301, USA. */ +along with GCC; see the file COPYING3. If not see +. */ #include "config.h" #include "system.h" #include "coretypes.h" #include "tree.h" -#include "tree-gimple.h" +#include "gimple.h" #include "ggc.h" #include "toplev.h" #include "real.h" @@ -46,6 +45,7 @@ enum ioparam_type IOPARM_ptype_filepos, IOPARM_ptype_inquire, IOPARM_ptype_dt, + IOPARM_ptype_wait, IOPARM_ptype_num }; @@ -97,7 +97,8 @@ static GTY(()) gfc_st_parameter st_parameter[] = { "close", NULL }, { "filepos", NULL }, { "inquire", NULL }, - { "dt", NULL } + { "dt", NULL }, + { "wait", NULL } }; static GTY(()) gfc_st_parameter_field st_parameter_field[] = @@ -120,6 +121,7 @@ enum iocall IOCALL_X_INTEGER, IOCALL_X_LOGICAL, IOCALL_X_CHARACTER, + IOCALL_X_CHARACTER_WIDE, IOCALL_X_REAL, IOCALL_X_COMPLEX, IOCALL_X_ARRAY, @@ -134,6 +136,7 @@ enum iocall IOCALL_FLUSH, IOCALL_SET_NML_VAL, IOCALL_SET_NML_VAL_DIM, + IOCALL_WAIT, IOCALL_NUM }; @@ -212,6 +215,63 @@ gfc_build_st_parameter (enum ioparam_type ptype, tree *types) 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 = build_fold_addr_expr (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 (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 (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 ()); + gfc_add_expr_to_block (pblock, tmp); + } +} + + /* Create function decls for IO library functions. */ void @@ -220,7 +280,6 @@ 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; - tree gfc_c_int_type_node; HOST_WIDE_INT pad_size; enum ioparam_type ptype; @@ -244,8 +303,6 @@ gfc_build_io_library_fndecls (void) TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node), TYPE_ALIGN (gfc_get_int_type (gfc_max_integer_kind))); - gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind); - for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++) gfc_build_st_parameter (ptype, types); @@ -271,6 +328,13 @@ gfc_build_io_library_fndecls (void) void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + iocall[IOCALL_X_CHARACTER_WIDE] = + gfc_build_library_function_decl (get_identifier + (PREFIX("transfer_character_wide")), + 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 (get_identifier (PREFIX("transfer_real")), void_type_node, 3, dt_parm_type, @@ -286,7 +350,7 @@ gfc_build_io_library_fndecls (void) gfc_build_library_function_decl (get_identifier (PREFIX("transfer_array")), void_type_node, 4, dt_parm_type, - pvoid_type_node, gfc_c_int_type_node, + pvoid_type_node, integer_type_node, gfc_charlen_type_node); /* Library entry points */ @@ -319,6 +383,11 @@ gfc_build_io_library_fndecls (void) gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")), void_type_node, 1, dt_parm_type); + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type); + iocall[IOCALL_WAIT] = + gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")), + gfc_int4_type_node, 1, parm_type); + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type); iocall[IOCALL_REWIND] = gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")), @@ -361,8 +430,8 @@ gfc_build_io_library_fndecls (void) iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")), void_type_node, 5, dt_parm_type, - gfc_int4_type_node, gfc_int4_type_node, - gfc_int4_type_node, gfc_int4_type_node); + gfc_int4_type_node, gfc_array_index_type, + gfc_array_index_type, gfc_array_index_type); } @@ -377,11 +446,11 @@ set_parameter_const (stmtblock_t *block, tree var, enum iofield type, gfc_st_parameter_field *p = &st_parameter_field[type]; if (p->param_type == IOPARM_ptype_common) - var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, - NULL_TREE); - gfc_add_modify_expr (block, tmp, build_int_cst (TREE_TYPE (p->field), val)); + var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + tmp = fold_build3 (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; } @@ -396,17 +465,47 @@ set_parameter_value (stmtblock_t *block, tree var, enum iofield type, 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_type (&se, e, TREE_TYPE (p->field)); + 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, max; + int i; + + /* Don't evaluate the UNIT number multiple times. */ + se.expr = gfc_evaluate_now (se.expr, &se.pre); + + /* UNIT numbers should be nonnegative. */ + cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr, + build_int_cst (TREE_TYPE (se.expr),0)); + gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT, + "Negative unit number in I/O statement", + &se.pre); + + /* UNIT numbers should be less than the max. */ + i = gfc_validate_kind (BT_INTEGER, 4, false); + max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); + cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr, + fold_convert (TREE_TYPE (se.expr), max)); + 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 = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, - NULL_TREE); - gfc_add_modify_expr (block, tmp, se.expr); + var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + + tmp = fold_build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE); + gfc_add_modify (block, tmp, se.expr); return p->mask; } @@ -430,27 +529,41 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, if (TYPE_MODE (TREE_TYPE (se.expr)) == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field)))) - addr = convert (TREE_TYPE (p->field), - build_fold_addr_expr (se.expr)); + { + addr = convert (TREE_TYPE (p->field), build_fold_addr_expr (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); + 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 = build_fold_addr_expr (tmpvar); + /* After the I/O operation, we set the variable from the temporary. */ tmp = convert (TREE_TYPE (se.expr), tmpvar); - gfc_add_modify_expr (postblock, se.expr, tmp); - } + gfc_add_modify (postblock, se.expr, tmp); + } if (p->param_type == IOPARM_ptype_common) - var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, - NULL_TREE); - gfc_add_modify_expr (block, tmp, addr); + var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + gfc_add_modify (block, tmp, addr); return p->mask; } @@ -512,7 +625,8 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) } tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); + size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, + fold_convert (gfc_array_index_type, tmp)); se->string_length = fold_convert (gfc_charlen_type_node, size); } @@ -534,31 +648,33 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, gfc_init_se (&se, NULL); if (p->param_type == IOPARM_ptype_common) - var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, - NULL_TREE); - len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len, - NULL_TREE); + var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + len = fold_build3 (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->symtree->n.sym->attr.assign == 1) { char * msg; + tree cond; gfc_conv_label_variable (&se, e); tmp = GFC_DECL_STRING_LEN (se.expr); - tmp = fold_build2 (LT_EXPR, boolean_type_node, - tmp, build_int_cst (TREE_TYPE (tmp), 0)); + cond = fold_build2 (LT_EXPR, boolean_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); - asprintf(&msg, "Label assigned to variable '%s' is not a format label", - e->symtree->name); - gfc_trans_runtime_check (tmp, msg, &se.pre, &e->where); + 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_expr (&se.pre, io, + gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr))); - gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr)); + gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr)); } else { @@ -572,8 +688,8 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, gcc_unreachable (); gfc_conv_string_parameter (&se); - gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr)); - gfc_add_modify_expr (&se.pre, len, se.string_length); + 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); @@ -586,7 +702,8 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, for an internal unit. */ static unsigned int -set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e) +set_internal_unit (stmtblock_t * block, stmtblock_t * post_block, + tree var, gfc_expr * e) { gfc_se se; tree io; @@ -600,13 +717,13 @@ set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e) p = &st_parameter_field[IOPARM_dt_internal_unit]; mask = p->mask; - io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, - NULL_TREE); - len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len, - NULL_TREE); + io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len), + var, p->field_len, NULL_TREE); p = &st_parameter_field[IOPARM_dt_internal_unit_desc]; - desc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, - NULL_TREE); + desc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); gcc_assert (e->ts.type == BT_CHARACTER); @@ -624,21 +741,36 @@ set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e) { se.ss = gfc_walk_expr (e); - /* 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); + 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); + tmp = build_fold_indirect_ref (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_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp)); - gfc_add_modify_expr (&se.pre, len, se.string_length); - gfc_add_modify_expr (&se.pre, desc, se.expr); + 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; } @@ -699,12 +831,13 @@ io_result (stmtblock_t * block, tree var, gfc_st_label * err_label, tmp = gfc_finish_block (&body); - var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - rc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, - NULL_TREE); - rc = build2 (BIT_AND_EXPR, TREE_TYPE (rc), rc, - build_int_cst (TREE_TYPE (rc), IOPARM_common_libreturn_mask)); + var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + rc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + rc = fold_build2 (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); @@ -723,21 +856,18 @@ set_error_locus (stmtblock_t * block, tree var, locus * where) int line; gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename]; - locus_file = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - locus_file = build3 (COMPONENT_REF, TREE_TYPE (p->field), locus_file, - p->field, NULL_TREE); + locus_file = fold_build3 (COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + locus_file = fold_build3 (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_expr (block, locus_file, str); + gfc_add_modify (block, locus_file, str); -#ifdef USE_MAPPED_LOCATION line = LOCATION_LINE (where->lb->location); -#else - line = where->lb->linenum; -#endif set_parameter_const (block, var, IOPARM_common_line, line); } @@ -760,10 +890,16 @@ gfc_trans_open (gfc_code * code) set_error_locus (&block, var, &code->loc); p = code->ext.open; - if (p->unit) - set_parameter_value (&block, var, IOPARM_common_unit, p->unit); - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); + 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); @@ -801,16 +937,23 @@ gfc_trans_open (gfc_code * code) if (p->pad) mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad); - if (p->iomsg) - mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, - p->iomsg); + if (p->decimal) + mask |= set_string (&block, &post_block, var, IOPARM_open_decimal, + p->decimal); - if (p->iostat) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, - p->iostat); + if (p->encoding) + mask |= set_string (&block, &post_block, var, IOPARM_open_encoding, + p->encoding); - if (p->err) - mask |= IOPARM_common_err; + 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, @@ -818,9 +961,13 @@ gfc_trans_open (gfc_code * code) 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 = build_fold_addr_expr (var); - tmp = gfc_chainon_list (NULL_TREE, tmp); - tmp = build_function_call_expr (iocall[IOCALL_OPEN], tmp); + tmp = build_call_expr (iocall[IOCALL_OPEN], 1, tmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &post_block); @@ -849,15 +996,6 @@ gfc_trans_close (gfc_code * code) set_error_locus (&block, var, &code->loc); p = code->ext.close; - if (p->unit) - set_parameter_value (&block, var, IOPARM_common_unit, p->unit); - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); - - if (p->status) - mask |= set_string (&block, &post_block, var, IOPARM_close_status, - p->status); - if (p->iomsg) mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, p->iomsg); @@ -869,11 +1007,19 @@ gfc_trans_close (gfc_code * code) 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 = build_fold_addr_expr (var); - tmp = gfc_chainon_list (NULL_TREE, tmp); - tmp = build_function_call_expr (iocall[IOCALL_CLOSE], tmp); + tmp = build_call_expr (iocall[IOCALL_CLOSE], 1, tmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &post_block); @@ -904,11 +1050,6 @@ build_filepos (tree function, gfc_code * code) set_error_locus (&block, var, &code->loc); - if (p->unit) - set_parameter_value (&block, var, IOPARM_common_unit, p->unit); - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); - if (p->iomsg) mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, p->iomsg); @@ -922,9 +1063,13 @@ build_filepos (tree function, gfc_code * code) 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 = build_fold_addr_expr (var); - tmp = gfc_chainon_list (NULL_TREE, tmp); - tmp = build_function_call_expr (function, tmp); + tmp = build_call_expr (function, 1, tmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &post_block); @@ -971,6 +1116,33 @@ gfc_trans_flush (gfc_code * 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 @@ -979,7 +1151,7 @@ gfc_trans_inquire (gfc_code * code) stmtblock_t block, post_block; gfc_inquire *p; tree tmp, var; - unsigned int mask = 0; + unsigned int mask = 0, mask2 = 0; gfc_start_block (&block); gfc_init_block (&post_block); @@ -990,19 +1162,6 @@ gfc_trans_inquire (gfc_code * code) set_error_locus (&block, var, &code->loc); p = code->ext.inquire; - /* Sanity check. */ - if (p->unit && p->file) - gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc); - - if (p->unit) - set_parameter_value (&block, var, IOPARM_common_unit, p->unit); - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); - - if (p->file) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_file, - p->file); - if (p->iomsg) mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, p->iomsg); @@ -1011,9 +1170,29 @@ gfc_trans_inquire (gfc_code * code) 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); + { + 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, @@ -1067,6 +1246,10 @@ gfc_trans_inquire (gfc_code * code) 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); @@ -1087,17 +1270,10 @@ gfc_trans_inquire (gfc_code * code) mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite, p->readwrite); - if (p->delim) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim, - p->delim); - if (p->pad) mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad, p->pad); - - if (p->err) - mask |= IOPARM_common_err; - + if (p->convert) mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert, p->convert); @@ -1106,11 +1282,53 @@ gfc_trans_inquire (gfc_code * code) 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); + + set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2); + + if (mask2) + mask |= IOPARM_inquire_flags2; + 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 = build_fold_addr_expr (var); - tmp = gfc_chainon_list (NULL_TREE, tmp); - tmp = build_function_call_expr (iocall[IOCALL_INQUIRE], tmp); + tmp = build_call_expr (iocall[IOCALL_INQUIRE], 1, tmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &post_block); @@ -1120,6 +1338,56 @@ gfc_trans_inquire (gfc_code * code) 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 = build_fold_addr_expr (var); + tmp = build_call_expr (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); + +} + static gfc_expr * gfc_new_nml_name_expr (const char * name) { @@ -1131,14 +1399,13 @@ gfc_new_nml_name_expr (const char * name) nml_name->ts.kind = gfc_default_character_kind; nml_name->ts.type = BT_CHARACTER; nml_name->value.character.length = strlen(name); - nml_name->value.character.string = gfc_getmem (strlen (name) + 1); - strcpy (nml_name->value.character.string, name); + nml_name->value.character.string = gfc_char_to_widechar (name); return nml_name; } /* nml_full_name builds up the fully qualified name of a - derived type component. */ + derived type component. */ static char* nml_full_name (const char* var_name, const char* cmp_name) @@ -1158,7 +1425,7 @@ nml_full_name (const char* var_name, const char* cmp_name) 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. */ + determine that span of the derived type. */ static tree nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, @@ -1174,6 +1441,13 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, { 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; @@ -1203,8 +1477,8 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, the derived type. */ if (TREE_CODE (decl) == FIELD_DECL) - tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp), - base_addr, tmp, NULL_TREE); + tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), + base_addr, tmp, NULL_TREE); /* If we have a derived type component, a reference to the first element of the array is built. This is done so that base_addr, @@ -1212,7 +1486,7 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, a RECORD_TYPE. */ if (array_flagged) - tmp = gfc_build_array_ref (tmp, gfc_index_zero_node); + tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL); /* Now build the address expression. */ @@ -1232,8 +1506,6 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */ -#define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a) -#define NML_ADD_ARG(a) args = gfc_chainon_list (args, a) #define IARG(i) build_int_cst (gfc_array_index_type, i) static void @@ -1247,7 +1519,6 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, tree dt = NULL; tree string; tree tmp; - tree args; tree dtype; tree dt_parm_addr; int n_dim; @@ -1313,18 +1584,14 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, (address, name, type, kind or string_length, dtype) */ dt_parm_addr = build_fold_addr_expr (dt_parm); - NML_FIRST_ARG (dt_parm_addr); - NML_ADD_ARG (addr_expr); - NML_ADD_ARG (string); - NML_ADD_ARG (IARG (ts->kind)); if (ts->type == BT_CHARACTER) - NML_ADD_ARG (ts->cl->backend_decl); + tmp = ts->cl->backend_decl; else - NML_ADD_ARG (build_int_cst (gfc_charlen_type_node, 0)); - - NML_ADD_ARG (dtype); - tmp = build_function_call_expr (iocall[IOCALL_SET_NML_VAL], args); + tmp = build_int_cst (gfc_charlen_type_node, 0); + tmp = build_call_expr (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: @@ -1332,12 +1599,12 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, for ( n_dim = 0 ; n_dim < rank ; n_dim++ ) { - NML_FIRST_ARG (dt_parm_addr); - NML_ADD_ARG (IARG (n_dim)); - NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim)); - NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim)); - NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim)); - tmp = build_function_call_expr (iocall[IOCALL_SET_NML_VAL_DIM], args); + tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL_DIM], 5, + dt_parm_addr, + IARG (n_dim), + GFC_TYPE_ARRAY_STRIDE (dt, n_dim), + GFC_TYPE_ARRAY_LBOUND (dt, n_dim), + GFC_TYPE_ARRAY_UBOUND (dt, n_dim)); gfc_add_expr_to_block (block, tmp); } @@ -1361,8 +1628,6 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, } #undef IARG -#undef NML_ADD_ARG -#undef NML_FIRST_ARG /* Create a data transfer statement. Not all of the fields are valid for both reading and writing, but improper use has been filtered @@ -1371,7 +1636,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, static tree build_dt (tree function, gfc_code * code) { - stmtblock_t block, post_block, post_end_block; + stmtblock_t block, post_block, post_end_block, post_iu_block; gfc_dt *dt; tree tmp, var; gfc_expr *nmlname; @@ -1381,6 +1646,7 @@ build_dt (tree function, gfc_code * code) 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"); @@ -1411,17 +1677,68 @@ build_dt (tree function, gfc_code * code) { if (dt->io_unit->ts.type == BT_CHARACTER) { - mask |= set_internal_unit (&block, var, dt->io_unit); + mask |= set_internal_unit (&block, &post_iu_block, + var, dt->io_unit); set_parameter_const (&block, var, IOPARM_common_unit, 0); } - else - set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit); } 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); @@ -1442,27 +1759,10 @@ build_dt (tree function, gfc_code * code) dt->format_label->format); } - 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->size) mask |= set_parameter_ref (&block, &post_end_block, var, IOPARM_dt_size, dt->size); - if (dt->err) - mask |= IOPARM_common_err; - - if (dt->eor) - mask |= IOPARM_common_eor; - - if (dt->end) - mask |= IOPARM_common_end; - if (dt->namelist) { if (dt->format_expr || dt->format_label) @@ -1486,13 +1786,15 @@ build_dt (tree function, gfc_code * code) } 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 = build_fold_addr_expr (var); - tmp = gfc_chainon_list (NULL_TREE, tmp); - tmp = build_function_call_expr (function, tmp); + tmp = build_call_expr (function, 1, tmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &post_block); @@ -1502,6 +1804,8 @@ build_dt (tree function, gfc_code * code) gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next)); + gfc_add_block_to_block (&block, &post_iu_block); + dt_parm = NULL; dt_post_end_block = NULL; @@ -1570,8 +1874,7 @@ gfc_trans_dt_end (gfc_code * code) } tmp = build_fold_addr_expr (dt_parm); - tmp = gfc_chainon_list (NULL_TREE, tmp); - tmp = build_function_call_expr (function, tmp); + tmp = build_call_expr (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); @@ -1587,7 +1890,7 @@ gfc_trans_dt_end (gfc_code * code) } static void -transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr); +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 @@ -1597,7 +1900,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr); recursive. */ static tree -transfer_array_component (tree expr, gfc_component * cm) +transfer_array_component (tree expr, gfc_component * cm, locus * where) { tree tmp; stmtblock_t body; @@ -1641,7 +1944,7 @@ transfer_array_component (tree expr, gfc_component * cm) gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, ss); gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop); + gfc_conv_loop_setup (&loop, where); gfc_mark_ss_chain_used (ss, 1); gfc_start_scalarized_body (&loop, &body); @@ -1655,7 +1958,7 @@ transfer_array_component (tree expr, gfc_component * cm) /* Now se.expr contains an element of the array. Take the address and pass it to the IO routines. */ tmp = build_fold_addr_expr (se.expr); - transfer_expr (&se, &cm->ts, tmp); + transfer_expr (&se, &cm->ts, tmp, NULL); /* We are done now with the loop body. Wrap up the scalarizer and return. */ @@ -1680,15 +1983,41 @@ transfer_array_component (tree expr, gfc_component * cm) /* Generate the call for a scalar transfer node. */ static void -transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) +transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) { - tree args, tmp, function, arg2, field, expr; + 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->is_iso_c == 1 && ts->derived != NULL) + || (ts->derived != NULL && ts->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->derived->name, code != NULL ? &(code->loc) : + &gfc_current_locus); + return; + } + + ts->type = ts->derived->ts.type; + ts->kind = ts->derived->ts.kind; + ts->f90_type = ts->derived->ts.f90_type; + } + kind = ts->kind; function = NULL; arg2 = NULL; + arg3 = NULL; switch (ts->type) { @@ -1713,6 +2042,26 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) break; case BT_CHARACTER: + if (kind == 4) + { + if (se->string_length) + arg2 = se->string_length; + else + { + tmp = build_fold_indirect_ref (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); + function = iocall[IOCALL_X_CHARACTER_WIDE]; + tmp = build_fold_addr_expr (dt_parm); + tmp = build_call_expr (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; @@ -1735,19 +2084,19 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) field = c->backend_decl; gcc_assert (field && TREE_CODE (field) == FIELD_DECL); - tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field, - NULL_TREE); + tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), + expr, field, NULL_TREE); if (c->dimension) { - tmp = transfer_array_component (tmp, c); + tmp = transfer_array_component (tmp, c, & code->loc); gfc_add_expr_to_block (&se->pre, tmp); } else { if (!c->pointer) tmp = build_fold_addr_expr (tmp); - transfer_expr (se, &c->ts, tmp); + transfer_expr (se, &c->ts, tmp, code); } } return; @@ -1757,11 +2106,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) } tmp = build_fold_addr_expr (dt_parm); - args = gfc_chainon_list (NULL_TREE, tmp); - args = gfc_chainon_list (args, addr_expr); - args = gfc_chainon_list (args, arg2); - - tmp = build_function_call_expr (function, args); + tmp = build_call_expr (function, 3, tmp, addr_expr, arg2); gfc_add_expr_to_block (&se->pre, tmp); gfc_add_block_to_block (&se->pre, &se->post); @@ -1774,21 +2119,18 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) static void transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr) { - tree args, tmp, charlen_arg, kind_arg; + tree tmp, charlen_arg, kind_arg; if (ts->type == BT_CHARACTER) charlen_arg = se->string_length; else - charlen_arg = build_int_cstu (NULL_TREE, 0); + charlen_arg = build_int_cst (NULL_TREE, 0); kind_arg = build_int_cst (NULL_TREE, ts->kind); tmp = build_fold_addr_expr (dt_parm); - args = gfc_chainon_list (NULL_TREE, tmp); - args = gfc_chainon_list (args, addr_expr); - args = gfc_chainon_list (args, kind_arg); - args = gfc_chainon_list (args, charlen_arg); - tmp = build_function_call_expr (iocall[IOCALL_X_ARRAY], args); + tmp = build_call_expr (iocall[IOCALL_X_ARRAY], 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); } @@ -1806,6 +2148,7 @@ gfc_trans_transfer (gfc_code * code) gfc_ss *ss; gfc_se se; tree tmp; + int n; gfc_start_block (&block); gfc_init_block (&body); @@ -1820,7 +2163,7 @@ gfc_trans_transfer (gfc_code * code) { /* Transfer a scalar value. */ gfc_conv_expr_reference (&se, expr); - transfer_expr (&se, &expr->ts, se.expr); + transfer_expr (&se, &expr->ts, se.expr, code); } else { @@ -1834,11 +2177,32 @@ gfc_trans_transfer (gfc_code * code) gcc_assert (ref->type == REF_ARRAY); } - if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL) + if (expr->ts.type != BT_DERIVED + && ref && ref->next == NULL + && !is_subref_array (expr)) { - /* Get the descriptor. */ - gfc_conv_expr_descriptor (&se, expr, ss); - tmp = build_fold_addr_expr (se.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); + tmp = se.expr; + } + else + { + /* Get the descriptor. */ + gfc_conv_expr_descriptor (&se, expr, ss); + tmp = build_fold_addr_expr (se.expr); + } + transfer_array_desc (&se, &expr->ts, tmp); goto finish_block_label; } @@ -1849,7 +2213,7 @@ gfc_trans_transfer (gfc_code * code) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop); + gfc_conv_loop_setup (&loop, &code->expr->where); /* The main loop body. */ gfc_mark_ss_chain_used (ss, 1); @@ -1859,7 +2223,7 @@ gfc_trans_transfer (gfc_code * code) se.ss = ss; gfc_conv_expr_reference (&se, expr); - transfer_expr (&se, &expr->ts, se.expr); + transfer_expr (&se, &expr->ts, se.expr, code); } finish_block_label: