From: Paul Thomas Date: Wed, 28 Jun 2023 11:38:58 +0000 (+0100) Subject: Fortran: Enable class expressions in structure constructors [PR49213] X-Git-Tag: basepoints/gcc-15~7979 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=3521768e8e3c448052c5bd3e8fde412e9cf5d70f;p=thirdparty%2Fgcc.git Fortran: Enable class expressions in structure constructors [PR49213] 2023-06-28 Paul Thomas gcc/fortran PR fortran/49213 * expr.cc (gfc_is_ptr_fcn): Remove reference to class_pointer. * resolve.cc (resolve_assoc_var): Call gfc_is_ptr_fcn to allow associate names with pointer function targets to be used in variable definition context. * trans-decl.cc (get_symbol_decl): Remove extraneous line. * trans-expr.cc (alloc_scalar_allocatable_subcomponent): Obtain size of intrinsic and character expressions. (gfc_trans_subcomponent_assign): Expand assignment to class components to include intrinsic and character expressions. gcc/testsuite/ PR fortran/49213 * gfortran.dg/pr49213.f90 : New test --- diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index c960dfeabd90..e418f1f33018 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -816,9 +816,7 @@ bool gfc_is_ptr_fcn (gfc_expr *e) { return e != NULL && e->expr_type == EXPR_FUNCTION - && (gfc_expr_attr (e).pointer - || (e->ts.type == BT_CLASS - && CLASS_DATA (e)->attr.class_pointer)); + && gfc_expr_attr (e).pointer; } diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 82e6ac53aa14..8e018b6e7e83 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -1350,6 +1350,9 @@ resolve_structure_cons (gfc_expr *expr, int init) && CLASS_DATA (comp)->as) rank = CLASS_DATA (comp)->as->rank; + if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS) + gfc_find_vtab (&cons->expr->ts); + if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank && (comp->attr.allocatable || cons->expr->rank)) { @@ -1381,7 +1384,7 @@ resolve_structure_cons (gfc_expr *expr, int init) gfc_basic_typename (comp->ts.type)); t = false; } - else + else if (!UNLIMITED_POLY (comp)) { bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1); if (t) diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 18589e17843f..b0fd25e92a3b 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -1915,7 +1915,6 @@ gfc_get_symbol_decl (gfc_symbol * sym) gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL); } - gfc_finish_var_decl (decl, sym); if (sym->ts.type == BT_CHARACTER) diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 63e3cf9681e2..ad0cdf902ba9 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -8805,6 +8805,7 @@ alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp, tree size; tree size_in_bytes; tree lhs_cl_size = NULL_TREE; + gfc_se se; if (!comp) return; @@ -8839,16 +8840,30 @@ alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp, } else if (cm->ts.type == BT_CLASS) { - gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED); - if (expr2->ts.type == BT_DERIVED) + if (expr2->ts.type != BT_CLASS) { - tmp = gfc_get_symbol_decl (expr2->ts.u.derived); - size = TYPE_SIZE_UNIT (tmp); + if (expr2->ts.type == BT_CHARACTER) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr2); + size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_charlen_type_node, + se.string_length, size); + size = fold_convert (size_type_node, size); + } + else + { + if (expr2->ts.type == BT_DERIVED) + tmp = gfc_get_symbol_decl (expr2->ts.u.derived); + else + tmp = gfc_typenode_for_spec (&expr2->ts); + size = TYPE_SIZE_UNIT (tmp); + } } else { gfc_expr *e2vtab; - gfc_se se; e2vtab = gfc_find_and_cut_at_last_class_ref (expr2); gfc_add_vptr_component (e2vtab); gfc_add_size_component (e2vtab); @@ -8999,6 +9014,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, { gfc_init_se (&se, NULL); gfc_conv_expr (&se, expr); + tree size; /* Take care about non-array allocatable components here. The alloc_* routine below is motivated by the alloc_scalar_allocatable_for_ @@ -9014,7 +9030,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, && expr->symtree->n.sym->attr.dummy) se.expr = build_fold_indirect_ref_loc (input_location, se.expr); - if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED) + if (cm->ts.type == BT_CLASS) { tmp = gfc_class_data_get (dest); tmp = build_fold_indirect_ref_loc (input_location, tmp); @@ -9029,7 +9045,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, /* For deferred strings insert a memcpy. */ if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) { - tree size; gcc_assert (se.string_length || expr->ts.u.cl->backend_decl); size = size_of_string_in_bytes (cm->ts.kind, se.string_length ? se.string_length @@ -9037,6 +9052,36 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, tmp = gfc_build_memcpy_call (tmp, se.expr, size); gfc_add_expr_to_block (&block, tmp); } + else if (cm->ts.type == BT_CLASS) + { + /* Fix the expression for memcpy. */ + if (expr->expr_type != EXPR_VARIABLE) + se.expr = gfc_evaluate_now (se.expr, &block); + + if (expr->ts.type == BT_CHARACTER) + { + size = build_int_cst (gfc_charlen_type_node, expr->ts.kind); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_charlen_type_node, + se.string_length, size); + size = fold_convert (size_type_node, size); + } + else + size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts)); + + /* Now copy the expression to the constructor component _data. */ + gfc_add_expr_to_block (&block, + gfc_build_memcpy_call (tmp, se.expr, size)); + + /* Fill the unlimited polymorphic _len field. */ + if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER) + { + tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp)); + gfc_add_modify (&block, tmp, + fold_convert (TREE_TYPE (tmp), + se.string_length)); + } + } else gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), se.expr)); diff --git a/gcc/testsuite/gfortran.dg/pr49213.f90 b/gcc/testsuite/gfortran.dg/pr49213.f90 new file mode 100644 index 000000000000..293dce84838d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr49213.f90 @@ -0,0 +1,109 @@ +! { dg-do run } +! +! Contributed by Neil Carlson +! +program main + character(2) :: c + + type :: S + integer :: n + end type + type(S) :: Sobj + + type, extends(S) :: S2 + integer :: m + end type + type(S2) :: S2obj + + type :: T + class(S), allocatable :: x + end type + + type tContainer + class(*), allocatable :: x + end type + + type(T) :: Tobj + + Sobj = S(1) + Tobj = T(Sobj) + + S2obj = S2(1,2) + Tobj = T(S2obj) ! Failed here + select type (x => Tobj%x) + type is (S2) + if ((x%n .ne. 1) .or. (x%m .ne. 2)) stop 1 + class default + stop 2 + end select + + c = " " + call pass_it (T(Sobj)) + if (c .ne. "S ") stop 3 + call pass_it (T(S2obj)) ! and here + if (c .ne. "S2") stop 4 + + call bar + +contains + + subroutine pass_it (foo) + type(T), intent(in) :: foo + select type (x => foo%x) + type is (S) + c = "S " + if (x%n .ne. 1) stop 5 + type is (S2) + c = "S2" + if ((x%n .ne. 1) .or. (x%m .ne. 2)) stop 6 + class default + stop 7 + end select + end subroutine + + subroutine check_it (t, errno) + type(tContainer) :: t + integer :: errno + select type (x => t%x) + type is (integer) + if (x .ne. 42) stop errno + type is (integer(8)) + if (x .ne. 42_8) stop errno + type is (real(8)) + if (int(x**2) .ne. 2) stop errno + type is (character(*, kind=1)) + if (x .ne. "end of tests") stop errno + type is (character(*, kind=4)) + if ((x .ne. 4_"hello!") .and. (x .ne. 4_"goodbye")) stop errno + class default + stop errno + end select + end subroutine + + subroutine bar + ! Test from comment #29 extended by Harald Anlauf to check kinds /= default + integer(8), parameter :: i = 0_8 + integer :: j = 42 + character(7,kind=4) :: chr4 = 4_"goodbye" + type(tContainer) :: cont + + cont%x = j + call check_it (cont, 8) + + cont = tContainer(i+42_8) + call check_it (cont, 9) + + cont = tContainer(sqrt (2.0_8)) + call check_it (cont, 10) + + cont = tContainer(4_"hello!") + call check_it (cont, 11) + + cont = tContainer(chr4) + call check_it (cont, 12) + + cont = tContainer("end of tests") + call check_it (cont, 13) + + end subroutine bar +end program