From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wr1-x42f.google.com (mail-wr1-x42f.google.com [IPv6:2a00:1450:4864:20::42f]) by sourceware.org (Postfix) with ESMTPS id 381A03854822 for ; Tue, 5 Sep 2023 11:08:21 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 381A03854822 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-wr1-x42f.google.com with SMTP id ffacd0b85a97d-31dcd553fecso1973244f8f.2 for ; Tue, 05 Sep 2023 04:08:21 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1693912100; x=1694516900; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=57pEKQPVO+EHsNwyQA8/cQkjXzkbch7R0Ycr0v9NunQ=; b=DmoA4aWvn1P3MZX9A+InvPZuBOzoGF+EkWhEORik0MZ9SKgdDc8+Gd+QkoyqhDC7xH /aOF094hY2p1SSYCjyU0r97AnGgfDFAXp9jgBCYy/32ySFFiZJZXiOHL/DEBhdoST0tb 3cs0Woq+Kg2vP9zK7uFXmmo1nWfCbCo0vI5MkTG4Iv+2YEjwwWkZqUEprDUVUcb1gMSS NKP1TaUtGWU6JcNM8IoeY4nCk4a0fUowd+GriJn4wDNOqEgUaWC5zSdqfYVnQOFDBmDA 3AeWD12ZRdZPpjkzaFbFz0ysjk/AmfzApOw52FI0TYKQg+AwocRKEWKEYaeXK2LJH/zE C6Ag== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1693912100; x=1694516900; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=57pEKQPVO+EHsNwyQA8/cQkjXzkbch7R0Ycr0v9NunQ=; b=ddWwtjE3iLH9cZuA6ILJp/Sn3h2ZLiNrKg2YLNavFF1/vPw9xC6MyVok8NsrzaHtp3 6/jnJFUrJfGm/+NKr/9fvg0OXgJaHDelwt0mMdJuFrS+scFjAlMQ9ki3cKdRFwn3ufxv Tucf0XFArjTkBSFNzOvt0mQmJnj5Xti05vTRMc8w0l3mUkbdKfjqispOWQ3nKlcprd4w jP3nsnemBTj84nN8J3/eOe8JsoEOQB7bGtwEdUXzulMKItllUdzTsLqG2ONW2SYc7PCj H9jbbhOwr4x6pBwVaBrjTA7lrk/ClC9iDiEtjnh3ElF4TpiqYMznA3/+0IekjPW0O+TL 4iVg== X-Gm-Message-State: AOJu0YxG7vtoJedNf0ABzJTBc4NDbvseu+Yn2HupepzT4mMrHEDHltz+ bmxqz3MAtF/H2aD01xdCjztP87o7yYsbRZpW5SdDwg== X-Google-Smtp-Source: AGHT+IGxi94ekTD6x+FEqH8i4IGjYc+vVT3fpAzqAN6bKbaIKedHOztGXEA4krAl9FR5fL8qcml4gg== X-Received: by 2002:a5d:6041:0:b0:31c:762b:ceb3 with SMTP id j1-20020a5d6041000000b0031c762bceb3mr8987570wrt.48.1693912099971; Tue, 05 Sep 2023 04:08:19 -0700 (PDT) Received: from poulhies-Precision-5550.lan ([2001:861:3382:1a90:20fc:79e4:455c:1075]) by smtp.gmail.com with ESMTPSA id c18-20020adfed92000000b003143c6e09ccsm17361909wro.16.2023.09.05.04.08.19 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 05 Sep 2023 04:08:19 -0700 (PDT) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [COMMITTED] ada: Crash on creation of extra formals on type extension Date: Tue, 5 Sep 2023 13:08:18 +0200 Message-Id: <20230905110818.562990-1-poulhies@adacore.com> X-Mailer: git-send-email 2.40.0 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,GIT_PATCH_0,KAM_ASCII_DIVIDERS,RCVD_IN_DNSWL_NONE,SPF_HELO_NONE,SPF_PASS,TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org List-Id: From: Javier Miranda The compiler blows up processing an overriding dispatching function of a derived tagged type that returns a private tagged type that has an access type discriminant. gcc/ada/ * accessibility.ads (Needs_Result_Accessibility_Extra_Formal): New subprogram. * accessibility.adb (Needs_Result_Accessibility_Level_Param): New subprogram. (Needs_Result_Accessibility_Extra_Formal): New subprogram, temporarily keep the previous behavior of the frontend. * sem_ch6.adb (Create_Extra_Formals): Replace occurrences of function Needs_Result_Accessibility_Level_Param by calls to function Needs_Result_Accessibility_Extra_Formal. (Extra_Formals_OK): Ditto. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/accessibility.adb | 54 +++++++++++++++++++++++++++++++++++++-- gcc/ada/accessibility.ads | 12 ++++++++- gcc/ada/sem_ch6.adb | 8 +++--- 3 files changed, 67 insertions(+), 7 deletions(-) diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index bc897d1ef18..6b4ec5b9d24 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -56,6 +56,16 @@ with Tbuild; use Tbuild; package body Accessibility is + function Needs_Result_Accessibility_Level_Param + (Func_Id : Entity_Id; + Func_Typ : Entity_Id) return Boolean; + -- Subsidiary of functions Needs_Result_Accessibility_Extra_Formal and + -- Needs_Result_Accessibility_Level_Param. Return True if the function + -- needs an implicit parameter to identify the accessibility level of + -- the function result "determined by the point of call". Func_Typ is + -- the function return type; this function returns False if Func_Typ is + -- Empty. + --------------------------- -- Accessibility_Message -- --------------------------- @@ -1892,6 +1902,34 @@ package body Accessibility is and then Is_Explicitly_Aliased (Entity (Prefix (Exp))); end Is_Special_Aliased_Formal_Access; + --------------------------------------------- + -- Needs_Result_Accessibility_Extra_Formal -- + --------------------------------------------- + + function Needs_Result_Accessibility_Extra_Formal + (Func_Id : Entity_Id) return Boolean + is + Func_Typ : Entity_Id; + + begin + if Present (Underlying_Type (Etype (Func_Id))) then + Func_Typ := Underlying_Type (Etype (Func_Id)); + + -- Case of a function returning a private type which is not completed + -- yet. The support for this case is required because this function is + -- called to create the extra formals of dispatching primitives, and + -- they may be frozen before we see the full-view of their returned + -- private type. + + else + -- Temporarily restore previous behavior + -- Func_Typ := Etype (Func_Id); + Func_Typ := Empty; + end if; + + return Needs_Result_Accessibility_Level_Param (Func_Id, Func_Typ); + end Needs_Result_Accessibility_Extra_Formal; + -------------------------------------- -- Needs_Result_Accessibility_Level -- -------------------------------------- @@ -1901,6 +1939,18 @@ package body Accessibility is is Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); + begin + return Needs_Result_Accessibility_Level_Param (Func_Id, Func_Typ); + end Needs_Result_Accessibility_Level; + + -------------------------------------------- + -- Needs_Result_Accessibility_Level_Param -- + -------------------------------------------- + + function Needs_Result_Accessibility_Level_Param + (Func_Id : Entity_Id; + Func_Typ : Entity_Id) return Boolean + is function Has_Unconstrained_Access_Discriminant_Component (Comp_Typ : Entity_Id) return Boolean; -- Returns True if any component of the type has an unconstrained access @@ -1952,7 +2002,7 @@ package body Accessibility is -- Flag used to temporarily disable a "True" result for tagged types. -- See comments further below for details. - -- Start of processing for Needs_Result_Accessibility_Level + -- Start of processing for Needs_Result_Accessibility_Level_Param begin -- False if completion unavailable, which can happen when we are @@ -2028,7 +2078,7 @@ package body Accessibility is else return False; end if; - end Needs_Result_Accessibility_Level; + end Needs_Result_Accessibility_Level_Param; ------------------------------------------ -- Prefix_With_Safe_Accessibility_Level -- diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads index e30c90ab6a7..731fea125f4 100644 --- a/gcc/ada/accessibility.ads +++ b/gcc/ada/accessibility.ads @@ -197,11 +197,21 @@ package Accessibility is -- prefix is an aliased formal of Scop and that Scop returns an anonymous -- access type. See RM 3.10.2 for more details. + function Needs_Result_Accessibility_Extra_Formal + (Func_Id : Entity_Id) return Boolean; + -- Ada 2012 (AI05-0234): Return True if the function needs an implicit + -- parameter to identify the accessibility level of the function result. + -- If the type of the function result is a private type and its completion + -- is unavailable, which can happen when we are analyzing an abstract + -- subprogram, determines its result using the returned private type. This + -- function is used by Create_Extra_Formals. + function Needs_Result_Accessibility_Level (Func_Id : Entity_Id) return Boolean; -- Ada 2012 (AI05-0234): Return True if the function needs an implicit -- parameter to identify the accessibility level of the function result - -- "determined by the point of call". + -- "determined by the point of call". Return False if the type of the + -- function result is a private type and its completion is unavailable. function Subprogram_Access_Level (Subp : Entity_Id) return Uint; -- Return the accessibility level of the view denoted by Subp diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 53011f465a8..297371a2c16 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -9139,13 +9139,13 @@ package body Sem_Ch6 is begin Ada_Version := Ada_2022; - if Needs_Result_Accessibility_Level (Ref_E) + if Needs_Result_Accessibility_Extra_Formal (Ref_E) or else (Present (Parent_Subp) - and then Needs_Result_Accessibility_Level (Parent_Subp)) + and then Needs_Result_Accessibility_Extra_Formal (Parent_Subp)) or else (Present (Alias_Subp) - and then Needs_Result_Accessibility_Level (Alias_Subp)) + and then Needs_Result_Accessibility_Extra_Formal (Alias_Subp)) then Set_Extra_Accessibility_Of_Result (E, Add_Extra_Formal (E, Standard_Natural, E, "L")); @@ -9694,7 +9694,7 @@ package body Sem_Ch6 is -- Check attribute Extra_Accessibility_Of_Result if Ekind (E) in E_Function | E_Subprogram_Type - and then Needs_Result_Accessibility_Level (E) + and then Needs_Result_Accessibility_Extra_Formal (E) and then No (Extra_Accessibility_Of_Result (E)) then return False; -- 2.40.0