From patchwork Mon May 16 08:43:10 2022 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: 54014 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 ED3F03858C74 for ; Mon, 16 May 2022 08:59:39 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org ED3F03858C74 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1652691580; bh=JLosfM29Ji4cBD0GMh5vCN/adJ9iKg7VEuSUg5ZC48c=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=Y7mrJNJMkzDwAWcjVkBoNFvN0or6zqV+p/6SYZflrf2iQxLLCJx84TVqJo11EK1mV q2OxZQdnmEwf/5y0ql9Hm88FbWnIfQnJu4//P+sRVXk9TNEPUGZHdn1p9YvuXYF5zQ NYgS3VTAOw4nLrGzttfkfAiAs4IKnSXtbauSwDj0= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42c.google.com (mail-wr1-x42c.google.com [IPv6:2a00:1450:4864:20::42c]) by sourceware.org (Postfix) with ESMTPS id EE576385840C for ; Mon, 16 May 2022 08:43:11 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org EE576385840C Received: by mail-wr1-x42c.google.com with SMTP id j24so4223032wrb.1 for ; Mon, 16 May 2022 01:43:11 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=JLosfM29Ji4cBD0GMh5vCN/adJ9iKg7VEuSUg5ZC48c=; b=yXv4Q3qbxSKBBsErLlF5B+8blc5lWawRVgX/ZQ+AL6GKzW/ai2ff4wA+Onbe69r8C4 bVIodSrAfnic9KpvRvbZymQh3qGmXr84EVZYZYnTyOEhf5MkEN4bB0mfD9OVUUVVTLGo BU8mEK97Oi23KOR9kZdKYCjqNlRU14nA7EqvFJ0zgRO3+56WbHh2opJ0pofgum+a6gcn B/U1V3fcKhnIGqm6ZPtjN2gJQsaCOa22alE4+VqEawwZJCe6mvuZci3fZNF5AmiNR75A 873EDlydQjxhIdI/yM6LlLwMmNP6JvONcQjy0JBGktnkx8DyCLWRLT5G05VH6UTXACh4 rPcw== X-Gm-Message-State: AOAM5319t7AYRCCT072vXMBo1IvYVP25tGCCtPg7HGgrp8ey/Odf5I3K yRs0SAzQfjGLVkIAtpE4XOByQbE7r2ibuA== X-Google-Smtp-Source: ABdhPJwflhxLDRFUZsk4uxhhmDmjTyPTFqvRdTuTHbkU2fox+UxhgQimQOw8de3jSW7K5uoFqjx5oA== X-Received: by 2002:a5d:4ccc:0:b0:20c:d966:85c with SMTP id c12-20020a5d4ccc000000b0020cd966085cmr12935706wrt.514.1652690591526; Mon, 16 May 2022 01:43:11 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id n14-20020a05600c500e00b00394708a3d7dsm12674583wmr.15.2022.05.16.01.43.10 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 16 May 2022 01:43:10 -0700 (PDT) Date: Mon, 16 May 2022 08:43:10 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Revise Storage_Model_Support operations to do checks and take objects and types Message-ID: <20220516084310.GA3843624@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-12.8 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, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) 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: , X-Patchwork-Original-From: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Gary Dismukes Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" The functions in subpackage Storage_Model_Support (apart from the Has_*_Aspect functions) are revised to have assertions that will fail when passed a parameter that doesn't specify the appropriate aspect (either aspect Storage_Model_Type or Designated_Storage_Model), instead of returning Empty for bad arguments. Also, various of the functions now allow either a type with aspect Storage_Model_Type or an object of such a type. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_util.ads (Storage_Model_Support): Revise comments on most operations within this nested package to reflect that they can now be passed either a type that has aspect Storage_Model_Type or an object of such a type. Change the names of the relevant formals to SM_Obj_Or_Type. Also, add more precise semantic descriptions in some cases, and declare the subprograms in a more logical order. * sem_util.adb (Storage_Model_Support.Storage_Model_Object): Add an assertion that the type must specify aspect Designated_Storage_Model, rather than returning Empty when it doesn't specify that aspect. (Storage_Model_Support.Storage_Model_Type): Add an assertion that formal must be an object whose type specifies aspect Storage_Model_Type, rather than returning Empty for when it doesn't have such a type (and test Has_Storage_Model_Type_Aspect rather than Find_Value_Of_Aspect). (Storage_Model_Support.Get_Storage_Model_Type_Entity): Allow both objects and types, and add an assertion that the type (or the type of the object) has a value for aspect Storage_Model_Type. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -32302,47 +32302,6 @@ package body Sem_Util is package body Storage_Model_Support is - ----------------------------------- - -- Get_Storage_Model_Type_Entity -- - ----------------------------------- - - function Get_Storage_Model_Type_Entity - (Typ : Entity_Id; - Nam : Name_Id) return Entity_Id - is - pragma Assert - (Is_Type (Typ) - and then - Nam in Name_Address_Type - | Name_Null_Address - | Name_Allocate - | Name_Deallocate - | Name_Copy_From - | Name_Copy_To - | Name_Storage_Size); - - SMT_Aspect_Value : constant Node_Id := - Find_Value_Of_Aspect (Typ, Aspect_Storage_Model_Type); - Assoc : Node_Id; - - begin - if No (SMT_Aspect_Value) then - return Empty; - - else - Assoc := First (Component_Associations (SMT_Aspect_Value)); - while Present (Assoc) loop - if Chars (First (Choices (Assoc))) = Nam then - return Entity (Expression (Assoc)); - end if; - - Next (Assoc); - end loop; - - return Empty; - end if; - end Get_Storage_Model_Type_Entity; - ----------------------------------------- -- Has_Designated_Storage_Model_Aspect -- ----------------------------------------- @@ -32370,13 +32329,11 @@ package body Sem_Util is function Storage_Model_Object (Typ : Entity_Id) return Entity_Id is begin - if Has_Designated_Storage_Model_Aspect (Typ) then - return - Entity - (Find_Value_Of_Aspect (Typ, Aspect_Designated_Storage_Model)); - else - return Empty; - end if; + pragma Assert (Has_Designated_Storage_Model_Aspect (Typ)); + + return + Entity + (Find_Value_Of_Aspect (Typ, Aspect_Designated_Storage_Model)); end Storage_Model_Object; ------------------------ @@ -32385,76 +32342,132 @@ package body Sem_Util is function Storage_Model_Type (Obj : Entity_Id) return Entity_Id is begin - if Present - (Find_Value_Of_Aspect (Etype (Obj), Aspect_Storage_Model_Type)) - then - return Etype (Obj); - else - return Empty; - end if; + pragma Assert (Has_Storage_Model_Type_Aspect (Etype (Obj))); + + return Etype (Obj); end Storage_Model_Type; + ----------------------------------- + -- Get_Storage_Model_Type_Entity -- + ----------------------------------- + + function Get_Storage_Model_Type_Entity + (SM_Obj_Or_Type : Entity_Id; + Nam : Name_Id) return Entity_Id + is + Typ : constant Entity_Id := (if Is_Object (SM_Obj_Or_Type) then + Storage_Model_Type (SM_Obj_Or_Type) + else + SM_Obj_Or_Type); + pragma Assert + (Is_Type (Typ) + and then + Nam in Name_Address_Type + | Name_Null_Address + | Name_Allocate + | Name_Deallocate + | Name_Copy_From + | Name_Copy_To + | Name_Storage_Size); + + Assoc : Node_Id; + SMT_Aspect_Value : constant Node_Id := + Find_Value_Of_Aspect (Typ, Aspect_Storage_Model_Type); + + begin + pragma Assert (Present (SMT_Aspect_Value)); + + Assoc := First (Component_Associations (SMT_Aspect_Value)); + while Present (Assoc) loop + if Chars (First (Choices (Assoc))) = Nam then + return Entity (Expression (Assoc)); + end if; + + Next (Assoc); + end loop; + + return Empty; + end Get_Storage_Model_Type_Entity; + -------------------------------- -- Storage_Model_Address_Type -- -------------------------------- - function Storage_Model_Address_Type (Typ : Entity_Id) return Entity_Id is + function Storage_Model_Address_Type + (SM_Obj_Or_Type : Entity_Id) return Entity_Id + is begin - return Get_Storage_Model_Type_Entity (Typ, Name_Address_Type); + return + Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Address_Type); end Storage_Model_Address_Type; -------------------------------- -- Storage_Model_Null_Address -- -------------------------------- - function Storage_Model_Null_Address (Typ : Entity_Id) return Entity_Id is + function Storage_Model_Null_Address + (SM_Obj_Or_Type : Entity_Id) return Entity_Id + is begin - return Get_Storage_Model_Type_Entity (Typ, Name_Null_Address); + return + Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Null_Address); end Storage_Model_Null_Address; ---------------------------- -- Storage_Model_Allocate -- ---------------------------- - function Storage_Model_Allocate (Typ : Entity_Id) return Entity_Id is + function Storage_Model_Allocate + (SM_Obj_Or_Type : Entity_Id) return Entity_Id + is begin - return Get_Storage_Model_Type_Entity (Typ, Name_Allocate); + return Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Allocate); end Storage_Model_Allocate; ------------------------------ -- Storage_Model_Deallocate -- ------------------------------ - function Storage_Model_Deallocate (Typ : Entity_Id) return Entity_Id is + function Storage_Model_Deallocate + (SM_Obj_Or_Type : Entity_Id) return Entity_Id + is begin - return Get_Storage_Model_Type_Entity (Typ, Name_Deallocate); + return + Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Deallocate); end Storage_Model_Deallocate; ----------------------------- -- Storage_Model_Copy_From -- ----------------------------- - function Storage_Model_Copy_From (Typ : Entity_Id) return Entity_Id is + function Storage_Model_Copy_From + (SM_Obj_Or_Type : Entity_Id) return Entity_Id + is begin - return Get_Storage_Model_Type_Entity (Typ, Name_Copy_From); + return Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Copy_From); end Storage_Model_Copy_From; --------------------------- -- Storage_Model_Copy_To -- --------------------------- - function Storage_Model_Copy_To (Typ : Entity_Id) return Entity_Id is + function Storage_Model_Copy_To + (SM_Obj_Or_Type : Entity_Id) return Entity_Id + is begin - return Get_Storage_Model_Type_Entity (Typ, Name_Copy_To); + return Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Copy_To); end Storage_Model_Copy_To; -------------------------------- -- Storage_Model_Storage_Size -- -------------------------------- - function Storage_Model_Storage_Size (Typ : Entity_Id) return Entity_Id is + function Storage_Model_Storage_Size + (SM_Obj_Or_Type : Entity_Id) return Entity_Id + is begin - return Get_Storage_Model_Type_Entity (Typ, Name_Storage_Size); + return + Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Storage_Size); end Storage_Model_Storage_Size; end Storage_Model_Support; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -3591,68 +3591,78 @@ package Sem_Util is -- for the Storage_Model feature. These functions provide an interface -- that the compiler (in particular back-end phases such as gigi and -- GNAT-LLVM) can use to easily obtain entities and operations that - -- are specified for types in the aspects Storage_Model_Type and + -- are specified for types that have aspects Storage_Model_Type or -- Designated_Storage_Model. - function Get_Storage_Model_Type_Entity - (Typ : Entity_Id; - Nam : Name_Id) return Entity_Id; - -- Given type Typ with aspect Storage_Model_Type, returns the Entity_Id - -- corresponding to the entity associated with Nam in the aspect. If the - -- type does not specify the aspect, or such an entity is not present, - -- then returns Empty. (Note: This function is modeled on function - -- Get_Iterable_Type_Primitive.) + function Has_Storage_Model_Type_Aspect (Typ : Entity_Id) return Boolean; + -- Returns True iff Typ specifies aspect Storage_Model_Type function Has_Designated_Storage_Model_Aspect (Typ : Entity_Id) return Boolean; -- Returns True iff Typ specifies aspect Designated_Storage_Model - function Has_Storage_Model_Type_Aspect (Typ : Entity_Id) return Boolean; - -- Returns True iff Typ specifies aspect Storage_Model_Type - function Storage_Model_Object (Typ : Entity_Id) return Entity_Id; - -- Given an access type with aspect Designated_Storage_Model, returns - -- the storage-model object associated with that type; returns Empty - -- if there is no associated object. + -- Given an access type Typ with aspect Designated_Storage_Model, + -- returns the storage-model object associated with that type. + -- The object Entity_Ids returned by this function can be passed + -- other functions declared in this interface to retrieve operations + -- associated with Storage_Model_Type aspect of the object's type. function Storage_Model_Type (Obj : Entity_Id) return Entity_Id; -- Given an object Obj of a type specifying aspect Storage_Model_Type, - -- returns that type; otherwise returns Empty. - - function Storage_Model_Address_Type (Typ : Entity_Id) return Entity_Id; - -- Given a type Typ that specifies aspect Storage_Model_Type, returns - -- the type specified for the Address_Type choice in that aspect; - -- returns Empty if the aspect or the type isn't specified. - - function Storage_Model_Null_Address (Typ : Entity_Id) return Entity_Id; - -- Given a type Typ that specifies aspect Storage_Model_Type, returns - -- constant specified for Null_Address choice in that aspect; returns - -- Empty if the aspect or the constant object isn't specified. - - function Storage_Model_Allocate (Typ : Entity_Id) return Entity_Id; - -- Given a type Typ that specifies aspect Storage_Model_Type, returns - -- procedure specified for the Allocate choice in that aspect; returns - -- Empty if the aspect or the procedure isn't specified. - - function Storage_Model_Deallocate (Typ : Entity_Id) return Entity_Id; - -- Given a type Typ that specifies aspect Storage_Model_Type, returns - -- procedure specified for the Deallocate choice in that aspect; returns - -- Empty if the aspect or the procedure isn't specified. - - function Storage_Model_Copy_From (Typ : Entity_Id) return Entity_Id; - -- Given a type Typ that specifies aspect Storage_Model_Type, returns - -- procedure specified for the Copy_From choice in that aspect; returns - -- Empty if the aspect or the procedure isn't specified. - - function Storage_Model_Copy_To (Typ : Entity_Id) return Entity_Id; - -- Given a type Typ that specifies aspect Storage_Model_Type, returns - -- procedure specified for the Copy_To choice in that aspect; returns - -- Empty if the aspect or the procedure isn't specified. - - function Storage_Model_Storage_Size (Typ : Entity_Id) return Entity_Id; - -- Given a type Typ that specifies aspect Storage_Model_Type, returns - -- function specified for Storage_Size choice in that aspect; returns - -- Empty if the aspect or the procedure isn't specified. + -- returns that type. + + function Get_Storage_Model_Type_Entity + (SM_Obj_Or_Type : Entity_Id; + Nam : Name_Id) return Entity_Id; + -- Given a type with aspect Storage_Model_Type or an object of such a + -- type, and Nam denoting the name of one of the argument kinds allowed + -- for that aspect, returns the Entity_Id corresponding to the entity + -- associated with Nam in the aspect. If such an entity is not present, + -- then returns Empty. (Note: This function is modeled on function + -- Get_Iterable_Type_Primitive.) + + function Storage_Model_Address_Type + (SM_Obj_Or_Type : Entity_Id) return Entity_Id; + -- Given a type with aspect Storage_Model_Type or an object of such a + -- type, returns the type specified for the Address_Type choice in that + -- aspect; returns Empty if the type isn't specified. + + function Storage_Model_Null_Address + (SM_Obj_Or_Type : Entity_Id) return Entity_Id; + -- Given a type with aspect Storage_Model_Type or an object of such a + -- type, returns the constant specified for the Null_Address choice in + -- that aspect; returns Empty if the constant object isn't specified. + + function Storage_Model_Allocate + (SM_Obj_Or_Type : Entity_Id) return Entity_Id; + -- Given a type with aspect Storage_Model_Type or an object of such a + -- type, returns the procedure specified for the Allocate choice in that + -- aspect; returns Empty if the procedure isn't specified. + + function Storage_Model_Deallocate + (SM_Obj_Or_Type : Entity_Id) return Entity_Id; + -- Given a type with aspect Storage_Model_Type or an object of such a + -- type, returns the procedure specified for the Deallocate choice in + -- that aspect; returns Empty if the procedure isn't specified. + + function Storage_Model_Copy_From + (SM_Obj_Or_Type : Entity_Id) return Entity_Id; + -- Given a type with aspect Storage_Model_Type or an object of such a + -- type, returns the procedure specified for the Copy_From choice in + -- that aspect; returns Empty if the procedure isn't specified. + + function Storage_Model_Copy_To + (SM_Obj_Or_Type : Entity_Id) return Entity_Id; + -- Given a type with aspect Storage_Model_Type or an object of such a + -- type, returns the procedure specified for the Copy_To choice in that + -- aspect; returns Empty if the procedure isn't specified. + + function Storage_Model_Storage_Size + (SM_Obj_Or_Type : Entity_Id) return Entity_Id; + -- Given a type with aspect Storage_Model_Type or an object of such a + -- type, returns the function specified for the Storage_Size choice in + -- that aspect; returns Empty if the procedure isn't specified. end Storage_Model_Support;