re PR libfortran/80850 (Sourced allocate() fails to allocate a pointer)

2017-10-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/80850
	* trans_expr.c (gfc_conv_procedure_call): When passing a class
	argument to an unlimited polymorphic dummy, it is wrong to cast
	the passed expression as unlimited, unless it is unlimited. The
	correct way is to assign to each of the fields and set the _len
	field to zero.

2017-10-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/80850
	* gfortran.dg/class_64_f90 : New test.

From-SVN: r254244

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0d4a873437e826756a3bfc890994429c07779caa..99f96dd159a256795f89ac5057500b3841705a40 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,6 +1,15 @@
+2017-10-30  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/80850
+       * trans_expr.c (gfc_conv_procedure_call): When passing a class
+       argument to an unlimited polymorphic dummy, it is wrong to cast
+       the passed expression as unlimited, unless it is unlimited. The
+       correct way is to assign to each of the fields and set the _len
+       field to zero.
+
 2017-10-30  Steven G. Kargl   <kargl@gcc.gnu.org>
 
-       * resolve.c (resolve_transfer): Set derived to correct symbol for 
+       * resolve.c (resolve_transfer): Set derived to correct symbol for
        BT_CLASS.
 
 2017-10-29  Jim Wilson  <wilson@tuliptree.org>

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 71ec176eac864f8b5e10679dbfe2bfb8c0b07e25..1a3e3d45e4cf389c8d8bb1148540b705fc16faf2 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5173,10 +5173,39 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                        }
                      else
                        {
-                         gfc_add_modify (&parmse.pre, var,
-                                         fold_build1_loc (input_location,
-                                                          VIEW_CONVERT_EXPR,
-                                                          type, parmse.expr));
+                         /* Since the internal representation of unlimited
+                            polymorphic expressions includes an extra field
+                            that other class objects do not, a cast to the
+                            formal type does not work.  */
+                         if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
+                           {
+                             tree efield;
+
+                             /* Set the _data field.  */
+                             tmp = gfc_class_data_get (var);
+                             efield = fold_convert (TREE_TYPE (tmp),
+                                       gfc_class_data_get (parmse.expr));
+                             gfc_add_modify (&parmse.pre, tmp, efield);
+
+                             /* Set the _vptr field.  */
+                             tmp = gfc_class_vptr_get (var);
+                             efield = fold_convert (TREE_TYPE (tmp),
+                                       gfc_class_vptr_get (parmse.expr));
+                             gfc_add_modify (&parmse.pre, tmp, efield);
+
+                             /* Set the _len field.  */
+                             tmp = gfc_class_len_get (var);
+                             gfc_add_modify (&parmse.pre, tmp,
+                                             build_int_cst (TREE_TYPE (tmp), 0));
+                           }
+                         else
+                           {
+                             tmp = fold_build1_loc (input_location,
+                                                    VIEW_CONVERT_EXPR,
+                                                    type, parmse.expr);
+                             gfc_add_modify (&parmse.pre, var, tmp);
+                                             ;
+                           }
                          parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
                        }
                    }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7b1bf85ab7616d7ff741a59412b40c95fa2e5b7e..e17c94dc5353ac9a8255782db6d8b341ffeee6a6 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2017-10-30  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/80850
+       * gfortran.dg/class_64_f90 : New test.
+
 2017-10-30  Uros Bizjak  <ubizjak@gmail.com>
 
        * g++.dg/pr82725.C: Move to ...

diff --git a/gcc/testsuite/gfortran.dg/class_64.f90 b/gcc/testsuite/gfortran.dg/class_64.f90
new file mode 100644 (file)
index 0000000..059ebaa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_64.f90
@@ -0,0 +1,38 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR80850 in which the _len field was not being
+! set for 'arg' in the call to 'foo'.
+!
+  type :: mytype
+    integer :: i
+  end type
+  class (mytype), pointer :: c
+
+  allocate (c, source = mytype (99_8))
+
+  call foo(c)
+  call bar(c)
+
+  deallocate (c)
+
+contains
+
+  subroutine foo (arg)
+    class(*) :: arg
+    select type (arg)
+      type is (mytype)
+        if (arg%i .ne. 99_8) call abort
+    end select
+  end subroutine
+
+  subroutine bar (arg)
+    class(mytype) :: arg
+    select type (arg)
+      type is (mytype)
+        if (arg%i .ne. 99_8) call abort
+    end select
+  end subroutine
+
+end
+! { dg-final { scan-tree-dump-times "arg.*._len" 1 "original" } }