From patchwork Fri Dec 13 09:55:01 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1209050 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-515849-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="g9CHQxkp"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 47Z5dJ2363z9sP6 for ; Fri, 13 Dec 2019 20:55:32 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=PDEZI8dDWdaCPqofBx01AVgTq4D7orkmwo6MTmbtNT2g9JPjzR o1q/3pLayfaBN0Xipq5hsGeFNMgSrAVWvbS/9aIwo8PYaf6DxrOPr3fV+ZkA3gkz 5L0li8qppDdHW6X7J9EGSFZo6PudIVxkeBV+1adwL66SjwSTaiJUBqrhw= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=wian52AqBuFUjdB3aLyt2gUN/qE=; b=g9CHQxkpxQgjwcUQInCm THYGTl9tOSkXorfaGnc0Ia5dhJ/3D3xX2+cZy0UNQfoUI0acbTmmRghujzPxj7dW BczQLjMASqt1NM1Yv0ZaS6+pouxHjQzFAd1LemCTsWTFwTcBapWfULnIk0Yeh8GD NRGwU8+mH8B5dJ2k7kxbkKo= Received: (qmail 36541 invoked by alias); 13 Dec 2019 09:55:07 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 36487 invoked by uid 89); 13 Dec 2019 09:55:06 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-10.6 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, KAM_NUMSUBJECT, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=exp_ch4.adb, exp_ch4adb, Prune, UD:exp_ch4.adb X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 13 Dec 2019 09:55:03 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 8BD67560A9; Fri, 13 Dec 2019 04:55:01 -0500 (EST) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id lUjXSHYG1neq; Fri, 13 Dec 2019 04:55:01 -0500 (EST) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 77B96560A6; Fri, 13 Dec 2019 04:55:01 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4862) id 75207180; Fri, 13 Dec 2019 04:55:01 -0500 (EST) Date: Fri, 13 Dec 2019 04:55:01 -0500 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Steve Baird Subject: [Ada] Implement AI12-0101 Message-ID: <20191213095501.GA13885@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes This AI simply relaxes a legality rule, legalizing a construct that was previously illegal. In particular, it deletes the second sentence of 4.5.2(9.8) In addition, if the untagged record type has a nonlimited partial view, then the declaration shall occur in the visible part of the enclosing package. which disallowed certain user-defined equality declarations occurring in a private part. Implementation of this AI includes getting the runtime behavior right for the previously-illegal cases, in particular with respect to AI05-0123. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-12-13 Steve Baird gcc/ada/ * exp_ch4.adb (Expand_N_Op_Eq.Is_Equality): Move this function from within Expand_N_Op_Eq.Find_Equality out to immediately within Expand_N_Op_Eq in order to give it greater visibility. Add a new Typ parameter (defaulted to Empty) which, if non-empty, means the function will return False in the case of an equality op for some other type. * (Expand_N_Op_Eq.User_Defined_Primitive_Equality_Op): A new function. Given an untagged record type, finds the corresponding user-defined primitive equality op (if any). May return Empty. Ignores visibility. * (Expand_N_Op): For Ada2012 or later, check for presence of a user-defined primitive equality op before falling back on the usual predefined component-by-component comparison. If found, then call the user-defined op instead. --- gcc/ada/exp_ch4.adb +++ gcc/ada/exp_ch4.adb @@ -7520,10 +7520,21 @@ package body Exp_Ch4 is -- build and analyze call, adding conversions if the operation is -- inherited. + function Is_Equality (Subp : Entity_Id; + Typ : Entity_Id := Empty) return Boolean; + -- Determine whether arbitrary Entity_Id denotes a function with the + -- right name and profile for an equality op, specifically for the + -- base type Typ if Typ is nonempty. + function Find_Equality (Prims : Elist_Id) return Entity_Id; -- Find a primitive equality function within primitive operation list -- Prims. + function User_Defined_Primitive_Equality_Op + (Typ : Entity_Id) return Entity_Id; + -- Find a user-defined primitive equality function for a given untagged + -- record type, ignoring visibility. Return Empty if no such op found. + function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean; -- Determines whether a type has a subcomponent of an unconstrained -- Unchecked_Union subtype. Typ is a record type. @@ -7772,6 +7783,43 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); end Build_Equality_Call; + ----------------- + -- Is_Equality -- + ----------------- + + function Is_Equality (Subp : Entity_Id; + Typ : Entity_Id := Empty) return Boolean is + Formal_1 : Entity_Id; + Formal_2 : Entity_Id; + begin + -- The equality function carries name "=", returns Boolean, and has + -- exactly two formal parameters of an identical type. + + if Ekind (Subp) = E_Function + and then Chars (Subp) = Name_Op_Eq + and then Base_Type (Etype (Subp)) = Standard_Boolean + then + Formal_1 := First_Formal (Subp); + Formal_2 := Empty; + + if Present (Formal_1) then + Formal_2 := Next_Formal (Formal_1); + end if; + + return + Present (Formal_1) + and then Present (Formal_2) + and then No (Next_Formal (Formal_2)) + and then Base_Type (Etype (Formal_1)) = + Base_Type (Etype (Formal_2)) + and then + (not Present (Typ) + or else Implementation_Base_Type (Etype (Formal_1)) = Typ); + end if; + + return False; + end Is_Equality; + ------------------- -- Find_Equality -- ------------------- @@ -7781,9 +7829,6 @@ package body Exp_Ch4 is -- Find an equality in a possible alias chain starting from primitive -- operation Prim. - function Is_Equality (Id : Entity_Id) return Boolean; - -- Determine whether arbitrary entity Id denotes an equality - --------------------------- -- Find_Aliased_Equality -- --------------------------- @@ -7807,39 +7852,6 @@ package body Exp_Ch4 is return Empty; end Find_Aliased_Equality; - ----------------- - -- Is_Equality -- - ----------------- - - function Is_Equality (Id : Entity_Id) return Boolean is - Formal_1 : Entity_Id; - Formal_2 : Entity_Id; - - begin - -- The equality function carries name "=", returns Boolean, and - -- has exactly two formal parameters of an identical type. - - if Ekind (Id) = E_Function - and then Chars (Id) = Name_Op_Eq - and then Base_Type (Etype (Id)) = Standard_Boolean - then - Formal_1 := First_Formal (Id); - Formal_2 := Empty; - - if Present (Formal_1) then - Formal_2 := Next_Formal (Formal_1); - end if; - - return - Present (Formal_1) - and then Present (Formal_2) - and then Etype (Formal_1) = Etype (Formal_2) - and then No (Next_Formal (Formal_2)); - end if; - - return False; - end Is_Equality; - -- Local variables Eq_Prim : Entity_Id; @@ -7869,6 +7881,47 @@ package body Exp_Ch4 is return Eq_Prim; end Find_Equality; + ---------------------------------------- + -- User_Defined_Primitive_Equality_Op -- + ---------------------------------------- + + function User_Defined_Primitive_Equality_Op + (Typ : Entity_Id) return Entity_Id + is + Enclosing_Scope : constant Node_Id := Scope (Typ); + E : Entity_Id; + begin + -- Prune this search by somehow not looking at decls that precede + -- the declaration of the first view of Typ (which might be a partial + -- view)??? + + for Private_Entities in Boolean loop + if Private_Entities then + if Ekind (Enclosing_Scope) /= E_Package then + exit; + end if; + E := First_Private_Entity (Enclosing_Scope); + + else + E := First_Entity (Enclosing_Scope); + end if; + + while Present (E) loop + if Is_Equality (E, Typ) then + return E; + end if; + E := Next_Entity (E); + end loop; + end loop; + + if Is_Derived_Type (Typ) then + return User_Defined_Primitive_Equality_Op + (Implementation_Base_Type (Etype (Typ))); + end if; + + return Empty; + end User_Defined_Primitive_Equality_Op; + ------------------------------------ -- Has_Unconstrained_UU_Component -- ------------------------------------ @@ -8190,6 +8243,15 @@ package body Exp_Ch4 is (Find_Equality (Primitive_Operations (Typl))); end if; + -- See AI12-0101 (which only removes a legality rule) and then + -- AI05-0123 (which then applies in the previously illegal case). + -- AI12-0101 is a binding interpretation. + + elsif Ada_Version >= Ada_2012 + and then Present (User_Defined_Primitive_Equality_Op (Typl)) + then + Build_Equality_Call (User_Defined_Primitive_Equality_Op (Typl)); + -- Ada 2005 (AI-216): Program_Error is raised when evaluating the -- predefined equality operator for a type which has a subcomponent -- of an Unchecked_Union type whose nominal subtype is unconstrained.