/* IO Code translation/library interface
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
- Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 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
};
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);
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;
= build_pointer_type (gfc_intio_type_node);
types[IOPARM_type_parray] = pchar_type_node;
types[IOPARM_type_pchar] = pchar_type_node;
- pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
+ pad_size = 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
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;
}
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)
{
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);
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)
+ if (c->attr.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)
+ if (!c->attr.pointer)
tmp = build_fold_addr_expr (tmp);
transfer_expr (se, &c->ts, tmp, code);
}
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);