re PR fortran/65548 (gfc_conv_procedure_call)

	PR fortran/65548
        * gfortran.dg/allocate_with_source_5.f90: New test.

        * trans-stmt.c (gfc_trans_allocate): For intrinsic functions
        use conv_expr_descriptor() instead of conv_expr_reference().

From-SVN: r221897

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7bba9d402d63ff0186e8db80dbfa1287a4b9b05e..f7b1d38d654143b38cc25606f5f7def317cf7483 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2015-04-07  Andre Vehreschild  <vehre@gmx.de>
+
+       PR fortran/65548
+       * trans-stmt.c (gfc_trans_allocate): For intrinsic functions
+       use conv_expr_descriptor() instead of conv_expr_reference().
+
 2015-03-30  Jakub Jelinek  <jakub@redhat.com>
 
        PR fortran/65597

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a6fb52c51e19b67f1ad3009905da8e411163e017..619564b6ef9d9092d9b981720d17a986abef3c14 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5049,12 +5049,17 @@ gfc_trans_allocate (gfc_code * code)
              /* In all other cases evaluate the expr3 and create a
                 temporary.  */
              gfc_init_se (&se, NULL);
-             gfc_conv_expr_reference (&se, code->expr3);
+             if (code->expr3->rank != 0
+                 && code->expr3->expr_type == EXPR_FUNCTION
+                 && code->expr3->value.function.isym)
+               gfc_conv_expr_descriptor (&se, code->expr3);
+             else
+               gfc_conv_expr_reference (&se, code->expr3);
              if (code->expr3->ts.type == BT_CLASS)
                gfc_conv_class_to_class (&se, code->expr3,
                                         code->expr3->ts,
                                         false, true,
-                                         false,false);
+                                        false, false);
              gfc_add_block_to_block (&block, &se.pre);
              gfc_add_block_to_block (&post, &se.post);
              /* Prevent aliasing, i.e., se.expr may be already a

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a51b9c56abb74d34dd5669c0e1bb487c731b7427..34d12535e0285b5fa7b5e9fb4cded8221ec053ee 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2015-04-07  Andre Vehreschild  <vehre@gmx.de>
+
+       PR fortran/65548
+       * gfortran.dg/allocate_with_source_5.f90: New test.
+
 2015-04-07  Ilya Enkovich  <ilya.enkovich@intel.com>
 
        * gcc.target/i386/mpx/chkp-thunk-comdat-1.cc: New.

diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
new file mode 100644 (file)
index 0000000..e934e08
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
@@ -0,0 +1,52 @@
+! { dg-do run }
+!
+! Check that pr65548 is fixed.
+! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
+
+module allocate_with_source_5_module
+
+  type :: selector_t
+    integer, dimension(:), allocatable :: map
+    real, dimension(:), allocatable :: weight
+  contains
+    procedure :: init => selector_init
+  end type selector_t
+
+contains
+
+  subroutine selector_init (selector, weight)
+    class(selector_t), intent(out) :: selector
+    real, dimension(:), intent(in) :: weight
+    real :: s
+    integer :: n, i
+    logical, dimension(:), allocatable :: mask
+    s = sum (weight)
+    allocate (mask (size (weight)), source = weight /= 0)
+    n = count (mask)
+    if (n > 0) then
+       allocate (selector%map (n), &
+            source = pack ([(i, i = 1, size (weight))], mask))
+       allocate (selector%weight (n), &
+            source = pack (weight / s, mask))
+    else
+       allocate (selector%map (1), source = 1)
+       allocate (selector%weight (1), source = 0.)
+    end if
+  end subroutine selector_init
+
+end module allocate_with_source_5_module
+
+program allocate_with_source_5
+  use allocate_with_source_5_module
+
+  class(selector_t), allocatable :: sel;
+  real, dimension(5) :: w = [ 1, 0, 2, 0, 3];
+
+  allocate (sel)
+  call sel%init(w)
+
+  if (any(sel%map /= [ 1, 3, 5])) call abort()
+  if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort()
+end program allocate_with_source_5
+! { dg-final { cleanup-modules "allocate_with_source_5_module" } }
+