/* IO Code translation/library interface
- Copyright (C) 2002-2015 Free Software Foundation, Inc.
+ Copyright (C) 2002-2018 Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
#include "config.h"
#include "system.h"
#include "coretypes.h"
-#include "options.h"
#include "tree.h"
#include "gfortran.h"
#include "trans.h"
#include "stringpool.h"
-#include "diagnostic-core.h" /* For internal_error. */
-#include "alias.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;
}
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,
- gfc_int4_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;
}
/* 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 (has_iostat, cond, var, LIBERROR_BAD_UNIT,
/* 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 (has_iostat, cond, var, LIBERROR_BAD_UNIT,
/* Don't evaluate the UNIT number multiple times. */
se.expr = gfc_evaluate_now (se.expr, &se.pre);
- /* UNIT numbers should be greater than zero. */
+ /* UNIT numbers should be greater than the min. */
i = gfc_validate_kind (BT_INTEGER, 4, false);
- cond1 = build2_loc (input_location, LT_EXPR, boolean_type_node,
+ 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),
- integer_zero_node));
+ 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, boolean_type_node,
+ 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,
- boolean_type_node, cond1, cond2);
+ logical_type_node, cond1, cond2);
gfc_start_block (&newblock);
body = gfc_finish_block (&newblock);
- cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
+ 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);
}
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));
msg = xasprintf ("Label assigned to variable '%s' (%%ld) is not a format "
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_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)
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);
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);
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 dt_parm_addr;
tree decl = NULL_TREE;
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 itype;
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,
- build_int_cst (gfc_int4_type_node, 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:
gfc_add_expr_to_block (block, tmp);
}
- if (ts->type == BT_DERIVED && ts->u.derived->components)
+ if (gfc_bt_struct (ts->type) && ts->u.derived->components
+ && dtio_proc == null_pointer_node)
{
gfc_component *cmp;
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_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)
}
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->kind = gfc_index_integer_kind;
}
+ /* 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;
break;
- case BT_DERIVED:
+ case_bt_struct:
+ case BT_CLASS:
if (ts->u.derived->components == NULL)
return;
+ if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS)
+ {
+ 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;
- /* 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);
+ if (derived->attr.has_dtio_procs)
+ arg2 = get_dtio_proc (ts, code, &dtio_sub);
- for (c = ts->u.derived->components; c; c = c->next)
- {
- 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);
- }
+ 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. */
}
- return;
-
+ gcc_fallthrough ();
default:
gfc_internal_error ("Bad IO basetype (%d)", ts->type);
}
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
{
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))
{
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:
projects / thirdparty / gcc.git / blobdiff