From patchwork Fri Oct 23 12:19:41 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 534946 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org 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 23E8E14131D for ; Fri, 23 Oct 2015 23:19:51 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=PW5m477E; dkim-atps=neutral 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=MnW+AqCAAStNIjM/dnc2yNSFkTfB1j/dc9V3ZRET6BFU+5r0x6 CPxmiPAkAbC5OaJjlWxoVvnmyJm+quByEQAX1GYrghSEpCzEwawxtXwG4ms/a+nX GyWT2SqtugE767s5mWDrRo0nWGwXilbhKFVr7IP8wvfxd/k9iHt+DhdPo= 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=AQ+8cFLID37IChElU6c+aasc5Ss=; b=PW5m477E67/L7YyYBoFJ FkTyAE4D/TO4PwmEE985BHSch7fDecdzH492ctWeCVsX2tFOBgqV/Gr8HoutTMvs R4TGJ4a3g5dw2KYtB7YoKbQtXsOemoVmcMTJxHPWW80N/MM0QQLgav1YBS9694sn mxn7be4sgmvTWKl5jfJgWtY= Received: (qmail 44427 invoked by alias); 23 Oct 2015 12:19:45 -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 44418 invoked by uid 89); 23 Oct 2015 12:19:45 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=1.9 required=5.0 tests=BAYES_50, KAM_ASCII_DIVIDERS, KAM_LAZY_DOMAIN_SECURITY, RCVD_IN_DNSWL_LOW autolearn=no version=3.3.2 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 (AES256-SHA encrypted) ESMTPS; Fri, 23 Oct 2015 12:19:44 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 1790B29520; Fri, 23 Oct 2015 08:19:42 -0400 (EDT) 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 a3OTSsDPVBxC; Fri, 23 Oct 2015 08:19:42 -0400 (EDT) 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 0515F28F4E; Fri, 23 Oct 2015 08:19:42 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 013C017C; Fri, 23 Oct 2015 08:19:41 -0400 (EDT) Date: Fri, 23 Oct 2015 08:19:41 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Instances of Ada.Unchecked_Conversion as volatile functions Message-ID: <20151023121941.GA34362@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch implements the following rule from the SPARK RM: 7.1.2 - (A protected function is also defined to be a volatile function,) as is an instance of Unchecked_Conversion where one or both of the actual Source and Target types are effectively volatile types. ------------- -- Source -- ------------- -- gnat.adc pragma SPARK_Mode (On); -- volatile_uc.ads with Ada.Unchecked_Conversion; package Volatile_UC is type Rec is null record; type Vol_Rec_1 is null record with Volatile; type Vol_Rec_2 is null record with Volatile; function Rec_To_Vol is new Ada.Unchecked_Conversion (Rec, Vol_Rec_1); function Vol_To_Rec is new Ada.Unchecked_Conversion (Vol_Rec_1, Rec); function Vol_To_Vol is new Ada.Unchecked_Conversion (Vol_Rec_1, Vol_Rec_2); procedure Test_UC; end Volatile_UC; -- volatile_uc.adb package body Volatile_UC is Rec_Obj : Rec; Vol_Obj_1 : Vol_Rec_1; Vol_Obj_2 : Vol_Rec_2; procedure Test_UC is Obj_Ren : Rec renames Vol_To_Rec (Vol_Obj_1); Vol_Ren_1 : Vol_Rec_1 renames Rec_To_Vol (Rec_Obj); Vol_Ren_2 : Vol_Rec_2 renames Vol_To_Vol (Vol_Obj_1); begin null; end Test_UC; end Volatile_UC; ----------------- -- Compilation -- ----------------- $ gcc -c volatile_uc.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2015-10-23 Hristian Kirtchev * sem_prag.adb (Analyze_Pragma): Pragma Volatile_Function should not apply to a function instantiation. * sem_util.adb (Has_Effectively_Volatile_Profile): New routine. (Is_Volatile_Function): An instance of Ada.Unchecked_Conversion is a volatile function when its profile contains an effectively volatile type. * sem_util.ads (Has_Effectively_Volatile_Profile): New routine. Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 229231) +++ sem_prag.adb (working copy) @@ -21543,14 +21543,9 @@ Subp_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True); - -- Function instantiation - - if Nkind (Subp_Decl) = N_Function_Instantiation then - null; - -- Generic subprogram - elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then + if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then null; -- Body acts as spec @@ -21578,7 +21573,6 @@ end if; Spec_Id := Corresponding_Spec_Of (Subp_Decl); - Over_Id := Overridden_Operation (Spec_Id); if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then Pragma_Misplaced; @@ -21595,6 +21589,8 @@ -- in New_Overloaded_Entity, however at that point the pragma has -- not been processed yet. + Over_Id := Overridden_Operation (Spec_Id); + if Present (Over_Id) and then not Is_Volatile_Function (Over_Id) then Index: sem_util.adb =================================================================== --- sem_util.adb (revision 229234) +++ sem_util.adb (working copy) @@ -2108,9 +2108,7 @@ T := Full_View (T); end if; - if Is_Descendent_Of_Address (T) - or else Is_Limited_Type (T) - then + if Is_Descendent_Of_Address (T) or else Is_Limited_Type (T) then Set_Is_Pure (Subp_Id, False); exit; end if; @@ -8552,6 +8550,39 @@ return False; end Has_Discriminant_Dependent_Constraint; + -------------------------------------- + -- Has_Effectively_Volatile_Profile -- + -------------------------------------- + + function Has_Effectively_Volatile_Profile + (Subp_Id : Entity_Id) return Boolean + is + Formal : Entity_Id; + + begin + -- Inspect the formal parameters looking for an effectively volatile + -- type. + + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + if Is_Effectively_Volatile (Etype (Formal)) then + return True; + end if; + + Next_Formal (Formal); + end loop; + + -- Inspect the return type of functions + + if Ekind_In (Subp_Id, E_Function, E_Generic_Function) + and then Is_Effectively_Volatile (Etype (Subp_Id)) + then + return True; + end if; + + return False; + end Has_Effectively_Volatile_Profile; + -------------------------- -- Has_Enabled_Property -- -------------------------- @@ -13721,6 +13752,14 @@ then return True; + -- An instance of Ada.Unchecked_Conversion is a volatile function if + -- either the source or the target are effectively volatile. + + elsif Is_Unchecked_Conversion_Instance (Func_Id) + and then Has_Effectively_Volatile_Profile (Func_Id) + then + return True; + -- Otherwise the function is treated as volatile if it is subject to -- enabled pragma Volatile_Function. Index: sem_util.ads =================================================================== --- sem_util.ads (revision 229234) +++ sem_util.ads (working copy) @@ -1006,6 +1006,11 @@ -- Returns True if and only if Comp has a constrained subtype that depends -- on a discriminant. + function Has_Effectively_Volatile_Profile + (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id has an effectively volatile formal + -- parameter or returns an effectively volatile value. + function Has_Infinities (E : Entity_Id) return Boolean; -- Determines if the range of the floating-point type E includes -- infinities. Returns False if E is not a floating-point type.