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 --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index c960dfeabd900ccb451dad7fe9cf8c62519e2596..e418f1f33018b4c13ef09ac881d25bc4a5345035 100644 (file)
--- 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 82e6ac53aa14c81fac087e29a9e0e56767fc5199..8e018b6e7e83c173b69ab39046c8c6f67145e767 100644 (file)
--- 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 18589e17843ffe2a334094dd06c063b8e598de92..b0fd25e92a3bef9237849be4b0810adc8b2876a0 100644 (file)
--- 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 63e3cf9681e2343b8c51aa0f25e5cbc690324737..ad0cdf902ba9ac994172bcc235830934fef43dde 100644 (file)
--- 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 (file)
index 0000000..293dce8
--- /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