re PR fortran/55763 (Issues with some simpler CLASS(*) programs)

2012-12-28  Tobias Burnus  <burnus@net-b.de>

        PR fortran/55763
        * check.c (gfc_check_move_alloc): Handle unlimited polymorphic.
        * trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.

2012-12-28  Tobias Burnus  <burnus@net-b.de>

        PR fortran/55763
        * gfortran.dg/unlimited_polymorphic_5.f90

From-SVN: r194743

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a8d6a21..d04897e 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2012-12-28  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/55763
+       * check.c (gfc_check_move_alloc): Handle unlimited polymorphic.
+       * trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.
+
 2012-12-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR fortran/48976

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 793ad75..0923f12 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2791,18 +2791,15 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
       return FAILURE;
     }
 
-  if (to->ts.kind != from->ts.kind)
+  /* CLASS arguments: Make sure the vtab of from is present.  */
+  if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
     {
-      gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L"
-                " must be of the same kind %d/%d", &to->where, from->ts.kind,
-                to->ts.kind);
-      return FAILURE;
+      if (from->ts.type == BT_CLASS || from->ts.type == BT_DERIVED)
+       gfc_find_derived_vtab (from->ts.u.derived);
+      else
+       gfc_find_intrinsic_vtab (&from->ts);
     }
 
-  /* CLASS arguments: Make sure the vtab of from is present.  */
-  if (to->ts.type == BT_CLASS)
-    gfc_find_derived_vtab (from->ts.u.derived);
-
   return SUCCESS;
 }
 

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index b9d13cc..5a89be1 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7373,8 +7373,13 @@ conv_intrinsic_move_alloc (gfc_code *code)
 
          if (from_expr->ts.type == BT_CLASS)
            {
-             vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
-             gcc_assert (vtab);
+             if (UNLIMITED_POLY (from_expr))
+               vtab = NULL;
+             else
+               {
+                 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+                 gcc_assert (vtab);
+               }
 
              gfc_free_expr (from_expr2);
              gfc_init_se (&from_se, NULL);
@@ -7386,13 +7391,23 @@ conv_intrinsic_move_alloc (gfc_code *code)
                                  from_se.expr));
 
               /* Reset _vptr component to declared type.  */
-             tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
-             gfc_add_modify_loc (input_location, &block, from_se.expr,
-                                 fold_convert (TREE_TYPE (from_se.expr), tmp));
+             if (UNLIMITED_POLY (from_expr))
+               gfc_add_modify_loc (input_location, &block, from_se.expr,
+                                   fold_convert (TREE_TYPE (from_se.expr),
+                                                 null_pointer_node));
+             else
+               {
+                 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+                 gfc_add_modify_loc (input_location, &block, from_se.expr,
+                                     fold_convert (TREE_TYPE (from_se.expr), tmp));
+               }
            }
          else
            {
-             vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+             if (from_expr->ts.type != BT_DERIVED)
+               vtab = gfc_find_intrinsic_vtab (&from_expr->ts);
+             else
+               vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
              gcc_assert (vtab);
              tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
              gfc_add_modify_loc (input_location, &block, to_se.expr,
@@ -7415,8 +7430,13 @@ conv_intrinsic_move_alloc (gfc_code *code)
 
       if (from_expr->ts.type == BT_CLASS)
        {
-         vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
-         gcc_assert (vtab);
+         if (UNLIMITED_POLY (from_expr))
+           vtab = NULL;
+         else
+           {
+             vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+             gcc_assert (vtab);
+           }
 
          from_se.want_pointer = 1;
          from_expr2 = gfc_copy_expr (from_expr);
@@ -7427,13 +7447,23 @@ conv_intrinsic_move_alloc (gfc_code *code)
                              from_se.expr));
 
          /* Reset _vptr component to declared type.  */
-         tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
-         gfc_add_modify_loc (input_location, &block, from_se.expr,
-                             fold_convert (TREE_TYPE (from_se.expr), tmp));
+         if (UNLIMITED_POLY (from_expr))
+           gfc_add_modify_loc (input_location, &block, from_se.expr,
+                               fold_convert (TREE_TYPE (from_se.expr),
+                                             null_pointer_node));
+         else
+           {
+             tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+             gfc_add_modify_loc (input_location, &block, from_se.expr,
+                                 fold_convert (TREE_TYPE (from_se.expr), tmp));
+           }
        }
       else
        {
-         vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+         if (from_expr->ts.type != BT_DERIVED)
+           vtab = gfc_find_intrinsic_vtab (&from_expr->ts);
+         else
+           vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
          gcc_assert (vtab);
          tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
          gfc_add_modify_loc (input_location, &block, to_se.expr,

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ffe56e9..38935dc 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2012-12-28  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/55763
+       * gfortran.dg/unlimited_polymorphic_5.f90
+
 2012-12-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR fortran/48960

diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_5.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_5.f90
new file mode 100644 (file)
index 0000000..12a3c4a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_5.f90
@@ -0,0 +1,41 @@
+! { dg-do run }
+!
+! PR fortran/55763
+!
+! Based on Reinhold Bader's test case
+!
+
+program mvall_03
+  implicit none
+  integer, parameter :: n1 = 100, n2 = 200
+  class(*), allocatable :: i1(:), i3(:)
+  integer, allocatable :: i2(:)
+
+  allocate(real :: i1(n1))
+  allocate(i2(n2))
+  i2 = 2
+  call move_alloc(i2, i1)
+  if (size(i1) /= n2 .or. allocated(i2)) then
+    call abort
+!   write(*,*) 'FAIL'
+  else
+!    write(*,*) 'OK'
+  end if
+
+  select type (i1)
+    type is (integer)
+      if (any (i1 /= 2)) call abort
+    class default
+      call abort()
+  end select
+  call move_alloc (i1, i3)
+  if (size(i3) /= n2 .or. allocated(i1)) then
+    call abort()
+  end if
+  select type (i3)
+    type is (integer)
+      if (any (i3 /= 2)) call abort
+    class default
+      call abort()
+  end select
+end program