/* 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
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
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
+<http://www.gnu.org/licenses/>. */
#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"
IOPARM_ptype_filepos,
IOPARM_ptype_inquire,
IOPARM_ptype_dt,
+ IOPARM_ptype_wait,
IOPARM_ptype_num
};
{ "close", NULL },
{ "filepos", NULL },
{ "inquire", NULL },
- { "dt", NULL }
+ { "dt", NULL },
+ { "wait", NULL }
};
static GTY(()) gfc_st_parameter_field st_parameter_field[] =
IOCALL_X_INTEGER,
IOCALL_X_LOGICAL,
IOCALL_X_CHARACTER,
+ IOCALL_X_CHARACTER_WIDE,
IOCALL_X_REAL,
IOCALL_X_COMPLEX,
IOCALL_X_ARRAY,
IOCALL_FLUSH,
IOCALL_SET_NML_VAL,
IOCALL_SET_NML_VAL_DIM,
+ IOCALL_WAIT,
IOCALL_NUM
};
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
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;
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);
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,
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 */
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")),
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);
}
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;
}
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;
}
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;
}
}
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);
}
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
{
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);
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;
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);
{
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;
}
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);
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);
}
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);
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,
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);
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);
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);
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);
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);
}
+/* 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
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);
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);
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,
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);
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);
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);
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)
{
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)
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,
{
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;
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,
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. */
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
tree dt = NULL;
tree string;
tree tmp;
- tree args;
tree dtype;
tree dt_parm_addr;
int n_dim;
(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:
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);
}
}
#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
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;
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");
{
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);
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)
}
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);
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;
}
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);
}
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
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;
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);
/* 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. */
/* 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)
{
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;
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;
}
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);
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);
}
gfc_ss *ss;
gfc_se se;
tree tmp;
+ int n;
gfc_start_block (&block);
gfc_init_block (&body);
{
/* 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
{
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;
}
/* 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);
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:
OSDN Git Service
