/* IO Code translation/library interface
- Copyright (C) 2002-2016 Free Software Foundation, Inc.
+ Copyright (C) 2002-2018 Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
#include "trans-array.h"
#include "trans-types.h"
#include "trans-const.h"
+#include "options.h"
/* Members of the ioparm structure. */
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;
}
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",
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, gfc_int4_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 (
/* 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);
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 |= 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);
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 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.
/* 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)
+ if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
{
- gfc_symbol *dtio_sub = NULL;
- gfc_symbol *vtab;
- dtio_sub = gfc_find_specific_dtio_proc (ts->u.derived,
- last_dt == WRITE,
- true);
- if (dtio_sub != NULL)
+ 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)
{
- dtio_proc = gfc_get_symbol_decl (dtio_sub);
- dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
- vtab = gfc_find_derived_vtab (ts->u.derived);
- vtable = vtab->backend_decl;
- if (vtable == NULL_TREE)
- vtable = gfc_get_symbol_decl (vtab);
- vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
+ // 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);
+ }
}
}
else
tmp = build_int_cst (gfc_charlen_type_node, 0);
- if (dtio_proc == NULL_TREE)
+ 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,
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)
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. */
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);
bool formatted = false;
gfc_dt *dt = code->ext.dt;
- if (dt && dt->format_expr)
- {
- char *fmt;
- fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
- -1);
- if (strtok (fmt, "DT") != NULL)
- formatted = true;
- }
- else if (dt && dt->format_label == &format_asterisk)
- {
- /* List directed io must call the formatted DTIO procedure. */
- formatted = true;
- }
+ /* Determine when to use the formatted DTIO procedure. */
+ if (dt && (dt->format_expr || dt->format_label))
+ formatted = true;
- if (ts->type == BT_DERIVED)
- derived = ts->u.derived;
- else
+ if (ts->type == BT_CLASS)
derived = ts->u.derived->components->ts.u.derived;
+ else
+ derived = ts->u.derived;
- *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
- formatted);
+ 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));
+ 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. */
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;
case BT_CLASS:
if (ts->u.derived->components == NULL)
return;
- if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
+ if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS)
{
gfc_symbol *derived;
gfc_symbol *dtio_sub = NULL;
function = iocall[IOCALL_X_DERIVED];
break;
}
- else if (ts->type == BT_DERIVED)
+ 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);
+ 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
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);
}
else
{
- if (!c->attr.pointer)
+ 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;
gcc_assert (ref && ref->type == REF_ARRAY);
}
+ 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
goto finish_block_label;
}
+scalarize:
/* Initialize the scalarizer. */
ss = gfc_walk_expr (expr);
gfc_init_loopinfo (&loop);
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
+
gfc_conv_expr_reference (&se, expr);
+
if (expr->ts.type == BT_CLASS)
vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
else
projects / thirdparty / gcc.git / blobdiff