/* IO Code translation/library interface
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
- Free Software Foundation, Inc.
+ Copyright (C) 2002-2018 Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "ggc.h"
-#include "diagnostic-core.h" /* For internal_error. */
#include "gfortran.h"
#include "trans.h"
+#include "stringpool.h"
+#include "fold-const.h"
+#include "stor-layout.h"
#include "trans-stmt.h"
#include "trans-array.h"
#include "trans-types.h"
#include "trans-const.h"
+#include "options.h"
/* Members of the ioparm structure. */
IOCALL_X_COMPLEX128_WRITE,
IOCALL_X_ARRAY,
IOCALL_X_ARRAY_WRITE,
+ IOCALL_X_DERIVED,
IOCALL_OPEN,
IOCALL_CLOSE,
IOCALL_INQUIRE,
IOCALL_ENDFILE,
IOCALL_FLUSH,
IOCALL_SET_NML_VAL,
+ IOCALL_SET_NML_DTIO_VAL,
IOCALL_SET_NML_VAL_DIM,
IOCALL_WAIT,
IOCALL_NUM
gcc_unreachable ();
}
+ /* -Wpadded warnings on these artificially created structures are not
+ helpful; suppress them. */
+ int save_warn_padded = warn_padded;
+ warn_padded = 0;
gfc_finish_type (t);
+ warn_padded = save_warn_padded;
st_parameter[ptype].type = t;
}
Therefore, the code to set these flags must be generated before
this function is used. */
-void
-gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
- const char * msgid, stmtblock_t * pblock)
+static void
+gfc_trans_io_runtime_check (bool has_iostat, tree cond, tree var,
+ int error_code, const char * msgid,
+ stmtblock_t * pblock)
{
stmtblock_t block;
tree body;
/* The code to generate the error. */
gfc_start_block (&block);
-
+
+ if (has_iostat)
+ gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_FAIL_IO,
+ NOT_TAKEN));
+ else
+ gfc_add_expr_to_block (&block, build_predict_expr (PRED_NORETURN,
+ NOT_TAKEN));
+
arg1 = gfc_build_addr_expr (NULL_TREE, var);
-
+
arg2 = build_int_cst (integer_type_node, error_code),
-
- asprintf (&message, "%s", _(msgid));
+
+ message = xasprintf ("%s", _(msgid));
arg3 = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (message));
free (message);
-
+
tmp = build_call_expr_loc (input_location,
gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
}
else
{
- cond = gfc_unlikely (cond);
tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
gfc_add_expr_to_block (pblock, tmp);
}
alignment that is at least as large as the needed alignment for those
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_intio_kind)));
+ SET_TYPE_ALIGN (types[IOPARM_type_pad], MAX (TYPE_ALIGN (pchar_type_node),
+ TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind))));
for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
gfc_build_st_parameter ((enum ioparam_type) ptype, types);
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);
+ void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_type_node);
iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("transfer_character_write")), ".wR",
- void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_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,
integer_type_node, gfc_charlen_type_node);
+ iocall[IOCALL_X_DERIVED] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_derived")), ".wrR",
+ void_type_node, 2, dt_parm_type, pvoid_type_node, pchar_type_node);
+
/* Library entry points */
iocall[IOCALL_READ] = 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",
+ get_identifier (PREFIX("st_wait_async")), ".w",
void_type_node, 1, parm_type);
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
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);
+ gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node());
+
+ iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R",
+ void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node,
+ gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node(),
+ pvoid_type_node, pvoid_type_node);
iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
}
-/* Generate code to store an integer constant into the
- st_parameter_XXX structure. */
-
-static unsigned int
-set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
- unsigned int val)
+static void
+set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value)
{
tree tmp;
gfc_st_parameter_field *p = &st_parameter_field[type];
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
var, p->field, NULL_TREE);
- gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
+ gfc_add_modify (block, tmp, value);
+}
+
+
+/* Generate code to store an integer constant into the
+ st_parameter_XXX structure. */
+
+static unsigned int
+set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
+ unsigned int val)
+{
+ gfc_st_parameter_field *p = &st_parameter_field[type];
+
+ set_parameter_tree (block, var, type,
+ build_int_cst (TREE_TYPE (p->field), val));
return p->mask;
}
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, e);
+ se.expr = convert (dest_type, se.expr);
+ gfc_add_block_to_block (block, &se.pre);
+
+ if (p->param_type == IOPARM_ptype_common)
+ var = fold_build3_loc (input_location, COMPONENT_REF,
+ st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
+ p->field, NULL_TREE);
+ gfc_add_modify (block, tmp, se.expr);
+ return p->mask;
+}
+
+
+/* Similar to set_parameter_value except generate runtime
+ error checks. */
+
+static unsigned int
+set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var,
+ enum iofield type, gfc_expr *e)
+{
+ gfc_se se;
+ tree tmp;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
+ tree dest_type = TREE_TYPE (p->field);
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_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)
{
/* 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_loc (input_location, LT_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
se.expr,
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);
-
+ gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
+ "Unit number in I/O statement too small",
+ &se.pre);
+
/* UNIT numbers should be less than the max. */
val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
- cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
se.expr,
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_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
+ "Unit number in I/O statement too large",
+ &se.pre);
}
se.expr = convert (dest_type, se.expr);
}
+/* Build code to check the unit range if KIND=8 is used. Similar to
+ set_parameter_value_chk but we do not generate error calls for
+ inquire statements. */
+
+static unsigned int
+set_parameter_value_inquire (stmtblock_t *block, tree var,
+ enum iofield type, gfc_expr *e)
+{
+ gfc_se se;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
+ tree dest_type = TREE_TYPE (p->field);
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_val (&se, e);
+
+ /* If we're inquiring on a UNIT number, we need to check to make
+ sure it exists for larger than kind = 4. */
+ if (type == IOPARM_common_unit && e->ts.kind > 4)
+ {
+ stmtblock_t newblock;
+ tree cond1, cond2, cond3, val, body;
+ int i;
+
+ /* Don't evaluate the UNIT number multiple times. */
+ se.expr = gfc_evaluate_now (se.expr, &se.pre);
+
+ /* 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);
+ cond1 = build2_loc (input_location, LT_EXPR, logical_type_node,
+ se.expr,
+ fold_convert (TREE_TYPE (se.expr), val));
+ /* UNIT numbers should be less than the max. */
+ val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
+ cond2 = build2_loc (input_location, GT_EXPR, logical_type_node,
+ se.expr,
+ fold_convert (TREE_TYPE (se.expr), val));
+ cond3 = build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, cond1, cond2);
+
+ gfc_start_block (&newblock);
+
+ /* The unit number GFC_INVALID_UNIT is reserved. No units can
+ ever have this value. It is used here to signal to the
+ runtime library that the inquire unit number is outside the
+ allowable range and so cannot exist. It is needed when
+ -fdefault-integer-8 is used. */
+ set_parameter_const (&newblock, var, IOPARM_common_unit,
+ GFC_INVALID_UNIT);
+
+ body = gfc_finish_block (&newblock);
+
+ cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
+ var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se.pre, var);
+ }
+
+ se.expr = convert (dest_type, se.expr);
+ gfc_add_block_to_block (block, &se.pre);
+
+ return p->mask;
+}
+
+
/* Generate code to store a non-string I/O parameter into the
st_parameter_XXX structure. This is pass by reference. */
gfc_add_modify (postblock, se.expr, tmp);
}
- if (p->param_type == IOPARM_ptype_common)
- var = fold_build3_loc (input_location, COMPONENT_REF,
- st_parameter[IOPARM_ptype_common].type,
- var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
- var, p->field, NULL_TREE);
- gfc_add_modify (block, tmp, addr);
+ set_parameter_tree (block, var, type, addr);
return p->mask;
}
gfc_conv_label_variable (&se, e);
tmp = GFC_DECL_STRING_LEN (se.expr);
- cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
tmp, build_int_cst (TREE_TYPE (tmp), 0));
- asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
- "label", e->symtree->name);
+ msg = xasprintf ("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));
free (msg);
gfc_conv_string_parameter (&se);
gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
- gfc_add_modify (&se.pre, len, se.string_length);
+ gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len),
+ se.string_length));
}
gfc_add_block_to_block (block, &se.pre);
rc, build_int_cst (TREE_TYPE (rc),
IOPARM_common_libreturn_mask));
- tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
- rc, tmp, NULL_TREE);
+ tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, rc, tmp);
gfc_add_expr_to_block (block, tmp);
}
mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
if (p->recl)
- mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
+ mask |= set_parameter_value (&block, var, IOPARM_open_recl_in,
+ p->recl);
if (p->blank)
mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
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);
+ if (p->cc)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_cc, p->cc);
+
+ if (p->share)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_share, p->share);
+
+ mask |= set_parameter_const (&block, var, IOPARM_open_readonly, p->readonly);
+
set_parameter_const (&block, var, IOPARM_common_flags, mask);
if (p->unit)
- set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
else
set_parameter_const (&block, var, IOPARM_common_unit, 0);
set_parameter_const (&block, var, IOPARM_common_flags, mask);
if (p->unit)
- set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
else
set_parameter_const (&block, var, IOPARM_common_unit, 0);
p->iomsg);
if (p->iostat)
- mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
- p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_common_iostat, p->iostat);
if (p->err)
mask |= IOPARM_common_err;
set_parameter_const (&block, var, IOPARM_common_flags, mask);
if (p->unit)
- set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit,
+ p->unit);
else
set_parameter_const (&block, var, IOPARM_common_unit, 0);
}
-/* 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
p->file);
if (p->exist)
- {
- mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_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,
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);
if (p->id)
mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
p->id);
+ if (p->iqstream)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream,
+ p->iqstream);
+
+ if (p->share)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_share,
+ p->share);
+
+ if (p->cc)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_cc, p->cc);
if (mask2)
mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
set_parameter_const (&block, var, IOPARM_common_flags, mask);
if (p->unit)
- set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ {
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit);
+ }
else
set_parameter_const (&block, var, IOPARM_common_unit, 0);
mask |= IOPARM_common_err;
if (p->id)
- mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
+ mask |= set_parameter_ref (&block, &post_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);
+ set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
tmp = gfc_build_addr_expr (NULL_TREE, var);
tmp = build_call_expr_loc (input_location,
/* nml_full_name builds up the fully qualified name of a
- derived type component. */
+ derived type component. '+' is used to denote a type extension. */
static char*
-nml_full_name (const char* var_name, const char* cmp_name)
+nml_full_name (const char* var_name, const char* cmp_name, bool parent)
{
int full_name_length;
char * full_name;
full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
full_name = XCNEWVEC (char, full_name_length + 1);
strcpy (full_name, var_name);
- full_name = strcat (full_name, "%");
+ full_name = strcat (full_name, parent ? "+" : "%");
full_name = strcat (full_name, cmp_name);
return full_name;
}
else
decl = c->backend_decl;
- gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
- || TREE_CODE (decl) == VAR_DECL
- || TREE_CODE (decl) == PARM_DECL)
- || TREE_CODE (decl) == COMPONENT_REF));
+ gcc_assert (decl && (TREE_CODE (decl) == FIELD_DECL
+ || VAR_P (decl)
+ || TREE_CODE (decl) == PARM_DECL
+ || TREE_CODE (decl) == COMPONENT_REF));
tmp = decl;
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
base_addr, tmp, NULL_TREE);
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp))))
+ tmp = gfc_class_data_get (tmp);
+
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
tmp = gfc_conv_array_data (tmp);
else
tree dtype;
tree dt_parm_addr;
tree decl = NULL_TREE;
- int n_dim;
- int itype;
+ tree gfc_int4_type_node = gfc_get_int_type (4);
+ tree dtio_proc = null_pointer_node;
+ tree vtable = null_pointer_node;
+ int n_dim;
int rank = 0;
gcc_assert (sym || c);
/* Build ts, as and data address using symbol or component. */
- ts = (sym) ? &sym->ts : &c->ts;
- as = (sym) ? sym->as : c->as;
+ ts = sym ? &sym->ts : &c->ts;
+
+ if (ts->type != BT_CLASS)
+ as = sym ? sym->as : c->as;
+ else
+ as = sym ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as;
addr_expr = nml_get_addr_expr (sym, c, base_addr);
if (rank)
{
- decl = (sym) ? sym->backend_decl : c->backend_decl;
+ decl = sym ? sym->backend_decl : c->backend_decl;
if (sym && sym->attr.dummy)
decl = build_fold_indirect_ref_loc (input_location, decl);
+
+ if (ts->type == BT_CLASS)
+ decl = gfc_class_data_get (decl);
dt = TREE_TYPE (decl);
dtype = gfc_get_dtype (dt);
}
else
{
- itype = ts->type;
- dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
+ dt = gfc_typenode_for_spec (ts);
+ dtype = gfc_get_dtype_rank_type (0, dt);
}
/* Build up the arguments for the transfer call.
dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ /* Check if the derived type has a specific DTIO for the mode.
+ Note that although namelist io is forbidden to have a format
+ list, the specific subroutine is of the formatted kind. */
+ if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
+ {
+ gfc_symbol *derived;
+ if (ts->type==BT_CLASS)
+ derived = ts->u.derived->components->ts.u.derived;
+ else
+ derived = ts->u.derived;
+
+ gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
+ last_dt == WRITE, true);
+
+ if (ts->type == BT_CLASS && tb_io_st)
+ {
+ // polymorphic DTIO call (based on the dynamic type)
+ gfc_se se;
+ gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
+ // build vtable expr
+ gfc_expr *expr = gfc_get_variable_expr (st);
+ gfc_add_vptr_component (expr);
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, expr);
+ vtable = se.expr;
+ // build dtio expr
+ gfc_add_component_ref (expr,
+ tb_io_st->n.tb->u.generic->specific_st->name);
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, expr);
+ gfc_free_expr (expr);
+ dtio_proc = se.expr;
+ }
+ else
+ {
+ // non-polymorphic DTIO call (based on the declared type)
+ gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived,
+ last_dt == WRITE, true);
+ if (dtio_sub != NULL)
+ {
+ dtio_proc = gfc_get_symbol_decl (dtio_sub);
+ dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
+ gfc_symbol *vtab = gfc_find_derived_vtab (derived);
+ vtable = vtab->backend_decl;
+ if (vtable == NULL_TREE)
+ vtable = gfc_get_symbol_decl (vtab);
+ vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
+ }
+ }
+ }
+
if (ts->type == BT_CHARACTER)
tmp = ts->u.cl->backend_decl;
else
tmp = build_int_cst (gfc_charlen_type_node, 0);
- tmp = build_call_expr_loc (input_location,
- iocall[IOCALL_SET_NML_VAL], 6,
- dt_parm_addr, addr_expr, string,
- IARG (ts->kind), tmp, dtype);
+
+ if (dtio_proc == null_pointer_node)
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_SET_NML_VAL], 6,
+ dt_parm_addr, addr_expr, string,
+ build_int_cst (gfc_int4_type_node, ts->kind),
+ tmp, dtype);
+ else
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_SET_NML_DTIO_VAL], 8,
+ dt_parm_addr, addr_expr, string,
+ build_int_cst (gfc_int4_type_node, ts->kind),
+ tmp, dtype, dtio_proc, vtable);
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
tmp = build_call_expr_loc (input_location,
iocall[IOCALL_SET_NML_VAL_DIM], 5,
dt_parm_addr,
- IARG (n_dim),
+ build_int_cst (gfc_int4_type_node, n_dim),
gfc_conv_array_stride (decl, n_dim),
gfc_conv_array_lbound (decl, n_dim),
gfc_conv_array_ubound (decl, n_dim));
gfc_add_expr_to_block (block, tmp);
}
- if (ts->type == BT_DERIVED)
+ if (gfc_bt_struct (ts->type) && ts->u.derived->components
+ && dtio_proc == null_pointer_node)
{
gfc_component *cmp;
for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
{
- char *full_name = nml_full_name (var_name, cmp->name);
+ char *full_name = nml_full_name (var_name, cmp->name,
+ ts->u.derived->attr.extension);
transfer_namelist_element (block,
full_name,
NULL, cmp, expr);
mask |= set_internal_unit (&block, &post_iu_block,
var, dt->io_unit);
set_parameter_const (&block, var, IOPARM_common_unit,
- dt->io_unit->ts.kind == 1 ? 0 : -1);
+ dt->io_unit->ts.kind == 1 ?
+ GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4);
}
}
else
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);
+ 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,
mask |= set_parameter_ref (&block, &post_end_block, var,
IOPARM_dt_size, dt->size);
+ if (dt->udtio)
+ mask |= IOPARM_dt_dtio;
+
+ if (dt->dec_ext)
+ mask |= IOPARM_dt_dec_ext;
+
if (dt->namelist)
{
if (dt->format_expr || dt->format_label)
mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
nmlname);
+ gfc_free_expr (nmlname);
+
if (last_dt == READ)
mask |= IOPARM_dt_namelist_read_mode;
set_parameter_const (&block, var, IOPARM_common_flags, mask);
if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
- set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
+ set_parameter_value_chk (&block, dt->iostat, var,
+ IOPARM_common_unit, dt->io_unit);
}
else
set_parameter_const (&block, var, IOPARM_common_flags, mask);
}
static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
+ gfc_code * code, tree vptr);
/* Given an array field in a derived type variable, generate the code
for the loop that iterates over array elements, and the code that
ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
GFC_SS_COMPONENT);
ss_array = &ss->info->data.array;
- ss_array->shape = gfc_get_shape (cm->as->rank);
+
+ if (cm->attr.pdt_array)
+ ss_array->shape = NULL;
+ else
+ ss_array->shape = gfc_get_shape (cm->as->rank);
+
ss_array->descriptor = expr;
ss_array->data = gfc_conv_array_data (expr);
ss_array->offset = gfc_conv_array_offset (expr);
ss_array->start[n] = gfc_conv_array_lbound (expr, n);
ss_array->stride[n] = gfc_index_one_node;
- mpz_init (ss_array->shape[n]);
- mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
- cm->as->lower[n]->value.integer);
- mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
+ if (cm->attr.pdt_array)
+ ss_array->end[n] = gfc_conv_array_ubound (expr, n);
+ else
+ {
+ mpz_init (ss_array->shape[n]);
+ mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
+ cm->as->lower[n]->value.integer);
+ mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
+ }
}
/* Once we got ss, we use scalarizer to create the loop. */
/* Now se.expr contains an element of the array. Take the address and pass
it to the IO routines. */
tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
- transfer_expr (&se, &cm->ts, tmp, NULL);
+ transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
/* We are done now with the loop body. Wrap up the scalarizer and
return. */
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
- gcc_assert (ss_array->shape != NULL);
- gfc_free_shape (&ss_array->shape, cm->as->rank);
+ if (!cm->attr.pdt_array)
+ {
+ gcc_assert (ss_array->shape != NULL);
+ gfc_free_shape (&ss_array->shape, cm->as->rank);
+ }
gfc_cleanup_loop (&loop);
return gfc_finish_block (&block);
}
+
+/* Helper function for transfer_expr that looks for the DTIO procedure
+ either as a typebound binding or in a generic interface. If present,
+ the address expression of the procedure is returned. It is assumed
+ that the procedure interface has been checked during resolution. */
+
+static tree
+get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
+{
+ gfc_symbol *derived;
+ bool formatted = false;
+ gfc_dt *dt = code->ext.dt;
+
+ /* Determine when to use the formatted DTIO procedure. */
+ if (dt && (dt->format_expr || dt->format_label))
+ formatted = true;
+
+ if (ts->type == BT_CLASS)
+ derived = ts->u.derived->components->ts.u.derived;
+ else
+ derived = ts->u.derived;
+
+ gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
+ last_dt == WRITE, formatted);
+ if (ts->type == BT_CLASS && tb_io_st)
+ {
+ // polymorphic DTIO call (based on the dynamic type)
+ gfc_se se;
+ gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1);
+ gfc_add_vptr_component (expr);
+ gfc_add_component_ref (expr,
+ tb_io_st->n.tb->u.generic->specific_st->name);
+ *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym;
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, expr);
+ gfc_free_expr (expr);
+ return se.expr;
+ }
+ else
+ {
+ // non-polymorphic DTIO call (based on the declared type)
+ *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
+ formatted);
+
+ if (*dtio_sub)
+ return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
+ }
+
+ return NULL_TREE;
+}
+
/* Generate the call for a scalar transfer node. */
static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
+ gfc_code * code, tree vptr)
{
tree tmp, function, arg2, arg3, field, expr;
gfc_component *c;
&& 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
- the component to be printed to help debugging. */
- if (gfc_notification_std (GFC_STD_GNU) != SILENT)
- {
- gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
- ts->u.derived->name, code != NULL ? &(code->loc) :
- &gfc_current_locus);
- return;
- }
+ ts->type = BT_INTEGER;
+ ts->kind = gfc_index_integer_kind;
+ }
- ts->type = ts->u.derived->ts.type;
- ts->kind = ts->u.derived->ts.kind;
- ts->f90_type = ts->u.derived->ts.f90_type;
+ /* gfortran reaches here for "print *, c_loc(xxx)". */
+ if (ts->type == BT_VOID
+ && code->expr1 && code->expr1->ts.type == BT_VOID
+ && code->expr1->symtree
+ && strcmp (code->expr1->symtree->name, "c_loc") == 0)
+ {
+ ts->type = BT_INTEGER;
+ ts->kind = gfc_index_integer_kind;
}
-
+
kind = ts->kind;
function = NULL;
arg2 = NULL;
function = iocall[IOCALL_X_CHARACTER_WIDE];
else
function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
-
+
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_block_to_block (&se->pre, &se->post);
return;
}
- /* Fall through. */
+ /* Fall through. */
case BT_HOLLERITH:
if (se->string_length)
arg2 = se->string_length;
break;
- case BT_DERIVED:
- /* Recurse into the elements of the derived type. */
- expr = gfc_evaluate_now (addr_expr, &se->pre);
- expr = build_fold_indirect_ref_loc (input_location,
- expr);
-
- for (c = ts->u.derived->components; c; c = c->next)
+ case_bt_struct:
+ case BT_CLASS:
+ if (ts->u.derived->components == NULL)
+ return;
+ if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS)
{
- field = c->backend_decl;
- gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
-
- tmp = fold_build3_loc (UNKNOWN_LOCATION,
- COMPONENT_REF, TREE_TYPE (field),
- expr, field, NULL_TREE);
-
- if (c->attr.dimension)
- {
- tmp = transfer_array_component (tmp, c, & code->loc);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
- else
- {
- if (!c->attr.pointer)
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- transfer_expr (se, &c->ts, tmp, code);
- }
- }
- return;
+ gfc_symbol *derived;
+ gfc_symbol *dtio_sub = NULL;
+ /* Test for a specific DTIO subroutine. */
+ if (ts->type == BT_DERIVED)
+ derived = ts->u.derived;
+ else
+ derived = ts->u.derived->components->ts.u.derived;
+
+ if (derived->attr.has_dtio_procs)
+ arg2 = get_dtio_proc (ts, code, &dtio_sub);
+ if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
+ {
+ tree decl;
+ decl = build_fold_indirect_ref_loc (input_location,
+ se->expr);
+ /* Remember that the first dummy of the DTIO subroutines
+ is CLASS(derived) for extensible derived types, so the
+ conversion must be done here for derived type and for
+ scalarized CLASS array element io-list objects. */
+ if ((ts->type == BT_DERIVED
+ && !(ts->u.derived->attr.sequence
+ || ts->u.derived->attr.is_bind_c))
+ || (ts->type == BT_CLASS
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
+ gfc_conv_derived_to_class (se, code->expr1,
+ dtio_sub->formal->sym->ts,
+ vptr, false, false);
+ addr_expr = se->expr;
+ function = iocall[IOCALL_X_DERIVED];
+ break;
+ }
+ else if (gfc_bt_struct (ts->type))
+ {
+ /* Recurse into the elements of the derived type. */
+ expr = gfc_evaluate_now (addr_expr, &se->pre);
+ expr = build_fold_indirect_ref_loc (input_location, expr);
+
+ /* Make sure that the derived type has been built. An external
+ function, if only referenced in an io statement, requires this
+ check (see PR58771). */
+ if (ts->u.derived->backend_decl == NULL_TREE)
+ (void) gfc_typenode_for_spec (ts);
+
+ for (c = ts->u.derived->components; c; c = c->next)
+ {
+ /* Ignore hidden string lengths. */
+ if (c->name[0] == '_')
+ continue;
+
+ field = c->backend_decl;
+ gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+
+ tmp = fold_build3_loc (UNKNOWN_LOCATION,
+ COMPONENT_REF, TREE_TYPE (field),
+ expr, field, NULL_TREE);
+
+ if (c->attr.dimension)
+ {
+ tmp = transfer_array_component (tmp, c, & code->loc);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ else
+ {
+ tree strlen = NULL_TREE;
+
+ if (!c->attr.pointer && !c->attr.pdt_string)
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+ /* Use the hidden string length for pdt strings. */
+ if (c->attr.pdt_string
+ && gfc_deferred_strlen (c, &strlen)
+ && strlen != NULL_TREE)
+ {
+ strlen = fold_build3_loc (UNKNOWN_LOCATION,
+ COMPONENT_REF,
+ TREE_TYPE (strlen),
+ expr, strlen, NULL_TREE);
+ se->string_length = strlen;
+ }
+
+ transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
+
+ /* Reset so that the pdt string length does not propagate
+ through to other strings. */
+ if (c->attr.pdt_string && strlen)
+ se->string_length = NULL_TREE;
+ }
+ }
+ return;
+ }
+ /* If a CLASS object gets through to here, fall through and ICE. */
+ }
+ gcc_fallthrough ();
default:
- internal_error ("Bad IO basetype (%d)", ts->type);
+ gfc_internal_error ("Bad IO basetype (%d)", ts->type);
}
tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
gfc_ss *ss;
gfc_se se;
tree tmp;
+ tree vptr;
int n;
gfc_start_block (&block);
if (expr->rank == 0)
{
/* Transfer a scalar value. */
- gfc_conv_expr_reference (&se, expr);
- transfer_expr (&se, &expr->ts, se.expr, code);
+ if (expr->ts.type == BT_CLASS)
+ {
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, expr);
+ vptr = gfc_get_vptr_from_expr (se.expr);
+ }
+ else
+ {
+ vptr = NULL_TREE;
+ gfc_conv_expr_reference (&se, expr);
+ }
+ transfer_expr (&se, &expr->ts, se.expr, code, vptr);
}
else
{
if (expr->ref && !gfc_is_proc_ptr_comp (expr))
{
for (ref = expr->ref; ref && ref->type != REF_ARRAY;
- ref = ref->next);
- gcc_assert (ref->type == REF_ARRAY);
+ ref = ref->next);
+ gcc_assert (ref && ref->type == REF_ARRAY);
}
- if (expr->ts.type != BT_DERIVED
+ if (expr->ts.type != BT_CLASS
+ && expr->expr_type == EXPR_VARIABLE
+ && gfc_expr_attr (expr).pointer)
+ goto scalarize;
+
+
+ if (!(gfc_bt_struct (expr->ts.type)
+ || expr->ts.type == BT_CLASS)
&& ref && ref->next == NULL
&& !is_subref_array (expr))
{
{
for (n = 0; n < ref->u.ar.dimen; n++)
if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
- seen_vector = true;
+ {
+ seen_vector = true;
+ break;
+ }
}
if (seen_vector && last_dt == READ)
goto finish_block_label;
}
+scalarize:
/* Initialize the scalarizer. */
ss = gfc_walk_expr (expr);
gfc_init_loopinfo (&loop);
se.ss = ss;
gfc_conv_expr_reference (&se, expr);
- transfer_expr (&se, &expr->ts, se.expr, code);
+
+ if (expr->ts.type == BT_CLASS)
+ vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
+ else
+ vptr = NULL_TREE;
+ transfer_expr (&se, &expr->ts, se.expr, code, vptr);
}
finish_block_label:
tmp = gfc_finish_block (&body);
else
{
+ gcc_assert (expr->rank != 0);
gcc_assert (se.ss == gfc_ss_terminator);
gfc_trans_scalarizing_loops (&loop, &body);