[Bug fortran/54618] [OOP] wrong-code with CLASS(...), INTENT(OUT) -- and OPTIONAL or ALLOCATABLE

["burnus at gcc dot gnu.org" <gcc-bugzilla at gcc dot gnu dot org>]

http://gcc.gnu.org/bugzilla/show_bug.cgi?id=54618

--- Comment #3 from Tobias Burnus <burnus at gcc dot gnu.org> 2012-09-19 17:31:06 UTC ---
There seem to be other issues with OPTIONAL as well. The following code prints
twice 'T' when it should print 'F' and it segfaults for one version.
I haven't dared to combine it with INTENT(OUT) and/or ALLOCATABLE.

The following program gives the same result with 4.7 as with 4.8 + my patch:

  type t
  end type t
  type(t) :: y, y2(2)
  class(t), allocatable :: z, z2(:)
  allocate (t :: z)
  allocate (t :: z2(2))
!print *, 'Scalars, expected: F F T T T T'
  call s1()   ! OK
  call s1a()  ! -> should print 'F', prints 'T'
  call s1(y)  ! OK
  call s1a(y) ! OK
  call s1(z)  ! OK
  call s1a(z) ! OK
!print *, 'Arrays, expected: F F T T T T'
!  call sa1()   ! Segfault
  call sa1a()   ! -> should print 'F', prints 'T'
  call sa1(y2)  ! OK
  call sa1a(y2) ! OK
  call sa1(z2)  ! OK
  call sa1a(z2) ! OK
contains
 subroutine s1(x)
   class(t), optional :: x
   call s2(x)
 end subroutine s1
 subroutine s1a(x)
   type(t), optional :: x
   call s2(x)
 end subroutine s1a
 subroutine s2(x)
   class(t), optional :: x
   print *, present(x)
 end subroutine s2

 subroutine sa1(x)
   class(t), optional :: x(:)
   call sa2(x)
 end subroutine sa1
 subroutine sa1a(x)
   type(t), optional :: x(:)
   call sa2(x)
 end subroutine sa1a
 subroutine sa2(x)
   class(t), optional :: x(:)
   print *, present(x)
 end subroutine sa2
end

 * * *

The missing bits for the patch in comment 2 are fixable as follows, which
completes the scalar version of the second issue.

--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3923,2 +3940,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,

+                     if (fsym->ts.type == BT_CLASS)
+                       {
+                         gfc_symbol *vtab;
+                         gcc_assert (fsym->ts.u.derived == e->ts.u.derived);
+                         vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
+                         tmp = gfc_get_symbol_decl (vtab);
+                         tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+                         ptr = gfc_class_vptr_get (parmse.expr);
+                         gfc_add_modify (&block, ptr,
+                                         fold_convert (TREE_TYPE (ptr), tmp));
+                         gfc_add_expr_to_block (&block, tmp);
+                       }
+
                      if (fsym->attr.optional