From patchwork Fri Oct 15 21:18:39 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 46296 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 E7B953857401 for ; Fri, 15 Oct 2021 21:19:03 +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 93F6C3858405; Fri, 15 Oct 2021 21:18:47 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 93F6C3858405 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: dBS9KDF6Lxl7C2yQW6KeI6GIe0l3hQiGbkYeYT2T8zvjnnISW7YxYglWOTIsOIph+irasK0pcJ 1dAU2SjetGpl4FLk3qiZ2Cp/DlEw4xAh3hAm34H/274tYekHIEqnvqX1IupmJdKiSTiMTIawJQ 34R5FQbA6YHWY/viEHlYEfuRGUEieD65hn7r6YlFPSv7YPL2Ac3G8CPzwtfhvI6EBiE7Javlxi dhgK1LGKsSkuh+PkdHygiPzcPH97AdVGlmQZdTt1p5yeglAJJtW5DtXHpzggYC+bE1SiUmhnnO TWK9scEdTR8xBpuh2zIApENm X-IronPort-AV: E=Sophos;i="5.85,376,1624348800"; d="diff'?scan'208";a="67258715" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa2.mentor.iphmx.com with ESMTP; 15 Oct 2021 13:18:46 -0800 IronPort-SDR: tImy+QF0TQjTMewKYiv5qVrLXAYqrpIgpOa1yM1OKXd1r+KP5Y+8VTAWrmzrCpkl+5MEds6sYF Dg3Qn3aC0caecLaDA59Rw9+0jD2uMw2JmTrhIWzZftGsfVvDjzJGs2IQOvtGU96i/Nwbuh5cfU xeQvz1pIkF7WqBFoNTp6nUg1/o6h/ZtjPWZSG+CDjzc4UWcxkgQxuXTQZkFZmWkdwz/M3+aDNI pkeIbZCHJQaBPFT6N/MChlA1mJOXzX08v7OfVXjRClqhjmJSTywRoftZQCFFfLHe2/cBH/2adc ERo= Message-ID: <408af1f1-0348-6032-7de7-a8cd33b7d6ed@codesourcery.com> Date: Fri, 15 Oct 2021 23:18:39 +0200 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:91.0) Gecko/20100101 Thunderbird/91.2.0 Content-Language: en-US To: gcc-patches , fortran From: Tobias Burnus Subject: [Patch] Fortran: Fix CLASS conversion check [PR102745] X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: SVR-IES-MBX-07.mgc.mentorg.com (139.181.222.7) 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: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch fixes two issues: First, to print 'CLASS(t2)' instead of: Error: Type mismatch in argument ‘x’ at (1); passed CLASS(__class_MAIN___T2_a) to TYPE(t) Additionally, class(t2) = class(t) ! 't2' extends 't' class(t2) = class(any) was wrongly accepted. OK? 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 CLASS conversion check [PR102745] PR fortran/102745 gcc/fortran/ChangeLog * intrinsic.c (gfc_convert_type_warn): Fix checks by checking CLASS and do typcheck in correct order for type extension. * misc.c (gfc_typename): Print proper not internal CLASS type name. gcc/testsuite/ChangeLog * gfortran.dg/class_72.f90: New. gcc/fortran/intrinsic.c | 7 +-- gcc/fortran/misc.c | 10 ++-- gcc/testsuite/gfortran.dg/class_72.f90 | 83 ++++++++++++++++++++++++++++++++++ 3 files changed, 92 insertions(+), 8 deletions(-) diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 219f04f2317..f5c88d98cc9 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -5237,12 +5237,13 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag, /* In building an array constructor, gfortran can end up here when no conversion is required for an intrinsic type. We need to let derived types drop through. */ - if (from_ts.type != BT_DERIVED + if (from_ts.type != BT_DERIVED && from_ts.type != BT_CLASS && (from_ts.type == ts->type && from_ts.kind == ts->kind)) return true; - if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED - && gfc_compare_types (&expr->ts, ts)) + if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) + && (ts->type == BT_DERIVED || ts->type == BT_CLASS) + && gfc_compare_types (ts, &expr->ts)) return true; /* If array is true then conversion is in an array constructor where diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 3d449ae17fe..e6402e881e3 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -130,7 +130,6 @@ gfc_typename (gfc_typespec *ts, bool for_hash) static char buffer2[GFC_MAX_SYMBOL_LEN + 8]; static int flag = 0; char *buffer; - gfc_typespec *ts1; gfc_charlen_t length = 0; buffer = flag ? buffer1 : buffer2; @@ -180,16 +179,17 @@ gfc_typename (gfc_typespec *ts, bool for_hash) sprintf (buffer, "TYPE(%s)", ts->u.derived->name); break; case BT_CLASS: - if (ts->u.derived == NULL) + if (!ts->u.derived || !ts->u.derived->components + || !ts->u.derived->components->ts.u.derived) { sprintf (buffer, "invalid class"); break; } - ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL; - if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic) + if (ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic) sprintf (buffer, "CLASS(*)"); else - sprintf (buffer, "CLASS(%s)", ts->u.derived->name); + sprintf (buffer, "CLASS(%s)", + ts->u.derived->components->ts.u.derived->name); break; case BT_ASSUMED: sprintf (buffer, "TYPE(*)"); diff --git a/gcc/testsuite/gfortran.dg/class_72.f90 b/gcc/testsuite/gfortran.dg/class_72.f90 new file mode 100644 index 00000000000..0fd6ec010f5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_72.f90 @@ -0,0 +1,83 @@ +! PR fortran/102745 + +implicit none + +type t +end type t + +type, extends(t) :: t2 +end type t2 + +type t3 +end type t3 + +type(t), allocatable :: var +type(t2), allocatable :: v2ar +type(t3), allocatable :: v3ar +class(t), allocatable :: cvar +class(t2), allocatable :: c2var +class(t3), allocatable :: c3var + +call f(var) +call f(v2ar) ! { dg-error "passed TYPE.t2. to TYPE.t." } +call f(v2ar%t) +call f(cvar) +call f(c2var) ! { dg-error "passed CLASS.t2. to TYPE.t." } +call f(c2var%t) + +call f2(var) ! { dg-error "passed TYPE.t. to TYPE.t2." } +call f2(v2ar) +call f2(cvar) ! { dg-error "passed CLASS.t. to TYPE.t2." } +call f2(c2var) + + +var = var +var = v2ar ! { dg-error "TYPE.t2. to TYPE.t." } +var = cvar +var = c2var ! { dg-error "TYPE.t2. to TYPE.t." } + +v2ar = var ! { dg-error "Cannot convert TYPE.t. to TYPE.t2." } +v2ar = v2ar +v2ar = cvar ! { dg-error "Cannot convert TYPE.t. to TYPE.t2." } +v2ar = c2var + +cvar = var +cvar = v2ar +cvar = cvar +cvar = c2var + +c2var = var ! { dg-error "Cannot convert TYPE.t. to CLASS.t2." } +c2var = v3ar ! { dg-error "Cannot convert TYPE.t3. to CLASS.t2." } +c2var = v2ar +c2var = cvar ! { dg-error "Cannot convert CLASS.t. to CLASS.t2." } +c2var = c3var ! { dg-error "Cannot convert CLASS.t3. to CLASS.t2." } +c2var = c2var + +allocate (var, source=var) +allocate (var, source=v2ar) ! { dg-error "incompatible with source-expr" } +allocate (var, source=cvar) +allocate (var, source=c2var) ! { dg-error "incompatible with source-expr" } + +allocate (v2ar, source=var) ! { dg-error "incompatible with source-expr" } +allocate (v2ar, source=v2ar) +allocate (v2ar, source=cvar) ! { dg-error "incompatible with source-expr" } +allocate (v2ar, source=c2var) + +allocate (cvar, source=var) +allocate (cvar, source=v2ar) +allocate (cvar, source=cvar) +allocate (cvar, source=c2var) + +allocate (c2var, source=var) ! { dg-error "incompatible with source-expr" } +allocate (c2var, source=v2ar) +allocate (c2var, source=cvar) ! { dg-error "incompatible with source-expr" } +allocate (c2var, source=c2var) + +contains + subroutine f(x) + type(t) :: x + end + subroutine f2(x) + type(t2) :: x + end +end