public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-2160] Fortran: Enable class expressions in structure constructors [PR49213]
@ 2023-06-28 11:39 Paul Thomas
0 siblings, 0 replies; only message in thread
From: Paul Thomas @ 2023-06-28 11:39 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:3521768e8e3c448052c5bd3e8fde412e9cf5d70f
commit r14-2160-g3521768e8e3c448052c5bd3e8fde412e9cf5d70f
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Wed Jun 28 12:38:58 2023 +0100
Fortran: Enable class expressions in structure constructors [PR49213]
2023-06-28 Paul Thomas <pault@gcc.gnu.org>
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:
---
gcc/fortran/expr.cc | 4 +-
gcc/fortran/resolve.cc | 5 +-
gcc/fortran/trans-decl.cc | 1 -
gcc/fortran/trans-expr.cc | 59 +++++++++++++++---
gcc/testsuite/gfortran.dg/pr49213.f90 | 109 ++++++++++++++++++++++++++++++++++
5 files changed, 166 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index c960dfeabd9..e418f1f3301 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 82e6ac53aa1..8e018b6e7e8 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 18589e17843..b0fd25e92a3 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 63e3cf9681e..ad0cdf902ba 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 00000000000..293dce84838
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr49213.f90
@@ -0,0 +1,109 @@
+! { dg-do run }
+!
+! Contributed by Neil Carlson <neil.n.carlson@gmail.com>
+!
+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
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-06-28 11:39 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-06-28 11:39 [gcc r14-2160] Fortran: Enable class expressions in structure constructors [PR49213] Paul Thomas
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).