/* IO Code translation/library interface
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
Foundation, Inc.
Contributed by Paul Brook
#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
};
arg2 = build_int_cst (integer_type_node, error_code),
asprintf (&message, "%s", _(msgid));
- arg3 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
+ 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);
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("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")),
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;
}
if (type == IOPARM_common_unit && e->ts.kind != 4)
{
tree cond, max;
- ioerror_codes bad_unit;
int i;
- bad_unit = IOERROR_BAD_UNIT;
-
/* 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, bad_unit,
+ gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
"Negative unit number in I/O statement",
&se.pre);
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, bad_unit,
+ gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
"Unit number in I/O statement too large",
&se.pre);
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);
+ var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
- tmp = build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE);
- gfc_add_modify_expr (block, tmp, se.expr);
+ tmp = fold_build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE);
+ gfc_add_modify (block, tmp, se.expr);
return p->mask;
}
addr = convert (TREE_TYPE (p->field), build_fold_addr_expr (se.expr));
/* If this is for the iostat variable initialize the
- user variable to IOERROR_OK which is zero. */
+ user variable to LIBERROR_OK which is zero. */
if (type == IOPARM_common_iostat)
- {
- ioerror_codes ok;
- ok = IOERROR_OK;
- gfc_add_modify_expr (block, se.expr,
- build_int_cst (TREE_TYPE (se.expr), ok));
- }
+ gfc_add_modify (block, se.expr,
+ build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
}
else
{
st_parameter_field[type].name);
/* If this is for the iostat variable, initialize the
- user variable to IOERROR_OK which is zero. */
+ user variable to LIBERROR_OK which is zero. */
if (type == IOPARM_common_iostat)
- {
- ioerror_codes ok;
- ok = IOERROR_OK;
- gfc_add_modify_expr (block, tmpvar,
- build_int_cst (TREE_TYPE (tmpvar), ok));
- }
+ 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;
}
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)
asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
"label", e->symtree->name);
- gfc_trans_runtime_check (cond, &se.pre, &e->where, msg,
+ 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);
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);
- if (is_aliased_array (e))
+ if (is_subref_array (e))
{
/* Use a temporary for components of arrays of derived types
or substring array references. */
- gfc_conv_aliased_arg (&se, e, 0,
+ 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);
/* 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,
+ 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_expr (&se.pre, desc, se.expr);
+ 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);
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);
}
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);
}
+/* 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);
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->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)
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;
}
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. */
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);
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);
static void
transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
{
- tree tmp, function, arg2, field, expr;
+ tree tmp, function, arg2, arg3, field, expr;
gfc_component *c;
int kind;
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
gfc_ss *ss;
gfc_se se;
tree tmp;
+ int n;
gfc_start_block (&block);
gfc_init_block (&body);
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);
OSDN Git Service
