mirrors/gcc
1
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-11-23 02:44:18 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

Fortran: Fix rejecting class arrays of different ranks as storage association argument and add un/pack_class. [PR96992]

Browse Source 
Removing the assert in trans-expr, lead to initial strides not set
which is now fixed.  When the array needs repacking, this is done for
class arrays now, too.

Packing class arrays was done using the regular internal pack
function in the past.  But that does not use the vptr's copy
function and breaks OOP paradigms (e.g. deep copy).  The new
un-/pack_class functions use the vptr's copy functionality to
implement OOP paradigms correctly.

	PR fortran/96992

gcc/fortran/ChangeLog:

	* trans-array.cc (gfc_trans_array_bounds): Set a starting
	stride, when descriptor expects a variable for the stride.
	(gfc_trans_dummy_array_bias): Allow storage association for
	dummy class arrays, when they are not elemental.
	(gfc_conv_array_parameter): Add more general class support
	and packing for classes, too.
	* trans-array.h (gfc_conv_array_parameter): Add lbound shift
	for class arrays.
	* trans-decl.cc (gfc_build_builtin_function_decls): Add decls
	for internal_un-/pack_class.
	* trans-expr.cc (gfc_reset_vptr): Allow supplying a type-tree
	to generate the vtab from.
	(gfc_class_set_vptr): Allow supplying a class-tree to take the
	vptr from.
	(class_array_data_assign): Rename to gfc_class_array_data_assign
	and make usable from other compile units.
	(gfc_class_array_data_assign): Renamed from class_array_data_
	assign.
	(gfc_conv_derived_to_class): Remove assert to
	allow converting derived to class type arrays with assumed
	rank.  Reduce code base and use gfc_conv_array_parameter also
	for classes.
	(gfc_conv_class_to_class): Use gfc_class_data_assign.
	(gfc_conv_procedure_call): Adapt to new signature of
	gfc_conv_derived_to_class.
	* trans-io.cc (transfer_expr): Same.
	* trans-stmt.cc (trans_associate_var): Same.
	* trans.h (gfc_conv_derived_to_class): Signature changed.
	(gfc_class_array_data_assign): Made public.
	(gfor_fndecl_in_pack_class): Added declaration.
	(gfor_fndecl_in_unpack_class): Same.

libgfortran/ChangeLog:

	* Makefile.am: Add in_un-/pack_class.c to build.
	* Makefile.in: Regenerated from Makefile.am.
	* gfortran.map: Added new functions and bumped ABI.
	* libgfortran.h (GFC_CLASS_T): Added for generating class
	representation at runtime.
	* runtime/in_pack_class.c: New file.
	* runtime/in_unpack_class.c: New file.

gcc/testsuite/ChangeLog:

	* gfortran.dg/class_dummy_11.f90: New test.
This commit is contained in:
Andre Vehreschild 2024-06-28 08:31:29 +02:00
parent 619f587f68
commit e4f2f46e01
14 changed files with 825 additions and 187 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

206
gcc/fortran/trans-array.cc
View File

@ -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;
ptr = gfc_evaluate_now (ptr, &se->pre);
/* 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);
}
/* 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);
}

5
gcc/fortran/trans-array.h
View File

@ -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);

16
gcc/fortran/trans-decl.cc
View File

@ -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;

242
gcc/fortran/trans-expr.cc
View File

@ -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)
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)))
{
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
{
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

4
gcc/fortran/trans-io.cc
View File

@ -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;

6
gcc/fortran/trans-stmt.cc
View File

@ -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

7
gcc/fortran/trans.h
View File

@ -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;

194
gcc/testsuite/gfortran.dg/class_dummy_11.f90 Normal file
View File

@ -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

4
libgfortran/Makefile.am
View File

@ -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

13
libgfortran/Makefile.in
View File

@ -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@

6
libgfortran/gfortran.map
View File

@ -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;

23
libgfortran/libgfortran.h
View File

@ -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

152
libgfortran/runtime/in_pack_class.c Normal file
View File

@ -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;
}
}
}
}

134
libgfortran/runtime/in_unpack_class.c Normal file
View File

@ -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);
}