From patchwork Tue Sep 28 16:25:45 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 45509 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 2EB213857800 for ; Tue, 28 Sep 2021 16:26:21 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa2.mentor.iphmx.com (esa2.mentor.iphmx.com [68.232.141.98]) by sourceware.org (Postfix) with ESMTPS id A47483858D39; Tue, 28 Sep 2021 16:25:53 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org A47483858D39 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: x9lK2h00qjTZ80D9CQbrUFinHlzysjAteDMf0wiGT2UPVjjUkYKuEt/k9308eCK0nedqATXoCh cXp2dGTRgRUFWUZ2ABynyr2KITKH1+1xqoHLJeZUogdBPg9kzYrDAqjNTlfuH2y/Xmy0jz1hG2 6w2q9Em99wz8AwpRbhF4vKToWwUabzCnYjhKyWTasghTwgwXM+EQvsfn4u4nas1CvrgjO+64aQ uZ4GXbcxUJje7SghosJxb/4wc4c+pF2xNDJCeFP1/+DSmtj8eOd9WdksoY2VPpbHCoWlzmFjFO nXAtqXRa55wjihDxyG9GWmLA X-IronPort-AV: E=Sophos;i="5.85,329,1624348800"; d="diff'?scan'208";a="66455444" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa2.mentor.iphmx.com with ESMTP; 28 Sep 2021 08:25:52 -0800 IronPort-SDR: P0o9uuPyckvSzZYO0+UESDRZhgmGs6H1hBO2V9fcJ6MZjFYX58H15gDVe+xS3ZQ6MTFv7x8wAx lXZ67LowD3uuahDJpTxyc4rAsTUAt96AC4aTEtVfvM77zRioEVkolo26cM13ZqV5p8ZqooTIw1 TwtJZHV8QfaPLlnL/vwF1s0LnRN9KqhIZmYboeEfNDHZLE+71CkW+/A3ynWEPkxlKu0Y9rAMs9 nz/7sL68DAS44bA2Uj6/+BsvUyCZ6LadxiYhHA4zPX1tbo6l7WccuQZYjT4wVWtHPP67e4xCRV PxM= To: gcc-patches , fortran From: Tobias Burnus Subject: [Patch] Fortran: Fix same_type_as Message-ID: Date: Tue, 28 Sep 2021 18:25:45 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.14.0 MIME-Version: 1.0 Content-Language: en-US X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-05.mgc.mentorg.com (139.181.222.5) To svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) X-Spam-Status: No, score=-11.6 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: Sandra Loosemore Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" 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 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