diff mbox series

Fortran: Fix same_type_as

Message ID e181c610-f768-ae0a-2a75-2374b79e0d6b@codesourcery.com
State New
Headers
Series Fortran: Fix same_type_as |

Commit Message

Tobias Burnus Sept. 28, 2021, 4:25 p.m. UTC 
  Found when looking at Sandra's c535b-1.f90 and playing around.
When fixing same_type_as, I spotted by code reading another issue,
related to not catering for derived types. (Untested whether it
failed indeed.)

I added now a bunch of testcases.

OK for mainline?

Tobias

-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955

Comments

Tobias Burnus Sept. 29, 2021, 7:48 a.m. UTC | #1 
Early ping ;-)  – but actually I do want to explain some parts of my
patch, what I forgot in my first patch email.

Note that while "class(t)" is of declared type when
unallocated/unassociated, "class(*)" is not. Thus, when
unassociated/unallocated, "same_type_as(class_star, class_star)" is
.false. Code wise, this implies the extra check for class_star._vtab ==
NULL while class_t._vtab is always set and, thus, class._vtab->hash is
always available. (Unchanged in this patch, but probably not obvious
without reading the standard.)

On 28.09.21 18:25, Tobias Burnus wrote:
> -  if (UNLIMITED_POLY (a))
> +  bool unlimited_poly_a = UNLIMITED_POLY (a);
> +  bool unlimited_poly_b = UNLIMITED_POLY (b);
Those variables are needed as we add component refs later, which then
cause UNLIMITED_POLY to evaluate false. UNLIMITED_POLY operates on on
expr->ts – thus, it already caters for derived-type accesses.
> +  if (unlimited_poly_a)
>       {
> -      tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl);
This caused the ICE as backend_decl was NULL. Additionally, it assumes
that the sym and not some component of it is the requested
unlimited-polymorphic object. Without the latter issue, a simple
gfc_get_symbol_decl() around the argument would be sufficient.
> +      se1.want_pointer = 1;
> +      gfc_add_vptr_component (a);

The gfc_add_vptr_component handles expr->ref->type == REF_COMPONENT
properly. As also used for the "else if" branch, DT are handled properly.

I think the rest of the patch is obvious.

Tobias

-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
diff mbox series

Patch

Fortran: Fix same_type_as

A test for CLASS(*) + assumed rank was missing; adding a test to
unlimited_polymorphic_1.f03 showed an ICE as backend_decl wasn't
set. While gfc_get_symbol_decl would fix it, the code also assumed
that the class(*) was a variable and could not be a subobject of
a derived type.

gcc/fortran/ChangeLog:

	* trans-intrinsic.c (gfc_conv_same_type_as): Fix handling
	of UNLIMITED_POLY.
	* trans.h (gfc_vtpr_hash_get): Renamed prototype to ...
	(gfc_vptr_hash_get): ... this to match function name.

gcc/testsuite/ChangeLog:

	* gfortran.dg/c-interop/c535b-1.f90: Remove wrong comment.
	* gfortran.dg/unlimited_polymorphic_1.f03: Extend.
	* gfortran.dg/unlimited_polymorphic_32.f90: New test.

 gcc/fortran/trans-intrinsic.c                      |  42 ++--
 gcc/fortran/trans.h                                |   2 +-
 gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90    |   2 -
 .../gfortran.dg/unlimited_polymorphic_1.f03        |  17 +-
 .../gfortran.dg/unlimited_polymorphic_32.f90       | 254 +++++++++++++++++++++
 5 files changed, 296 insertions(+), 21 deletions(-)

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 900a1a29817..2a2829c9f04 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -9126,21 +9126,14 @@  gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
   a = expr->value.function.actual->expr;
   b = expr->value.function.actual->next->expr;
 
-  if (UNLIMITED_POLY (a))
+  bool unlimited_poly_a = UNLIMITED_POLY (a);
+  bool unlimited_poly_b = UNLIMITED_POLY (b);
+  if (unlimited_poly_a)
     {
-      tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl);
-      conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
-			       tmp, build_int_cst (TREE_TYPE (tmp), 0));
-    }
-
-  if (UNLIMITED_POLY (b))
-    {
-      tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl);
-      condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
-			       tmp, build_int_cst (TREE_TYPE (tmp), 0));
+      se1.want_pointer = 1;
+      gfc_add_vptr_component (a);
     }
-
-  if (a->ts.type == BT_CLASS)
+  else if (a->ts.type == BT_CLASS)
     {
       gfc_add_vptr_component (a);
       gfc_add_hash_component (a);
@@ -9149,7 +9142,12 @@  gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
     a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
 			  a->ts.u.derived->hash_value);
 
-  if (b->ts.type == BT_CLASS)
+  if (unlimited_poly_b)
+    {
+      se2.want_pointer = 1;
+      gfc_add_vptr_component (b);
+    }
+  else if (b->ts.type == BT_CLASS)
     {
       gfc_add_vptr_component (b);
       gfc_add_hash_component (b);
@@ -9161,6 +9159,22 @@  gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
   gfc_conv_expr (&se1, a);
   gfc_conv_expr (&se2, b);
 
+  if (unlimited_poly_a)
+    {
+      conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			       se1.expr,
+			       build_int_cst (TREE_TYPE (se1.expr), 0));
+      se1.expr = gfc_vptr_hash_get (se1.expr);
+    }
+
+  if (unlimited_poly_b)
+    {
+      condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			       se2.expr,
+			       build_int_cst (TREE_TYPE (se2.expr), 0));
+      se2.expr = gfc_vptr_hash_get (se2.expr);
+    }
+
   tmp = fold_build2_loc (input_location, EQ_EXPR,
 			 logical_type_node, se1.expr,
 			 fold_convert (TREE_TYPE (se1.expr), se2.expr));
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 53f0f86b265..fa3e8651b44 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -438,7 +438,7 @@  tree gfc_class_vtab_def_init_get (tree);
 tree gfc_class_vtab_copy_get (tree);
 tree gfc_class_vtab_final_get (tree);
 /* Get an accessor to the vtab's * field, when a vptr handle is present.  */
-tree gfc_vtpr_hash_get (tree);
+tree gfc_vptr_hash_get (tree);
 tree gfc_vptr_size_get (tree);
 tree gfc_vptr_extends_get (tree);
 tree gfc_vptr_def_init_get (tree);
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90
index 3de77b00106..748e027f897 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90
@@ -297,8 +297,6 @@  end function
 ! coshape, lcobound, ucobound: requires CODIMENSION attribute, which is
 !   not permitted on an assumed-rank variable.
 !
-! extends_type_of, same_type_as: require a class argument.
-
 
 ! F2018 additionally permits the first arg to C_SIZEOF to be
 ! assumed-rank (C838).
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03
index afd752242bb..8634031ad81 100644
--- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03
@@ -196,16 +196,25 @@  END MODULE
 
 
 ! Check assumed rank calls
-  call foobar (u3, 0)
-  call foobar (u4, 1)
+  call foobar (u3, 0, is_u3=.true.)
+  call foobar (u4, 1, is_u3=.false.)
 contains
 
-  subroutine foobar (arg, ranki)
+  subroutine foobar (arg, ranki, is_u3)
     class(*) :: arg (..)
     integer :: ranki
+    logical, value :: is_u3
     integer i
     i = rank (arg)
-    if (i .ne. ranki) STOP 1
+    if (i .ne. ranki) STOP 1
+    if (is_u3) then
+      if (EXTENDS_TYPE_OF (arg, obj1) .neqv. .FALSE.) STOP 1
+    else
+      ! arg == u4
+      if (EXTENDS_TYPE_OF (arg, obj1) .neqv. .FALSE.) STOP 1
+    end if
+  !  if (.NOT. SAME_TYPE_AS (arg, u3)) STOP 1
+  !  if (.NOT. SAME_TYPE_AS (arg, u4)) STOP 1
   end subroutine
 
 END
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_32.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_32.f90
new file mode 100644
index 00000000000..df57bcd41cb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_32.f90
@@ -0,0 +1,254 @@ 
+implicit none
+type t2
+  integer :: x
+end type t2
+
+type, extends(t2) :: t2e
+  integer :: y
+end type t2e
+
+type t
+  class(*), allocatable :: au, au2(:,:)
+  class(t2), allocatable :: at, at2(:,:)
+end type t
+
+type(t), target :: var, var0, var2(4), var2a(4)
+class(*), allocatable :: au, au2(:,:)
+class(t2), allocatable :: at, at2(:,:)
+
+
+if (same_type_as (var%au, var%at)) error stop 1
+if (same_type_as (var%au2, var%at)) error stop 2
+if (same_type_as (var%au, var%at)) error stop 3
+! Note: class(*) has no declared type, hence .false.
+if (same_type_as (var%au, var0%au)) error stop 4
+if (same_type_as (var%au2, var0%au2)) error stop 5
+if (same_type_as (var%au, var0%au2)) error stop 6
+call c1(var%au, var%au, var%au2)
+
+if (.not.same_type_as (var%at, var%at)) error stop 7
+if (.not.same_type_as (var%at2, var%at)) error stop 8
+if (.not.same_type_as (var%at, var%at2)) error stop 9
+if (.not.extends_type_of (var%at, var%at)) error stop 10
+if (.not.extends_type_of (var%at2, var%at)) error stop 11
+if (.not.extends_type_of (var%at, var%at2)) error stop 12
+if (same_type_as (var%at, var0%au)) error stop 13
+if (same_type_as (var%at2, var0%au2)) error stop 14
+if (same_type_as (var%at, var0%au2)) error stop 15
+call c2(var%at, var%at, var%at2)
+
+if (same_type_as (au, var%at)) error stop 16
+if (same_type_as (au2, var%at)) error stop 17
+if (same_type_as (au, var%at)) error stop 18
+! Note: class(*) has no declared type, hence .false.
+if (same_type_as (au, var0%au)) error stop 19
+if (same_type_as (au2, var0%au2)) error stop 20
+if (same_type_as (au, var0%au2)) error stop 21
+call c1(au, var%au, var%au2)
+
+if (.not.same_type_as (at, var%at)) error stop 22
+if (.not.same_type_as (at2, var%at)) error stop 23
+if (.not.same_type_as (at, var%at2)) error stop 24
+if (.not.extends_type_of (at, var%at)) error stop 25
+if (.not.extends_type_of (at2, var%at)) error stop 26
+if (.not.extends_type_of (at, var%at2)) error stop 27
+if (same_type_as (at, var0%au)) error stop 28
+if (same_type_as (at2, var0%au2)) error stop 29
+if (same_type_as (at, var0%au2)) error stop 30
+call c2(var%at, var%at, var%at2)
+
+if (same_type_as (var%au, at)) error stop 31
+if (same_type_as (var%au2, at)) error stop 32
+if (same_type_as (var%au, at)) error stop 33
+! Note: class(*) has no declared type, hence .false.
+if (same_type_as (var%au, au)) error stop 34
+if (same_type_as (var%au2, au2)) error stop 35
+if (same_type_as (var%au, au2)) error stop 36
+call c1(var%au, var%au, au2)
+
+if (.not.same_type_as (var%at, at)) error stop 37
+if (.not.same_type_as (var%at2, at)) error stop 38
+if (.not.same_type_as (var%at, at2)) error stop 39
+if (.not.extends_type_of (var%at, at)) error stop 40
+if (.not.extends_type_of (var%at2, at)) error stop 41
+if (.not.extends_type_of (var%at, at2)) error stop 42
+if (same_type_as (var%at, au)) error stop 43
+if (same_type_as (var%at2, au2)) error stop 44
+if (same_type_as (var%at, au2)) error stop 45
+call c2(var%at, var%at, at2)
+
+allocate(t2e :: var0%at, var0%at2(4,4))
+allocate(t2 :: var0%au, var0%au2(4,4))
+
+if (.not.same_type_as (var0%au, var%at)) error stop 46
+if (.not.same_type_as (var0%au2, var%at)) error stop 47
+if (.not.same_type_as (var0%au, var%at)) error stop 48
+if (.not.same_type_as (var0%au, var0%au2)) error stop 49
+if (.not.same_type_as (var0%au2, var0%au2)) error stop 50
+if (.not.same_type_as (var0%au, var0%au2)) error stop 51
+if (.not.extends_type_of (var0%au, var%at)) error stop 52
+if (.not.extends_type_of (var0%au2, var%at)) error stop 53
+if (.not.extends_type_of (var0%au, var%at)) error stop 54
+if (.not.extends_type_of (var0%au, var0%au2)) error stop 55
+if (.not.extends_type_of (var0%au2, var0%au2)) error stop 56
+if (.not.extends_type_of (var0%au, var0%au2)) error stop 57
+
+if (.not.same_type_as (var0%au, at)) error stop 58
+if (.not.same_type_as (var0%au2, at)) error stop 59
+if (.not.same_type_as (var0%au, at2)) error stop 60
+if (.not.extends_type_of (var0%au, at)) error stop 61
+if (.not.extends_type_of (var0%au2, at)) error stop 62
+if (.not.extends_type_of (var0%au, at2)) error stop 63
+
+if (same_type_as (var0%at, var%at)) error stop 64
+if (same_type_as (var0%at2, var%at)) error stop 65
+if (same_type_as (var0%at, var%at)) error stop 66
+if (same_type_as (var0%at, var0%au2)) error stop 67
+if (same_type_as (var0%at2, var0%au2)) error stop 68
+if (same_type_as (var0%at, var0%au2)) error stop 69
+if (.not.extends_type_of (var0%at, var%at)) error stop 70
+if (.not.extends_type_of (var0%at2, var%at)) error stop 71
+if (.not.extends_type_of (var0%at, var%at)) error stop 72
+if (.not.extends_type_of (var0%at, var0%au2)) error stop 73
+if (.not.extends_type_of (var0%at2, var0%au2)) error stop 74
+if (.not.extends_type_of (var0%at, var0%au2)) error stop 75
+
+if (same_type_as (var0%at, at)) error stop 76
+if (same_type_as (var0%at2, at)) error stop 77
+if (same_type_as (var0%at, at2)) error stop 78
+if (.not.extends_type_of (var0%at, at)) error stop 79
+if (.not.extends_type_of (var0%at2, at)) error stop 80
+if (.not.extends_type_of (var0%at, at2)) error stop 81
+
+call c3(var0%au, var0%au2, var0%at, var0%at2)
+call c4(var0%au, var0%au2, var0%at, var0%at2)
+
+contains
+  subroutine c1(x, y, z)
+    class(*) :: x, y(..), z(..)
+    if (same_type_as (x, var0%at)) error stop 82
+    if (same_type_as (y, var0%at)) error stop 83
+    if (same_type_as (z, var0%at)) error stop 84
+    if (same_type_as (x, var%au)) error stop 85
+    if (same_type_as (y, var%au2)) error stop 86
+    if (same_type_as (z, var%au2)) error stop 87
+
+    if (same_type_as (x, at)) error stop 88
+    if (same_type_as (y, at)) error stop 89
+    if (same_type_as (z, at)) error stop 90
+    if (same_type_as (x, au)) error stop 91
+    if (same_type_as (y, au2)) error stop 92
+    if (same_type_as (z, au2)) error stop 93
+  end
+
+  subroutine c2(x, y, z)
+    class(*) :: x, y(..), z(..)
+    if (.not.same_type_as (x, var0%at)) error stop 94
+    if (.not.same_type_as (y, var0%at)) error stop 95
+    if (.not.same_type_as (z, var0%at)) error stop 96
+    if (.not.extends_type_of (x, var0%at)) error stop 97
+    if (.not.extends_type_of (y, var0%at)) error stop 98
+    if (.not.extends_type_of (z, var0%at)) error stop 99
+    if (same_type_as (x, var%au)) error stop 100
+    if (same_type_as (y, var%au2)) error stop 101
+    if (same_type_as (z, var%au2)) error stop 102
+
+    if (.not.same_type_as (x, at)) error stop 103
+    if (.not.same_type_as (y, at)) error stop 104
+    if (.not.same_type_as (z, at)) error stop 105
+    if (.not.extends_type_of (x, at)) error stop 106
+    if (.not.extends_type_of (y, at)) error stop 107
+    if (.not.extends_type_of (z, at)) error stop 108
+    if (same_type_as (x, au)) error stop 109
+    if (same_type_as (y, au2)) error stop 110
+    if (same_type_as (z, au2)) error stop 111
+  end
+
+  subroutine c3(mau, mau2, mat, mat2)
+    class(*) :: mau, mau2(:,:), mat, mat2(:,:)
+
+    if (.not.same_type_as (mau, var%at)) error stop 112
+    if (.not.same_type_as (mau2, var%at)) error stop 113
+    if (.not.same_type_as (mau, var%at)) error stop 114
+    if (.not.same_type_as (mau, var0%au2)) error stop 115
+    if (.not.same_type_as (mau2, var0%au2)) error stop 116
+    if (.not.same_type_as (mau, var0%au2)) error stop 117
+    if (.not.extends_type_of (mau, var%at)) error stop 118
+    if (.not.extends_type_of (mau2, var%at)) error stop 119
+    if (.not.extends_type_of (mau, var%at)) error stop 120
+    if (.not.extends_type_of (mau, var0%au2)) error stop 121
+    if (.not.extends_type_of (mau2, var0%au2)) error stop 122
+    if (.not.extends_type_of (mau, var0%au2)) error stop 123
+
+    if (.not.same_type_as (mau, at)) error stop 124
+    if (.not.same_type_as (mau2, at)) error stop 125
+    if (.not.same_type_as (mau, at2)) error stop 126
+    if (.not.extends_type_of (mau, at)) error stop 127
+    if (.not.extends_type_of (mau2, at)) error stop 128
+    if (.not.extends_type_of (mau, at2)) error stop 129
+
+    if (same_type_as (mat, var%at)) error stop 130
+    if (same_type_as (mat2, var%at)) error stop 131
+    if (same_type_as (mat, var%at)) error stop 132
+    if (same_type_as (mat, var0%au2)) error stop 133
+    if (same_type_as (mat2, var0%au2)) error stop 134
+    if (same_type_as (mat, var0%au2)) error stop 135
+    if (.not.extends_type_of (mat, var%at)) error stop 136
+    if (.not.extends_type_of (mat2, var%at)) error stop 137
+    if (.not.extends_type_of (mat, var%at)) error stop 138
+    if (.not.extends_type_of (mat, var0%au2)) error stop 139
+    if (.not.extends_type_of (mat2, var0%au2)) error stop 140
+    if (.not.extends_type_of (mat, var0%au2)) error stop 141
+
+    if (same_type_as (mat, at)) error stop 142
+    if (same_type_as (mat2, at)) error stop 143
+    if (same_type_as (mat, at2)) error stop 144
+    if (.not.extends_type_of (mat, at)) error stop 145
+    if (.not.extends_type_of (mat2, at)) error stop 147
+    if (.not.extends_type_of (mat, at2)) error stop 148
+  end
+
+  subroutine c4(mau, mau2, mat, mat2)
+    class(*) :: mau(..), mau2(..), mat(..), mat2(..)
+
+    if (.not.same_type_as (mau, var%at)) error stop 149
+    if (.not.same_type_as (mau2, var%at)) error stop 150
+    if (.not.same_type_as (mau, var%at)) error stop 151
+    if (.not.same_type_as (mau, var0%au2)) error stop 152
+    if (.not.same_type_as (mau2, var0%au2)) error stop 153
+    if (.not.same_type_as (mau, var0%au2)) error stop 154
+    if (.not.extends_type_of (mau, var%at)) error stop 155
+    if (.not.extends_type_of (mau2, var%at)) error stop 156
+    if (.not.extends_type_of (mau, var%at)) error stop 157
+    if (.not.extends_type_of (mau, var0%au2)) error stop 158
+    if (.not.extends_type_of (mau2, var0%au2)) error stop 159
+    if (.not.extends_type_of (mau, var0%au2)) error stop 160
+
+    if (.not.same_type_as (mau, at)) error stop 161
+    if (.not.same_type_as (mau2, at)) error stop 162
+    if (.not.same_type_as (mau, at2)) error stop 163
+    if (.not.extends_type_of (mau, at)) error stop 164
+    if (.not.extends_type_of (mau2, at)) error stop 165
+    if (.not.extends_type_of (mau, at2)) error stop 166
+
+    if (same_type_as (mat, var%at)) error stop 167
+    if (same_type_as (mat2, var%at)) error stop 168
+    if (same_type_as (mat, var%at)) error stop 169
+    if (same_type_as (mat, var0%au2)) error stop 170
+    if (same_type_as (mat2, var0%au2)) error stop 171
+    if (same_type_as (mat, var0%au2)) error stop 172
+    if (.not.extends_type_of (mat, var%at)) error stop 173
+    if (.not.extends_type_of (mat2, var%at)) error stop 174
+    if (.not.extends_type_of (mat, var%at)) error stop 175
+    if (.not.extends_type_of (mat, var0%au2)) error stop 176
+    if (.not.extends_type_of (mat2, var0%au2)) error stop 178
+    if (.not.extends_type_of (mat, var0%au2)) error stop 179
+
+    if (same_type_as (mat, at)) error stop 180
+    if (same_type_as (mat2, at)) error stop 181
+    if (same_type_as (mat, at2)) error stop 182
+    if (.not.extends_type_of (mat, at)) error stop 183
+    if (.not.extends_type_of (mat2, at)) error stop 184
+    if (.not.extends_type_of (mat, at2)) error stop 185
+  end
+end