/* 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, 2009, 2010
+ Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 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 "ggc.h"
-#include "toplev.h"
-#include "real.h"
+#include "diagnostic-core.h" /* For internal_error. */
#include "gfortran.h"
#include "trans.h"
#include "trans-stmt.h"
IOPARM_ptype_filepos,
IOPARM_ptype_inquire,
IOPARM_ptype_dt,
+ IOPARM_ptype_wait,
IOPARM_ptype_num
};
IOPARM_type_num
};
-typedef struct gfc_st_parameter_field GTY(())
-{
+typedef struct GTY(()) gfc_st_parameter_field {
const char *name;
unsigned int mask;
enum ioparam_type param_type;
}
gfc_st_parameter_field;
-typedef struct gfc_st_parameter GTY(())
-{
+typedef struct GTY(()) gfc_st_parameter {
const char *name;
tree type;
}
{ "close", NULL },
{ "filepos", NULL },
{ "inquire", NULL },
- { "dt", NULL }
+ { "dt", NULL },
+ { "wait", NULL }
};
static GTY(()) gfc_st_parameter_field st_parameter_field[] =
{ #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
#include "ioparm.def"
#undef IOPARM
- { NULL, 0, 0, 0, NULL, NULL }
+ { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL }
};
/* Library I/O subroutines */
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
};
static void
gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
{
- enum iofield type;
+ unsigned int type;
gfc_st_parameter_field *p;
char name[64];
size_t len;
tree t = make_node (RECORD_TYPE);
+ tree *chain = NULL;
len = strlen (st_parameter[ptype].name);
gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
case IOPARM_type_parray:
case IOPARM_type_pchar:
case IOPARM_type_pad:
- p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
- get_identifier (p->name),
- types[p->type]);
+ p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
+ types[p->type], &chain);
break;
case IOPARM_type_char1:
- p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
- get_identifier (p->name),
- pchar_type_node);
+ p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
+ pchar_type_node, &chain);
/* FALLTHROUGH */
case IOPARM_type_char2:
len = strlen (p->name);
gcc_assert (len <= sizeof (name) - sizeof ("_len"));
memcpy (name, p->name, len);
memcpy (name + len, "_len", sizeof ("_len"));
- p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
- get_identifier (name),
- gfc_charlen_type_node);
+ p->field_len = gfc_add_field_to_struct (t, get_identifier (name),
+ gfc_charlen_type_node,
+ &chain);
if (p->type == IOPARM_type_char2)
- p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
- get_identifier (p->name),
- pchar_type_node);
+ p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
+ pchar_type_node, &chain);
break;
case IOPARM_type_common:
p->field
- = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ = gfc_add_field_to_struct (t,
get_identifier (p->name),
- st_parameter[IOPARM_ptype_common].type);
+ st_parameter[IOPARM_ptype_common].type,
+ &chain);
break;
case IOPARM_type_num:
gcc_unreachable ();
/* The code to generate the error. */
gfc_start_block (&block);
- arg1 = build_fold_addr_expr (var);
+ arg1 = gfc_build_addr_expr (NULL_TREE, var);
arg2 = build_int_cst (integer_type_node, error_code),
asprintf (&message, "%s", _(msgid));
- arg3 = gfc_build_addr_expr (pchar_type_node, gfc_build_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);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
gfc_add_expr_to_block (&block, tmp);
/* 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 = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
cond = fold_convert (boolean_type_node, cond);
- tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
gfc_add_expr_to_block (pblock, tmp);
}
}
tree gfc_intio_type_node;
tree parm_type, dt_parm_type;
HOST_WIDE_INT pad_size;
- enum ioparam_type ptype;
+ unsigned int ptype;
types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
types[IOPARM_type_intio] = gfc_intio_type_node
types[IOPARM_type_pchar] = pchar_type_node;
pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
- pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
+ pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size - 1));
types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
/* pad actually contains pointers and integers so it needs to have an
types. See the st_parameter_dt structure in libgfortran/io/io.h for
what really goes into this space. */
TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
- TYPE_ALIGN (gfc_get_int_type (gfc_max_integer_kind)));
+ TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)));
for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
- gfc_build_st_parameter (ptype, types);
+ gfc_build_st_parameter ((enum ioparam_type) ptype, types);
- /* Define the transfer functions. */
+ /* Define the transfer functions.
+ TODO: Split them between READ and WRITE to allow further
+ optimizations, e.g. by using aliases? */
dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
- iocall[IOCALL_X_INTEGER] =
- gfc_build_library_function_decl (get_identifier
- (PREFIX("transfer_integer")),
- void_type_node, 3, dt_parm_type,
- pvoid_type_node, gfc_int4_type_node);
-
- iocall[IOCALL_X_LOGICAL] =
- gfc_build_library_function_decl (get_identifier
- (PREFIX("transfer_logical")),
- void_type_node, 3, dt_parm_type,
- pvoid_type_node, gfc_int4_type_node);
-
- iocall[IOCALL_X_CHARACTER] =
- gfc_build_library_function_decl (get_identifier
- (PREFIX("transfer_character")),
- void_type_node, 3, dt_parm_type,
- pvoid_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,
- pvoid_type_node, gfc_int4_type_node);
-
- iocall[IOCALL_X_COMPLEX] =
- gfc_build_library_function_decl (get_identifier
- (PREFIX("transfer_complex")),
- void_type_node, 3, dt_parm_type,
- pvoid_type_node, gfc_int4_type_node);
-
- iocall[IOCALL_X_ARRAY] =
- gfc_build_library_function_decl (get_identifier
- (PREFIX("transfer_array")),
- void_type_node, 4, dt_parm_type,
- pvoid_type_node, integer_type_node,
- gfc_charlen_type_node);
+ iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_integer")), ".wW",
+ void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+ iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_logical")), ".wW",
+ void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+ iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_character")), ".wW",
+ void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+ iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_character_wide")), ".wW",
+ void_type_node, 4, dt_parm_type, pvoid_type_node,
+ gfc_charlen_type_node, gfc_int4_type_node);
+
+ iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_real")), ".wW",
+ void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+ iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_complex")), ".wW",
+ void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+ iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_array")), ".wW",
+ void_type_node, 4, dt_parm_type, pvoid_type_node,
+ integer_type_node, gfc_charlen_type_node);
/* Library entry points */
- iocall[IOCALL_READ] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
- void_type_node, 1, dt_parm_type);
+ iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_read")), ".w",
+ void_type_node, 1, dt_parm_type);
- iocall[IOCALL_WRITE] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
- void_type_node, 1, dt_parm_type);
+ iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_write")), ".w",
+ void_type_node, 1, dt_parm_type);
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
- iocall[IOCALL_OPEN] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
- void_type_node, 1, parm_type);
-
+ iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_open")), ".w",
+ void_type_node, 1, parm_type);
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
- iocall[IOCALL_CLOSE] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
- void_type_node, 1, parm_type);
+ iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_close")), ".w",
+ void_type_node, 1, parm_type);
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
- iocall[IOCALL_INQUIRE] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
- gfc_int4_type_node, 1, parm_type);
+ iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_inquire")), ".w",
+ void_type_node, 1, parm_type);
- iocall[IOCALL_IOLENGTH] =
- gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
- void_type_node, 1, dt_parm_type);
+ iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec(
+ get_identifier (PREFIX("st_iolength")), ".w",
+ void_type_node, 1, dt_parm_type);
+
+ /* TODO: Change when asynchronous I/O is implemented. */
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
+ iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_wait")), ".X",
+ void_type_node, 1, parm_type);
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
- iocall[IOCALL_REWIND] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
- gfc_int4_type_node, 1, parm_type);
+ iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_rewind")), ".w",
+ void_type_node, 1, parm_type);
- iocall[IOCALL_BACKSPACE] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
- gfc_int4_type_node, 1, parm_type);
+ iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_backspace")), ".w",
+ void_type_node, 1, parm_type);
- iocall[IOCALL_ENDFILE] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
- gfc_int4_type_node, 1, parm_type);
+ iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_endfile")), ".w",
+ void_type_node, 1, parm_type);
- iocall[IOCALL_FLUSH] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
- gfc_int4_type_node, 1, parm_type);
+ iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_flush")), ".w",
+ void_type_node, 1, parm_type);
/* Library helpers */
- iocall[IOCALL_READ_DONE] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
- gfc_int4_type_node, 1, dt_parm_type);
-
- iocall[IOCALL_WRITE_DONE] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
- gfc_int4_type_node, 1, dt_parm_type);
+ iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_read_done")), ".w",
+ void_type_node, 1, dt_parm_type);
- iocall[IOCALL_IOLENGTH_DONE] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
- gfc_int4_type_node, 1, dt_parm_type);
+ iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_write_done")), ".w",
+ void_type_node, 1, dt_parm_type);
+ iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_iolength_done")), ".w",
+ void_type_node, 1, dt_parm_type);
- iocall[IOCALL_SET_NML_VAL] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
- void_type_node, 6, dt_parm_type,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node, gfc_charlen_type_node,
- gfc_int4_type_node);
+ iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_set_nml_var")), ".w.R",
+ void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
+ void_type_node, gfc_charlen_type_node, gfc_int4_type_node);
- iocall[IOCALL_SET_NML_VAL_DIM] =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
- void_type_node, 5, dt_parm_type,
- gfc_int4_type_node, gfc_array_index_type,
- gfc_array_index_type, gfc_array_index_type);
+ iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
+ void_type_node, 5, dt_parm_type, gfc_int4_type_node,
+ gfc_array_index_type, gfc_array_index_type, gfc_array_index_type);
}
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_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)
+ if (type == IOPARM_common_unit && e->ts.kind > 4)
{
- tree cond, max;
- ioerror_codes bad_unit;
+ tree cond, val;
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. */
+ /* UNIT numbers should be greater than the min. */
+ i = gfc_validate_kind (BT_INTEGER, 4, false);
+ val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr,
- build_int_cst (TREE_TYPE (se.expr),0));
- gfc_trans_io_runtime_check (cond, var, bad_unit,
- "Negative unit number in I/O statement",
+ fold_convert (TREE_TYPE (se.expr), val));
+ gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
+ "Unit number in I/O statement too small",
&se.pre);
/* UNIT numbers should be less than the max. */
- i = gfc_validate_kind (BT_INTEGER, 4, false);
- max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
+ val = 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,
+ fold_convert (TREE_TYPE (se.expr), val));
+ gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
"Unit number in I/O statement too large",
&se.pre);
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;
}
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), gfc_build_addr_expr (NULL_TREE, 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);
+ addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
/* After the I/O operation, we set the variable from the temporary. */
tmp = convert (TREE_TYPE (se.expr), tmpvar);
- gfc_add_modify_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;
}
/* Given an array expr, find its address and length to get a string. If the
array is full, the string's address is the address of array's first element
- and the length is the size of the whole array. If it is an element, the
+ and the length is the size of the whole array. If it is an element, the
string's address is the element's address and the length is the rest size of
- the array.
-*/
+ the array. */
static void
gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
{
- tree tmp;
- tree array;
- tree type;
tree size;
- int rank;
- gfc_symbol *sym;
- sym = e->symtree->n.sym;
- rank = sym->as->rank - 1;
-
- if (e->ref->u.ar.type == AR_FULL)
- {
- se->expr = gfc_get_symbol_decl (sym);
- se->expr = gfc_conv_array_data (se->expr);
- }
- else
+ if (e->rank == 0)
{
+ tree type, array, tmp;
+ gfc_symbol *sym;
+ int rank;
+
+ /* If it is an element, we need its address and size of the rest. */
+ gcc_assert (e->expr_type == EXPR_VARIABLE);
+ gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
+ sym = e->symtree->n.sym;
+ rank = sym->as->rank - 1;
gfc_conv_expr (se, e);
- }
- array = sym->backend_decl;
- type = TREE_TYPE (array);
-
- if (GFC_ARRAY_TYPE_P (type))
- size = GFC_TYPE_ARRAY_SIZE (type);
- else
- {
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
- size = gfc_conv_array_stride (array, rank);
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_array_ubound (array, rank),
- gfc_conv_array_lbound (array, rank));
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
- gfc_index_one_node);
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
- }
+ array = sym->backend_decl;
+ type = TREE_TYPE (array);
- gcc_assert (size);
+ if (GFC_ARRAY_TYPE_P (type))
+ size = GFC_TYPE_ARRAY_SIZE (type);
+ else
+ {
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ size = gfc_conv_array_stride (array, rank);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_array_ubound (array, rank),
+ gfc_conv_array_lbound (array, rank));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
+ gfc_index_one_node);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
+ }
+ gcc_assert (size);
- /* If it is an element, we need the its address and size of the rest. */
- if (e->ref->u.ar.type == AR_ELEMENT)
- {
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
- TREE_OPERAND (se->expr, 1));
- se->expr = build_fold_addr_expr (se->expr);
+ TREE_OPERAND (se->expr, 1));
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
+ fold_convert (gfc_array_index_type, tmp));
+ se->string_length = fold_convert (gfc_charlen_type_node, size);
+ return;
}
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
- fold_convert (gfc_array_index_type, tmp));
-
+ gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);
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)
+ if (e->ts.type == BT_INTEGER
+ && e->rank == 0
+ && e->symtree->n.sym->attr.assign == 1)
{
char * msg;
+ tree cond;
gfc_conv_label_variable (&se, e);
tmp = GFC_DECL_STRING_LEN (se.expr);
- 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
{
if (e->ts.type == BT_CHARACTER && e->rank == 0)
gfc_conv_expr (&se, e);
/* Array assigned Hollerith constant or character array. */
- else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
+ else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
gfc_convert_array_to_string (&se, e);
else
gcc_unreachable ();
gfc_conv_string_parameter (&se);
- gfc_add_modify_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,
- last_dt == READ ? INTENT_IN : INTENT_OUT);
- tmp = build_fold_indirect_ref (se.expr);
+ gfc_conv_subref_array_arg (&se, e, 0,
+ last_dt == READ ? INTENT_IN : INTENT_OUT, false);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ se.expr);
se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
tmp = gfc_conv_descriptor_data_get (tmp);
}
/* 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);
+
+ if (p->newunit)
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
+ p->newunit);
set_parameter_const (&block, var, IOPARM_common_flags, mask);
else
set_parameter_const (&block, var, IOPARM_common_unit, 0);
- tmp = build_fold_addr_expr (var);
- tmp = build_call_expr (iocall[IOCALL_OPEN], 1, tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_OPEN], 1, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
else
set_parameter_const (&block, var, IOPARM_common_unit, 0);
- tmp = build_fold_addr_expr (var);
- tmp = build_call_expr (iocall[IOCALL_CLOSE], 1, tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_CLOSE], 1, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
else
set_parameter_const (&block, var, IOPARM_common_unit, 0);
- tmp = build_fold_addr_expr (var);
- tmp = build_call_expr (function, 1, tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (input_location,
+ function, 1, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
}
+/* 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);
+
+ if (mask2)
+ mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
+
set_parameter_const (&block, var, IOPARM_common_flags, mask);
if (p->unit)
else
set_parameter_const (&block, var, IOPARM_common_unit, 0);
- tmp = build_fold_addr_expr (var);
- tmp = build_call_expr (iocall[IOCALL_INQUIRE], 1, tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_INQUIRE], 1, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
return gfc_finish_block (&block);
}
-static gfc_expr *
-gfc_new_nml_name_expr (const char * name)
+
+tree
+gfc_trans_wait (gfc_code * code)
{
- gfc_expr * nml_name;
-
- nml_name = gfc_get_expr();
- nml_name->ref = NULL;
- nml_name->expr_type = EXPR_CONSTANT;
- 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);
-
- return nml_name;
+ stmtblock_t block, post_block;
+ gfc_wait *p;
+ tree tmp, var;
+ unsigned int mask = 0;
+
+ gfc_start_block (&block);
+ gfc_init_block (&post_block);
+
+ var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
+ "wait_parm");
+
+ set_error_locus (&block, var, &code->loc);
+ p = code->ext.wait;
+
+ /* Set parameters here. */
+ if (p->iomsg)
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
+
+ if (p->iostat)
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
+
+ if (p->err)
+ mask |= IOPARM_common_err;
+
+ if (p->id)
+ mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
+
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ if (p->unit)
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_WAIT], 1, tmp);
+ gfc_add_expr_to_block (&block, tmp);
+
+ gfc_add_block_to_block (&block, &post_block);
+
+ io_result (&block, var, p->err, NULL, NULL);
+
+ return gfc_finish_block (&block);
+
}
+
/* nml_full_name builds up the fully qualified name of a
derived type component. */
dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
- itmp = (dummy_arg_flagged) ? build_fold_indirect_ref (tmp) : tmp;
+ itmp = (dummy_arg_flagged) ? build_fold_indirect_ref_loc (input_location,
+ tmp) : tmp;
/* If an array, set flag and use indirect ref. if built. */
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. */
- tmp = build_fold_addr_expr (tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
/* If scalar dummy, resolve indirect reference now. */
if (dummy_arg_flagged && !array_flagged)
- tmp = build_fold_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ tmp);
gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
The call for the scalar part transfers:
(address, name, type, kind or string_length, dtype) */
- dt_parm_addr = build_fold_addr_expr (dt_parm);
+ dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
if (ts->type == BT_CHARACTER)
- tmp = ts->cl->backend_decl;
+ tmp = ts->u.cl->backend_decl;
else
tmp = build_int_cst (gfc_charlen_type_node, 0);
- tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL], 6,
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_SET_NML_VAL], 6,
dt_parm_addr, addr_expr, string,
IARG (ts->kind), tmp, dtype);
gfc_add_expr_to_block (block, tmp);
for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
{
- tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL_DIM], 5,
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_SET_NML_VAL_DIM], 5,
dt_parm_addr,
IARG (n_dim),
GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
/* Provide the RECORD_TYPE to build component references. */
- tree expr = build_fold_indirect_ref (addr_expr);
+ tree expr = build_fold_indirect_ref_loc (input_location,
+ addr_expr);
- for (cmp = ts->derived->components; cmp; cmp = cmp->next)
+ for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
{
char *full_name = nml_full_name (var_name, cmp->name);
transfer_namelist_element (block,
{
mask |= set_internal_unit (&block, &post_iu_block,
var, dt->io_unit);
- set_parameter_const (&block, var, IOPARM_common_unit, 0);
+ set_parameter_const (&block, var, IOPARM_common_unit,
+ dt->io_unit->ts.kind == 1 ? 0 : -1);
}
}
else
if (dt->end)
mask |= IOPARM_common_end;
+ if (dt->id)
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_dt_id, dt->id);
+
+ if (dt->pos)
+ mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
+
+ if (dt->asynchronous)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
+ dt->asynchronous);
+
+ if (dt->blank)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
+ dt->blank);
+
+ if (dt->decimal)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
+ dt->decimal);
+
+ if (dt->delim)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
+ dt->delim);
+
+ if (dt->pad)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
+ dt->pad);
+
+ if (dt->round)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
+ dt->round);
+
+ if (dt->sign)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
+ dt->sign);
+
if (dt->rec)
mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
if (dt->format_expr || dt->format_label)
gfc_internal_error ("build_dt: format with namelist");
- nmlname = gfc_new_nml_name_expr (dt->namelist->name);
+ nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
+ dt->namelist->name,
+ strlen (dt->namelist->name));
mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
nmlname);
for (nml = dt->namelist->namelist; nml; nml = nml->next)
transfer_namelist_element (&block, nml->sym->name, nml->sym,
- NULL, NULL);
+ NULL, NULL_TREE);
}
else
set_parameter_const (&block, var, IOPARM_common_flags, mask);
else
set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = build_fold_addr_expr (var);
- tmp = build_call_expr (function, 1, tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (UNKNOWN_LOCATION,
+ function, 1, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
dt_parm = var;
dt_post_end_block = &post_end_block;
- gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
+ /* Set implied do loop exit condition. */
+ if (last_dt == READ || last_dt == WRITE)
+ {
+ gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
+
+ tmp = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
+ tmp, p->field, NULL_TREE);
+ tmp = fold_build2 (BIT_AND_EXPR, TREE_TYPE (tmp),
+ tmp, build_int_cst (TREE_TYPE (tmp),
+ IOPARM_common_libreturn_mask));
+ }
+ else /* IOLENGTH */
+ tmp = NULL_TREE;
+
+ gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
gfc_add_block_to_block (&block, &post_iu_block);
gcc_unreachable ();
}
- tmp = build_fold_addr_expr (dt_parm);
- tmp = build_call_expr (function, 1, tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = build_call_expr_loc (input_location,
+ function, 1, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, dt_post_end_block);
gfc_init_block (dt_post_end_block);
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);
+ tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
transfer_expr (&se, &cm->ts, tmp, NULL);
/* We are done now with the loop body. Wrap up the scalarizer and
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;
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))
+ if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
+ && ts->u.derived != NULL
+ && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
{
/* C_PTR and C_FUNPTR have private components which means they can not
be printed. However, if -std=gnu and not -pedantic, allow
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) :
+ ts->u.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;
+ ts->type = ts->u.derived->ts.type;
+ ts->kind = ts->u.derived->ts.kind;
+ ts->f90_type = ts->u.derived->ts.f90_type;
}
kind = ts->kind;
function = NULL;
arg2 = NULL;
+ arg3 = NULL;
switch (ts->type)
{
break;
case BT_CHARACTER:
+ if (kind == 4)
+ {
+ if (se->string_length)
+ arg2 = se->string_length;
+ else
+ {
+ tmp = build_fold_indirect_ref_loc (input_location,
+ addr_expr);
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+ arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
+ arg2 = fold_convert (gfc_charlen_type_node, arg2);
+ }
+ arg3 = build_int_cst (NULL_TREE, kind);
+ function = iocall[IOCALL_X_CHARACTER_WIDE];
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = build_call_expr_loc (input_location,
+ function, 4, tmp, addr_expr, arg2, arg3);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_add_block_to_block (&se->pre, &se->post);
+ return;
+ }
+ /* Fall through. */
case BT_HOLLERITH:
if (se->string_length)
arg2 = se->string_length;
else
{
- tmp = build_fold_indirect_ref (addr_expr);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ addr_expr);
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
}
case BT_DERIVED:
/* Recurse into the elements of the derived type. */
expr = gfc_evaluate_now (addr_expr, &se->pre);
- expr = build_fold_indirect_ref (expr);
+ expr = build_fold_indirect_ref_loc (input_location,
+ expr);
- for (c = ts->derived->components; c; c = c->next)
+ for (c = ts->u.derived->components; c; c = c->next)
{
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_loc (UNKNOWN_LOCATION,
+ 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)
- tmp = build_fold_addr_expr (tmp);
+ if (!c->attr.pointer)
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
transfer_expr (se, &c->ts, tmp, code);
}
}
internal_error ("Bad IO basetype (%d)", ts->type);
}
- tmp = build_fold_addr_expr (dt_parm);
- tmp = build_call_expr (function, 3, tmp, addr_expr, arg2);
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = build_call_expr_loc (input_location,
+ function, 3, tmp, addr_expr, arg2);
gfc_add_expr_to_block (&se->pre, tmp);
gfc_add_block_to_block (&se->pre, &se->post);
kind_arg = build_int_cst (NULL_TREE, ts->kind);
- tmp = build_fold_addr_expr (dt_parm);
- tmp = build_call_expr (iocall[IOCALL_X_ARRAY], 4,
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = build_call_expr_loc (UNKNOWN_LOCATION,
+ 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);
- expr = code->expr;
+ expr = code->expr1;
ss = gfc_walk_expr (expr);
ref = NULL;
/* Transfer an array. If it is an array of an intrinsic
type, pass the descriptor to the library. Otherwise
scalarize the transfer. */
- if (expr->ref)
+ if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
{
for (ref = expr->ref; ref && ref->type != REF_ARRAY;
ref = ref->next);
gcc_assert (ref->type == REF_ARRAY);
}
- if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL)
+ 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, false);
+ tmp = se.expr;
+ }
+ else
+ {
+ /* Get the descriptor. */
+ gfc_conv_expr_descriptor (&se, expr, ss);
+ tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
+ }
+
transfer_array_desc (&se, &expr->ts, tmp);
goto finish_block_label;
}
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &code->expr1->where);
/* The main loop body. */
gfc_mark_ss_chain_used (ss, 1);
}
#include "gt-fortran-trans-io.h"
-
OSDN Git Service
