diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index c7d24468939..ed0ad5429e2 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; - 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); } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index a51e9a5256b..29499a337c2 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 11247ddc07a..54ab60b4935 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 477c2720187..3ff248549c6 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) + 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 diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc index ee2cc560cdf..7ab82fa2f5b 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 703a705e7ca..41740ab762e 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 ec04aede0fd..fdcce206756 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 00000000000..a5c0fa6d52b --- /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 + +! 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 ab605d49984..8524cc6ed03 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 ced10e98aaa..6c6c89cc14e 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 4a5a037a906..82f8f3c5e9c 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 5c59ec26e16..effa3732c18 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 00000000000..248689c1c2a --- /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 + +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 +. */ + +#include "libgfortran.h" +#include + +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 00000000000..467f0ce2d60 --- /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 + +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 +. */ + +#include "libgfortran.h" +#include + +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); +}