https://gcc.gnu.org/g:2704437a6db0f5a86a26a09abf4f93e1f695bd0b
commit 2704437a6db0f5a86a26a09abf4f93e1f695bd0b Author: Mikael Morin <[email protected]> Date: Wed Aug 19 14:21:58 2026 +0200 fortran: array descriptor: Mark polymorphic descriptors as such [PR122521] Fortran-tested on aarch64-unknown-linux-gnu. OK for mainline? -- >8 -- Make sure that when associating a scalar polymorphic reference with an assumed rank dummy, the resulting descriptor is initialized with a class type. Before this change, the descriptor for polymorphic scalar coarrays had a type set to derived, that is non-polymorphic, because the type that was passed as source for the initialization of the dtype field was not the type of the class descriptor. That source type was taken from the value reference which for coarrays matches class->_data.data, that is includes a a reference to class container's _data and array descriptor's data fields. This is corrected by walking the reference chain up to the class descriptor and then using its type for the dtype values. The type field of descriptors is hardly used, so I'm not aware of any observable behaviour change caused by this, that could be checked by a testcase. There could be a testcase with a tree dump check, but I'm not sure how useful that is if there is no observable effect anyway. PR fortran/122521 gcc/fortran/ChangeLog: * trans-descriptor.cc (is_polymorphic_ref): New helper. (gfc_set_descriptor_from_scalar_class): Find the class descriptor ref and always pass its type to build the dtype value from. Diff: --- gcc/fortran/trans-descriptor.cc | 58 ++++++++++++++++++++++++++++++++++++----- 1 file changed, 52 insertions(+), 6 deletions(-) diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc index d3304f443f6d..9980e9183f35 100644 --- a/gcc/fortran/trans-descriptor.cc +++ b/gcc/fortran/trans-descriptor.cc @@ -899,6 +899,53 @@ gfc_set_descriptor_from_scalar (stmtblock_t *block, tree descr, tree scalar) } +/* Return true if EXPR is a polymorphic reference; otherwise return false. If + CLASS_REF isn't nullptr, set its target to a reference to the class container + in the true case, and leave it unmodified in the false case. */ + +static bool +is_polymorphic_ref (tree expr, tree *class_ref = nullptr) +{ + tree e = expr; + while (true) + { + STRIP_NOPS (e); + if (TREE_CODE (e) == ADDR_EXPR) + ; + else if (POINTER_TYPE_P (TREE_TYPE (e)) + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (e)))) + { + if (class_ref != nullptr) + *class_ref = build_fold_indirect_ref_loc (input_location, e); + return true; + } + else if (GFC_CLASS_TYPE_P (TREE_TYPE (e))) + { + if (class_ref != nullptr) + *class_ref = e; + return true; + } + else if (TREE_CODE (e) == COMPONENT_REF) + { + tree base_obj = TREE_OPERAND (e, 0); + tree field_decl = TREE_OPERAND (e, 1); + tree field_name = DECL_NAME (field_decl); + if (!((GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (base_obj)) + && strcmp (IDENTIFIER_POINTER (field_name), "data") == 0) + || (GFC_CLASS_TYPE_P (TREE_TYPE (base_obj)) + && strcmp (IDENTIFIER_POINTER (field_name), "_data") == 0))) + return false; + } + else if (!(TREE_CODE (e) == INDIRECT_REF + || TREE_CODE (e) == ARRAY_REF + || TREE_CODE (e) == POINTER_PLUS_EXPR)) + return false; + + e = TREE_OPERAND (e, 0); + } +} + + /* Add code to BLOCK initializing the zero-rank array descriptor DESCR, so that it represents the same data as the class descriptor reference SCALAR corresponding to the scalar polymorphic expression SCALAR_EXPR. This is used @@ -909,12 +956,11 @@ void gfc_set_descriptor_from_scalar_class (stmtblock_t *block, tree descr, tree scalar) { - tree scalar_type = TREE_TYPE (scalar); - tree etype = POINTER_TYPE_P (scalar_type) - ? TREE_TYPE (scalar_type) - : scalar_type; - gfc_conv_descriptor_dtype_set (block, descr, - gfc_get_dtype_rank_type (0, etype)); + tree class_ref; + if (!is_polymorphic_ref (scalar, &class_ref)) + gcc_unreachable (); + tree dtype_val = gfc_get_dtype_rank_type (0, TREE_TYPE (class_ref)); + gfc_conv_descriptor_dtype_set (block, descr, dtype_val); tree tmp = scalar; if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
