public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc/devel/omp/gcc-11] Fortran: Fix same_type_as
@ 2021-09-30 17:27 Tobias Burnus
0 siblings, 0 replies; only message in thread
From: Tobias Burnus @ 2021-09-30 17:27 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:1eb2dc0062e2d5821b35bd8babca1a74ca111626
commit 1eb2dc0062e2d5821b35bd8babca1a74ca111626
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Thu Sep 30 19:23:41 2021 +0200
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.
PR fortran/71703
PR fortran/84007
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.
(cherry picked from commit 643e8f4ee3a2a59a9b96fbcd1ffa8bacbda5b383)
Diff:
---
gcc/fortran/ChangeLog.omp | 12 +
gcc/fortran/trans-intrinsic.c | 42 ++--
gcc/fortran/trans.h | 2 +-
gcc/testsuite/ChangeLog.omp | 11 +
gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90 | 2 -
.../gfortran.dg/unlimited_polymorphic_1.f03 | 17 +-
.../gfortran.dg/unlimited_polymorphic_32.f90 | 254 +++++++++++++++++++++
7 files changed, 319 insertions(+), 21 deletions(-)
diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index 9930520902c..9a1995ba8f1 100644
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,15 @@
+2021-09-30 Tobias Burnus <tobias@codesourcery.com>
+
+ Backported from master:
+ 2021-09-30 Tobias Burnus <tobias@codesourcery.com>
+
+ PR fortran/71703
+ PR fortran/84007
+ * 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.
+
2021-09-27 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 5232f75ae7a..fd0bc96ed1f 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -9113,21 +9113,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);
@@ -9136,7 +9129,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);
@@ -9148,6 +9146,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 df7f22ac3a6..d1889bee60c 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/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index 46c27e16d4d..9991a6ed0dd 100644
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,14 @@
+2021-09-30 Tobias Burnus <tobias@codesourcery.com>
+
+ Backported from master:
+ 2021-09-30 Tobias Burnus <tobias@codesourcery.com>
+
+ PR fortran/71703
+ PR fortran/84007
+ * 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.
+
2021-09-29 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
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
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-09-30 17:27 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-09-30 17:27 [gcc/devel/omp/gcc-11] Fortran: Fix same_type_as Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).