diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/trans-array.cc | 204 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.h | 5 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.cc | 16 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 242 | ||||
| -rw-r--r-- | gcc/fortran/trans-io.cc | 4 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.cc | 6 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 7 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/class_dummy_11.f90 | 194 |
8 files changed, 496 insertions, 182 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 + |