aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/trans-array.cc204
-rw-r--r--gcc/fortran/trans-array.h5
-rw-r--r--gcc/fortran/trans-decl.cc16
-rw-r--r--gcc/fortran/trans-expr.cc242
-rw-r--r--gcc/fortran/trans-io.cc4
-rw-r--r--gcc/fortran/trans-stmt.cc6
-rw-r--r--gcc/fortran/trans.h7
-rw-r--r--gcc/testsuite/gfortran.dg/class_dummy_11.f90194
-rw-r--r--libgfortran/Makefile.am4
-rw-r--r--libgfortran/Makefile.in13
-rw-r--r--libgfortran/gfortran.map6
-rw-r--r--libgfortran/libgfortran.h23
-rw-r--r--libgfortran/runtime/in_pack_class.c152
-rw-r--r--libgfortran/runtime/in_unpack_class.c134
14 files changed, 824 insertions, 186 deletions
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c7d2446..ed0ad54 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6803,6 +6803,9 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
size = gfc_index_one_node;
offset = gfc_index_zero_node;
+ stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
+ if (stride && VAR_P (stride))
+ gfc_add_modify (pblock, stride, gfc_index_one_node);
for (dim = 0; dim < as->rank; dim++)
{
/* Evaluate non-constant array bound expressions.
@@ -7148,7 +7151,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
|| (is_classarray && CLASS_DATA (sym)->attr.allocatable))
return;
- if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
+ if ((!is_classarray
+ || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
+ && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
{
gfc_trans_g77_array (sym, block);
return;
@@ -8647,15 +8652,17 @@ is_pointer (gfc_expr *e)
/* Convert an array for passing as an actual parameter. */
void
-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
+gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
const gfc_symbol *fsym, const char *proc_name,
- tree *size)
+ tree *size, tree *lbshift, tree *packed)
{
tree ptr;
tree desc;
tree tmp = NULL_TREE;
tree stmt;
tree parent = DECL_CONTEXT (current_function_decl);
+ tree ctree;
+ tree pack_attr;
bool full_array_var;
bool this_array_result;
bool contiguous;
@@ -8767,20 +8774,28 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
/* There is no need to pack and unpack the array, if it is contiguous
and not a deferred- or assumed-shape array, or if it is simply
contiguous. */
- no_pack = ((sym && sym->as
- && !sym->attr.pointer
- && sym->as->type != AS_DEFERRED
- && sym->as->type != AS_ASSUMED_RANK
- && sym->as->type != AS_ASSUMED_SHAPE)
- ||
- (ref && ref->u.ar.as
- && ref->u.ar.as->type != AS_DEFERRED
+ no_pack = false;
+ // clang-format off
+ if (sym)
+ {
+ symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
+ ? CLASS_DATA (sym)->attr : sym->attr);
+ gfc_array_spec *as = IS_CLASS_ARRAY (sym)
+ ? CLASS_DATA (sym)->as : sym->as;
+ no_pack = (as
+ && !attr->pointer
+ && as->type != AS_DEFERRED
+ && as->type != AS_ASSUMED_RANK
+ && as->type != AS_ASSUMED_SHAPE);
+ }
+ if (ref && ref->u.ar.as)
+ no_pack = no_pack
+ || (ref->u.ar.as->type != AS_DEFERRED
&& ref->u.ar.as->type != AS_ASSUMED_RANK
- && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
- ||
- gfc_is_simply_contiguous (expr, false, true));
-
- no_pack = contiguous && no_pack;
+ && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
+ no_pack = contiguous
+ && (no_pack || gfc_is_simply_contiguous (expr, false, true));
+ // clang-format on
/* If we have an EXPR_OP or a function returning an explicit-shaped
or allocatable array, an array temporary will be generated which
@@ -8835,6 +8850,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
return;
}
+ if (fsym && fsym->ts.type == BT_CLASS)
+ {
+ gcc_assert (se->expr);
+ ctree = se->expr;
+ }
+ else
+ ctree = NULL_TREE;
+
if (this_array_result)
{
/* Result of the enclosing function. */
@@ -8853,7 +8876,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
else
{
/* Every other type of array. */
- se->want_pointer = 1;
+ se->want_pointer = (ctree) ? 0 : 1;
gfc_conv_expr_descriptor (se, expr);
if (size)
@@ -8861,6 +8884,55 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
build_fold_indirect_ref_loc (input_location,
se->expr),
expr, size);
+ if (ctree)
+ {
+ stmtblock_t block;
+
+ gfc_init_block (&block);
+ if (lbshift && *lbshift)
+ {
+ /* Apply a shift of the lbound when supplied. */
+ for (int dim = 0; dim < expr->rank; ++dim)
+ gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
+ *lbshift);
+ }
+ tmp = gfc_class_data_get (ctree);
+ if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
+ && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
+ {
+ tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
+ gfc_conv_descriptor_data_set (&block, arr,
+ gfc_conv_descriptor_data_get (
+ se->expr));
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (
+ &block, arr, gfc_index_zero_node,
+ gfc_conv_descriptor_size (se->expr, expr->rank));
+ gfc_conv_descriptor_stride_set (
+ &block, arr, gfc_index_zero_node,
+ gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+ gfc_conv_descriptor_dtype (se->expr));
+ gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+ build_int_cst (signed_char_type_node, 1));
+ gfc_conv_descriptor_span_set (&block, arr,
+ gfc_conv_descriptor_span_get (arr));
+ gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
+ se->expr = arr;
+ }
+ gfc_class_array_data_assign (&block, tmp, se->expr, true);
+
+ /* Handle optional. */
+ if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
+ gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ else
+ tmp = gfc_finish_block (&block);
+
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
}
/* Deallocate the allocatable components of structures that are
@@ -8880,12 +8952,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
if (g77 || (fsym && fsym->attr.contiguous
&& !gfc_is_simply_contiguous (expr, false, true)))
{
- tree origptr = NULL_TREE;
+ tree origptr = NULL_TREE, packedptr = NULL_TREE;
desc = se->expr;
/* For contiguous arrays, save the original value of the descriptor. */
- if (!g77)
+ if (!g77 && !ctree)
{
origptr = gfc_create_var (pvoid_type_node, "origptr");
tmp = build_fold_indirect_ref_loc (input_location, desc);
@@ -8924,18 +8996,51 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
return;
}
- ptr = build_call_expr_loc (input_location,
- gfor_fndecl_in_pack, 1, desc);
-
- if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ if (ctree)
{
- tmp = gfc_conv_expr_present (sym);
- ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
- tmp, fold_convert (TREE_TYPE (se->expr), ptr),
- fold_convert (TREE_TYPE (se->expr), null_pointer_node));
+ packedptr
+ = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
+ "packed"));
+ if (fsym)
+ {
+ int pack_mask = 0;
+
+ /* Set bit 0 to the mask, when this is an unlimited_poly
+ class. */
+ if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
+ pack_mask = 1 << 0;
+ pack_attr = build_int_cst (integer_type_node, pack_mask);
+ }
+ else
+ pack_attr = integer_zero_node;
+
+ gfc_add_expr_to_block (
+ &se->pre,
+ build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
+ packedptr,
+ gfc_build_addr_expr (NULL_TREE, ctree),
+ size_in_bytes (TREE_TYPE (ctree)), pack_attr));
+ ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
+ se->expr = packedptr;
+ if (packed)
+ *packed = packedptr;
}
+ else
+ {
+ ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
+ desc);
+
+ if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ {
+ tmp = gfc_conv_expr_present (sym);
+ ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
+ tmp, fold_convert (TREE_TYPE (se->expr), ptr),
+ fold_convert (TREE_TYPE (se->expr),
+ null_pointer_node));
+ }
- ptr = gfc_evaluate_now (ptr, &se->pre);
+ ptr = gfc_evaluate_now (ptr, &se->pre);
+ }
/* Use the packed data for the actual argument, except for contiguous arrays,
where the descriptor's data component is set. */
@@ -8947,8 +9052,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
gfc_ss * ss = gfc_walk_expr (expr);
if (!transposed_dims (ss))
- gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
- else
+ {
+ if (!ctree)
+ gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
+ }
+ else if (!ctree)
{
tree old_field, new_field;
@@ -9021,22 +9129,36 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
/* Copy the data back. */
if (fsym == NULL || fsym->attr.intent != INTENT_IN)
{
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_in_unpack, 2, desc, ptr);
+ if (ctree)
+ {
+ tmp = gfc_build_addr_expr (NULL_TREE, ctree);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_in_unpack_class, 4, tmp,
+ packedptr,
+ size_in_bytes (TREE_TYPE (ctree)),
+ pack_attr);
+ }
+ else
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
+ desc, ptr);
gfc_add_expr_to_block (&block, tmp);
}
+ else if (ctree && fsym->attr.intent == INTENT_IN)
+ {
+ /* Need to free the memory for class arrays, that got packed. */
+ gfc_add_expr_to_block (&block, gfc_call_free (ptr));
+ }
/* Free the temporary. */
- tmp = gfc_call_free (ptr);
- gfc_add_expr_to_block (&block, tmp);
+ if (!ctree)
+ gfc_add_expr_to_block (&block, gfc_call_free (ptr));
stmt = gfc_finish_block (&block);
gfc_init_block (&block);
/* Only if it was repacked. This code needs to be executed before the
loop cleanup code. */
- tmp = build_fold_indirect_ref_loc (input_location,
- desc);
+ tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
tmp = gfc_conv_array_data (tmp);
tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
fold_convert (TREE_TYPE (tmp), ptr), tmp);
@@ -9054,11 +9176,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
gfc_init_block (&se->post);
/* Reset the descriptor pointer. */
- if (!g77)
- {
- tmp = build_fold_indirect_ref_loc (input_location, desc);
- gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
- }
+ if (!g77 && !ctree)
+ {
+ tmp = build_fold_indirect_ref_loc (input_location, desc);
+ gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
+ }
gfc_add_block_to_block (&se->post, &block);
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index a51e9a5..29499a3 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -152,8 +152,9 @@ tree gfc_get_array_span (tree, gfc_expr *);
/* Evaluate an array expression. */
void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *);
/* Convert an array for passing as an actual function parameter. */
-void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool,
- const gfc_symbol *, const char *, tree *);
+void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool, const gfc_symbol *,
+ const char *, tree *, tree * = nullptr,
+ tree * = nullptr);
/* These work with both descriptors and descriptorless arrays. */
tree gfc_conv_array_data (tree);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 11247dd..54ab60b 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -118,6 +118,8 @@ tree gfor_fndecl_fdate;
tree gfor_fndecl_ttynam;
tree gfor_fndecl_in_pack;
tree gfor_fndecl_in_unpack;
+tree gfor_fndecl_in_pack_class;
+tree gfor_fndecl_in_unpack_class;
tree gfor_fndecl_associated;
tree gfor_fndecl_system_clock4;
tree gfor_fndecl_system_clock8;
@@ -3916,9 +3918,19 @@ gfc_build_builtin_function_decls (void)
get_identifier (PREFIX("internal_unpack")), ". w R ",
void_type_node, 2, pvoid_type_node, pvoid_type_node);
+ gfor_fndecl_in_pack_class = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("internal_pack_class")), ". w R r r ",
+ void_type_node, 4, pvoid_type_node, pvoid_type_node, size_type_node,
+ integer_type_node);
+
+ gfor_fndecl_in_unpack_class = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("internal_unpack_class")), ". w R r r ",
+ void_type_node, 4, pvoid_type_node, pvoid_type_node, size_type_node,
+ integer_type_node);
+
gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("associated")), ". R R ",
- integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
+ get_identifier (PREFIX ("associated")), ". R R ", integer_type_node, 2,
+ ppvoid_type_node, ppvoid_type_node);
DECL_PURE_P (gfor_fndecl_associated) = 1;
TREE_NOTHROW (gfor_fndecl_associated) = 1;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 477c272..3ff2485 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -598,7 +598,6 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
}
}
-
/* Set the vptr of a class in to from the type given in from. If from is NULL,
then reset the vptr to the default or to. */
@@ -606,6 +605,7 @@ void
gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
{
tree tmp, vptr_ref;
+ gfc_symbol *type;
vptr_ref = gfc_get_vptr_from_expr (to);
if (POINTER_TYPE_P (TREE_TYPE (from))
@@ -614,38 +614,44 @@ gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
gfc_add_modify (block, vptr_ref,
fold_convert (TREE_TYPE (vptr_ref),
gfc_get_vptr_from_expr (from)));
+ return;
}
- else if (VAR_P (from)
- && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
+ tmp = gfc_get_vptr_from_expr (from);
+ if (tmp)
+ {
+ gfc_add_modify (block, vptr_ref,
+ fold_convert (TREE_TYPE (vptr_ref), tmp));
+ return;
+ }
+ if (VAR_P (from)
+ && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
{
gfc_add_modify (block, vptr_ref,
gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
+ return;
}
- else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
- && GFC_CLASS_TYPE_P (
- TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
+ && GFC_CLASS_TYPE_P (
+ TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
{
gfc_add_modify (block, vptr_ref,
fold_convert (TREE_TYPE (vptr_ref),
gfc_get_vptr_from_expr (TREE_OPERAND (
TREE_OPERAND (from, 0), 0))));
+ return;
}
- else
- {
- tree vtab;
- gfc_symbol *type;
- tmp = TREE_TYPE (from);
- if (POINTER_TYPE_P (tmp))
- tmp = TREE_TYPE (tmp);
- gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
- &type);
- vtab = gfc_find_derived_vtab (type)->backend_decl;
- gcc_assert (vtab);
- gfc_add_modify (block, vptr_ref,
- gfc_build_addr_expr (TREE_TYPE (vptr_ref), vtab));
- }
-}
+ /* If nothing of the above matches, set the vtype according to the type. */
+ tmp = TREE_TYPE (from);
+ if (POINTER_TYPE_P (tmp))
+ tmp = TREE_TYPE (tmp);
+ gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
+ &type);
+ tmp = gfc_find_derived_vtab (type)->backend_decl;
+ gcc_assert (tmp);
+ gfc_add_modify (block, vptr_ref,
+ gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
+}
/* Reset the len for unlimited polymorphic objects. */
@@ -739,10 +745,9 @@ gfc_get_vptr_from_expr (tree expr)
return NULL_TREE;
}
-
-static void
-class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
- bool lhs_type)
+void
+gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
+ bool lhs_type)
{
tree tmp, tmp2, type;
@@ -766,9 +771,8 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
gfc_add_modify (block, tmp, tmp2);
}
-
/* Takes a derived type expression and returns the address of a temporary
- class object of the 'declared' type. If vptr is not NULL, this is
+ class object of the 'declared' type. If opt_vptr_src is not NULL, this is
used for the temporary class object.
optional_alloc_ptr is false when the dummy is neither allocatable
nor a pointer; that's only relevant for the optional handling.
@@ -776,49 +780,65 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
expression for deallocation of allocatable components. Assumed rank
formal arguments made this necessary. */
void
-gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts, tree vptr, bool optional,
- bool optional_alloc_ptr,
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
+ tree opt_vptr_src, bool optional,
+ bool optional_alloc_ptr, const char *proc_name,
tree *derived_array)
{
- gfc_symbol *vtab;
tree cond_optional = NULL_TREE;
gfc_ss *ss;
tree ctree;
tree var;
tree tmp;
- int dim;
+ tree packed = NULL_TREE;
- /* The derived type needs to be converted to a temporary
- CLASS object. */
- tmp = gfc_typenode_for_spec (&class_ts);
+ /* The derived type needs to be converted to a temporary CLASS object. */
+ tmp = gfc_typenode_for_spec (&fsym->ts);
var = gfc_create_var (tmp, "class");
/* Set the vptr. */
- ctree = gfc_class_vptr_get (var);
-
- if (vptr != NULL_TREE)
- {
- /* Use the dynamic vptr. */
- tmp = vptr;
- }
+ if (opt_vptr_src)
+ gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
else
- {
- /* In this case the vtab corresponds to the derived type and the
- vptr must point to it. */
- vtab = gfc_find_derived_vtab (e->ts.u.derived);
- gcc_assert (vtab);
- tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
- }
- gfc_add_modify (&parmse->pre, ctree,
- fold_convert (TREE_TYPE (ctree), tmp));
+ gfc_reset_vptr (&parmse->pre, e, var);
/* Now set the data field. */
- ctree = gfc_class_data_get (var);
+ ctree = gfc_class_data_get (var);
if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
+ /* Set the _len as early as possible. */
+ if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
+ && fsym->ts.u.derived->components->ts.u.derived->attr
+ .unlimited_polymorphic)
+ {
+ /* Take care about initializing the _len component correctly. */
+ tree len_tree = gfc_class_len_get (var);
+ if (UNLIMITED_POLY (e))
+ {
+ gfc_expr *len;
+ gfc_se se;
+
+ len = gfc_find_and_cut_at_last_class_ref (e);
+ gfc_add_len_component (len);
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, len);
+ if (optional)
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
+ cond_optional, se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ integer_zero_node));
+ else
+ tmp = se.expr;
+ gfc_free_expr (len);
+ }
+ else
+ tmp = integer_zero_node;
+ gfc_add_modify (&parmse->pre, len_tree,
+ fold_convert (TREE_TYPE (len_tree), tmp));
+ }
+
if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
{
/* If there is a ready made pointer to a derived type, use it
@@ -847,7 +867,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_conv_expr_reference (parmse, e);
/* Scalar to an assumed-rank array. */
- if (class_ts.u.derived->components->as)
+ if (fsym->ts.u.derived->components->as)
{
tree type;
type = get_scalar_to_descriptor_type (parmse->expr,
@@ -878,15 +898,23 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
stmtblock_t block;
gfc_init_block (&block);
gfc_ref *ref;
+ int dim;
+ tree lbshift = NULL_TREE;
- parmse->ss = ss;
- parmse->use_offset = 1;
- gfc_conv_expr_descriptor (parmse, e);
+ /* Array refs with sections indicate, that a for a formal argument
+ expecting contiguous repacking needs to be done. */
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+ break;
+ if (IS_CLASS_ARRAY (fsym)
+ && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
+ || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
+ && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
+ fsym->attr.contiguous = 1;
/* Detect any array references with vector subscripts. */
for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_ELEMENT
+ if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
&& ref->u.ar.type != AR_FULL)
{
for (dim = 0; dim < ref->u.ar.dimen; dim++)
@@ -895,37 +923,20 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
if (dim < ref->u.ar.dimen)
break;
}
-
- /* Array references with vector subscripts and non-variable expressions
- need be converted to a one-based descriptor. */
+ /* Array references with vector subscripts and non-variable
+ expressions need be converted to a one-based descriptor. */
if (ref || e->expr_type != EXPR_VARIABLE)
- {
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
- gfc_index_one_node);
- }
+ lbshift = gfc_index_one_node;
- if (e->rank != class_ts.u.derived->components->as->rank)
- {
- gcc_assert (class_ts.u.derived->components->as->type
- == AS_ASSUMED_RANK);
- if (derived_array
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
- {
- *derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
- "array");
- gfc_add_modify (&block, *derived_array , parmse->expr);
- }
- class_array_data_assign (&block, ctree, parmse->expr, false);
- }
- else
+ parmse->expr = var;
+ gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
+ &lbshift, &packed);
+
+ if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
{
- if (gfc_expr_attr (e).codimension)
- parmse->expr = fold_build1_loc (input_location,
- VIEW_CONVERT_EXPR,
- TREE_TYPE (ctree),
- parmse->expr);
- gfc_add_modify (&block, ctree, parmse->expr);
+ *derived_array
+ = gfc_create_var (TREE_TYPE (parmse->expr), "array");
+ gfc_add_modify (&block, *derived_array, parmse->expr);
}
if (optional)
@@ -947,47 +958,19 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
}
}
- if (class_ts.u.derived->components->ts.type == BT_DERIVED
- && class_ts.u.derived->components->ts.u.derived
- ->attr.unlimited_polymorphic)
- {
- /* Take care about initializing the _len component correctly. */
- ctree = gfc_class_len_get (var);
- if (UNLIMITED_POLY (e))
- {
- gfc_expr *len;
- gfc_se se;
-
- len = gfc_find_and_cut_at_last_class_ref (e);
- gfc_add_len_component (len);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, len);
- if (optional)
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
- cond_optional, se.expr,
- fold_convert (TREE_TYPE (se.expr),
- integer_zero_node));
- else
- tmp = se.expr;
- gfc_free_expr (len);
- }
- else
- tmp = integer_zero_node;
- gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
- tmp));
- }
/* Pass the address of the class object. */
- parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+ if (packed)
+ parmse->expr = packed;
+ else
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
if (optional && optional_alloc_ptr)
- parmse->expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse->expr),
- cond_optional, parmse->expr,
- fold_convert (TREE_TYPE (parmse->expr),
- null_pointer_node));
+ parmse->expr
+ = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
+ cond_optional, parmse->expr,
+ fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
}
-
/* Create a new class container, which is required as scalar coarrays
have an array descriptor while normal scalars haven't. Optionally,
NULL pointer checks are added if the argument is OPTIONAL. */
@@ -1292,7 +1275,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
gfc_conv_descriptor_data_set (&block, ctree, tmp);
}
else
- class_array_data_assign (&block, ctree, parmse->expr, false);
+ gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
else
{
@@ -1318,7 +1301,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
gfc_conv_descriptor_data_get (ctree)));
}
else
- class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
+ gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
+ true);
}
else
gfc_add_modify (&parmse->post, parmse->expr, ctree);
@@ -6530,13 +6514,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
- gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
+ gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional,
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional,
CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable,
- &derived_array);
+ || CLASS_DATA (fsym)->attr.allocatable,
+ sym->name, &derived_array);
}
else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
&& e->ts.type != BT_PROCEDURE
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index ee2cc56..7ab82fa 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2462,8 +2462,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
|| (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);
+ dtio_sub->formal->sym, vptr, false,
+ false, "transfer");
addr_expr = se->expr;
function = iocall[IOCALL_X_DERIVED];
break;
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 703a705..41740ab 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2118,11 +2118,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
/* This is bound to be a class array element. */
gfc_conv_expr_reference (&se, e);
- /* Get the _vptr component of the class object. */
- tmp = gfc_get_vptr_from_expr (se.expr);
/* Obtain a temporary class container for the result. */
- gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
- se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+ gfc_conv_derived_to_class (&se, e, sym, se.expr, false, false,
+ e->symtree->name);
need_len_assign = false;
}
else
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index ec04aed..fdcce20 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -464,8 +464,9 @@ bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
void gfc_finalize_tree_expr (gfc_se *, gfc_symbol *, symbol_attribute, int);
bool gfc_assignment_finalizer_call (gfc_se *, gfc_expr *, bool);
-void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
- bool, tree *derived_array = NULL);
+void gfc_class_array_data_assign (stmtblock_t *, tree, tree, bool);
+void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_symbol *fsym, tree,
+ bool, bool, const char *, tree * = nullptr);
void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
bool, bool);
@@ -872,6 +873,8 @@ extern GTY(()) tree gfor_fndecl_ctime;
extern GTY(()) tree gfor_fndecl_fdate;
extern GTY(()) tree gfor_fndecl_in_pack;
extern GTY(()) tree gfor_fndecl_in_unpack;
+extern GTY(()) tree gfor_fndecl_in_pack_class;
+extern GTY(()) tree gfor_fndecl_in_unpack_class;
extern GTY(()) tree gfor_fndecl_associated;
extern GTY(()) tree gfor_fndecl_system_clock4;
extern GTY(()) tree gfor_fndecl_system_clock8;
diff --git a/gcc/testsuite/gfortran.dg/class_dummy_11.f90 b/gcc/testsuite/gfortran.dg/class_dummy_11.f90
new file mode 100644
index 0000000..a5c0fa6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_dummy_11.f90
@@ -0,0 +1,194 @@
+! { dg-do run }
+
+! PR fortran/96992
+
+! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
+
+! From the standard:
+! An actual argument that represents an element sequence and
+! corresponds to a dummy argument that is an array is sequence
+! associated with the dummy argument. The rank and shape of the
+! actual argument need not agree with the rank and shape of the
+! dummy argument, but the number of elements in the dummy argument
+! shall not exceed the number of elements in the element sequence
+! of the actual argument. If the dummy argument is assumed-size,
+! the number of elements in the dummy argument is exactly
+! the number of elements in the element sequence.
+
+! Check that walking the sequence starts with an initialized stride
+! for dim == 0.
+
+module foo_mod
+
+ implicit none
+
+ type foo
+ integer :: i
+ end type foo
+
+contains
+
+ subroutine d1(x,n)
+ integer, intent(in) :: n
+ integer :: i
+ class (foo), intent(out), dimension(n) :: x
+
+ x(:)%i = (/ (42 + i, i = 1, n ) /)
+ end subroutine d1
+
+ subroutine d2(x,n,sb)
+ integer, intent(in) :: n
+ integer :: i, sb
+ class (foo), intent(in), dimension(n,n,n) :: x
+
+ if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop sb + 1
+ end subroutine d2
+
+ subroutine d3(x,n)
+ integer, intent(in) :: n
+ integer :: i
+ class (foo), intent(inout) :: x(n)
+
+ x%i = -x%i ! Simply negate elements
+ end subroutine d3
+
+ subroutine d4(a,n)
+ integer, intent(in) :: n
+ class (foo), intent(inout) :: a(*)
+
+ call d3(a,n)
+ end subroutine d4
+
+ subroutine d1s(x,n, sb)
+ integer, intent(in) :: n, sb
+ integer :: i
+ class (*), intent(out), dimension(n) :: x
+
+ select type(x)
+ class is(foo)
+ x(:)%i = (/ (42 + i, i = 1, n ) /)
+ class default
+ stop sb + 2
+ end select
+ end subroutine d1s
+
+ subroutine d2s(x,n,sb)
+ integer, intent(in) :: n,sb
+ integer :: i
+ class (*), intent(in), dimension(n,n,n) :: x
+
+ select type (x)
+ class is (foo)
+ if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop sb + 3
+ class default
+ stop sb + 4
+ end select
+ end subroutine d2s
+
+ subroutine d3s(x,n,sb)
+ integer, intent(in) :: n, sb
+ integer :: i
+ class (*), intent(inout) :: x(n)
+
+ select type (x)
+ class is (foo)
+ x%i = -x%i ! Simply negate elements
+ class default
+ stop sb + 5
+ end select
+ end subroutine d3s
+
+end module foo_mod
+
+program main
+
+ use foo_mod
+
+ implicit none
+
+ type (foo), dimension(:), allocatable :: f
+ type (foo), dimension(27) :: g
+ type (foo), dimension(3, 9) :: td
+ integer :: n,i,np3
+
+ n = 3
+ np3 = n **3
+ allocate (f(np3))
+ call d1(f, np3)
+ call d2(f, n, 0)
+
+ call d1s(f, np3, 0)
+ call d2s(f, n, 0)
+
+ ! Use negative stride
+ call d1(f(np3:1:-1), np3)
+ if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 6
+ call d2(f(np3:1:-1), n, 0)
+ call d3(f(1:np3:4), np3/4)
+ if ( any( f%i /= (/ (merge(-(42 + (np3 - i)), &
+ 42 + (np3 - i), &
+ MOD(i, 4) == 0 .AND. i < 21), &
+ i = 0, np3 - 1 ) /) )) &
+ stop 7
+ call d4(f(1:np3:4), np3/4)
+ if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 8
+
+ call d1s(f(np3:1:-1), np3, 0)
+ if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 9
+ call d2s(f(np3:1:-1), n, 0)
+ call d3s(f(1:np3:4), np3/4, 0)
+ if ( any( f%i /= (/ (merge(-(42 + (np3 - i)), &
+ 42 + (np3 - i), &
+ MOD(i, 4) == 0 .AND. i < 21), &
+ i = 0, np3 - 1 ) /) )) &
+ stop 10
+
+ deallocate (f)
+
+ call d1(g, np3)
+ call d2(g, n, 11)
+
+ call d1s(g, np3, 11)
+ call d2s(g, n, 11)
+
+ ! Use negative stride
+ call d1(g(np3:1:-1), np3)
+ if ( any( g%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 17
+ call d2(g(np3:1:-1), n, 11)
+ call d3(g(1:np3:4), np3/4)
+ if ( any( g%i /= (/ (merge(-(42 + (np3 - i)), &
+ 42 + (np3 - i), &
+ MOD(i, 4) == 0 .AND. i < 21), &
+ i = 0, np3 - 1 ) /) )) &
+ stop 18
+
+ call d1s(g(np3:1:-1), np3, 11)
+ if ( any( g%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 19
+ call d2s(g(np3:1:-1), n, 11)
+ call d3s(g(1:np3:4), np3/4, 11)
+ if ( any( g%i /= (/ (merge(-(42 + (np3 - i)), &
+ 42 + (np3 - i), &
+ MOD(i, 4) == 0 .AND. i < 21), &
+ i = 0, np3 - 1 ) /) )) &
+ stop 20
+
+ ! Check for 2D
+ call d1(td, np3)
+ call d2(td, n, 21)
+
+ call d1s(td, np3, 21)
+ call d2s(td, n, 21)
+
+ ! Use negative stride
+ call d1(td(3:1:-1,9:1:-1), np3)
+ if ( any( reshape(td%i, [np3]) /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 26
+ call d2(td(3:1:-1,9:1:-1), n, 21)
+ call d3(td(2,1:n), n)
+ if ( any( reshape(td%i, [np3]) /= (/ (merge(-(42 + (np3 - i)), &
+ 42 + (np3 - i), &
+ MOD(i, 3) == 1 .AND. i < 9), &
+ i = 0, np3 - 1 ) /) )) &
+ stop 27
+
+end program main
+
diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am
index ab605d4..8524cc6 100644
--- a/libgfortran/Makefile.am
+++ b/libgfortran/Makefile.am
@@ -156,7 +156,9 @@ intrinsics/selected_real_kind.f90 \
intrinsics/trigd.c \
intrinsics/unpack_generic.c \
runtime/in_pack_generic.c \
-runtime/in_unpack_generic.c
+runtime/in_unpack_generic.c \
+runtime/in_pack_class.c \
+runtime/in_unpack_class.c
if !LIBGFOR_MINIMAL
diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in
index ced10e9..6c6c89c 100644
--- a/libgfortran/Makefile.in
+++ b/libgfortran/Makefile.in
@@ -569,8 +569,8 @@ am__objects_58 = intrinsics/associated.lo intrinsics/abort.lo \
intrinsics/selected_int_kind.lo \
intrinsics/selected_real_kind.lo intrinsics/trigd.lo \
intrinsics/unpack_generic.lo runtime/in_pack_generic.lo \
- runtime/in_unpack_generic.lo $(am__objects_56) \
- $(am__objects_57)
+ runtime/in_unpack_generic.lo runtime/in_pack_class.lo \
+ runtime/in_unpack_class.lo $(am__objects_56) $(am__objects_57)
@IEEE_SUPPORT_TRUE@am__objects_59 = ieee/ieee_arithmetic.lo \
@IEEE_SUPPORT_TRUE@ ieee/ieee_exceptions.lo \
@IEEE_SUPPORT_TRUE@ ieee/ieee_features.lo
@@ -985,7 +985,8 @@ gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \
intrinsics/selected_int_kind.f90 \
intrinsics/selected_real_kind.f90 intrinsics/trigd.c \
intrinsics/unpack_generic.c runtime/in_pack_generic.c \
- runtime/in_unpack_generic.c $(am__append_4) $(am__append_5)
+ runtime/in_unpack_generic.c runtime/in_pack_class.c \
+ runtime/in_unpack_class.c $(am__append_4) $(am__append_5)
@IEEE_SUPPORT_TRUE@gfor_ieee_helper_src = ieee/ieee_helper.c
@IEEE_SUPPORT_FALSE@gfor_ieee_src =
@IEEE_SUPPORT_TRUE@gfor_ieee_src = \
@@ -3174,6 +3175,10 @@ runtime/in_pack_generic.lo: runtime/$(am__dirstamp) \
runtime/$(DEPDIR)/$(am__dirstamp)
runtime/in_unpack_generic.lo: runtime/$(am__dirstamp) \
runtime/$(DEPDIR)/$(am__dirstamp)
+runtime/in_pack_class.lo: runtime/$(am__dirstamp) \
+ runtime/$(DEPDIR)/$(am__dirstamp)
+runtime/in_unpack_class.lo: runtime/$(am__dirstamp) \
+ runtime/$(DEPDIR)/$(am__dirstamp)
intrinsics/access.lo: intrinsics/$(am__dirstamp) \
intrinsics/$(DEPDIR)/$(am__dirstamp)
intrinsics/c99_functions.lo: intrinsics/$(am__dirstamp) \
@@ -4223,7 +4228,9 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/environ.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/error.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/fpu.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_pack_class.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_pack_generic.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_unpack_class.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_unpack_generic.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/main.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/memory.Plo@am__quote@
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index 4a5a037..82f8f3c 100644
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -1770,3 +1770,9 @@ GFORTRAN_14 {
global:
_gfortran_selected_logical_kind;
} GFORTRAN_13;
+
+GFORTRAN_15 {
+ global:
+ _gfortran_internal_pack_class;
+ _gfortran_internal_unpack_class;
+} GFORTRAN_14;
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index 5c59ec2..effa373 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -570,6 +570,29 @@ typedef GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_INTEGER_4) gfc_full_a
#define GFC_UNALIGNED_C8(x) (((uintptr_t)(x)) & \
(__alignof__(GFC_COMPLEX_8) - 1))
+/* Generic vtab structure. */
+typedef struct
+{
+ GFC_INTEGER_4 _hash;
+ size_t _size;
+ struct gfc_vtype_generic_t *_extends;
+ void *_def_init;
+ void (*_copy) (const void *, void *);
+ void *(*_final);
+ void (*_deallocate) (void *);
+} gfc_vtype_generic_t;
+
+/* Generic class structure. */
+#define GFC_CLASS_T(type) \
+ struct \
+ { \
+ type _data; \
+ gfc_vtype_generic_t *_vptr; \
+ size_t _len; \
+ }
+
+typedef GFC_CLASS_T (GFC_ARRAY_DESCRIPTOR (void)) gfc_class_array_t;
+
/* Runtime library include. */
#define stringize(x) expand_macro(x)
#define expand_macro(x) # x
diff --git a/libgfortran/runtime/in_pack_class.c b/libgfortran/runtime/in_pack_class.c
new file mode 100644
index 0000000..248689c
--- /dev/null
+++ b/libgfortran/runtime/in_pack_class.c
@@ -0,0 +1,152 @@
+/* Class specific helper function for repacking arrays.
+ Copyright (C) 2003-2024 Free Software Foundation, Inc.
+ Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran 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 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <string.h>
+
+extern void
+internal_pack_class (gfc_class_array_t *, gfc_class_array_t *, const size_t,
+ const int);
+export_proto (internal_pack_class);
+
+/* attr is a bitfield. The bits in use are:
+ 0 - _len is present.
+ */
+void
+internal_pack_class (gfc_class_array_t *dest_class,
+ gfc_class_array_t *source_class, const size_t size_class,
+ const int attr)
+{
+#define BIT_TEST(mask, bit) (((mask) & (1U << (bit))) == (1U << (bit)))
+
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type stride[GFC_MAX_DIMENSIONS];
+ index_type stride0;
+ index_type dim;
+ index_type ssize;
+ index_type dest_stride;
+ index_type n;
+ const void *src;
+ void *dest;
+ int packed;
+ index_type size;
+ gfc_array_void *source_arr;
+ gfc_array_void *dest_arr;
+ size_t dest_offset;
+ bool len_present = BIT_TEST (attr, 0);
+ gfc_vtype_generic_t *vtab;
+ void (*copyfn) (const void *, void *);
+
+ /* Always make sure the dest is initialized. */
+ memcpy (dest_class, source_class, size_class);
+ if (source_class->_data.base_addr == NULL)
+ return;
+
+ source_arr = (gfc_array_void *) &(source_class->_data);
+ size = GFC_DESCRIPTOR_SIZE (source_arr);
+ dim = GFC_DESCRIPTOR_RANK (source_arr);
+ ssize = 1;
+ packed = 1;
+ for (n = 0; n < dim; n++)
+ {
+ count[n] = 0;
+ stride[n] = GFC_DESCRIPTOR_STRIDE (source_arr, n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT (source_arr, n);
+ if (extent[n] <= 0)
+ {
+ /* Do nothing. */
+ packed = 1;
+ break;
+ }
+
+ if (ssize != stride[n])
+ packed = 0;
+
+ ssize *= extent[n];
+ }
+
+ /* When the data is packed already, nothing needs to be done and unpack, will
+ quit immediately, because _data is identical and nothing needs to be done.
+ */
+ if (packed)
+ return;
+
+ /* Allocate storage for the destination. */
+ dest_arr = (gfc_array_void *) &dest_class->_data;
+ dest_stride = 1;
+ dest_offset = 0;
+ for (n = 0; n < dim; ++n)
+ {
+ GFC_DESCRIPTOR_LBOUND (dest_arr, n) = 1;
+ GFC_DESCRIPTOR_UBOUND (dest_arr, n) = extent[n];
+ GFC_DESCRIPTOR_STRIDE (dest_arr, n) = dest_stride;
+ dest_offset -= dest_stride * 1 /* GFC_DESCRIPTOR_LBOUND (dest_arr, n) */;
+ dest_stride *= GFC_DESCRIPTOR_EXTENT (dest_arr, n);
+ }
+ dest_arr->offset = dest_offset;
+ dest_arr->base_addr = xmallocarray (ssize, size);
+ dest = (void *) dest_arr->base_addr;
+ src = source_arr->base_addr;
+ stride0 = stride[0] * size;
+ /* Can not use the dimension here, because the class may be allocated for
+ a higher dimensional array, but only a smaller amount is present. */
+ vtab = *(gfc_vtype_generic_t **) (((void *) source_class) + size_class
+ - (len_present ? sizeof (size_t) : 0)
+ - sizeof (void *)); /* _vptr */
+ copyfn = vtab->_copy;
+
+ while (src)
+ {
+ /* Copy the data. */
+ copyfn (src, dest);
+ /* Advance to the next element. */
+ dest += size;
+ src += stride0;
+ count[0]++;
+ /* Advance to the next source element. */
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ src -= stride[n] * extent[n] * size;
+ n++;
+ if (n == dim)
+ {
+ src = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ src += stride[n] * size;
+ }
+ }
+ }
+}
diff --git a/libgfortran/runtime/in_unpack_class.c b/libgfortran/runtime/in_unpack_class.c
new file mode 100644
index 0000000..467f0ce
--- /dev/null
+++ b/libgfortran/runtime/in_unpack_class.c
@@ -0,0 +1,134 @@
+/* Class helper function for repacking arrays.
+ Copyright (C) 2003-2024 Free Software Foundation, Inc.
+ Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran 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 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <string.h>
+
+extern void
+internal_unpack_class (gfc_class_array_t *, gfc_class_array_t *, const size_t,
+ const int);
+export_proto (internal_unpack_class);
+
+void
+internal_unpack_class (gfc_class_array_t *dest_class,
+ gfc_class_array_t *source_class, const size_t size_class,
+ const int attr)
+{
+#define BIT_TEST(mask, bit) (((mask) & (1U << (bit))) == (1U << (bit)))
+
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type stride[GFC_MAX_DIMENSIONS];
+ index_type stride0;
+ index_type dim;
+ index_type dsize;
+ void *dest;
+ const void *src;
+ index_type size;
+ const gfc_array_void *src_arr;
+ gfc_array_void *dest_arr;
+ bool len_present = BIT_TEST (attr, 0);
+ gfc_vtype_generic_t *vtab;
+ void (*copyfn) (const void *, void *);
+
+ /* This check may be redundant, but do it anyway. */
+ if (!source_class || !dest_class || !source_class->_data.base_addr
+ || !dest_class->_data.base_addr)
+ return;
+
+ dest_arr = (gfc_array_void *) &(dest_class->_data);
+ dest = dest_arr->base_addr;
+ size = GFC_DESCRIPTOR_SIZE (dest_arr);
+ dim = GFC_DESCRIPTOR_RANK (dest_arr);
+ dsize = 1;
+ for (index_type n = 0; n < dim; n++)
+ {
+ count[n] = 0;
+ stride[n] = GFC_DESCRIPTOR_STRIDE (dest_arr, n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT (dest_arr, n);
+ if (extent[n] <= 0)
+ return;
+
+ if (dsize == stride[n])
+ dsize *= extent[n];
+ else
+ dsize = 0;
+ }
+
+ src_arr = (gfc_array_void *) &source_class->_data;
+ src = src_arr->base_addr;
+
+ vtab = *(gfc_vtype_generic_t **) (((void *) source_class) + size_class
+ - (len_present ? sizeof (size_t) : 0)
+ - sizeof (void *)); /* _vptr */
+ copyfn = vtab->_copy;
+
+ if (dsize != 0)
+ {
+ for (index_type n = 0; n < dsize; ++n)
+ {
+ copyfn (src, dest);
+ src += size;
+ dest += size;
+ }
+ free (src_arr->base_addr);
+ return;
+ }
+
+ stride0 = stride[0] * size;
+
+ while (dest)
+ {
+ /* Copy the data. */
+ copyfn (src, dest);
+ /* Advance to the next element. */
+ src += size;
+ dest += stride0;
+ count[0]++;
+ /* Advance to the next source element. */
+ index_type n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= stride[n] * extent[n] * size;
+ n++;
+ if (n == dim)
+ {
+ dest = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ dest += stride[n] * size;
+ }
+ }
+ }
+ free (src_arr->base_addr);
+}
generated by cgit v1.1 at 2024-08-07 02:43:08 +0000