Re: [Patch, fortran] PR49213 - [OOP] gfortran rejects structure constructor expression

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 4267 bytes --]

Hi Harald,

Let's try again :-)

OK for trunk?

Regards

Paul

Fortran: Enable class expressions in structure constructors [PR49213]

2023-06-27  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

On Sat, 24 Jun 2023 at 20:50, Harald Anlauf <anlauf@gmx.de> wrote:
>
> Hi Paul!
>
> On 6/24/23 15:18, Paul Richard Thomas via Gcc-patches wrote:
> > I have included the adjustment to 'gfc_is_ptr_fcn' and eliminating the
> > extra blank line, introduced by my last patch. I played safe and went
> > exclusively for class functions with attr.class_pointer set on the
> > grounds that these have had all the accoutrements checked and built
> > (ie. class_ok). I am still not sure if this is necessary or not.
>
> maybe it is my fault, but I find the version in the patch confusing:
>
> @@ -816,7 +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 && gfc_expr_attr (e).pointer)
>                    || (e->ts.type == BT_CLASS
>                        && CLASS_DATA (e)->attr.class_pointer));
>   }
>
> The caller 'gfc_is_ptr_fcn' has e->expr_type == EXPR_FUNCTION, so
> gfc_expr_attr (e) boils down to:
>
>        if (e->value.function.esym && e->value.function.esym->result)
>         {
>           gfc_symbol *sym = e->value.function.esym->result;
>           attr = sym->attr;
>           if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
>             {
>               attr.dimension = CLASS_DATA (sym)->attr.dimension;
>               attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
>               attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
>             }
>         }
> ...
>        else if (e->symtree)
>         attr = gfc_variable_attr (e, NULL);
>
> So I thought this should already do what you want if you do
>
> gfc_is_ptr_fcn (gfc_expr *e)
> {
>    return e != NULL && e->expr_type == EXPR_FUNCTION && gfc_expr_attr
> (e).pointer;
> }
>
> or what am I missing?  The additional checks in gfc_expr_attr are
> there to avoid ICEs in case CLASS_DATA (sym) has issues, and we all
> know Gerhard who showed that he is an expert in exploiting this.
>
> To sum up, I'd prefer to use the safer form if it works.  If it
> doesn't, I would expect a latent issue.
>
> The rest of the code looked good to me, but I was suspicious about
> the handling of CHARACTER.
>
> Nasty as I am, I modified the testcase to use character(kind=4)
> instead of kind=1 (see attached).  This either fails here (stop 10),
> or if I activate the marked line
>
> !    cont = tContainer('hello!')       ! ### ICE! ###
>
> I get an ICE.
>
> Can you have another look?
>
> Thanks,
> Harald
>
> >
>
> > OK for trunk?
> >
> > Paul
> >
> > Fortran: Enable class expressions in structure constructors [PR49213]
> >
> > 2023-06-24  Paul Thomas  <pault@gcc.gnu.org>
> >
> > gcc/fortran
> > PR fortran/49213
> > * expr.cc (gfc_is_ptr_fcn): Guard pointer attribute to exclude
> > class expressions.
> > * 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



-- 
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein

[-- Attachment #2: pr49213.f90 --]
[-- Type: text/x-fortran, Size: 2252 bytes --]

! { 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

[-- Attachment #3: pr49213.diff --]
[-- Type: text/x-patch, Size: 5560 bytes --]

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 3c209bcde97..b292b5f8995 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -8781,6 +8781,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;
@@ -8815,16 +8816,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_array_index_type, expr2->ts.kind);
+	      size = fold_build2_loc (input_location, MULT_EXPR,
+				      gfc_array_index_type,
+				      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);
@@ -8975,6 +8990,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_
@@ -8990,7 +9006,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);
@@ -9005,7 +9021,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
@@ -9013,6 +9028,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_array_index_type, expr->ts.kind);
+	      size = fold_build2_loc (input_location, MULT_EXPR,
+				      gfc_array_index_type,
+				      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));