re PR fortran/50981 ([OOP] Wrong-code for scalarizing ELEMENTAL call with absent OPTIONAL argument)

2012-10-16  Tobias Burnus  <burnus@net-b.de>

        PR fortran/50981
        PR fortran/54618
        * trans.h (gfc_conv_derived_to_class, gfc_conv_class_to_class):
        Update prototype.
        * trans-stmt.c (trans_associate_var,gfc_trans_allocate): Update
        calls to those functions.
        * trans-expr.c (gfc_conv_derived_to_class,
        * gfc_conv_class_to_class,
        gfc_conv_expr_present): Handle absent polymorphic arguments.
        (class_scalar_coarray_to_class): New function.
        (gfc_conv_procedure_call): Update calls.

2012-10-16  Tobias Burnus  <burnus@net-b.de>

        PR fortran/50981
        PR fortran/54618
        * gfortran.dg/class_optional_1.f90: New.
        * gfortran.dg/class_optional_2.f90: New.

From-SVN: r192495

gcc/fortran/ChangeLog

+2012-10-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50981
+	PR fortran/54618
+	* trans.h (gfc_conv_derived_to_class, gfc_conv_class_to_class):
+	Update prototype.
+	* trans-stmt.c (trans_associate_var,gfc_trans_allocate): Update
+	calls to those functions.
+	* trans-expr.c (gfc_conv_derived_to_class, gfc_conv_class_to_class,
+	gfc_conv_expr_present): Handle absent polymorphic arguments.
+	(class_scalar_coarray_to_class): New function.
+	(gfc_conv_procedure_call): Update calls.
+
 2012-10-12  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/40453

gcc/fortran/trans-stmt.c

@@ -1228,7 +1228,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  gfc_conv_expr_descriptor (&se, e);
 
 	  /* Obtain a temporary class container for the result.  */ 
-	  gfc_conv_class_to_class (&se, e, sym->ts, false);
+	  gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 
 	  /* Set the offset.  */
@@ -1255,7 +1255,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  /* Get the _vptr component of the class object.  */ 
 	  tmp = gfc_get_vptr_from_expr (se.expr);
 	  /* Obtain a temporary class container for the result.  */
-	  gfc_conv_derived_to_class (&se, e, sym->ts, tmp);
+	  gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
 	  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 	}
       else
@@ -4874,7 +4874,7 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_init_se (&se_sz, NULL);
 	  gfc_conv_expr_reference (&se_sz, code->expr3);
 	  gfc_conv_class_to_class (&se_sz, code->expr3,
-				   code->expr3->ts, false);
+				   code->expr3->ts, false, true, false, false);
 	  gfc_add_block_to_block (&se.pre, &se_sz.pre);
 	  gfc_add_block_to_block (&se.post, &se_sz.post);
 	  classexpr = build_fold_indirect_ref_loc (input_location,

gcc/fortran/trans.h

@@ -351,8 +351,10 @@ tree gfc_vtable_copy_get (tree);
 tree gfc_get_vptr_from_expr (tree);
 tree gfc_get_class_array_ref (tree, tree);
 tree gfc_copy_class_to_class (tree, tree, tree);
-void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree);
-void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool);
+void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
+				bool);
+void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
+			      bool, bool);
 
 /* Initialize an init/cleanup block.  */
 void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);

gcc/testsuite/ChangeLog

+2012-10-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/50981
+	PR fortran/54618
+	* gfortran.dg/class_optional_1.f90: New.
+	* gfortran.dg/class_optional_2.f90: New.
+
 2012-10-16  Jakub Jelinek  <jakub@redhat.com>
 
 	PR debug/54796

gcc/testsuite/gfortran.dg/class_optional_1.f90

+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/50981
+! PR fortran/54618
+!
+
+  implicit none
+  type t
+   integer, allocatable :: i
+  end type t
+  type, extends (t):: t2
+   integer, allocatable :: j
+  end type t2
+
+  class(t), allocatable :: xa, xa2(:), xac[:], xa2c(:)[:]
+  class(t), pointer :: xp, xp2(:)
+
+  xp => null()
+  xp2 => null()
+
+  call suba(alloc=.false., prsnt=.false.)
+  call suba(xa, alloc=.false., prsnt=.true.)
+  if (.not. allocated (xa)) call abort ()
+  if (.not. allocated (xa%i)) call abort ()
+  if (xa%i /= 5) call abort ()
+  xa%i = -3
+  call suba(xa, alloc=.true., prsnt=.true.)
+  if (allocated (xa)) call abort ()
+
+  call suba2(alloc=.false., prsnt=.false.)
+  call suba2(xa2, alloc=.false., prsnt=.true.)
+  if (.not. allocated (xa2)) call abort ()
+  if (size (xa2) /= 1) call abort ()
+  if (.not. allocated (xa2(1)%i)) call abort ()
+  if (xa2(1)%i /= 5) call abort ()
+  xa2(1)%i = -3
+  call suba2(xa2, alloc=.true., prsnt=.true.)
+  if (allocated (xa2)) call abort ()
+
+  call subp(alloc=.false., prsnt=.false.)
+  call subp(xp, alloc=.false., prsnt=.true.)
+  if (.not. associated (xp)) call abort ()
+  if (.not. allocated (xp%i)) call abort ()
+  if (xp%i /= 5) call abort ()
+  xp%i = -3
+  call subp(xp, alloc=.true., prsnt=.true.)
+  if (associated (xp)) call abort ()
+
+  call subp2(alloc=.false., prsnt=.false.)
+  call subp2(xp2, alloc=.false., prsnt=.true.)
+  if (.not. associated (xp2)) call abort ()
+  if (size (xp2) /= 1) call abort ()
+  if (.not. allocated (xp2(1)%i)) call abort ()
+  if (xp2(1)%i /= 5) call abort ()
+  xp2(1)%i = -3
+  call subp2(xp2, alloc=.true., prsnt=.true.)
+  if (associated (xp2)) call abort ()
+
+  call subac(alloc=.false., prsnt=.false.)
+  call subac(xac, alloc=.false., prsnt=.true.)
+  if (.not. allocated (xac)) call abort ()
+  if (.not. allocated (xac%i)) call abort ()
+  if (xac%i /= 5) call abort ()
+  xac%i = -3
+  call subac(xac, alloc=.true., prsnt=.true.)
+  if (allocated (xac)) call abort ()
+
+  call suba2c(alloc=.false., prsnt=.false.)
+  call suba2c(xa2c, alloc=.false., prsnt=.true.)
+  if (.not. allocated (xa2c)) call abort ()
+  if (size (xa2c) /= 1) call abort ()
+  if (.not. allocated (xa2c(1)%i)) call abort ()
+  if (xa2c(1)%i /= 5) call abort ()
+  xa2c(1)%i = -3
+  call suba2c(xa2c, alloc=.true., prsnt=.true.)
+  if (allocated (xa2c)) call abort ()
+
+contains
+ subroutine suba2c(x, prsnt, alloc)
+   class(t), optional, allocatable :: x(:)[:]
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (prsnt) then
+     if (alloc .neqv. allocated(x)) call abort ()
+     if (.not. allocated (x)) then
+       allocate (x(1)[*])
+       x(1)%i = 5
+     else
+       if (x(1)%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine suba2c
+
+ subroutine subac(x, prsnt, alloc)
+   class(t), optional, allocatable :: x[:]
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (present (x)) then
+     if (alloc .neqv. allocated(x)) call abort ()
+     if (.not. allocated (x)) then
+       allocate (x[*])
+       x%i = 5
+     else
+       if (x%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine subac
+
+ subroutine suba2(x, prsnt, alloc)
+   class(t), optional, allocatable :: x(:)
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (prsnt) then
+     if (alloc .neqv. allocated(x)) call abort ()
+     if (.not. allocated (x)) then
+       allocate (x(1))
+       x(1)%i = 5
+     else
+       if (x(1)%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine suba2
+
+ subroutine suba(x, prsnt, alloc)
+   class(t), optional, allocatable :: x
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (present (x)) then
+     if (alloc .neqv. allocated(x)) call abort ()
+     if (.not. allocated (x)) then
+       allocate (x)
+       x%i = 5
+     else
+       if (x%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine suba
+
+ subroutine subp2(x, prsnt, alloc)
+   class(t), optional, pointer :: x(:)
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (present (x)) then
+     if (alloc .neqv. associated(x)) call abort ()
+     if (.not. associated (x)) then
+       allocate (x(1))
+       x(1)%i = 5
+     else
+       if (x(1)%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine subp2
+
+ subroutine subp(x, prsnt, alloc)
+   class(t), optional, pointer :: x
+   logical prsnt, alloc
+   if (present (x) .neqv. prsnt) call abort ()
+   if (present (x)) then
+     if (alloc .neqv. associated(x)) call abort ()
+     if (.not. associated (x)) then
+       allocate (x)
+       x%i = 5
+     else
+       if (x%i /= -3) call abort()
+       deallocate (x)
+     end if
+   end if
+ end subroutine subp
+end