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