From patchwork Fri May 22 12:53:31 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 475598 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 82B241402BD for ; Fri, 22 May 2015 22:53:44 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=xOEP1Zoo; 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=k5HxBAlEvEdz6OyoKNO7Dw+YOyhcmtle844vRQbVjO3R4gvZ/1 VSyJp8OLzw0KKy6kHbKqo4Pd5dXmSr98h8dwkaf7i6JT1dV/sTx4eEIRFC/le2N/ uq1YTrB9uAlufj3oXquilEixQQqPcP5iMobKhqh/UySPW1xyME/txVXhU= 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=7Yy36bN2O6P61mFIVGvcDyfM58A=; b=xOEP1Zoo/1zT5nzoFUv0 HboBDh5Ajp2C2MK55PFLX04H9k939PwaAvK4SWrLnMWTNBQS21fbMfVZn1QddN5r Xj8ONJGVpbx9L+TszELF6xehu7yrq3bdvHOUCsFpmwlhfgWfeWfKPwCj7mRLHaXh GjSFWivCEwA/deY093+CLac= Received: (qmail 114332 invoked by alias); 22 May 2015 12:53:36 -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 114321 invoked by uid 89); 22 May 2015 12:53:35 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=1.9 required=5.0 tests=AWL, BAYES_99, KAM_ASCII_DIVIDERS, KAM_LAZY_DOMAIN_SECURITY 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, 22 May 2015 12:53:33 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 7E7FD28CCA; Fri, 22 May 2015 08:53:31 -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 6Fb0tTazSd7q; Fri, 22 May 2015 08:53:31 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 6C1DE286C4; Fri, 22 May 2015 08:53:31 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 684B0439C4; Fri, 22 May 2015 08:53:31 -0400 (EDT) Date: Fri, 22 May 2015 08:53:31 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Make sure Volatile_Full_Access is treated like Atomic Message-ID: <20150522125331.GA3733@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.21 (2010-09-15) This update makes sure that Volatile_Full_Access is treated like Atomic in all cases except checking specific RM legality rules, and controlling atomic synchronization. Tested on x86_64-pc-linux-gnu, committed on trunk 2015-05-22 Robert Dewar * exp_ch5.adb, layout.adb, einfo.adb, einfo.ads, sem_prag.adb, freeze.adb, freeze.ads, sem_util.adb, sem_util.ads, exp_ch2.adb, exp_ch4.adb, errout.adb, exp_aggr.adb, sem_ch13.adb: This is a general change that deals with the fact that most of the special coding for Atomic should also apply to the case of Volatile_Full_Access. A new attribute Is_Atomic_Or_VFA is introduced, and many of the references to Is_Atomic now use this new attribute. Index: exp_ch5.adb =================================================================== --- exp_ch5.adb (revision 223476) +++ exp_ch5.adb (working copy) @@ -429,11 +429,11 @@ elsif Has_Controlled_Component (L_Type) then Loop_Required := True; - -- If object is atomic, we cannot tolerate a loop + -- If object is atomic/VFA, we cannot tolerate a loop - elsif Is_Atomic_Object (Act_Lhs) + elsif Is_Atomic_Or_VFA_Object (Act_Lhs) or else - Is_Atomic_Object (Act_Rhs) + Is_Atomic_Or_VFA_Object (Act_Rhs) then return; @@ -442,8 +442,8 @@ elsif Has_Atomic_Components (L_Type) or else Has_Atomic_Components (R_Type) - or else Is_Atomic (Component_Type (L_Type)) - or else Is_Atomic (Component_Type (R_Type)) + or else Is_Atomic_Or_VFA (Component_Type (L_Type)) + or else Is_Atomic_Or_VFA (Component_Type (R_Type)) then Loop_Required := True; @@ -3395,7 +3395,7 @@ Next_Elmt (Prim); end loop; - -- default iterator must exist. + -- Default iterator must exist pragma Assert (False); Index: layout.adb =================================================================== --- layout.adb (revision 223476) +++ layout.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2684,11 +2684,11 @@ elsif Is_Array_Type (E) then - -- For arrays that are required to be atomic, we do the same + -- For arrays that are required to be atomic/VFA, we do the same -- processing as described above for short records, since we -- really need to have the alignment set for the whole array. - if Is_Atomic (E) and then not Debug_Flag_Q then + if Is_Atomic_Or_VFA (E) and then not Debug_Flag_Q then Set_Composite_Alignment (E); end if; @@ -2903,11 +2903,19 @@ and then Is_Record_Type (E) and then Is_Packed (E) then - -- No effect for record with atomic components + -- No effect for record with atomic/VFA components - if Is_Atomic (E) then + if Is_Atomic_Or_VFA (E) then Error_Msg_N ("Optimize_Alignment has no effect for &??", E); - Error_Msg_N ("\pragma ignored for atomic record??", E); + + if Is_Atomic (E) then + Error_Msg_N + ("\pragma ignored for atomic record??", E); + else + Error_Msg_N + ("\pragma ignored for bolatile full access record??", E); + end if; + return; end if; @@ -2920,20 +2928,30 @@ return; end if; - -- No effect if any component is atomic or is a by reference type + -- No effect if any component is atomic/VFA or is a by reference type declare Ent : Entity_Id; + begin Ent := First_Component_Or_Discriminant (E); while Present (Ent) loop if Is_By_Reference_Type (Etype (Ent)) - or else Is_Atomic (Etype (Ent)) - or else Is_Atomic (Ent) + or else Is_Atomic_Or_VFA (Etype (Ent)) + or else Is_Atomic_Or_VFA (Ent) then Error_Msg_N ("Optimize_Alignment has no effect for &??", E); - Error_Msg_N - ("\pragma is ignored if atomic components present??", E); + + if Is_Atomic (Etype (Ent)) or else Is_Atomic (Ent) then + Error_Msg_N + ("\pragma is ignored if atomic " + & "components present??", E); + else + Error_Msg_N + ("\pragma is ignored if bolatile full access " + & "components present??", E); + end if; + return; else Next_Component_Or_Discriminant (Ent); @@ -3026,9 +3044,9 @@ -- Further processing for record types only to reduce the alignment -- set by the above processing in some specific cases. We do not - -- do this for atomic records, since we need max alignment there, + -- do this for atomic/VFA records, since we need max alignment there, - if Is_Record_Type (E) and then not Is_Atomic (E) then + if Is_Record_Type (E) and then not Is_Atomic_Or_VFA (E) then -- For records, there is generally no point in setting alignment -- higher than word size since we cannot do better than move by Index: einfo.adb =================================================================== --- einfo.adb (revision 223557) +++ einfo.adb (working copy) @@ -7329,6 +7329,15 @@ end if; end Invariant_Procedure; + ---------------------- + -- Is_Atomic_Or_VFA -- + ---------------------- + + function Is_Atomic_Or_VFA (Id : E) return B is + begin + return Is_Atomic (Id) or else Has_Volatile_Full_Access (Id); + end Is_Atomic_Or_VFA; + ------------------ -- Is_Base_Type -- ------------------ Index: einfo.ads =================================================================== --- einfo.ads (revision 223557) +++ einfo.ads (working copy) @@ -2218,6 +2218,14 @@ -- In the case of private and incomplete types, this flag is set in -- both the partial view and the full view. +-- Is_Atomic_Or_VFA (synth) +-- Defined in all type entities, and also in constants, components and +-- variables. Set if a pragma Atomic or Shared or Volatile_Full_Access +-- applies to the entity. For many purposes VFA objects should be treated +-- the same as Atomic objects, and this predicate is intended for that +-- usage. In the case of private and incomplete types, the predicate +-- applies to both the partial view and the full view. + -- Is_Array_Type (synthesized) -- Applies to all entities, true for array types and subtypes @@ -5476,6 +5484,7 @@ -- Implementation_Base_Type (synth) -- Invariant_Procedure (synth) -- Is_Access_Protected_Subprogram_Type (synth) + -- Is_Atomic_Or_VFA (synth) -- Predicate_Function (synth) -- Predicate_Function_M (synth) -- Root_Type (synth) @@ -5628,6 +5637,7 @@ -- Is_Tag (Flag78) -- Is_Volatile (Flag16) -- Treat_As_Volatile (Flag41) + -- Is_Atomic_Or_VFA (synth) -- Next_Component (synth) -- Next_Component_Or_Discriminant (synth) @@ -5676,6 +5686,7 @@ -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) -- Alignment_Clause (synth) + -- Is_Atomic_Or_VFA (synth) -- Size_Clause (synth) -- E_Decimal_Fixed_Point_Type @@ -6413,6 +6424,7 @@ -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) -- Alignment_Clause (synth) + -- Is_Atomic_Or_VFA (synth) -- Size_Clause (synth) -- E_Void @@ -6869,6 +6881,7 @@ function Is_Aliased (Id : E) return B; function Is_Asynchronous (Id : E) return B; function Is_Atomic (Id : E) return B; + function Is_Atomic_Or_VFA (Id : E) return B; function Is_Bit_Packed_Array (Id : E) return B; function Is_Called (Id : E) return B; function Is_Character_Type (Id : E) return B; @@ -9041,6 +9054,7 @@ -- be handled by xeinfo. pragma Inline (Base_Type); + pragma Inline (Is_Atomic_Or_VFA); pragma Inline (Is_Base_Type); pragma Inline (Is_Package_Or_Generic_Package); pragma Inline (Is_Packed_Array); Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 223548) +++ sem_prag.adb (working copy) @@ -5842,17 +5842,17 @@ K : Node_Kind; Utyp : Entity_Id; - procedure Set_Atomic_Full (E : Entity_Id); + procedure Set_Atomic_VFA (E : Entity_Id); -- Set given type as Is_Atomic or Has_Volatile_Full_Access. Also, if -- no explicit alignment was given, set alignment to unknown, since -- back end knows what the alignment requirements are for atomic and -- full access arrays. Note: this is necessary for derived types. - --------------------- - -- Set_Atomic_Full -- - --------------------- + -------------------- + -- Set_Atomic_VFA -- + -------------------- - procedure Set_Atomic_Full (E : Entity_Id) is + procedure Set_Atomic_VFA (E : Entity_Id) is begin if Prag_Id = Pragma_Volatile_Full_Access then Set_Has_Volatile_Full_Access (E); @@ -5863,7 +5863,7 @@ if not Has_Alignment_Clause (E) then Set_Alignment (E, Uint_0); end if; - end Set_Atomic_Full; + end Set_Atomic_VFA; -- Start of processing for Process_Atomic_Independent_Shared_Volatile @@ -5956,9 +5956,9 @@ or else Prag_Id = Pragma_Volatile_Full_Access then - Set_Atomic_Full (E); - Set_Atomic_Full (Base_Type (E)); - Set_Atomic_Full (Underlying_Type (E)); + Set_Atomic_VFA (E); + Set_Atomic_VFA (Base_Type (E)); + Set_Atomic_VFA (Underlying_Type (E)); end if; -- Atomic/Shared/Volatile_Full_Access imply Independent Index: freeze.adb =================================================================== --- freeze.adb (revision 223549) +++ freeze.adb (working copy) @@ -942,13 +942,13 @@ Packed_Size_Known := False; end if; - -- We do not know the packed size if we have an atomic type + -- We do not know the packed size for an atomic/VFA type -- or component, or an independent type or component, or a -- by reference type or aliased component (because packing -- does not touch these). - if Is_Atomic (Ctyp) - or else Is_Atomic (Comp) + if Is_Atomic_Or_VFA (Ctyp) + or else Is_Atomic_Or_VFA (Comp) or else Is_Independent (Ctyp) or else Is_Independent (Comp) or else Is_By_Reference_Type (Ctyp) @@ -1036,11 +1036,11 @@ and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Ctyp))) then - -- Packed size unknown if we have an atomic type - -- or a by reference type, since the back end - -- knows how these are layed out. + -- Packed size unknown if we have an atomic/VFA type + -- or a by reference type, since the back end knows + -- how these are layed out. - if Is_Atomic (Ctyp) + if Is_Atomic_Or_VFA (Ctyp) or else Is_By_Reference_Type (Ctyp) then Packed_Size_Known := False; @@ -1455,11 +1455,11 @@ end loop; end Check_Unsigned_Type; - ------------------------- - -- Is_Atomic_Aggregate -- - ------------------------- + ----------------------------- + -- Is_Atomic_VFA_Aggregate -- + ----------------------------- - function Is_Atomic_Aggregate + function Is_Atomic_VFA_Aggregate (E : Entity_Id; Typ : Entity_Id) return Boolean is @@ -1495,7 +1495,7 @@ else return False; end if; - end Is_Atomic_Aggregate; + end Is_Atomic_VFA_Aggregate; ----------------------------------------------- -- Explode_Initialization_Compound_Statement -- @@ -2423,12 +2423,12 @@ end if; end; - -- Check for Aliased or Atomic_Components/Atomic with unsuitable - -- packing or explicit component size clause given. + -- Check for Aliased or Atomic_Components/Atomic/VFA with + -- unsuitable packing or explicit component size clause given. if (Has_Aliased_Components (Arr) or else Has_Atomic_Components (Arr) - or else Is_Atomic (Ctyp)) + or else Is_Atomic_Or_VFA (Ctyp)) and then (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr)) then @@ -2436,8 +2436,8 @@ procedure Complain_CS (T : String); -- Outputs error messages for incorrect CS clause or pragma - -- Pack for aliased or atomic components (T is "aliased" or - -- "atomic"); + -- Pack for aliased or atomic/VFA components (T is "aliased" + -- or "atomic/vfa"); ----------------- -- Complain_CS -- @@ -2498,9 +2498,13 @@ elsif Has_Aliased_Components (Arr) then Complain_CS ("aliased"); - elsif Has_Atomic_Components (Arr) or else Is_Atomic (Ctyp) + elsif Has_Atomic_Components (Arr) + or else Is_Atomic (Ctyp) then Complain_CS ("atomic"); + + elsif Has_Volatile_Full_Access (Ctyp) then + Complain_CS ("volatile full access"); end if; end Alias_Atomic_Check; end if; @@ -2509,8 +2513,8 @@ -- packing or explicit component size clause given. if (Has_Independent_Components (Arr) or else Is_Independent (Ctyp)) - and then - (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr)) + and then + (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr)) then begin -- If object size of component type isn't known, we cannot @@ -2772,7 +2776,7 @@ -- For non-packed arrays set the alignment of the array to the -- alignment of the component type if it is unknown. Skip this - -- in atomic case (atomic arrays may need larger alignments). + -- in atomic/VFA case (atomic/VFA arrays may need larger alignments). if not Is_Packed (Arr) and then Unknown_Alignment (Arr) @@ -2780,7 +2784,7 @@ and then Known_Static_Component_Size (Arr) and then Known_Static_Esize (Ctyp) and then Esize (Ctyp) = Component_Size (Arr) - and then not Is_Atomic (Arr) + and then not Is_Atomic_Or_VFA (Arr) then Set_Alignment (Arr, Alignment (Component_Type (Arr))); end if; @@ -4813,11 +4817,12 @@ -- than component-wise (the assignment to the temp may be done -- component-wise, but that is harmless). - elsif Is_Atomic (E) + elsif Is_Atomic_Or_VFA (E) and then Nkind (Parent (E)) = N_Object_Declaration and then Present (Expression (Parent (E))) and then Nkind (Expression (Parent (E))) = N_Aggregate - and then Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E)) + and then + Is_Atomic_VFA_Aggregate (Expression (Parent (E)), Etype (E)) then null; end if; Index: freeze.ads =================================================================== --- freeze.ads (revision 223476) +++ freeze.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -174,12 +174,11 @@ -- do not allow a size clause if the size would not otherwise be known at -- compile time in any case. - function Is_Atomic_Aggregate + function Is_Atomic_VFA_Aggregate (E : Entity_Id; Typ : Entity_Id) return Boolean; - - -- If an atomic object is initialized with an aggregate or is assigned an - -- aggregate, we have to prevent a piecemeal access or assignment to the + -- If an atomic/VFA object is initialized with an aggregate or is assigned + -- an aggregate, we have to prevent a piecemeal access or assignment to the -- object, even if the aggregate is to be expanded. We create a temporary -- for the aggregate, and assign the temporary instead, so that the back -- end can generate an atomic move for it. This is only done in the context Index: sem_util.adb =================================================================== --- sem_util.adb (revision 223541) +++ sem_util.adb (working copy) @@ -10276,6 +10276,20 @@ end if; end Is_Atomic_Object; + ----------------------------- + -- Is_Atomic_Or_VFA_Object -- + ----------------------------- + + function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is + begin + return Is_Atomic_Object (N) + or else (Is_Object_Reference (N) + and then Is_Entity_Name (N) + and then (Has_Volatile_Full_Access (Entity (N)) + or else + Has_Volatile_Full_Access (Etype (Entity (N))))); + end Is_Atomic_Or_VFA_Object; + ------------------------- -- Is_Attribute_Result -- ------------------------- Index: sem_util.ads =================================================================== --- sem_util.ads (revision 223535) +++ sem_util.ads (working copy) @@ -1168,6 +1168,10 @@ -- Determines if the given node denotes an atomic object in the sense of -- the legality checks described in RM C.6(12). + function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean; + -- Determines if the given node is an atomic object (Is_Atomic_Object true) + -- or else is an object for which VFA is present. + function Is_Attribute_Result (N : Node_Id) return Boolean; -- Determine whether node N denotes attribute 'Result Index: exp_ch2.adb =================================================================== --- exp_ch2.adb (revision 223476) +++ exp_ch2.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -396,7 +396,8 @@ Write_Eol; end if; - -- Set Atomic_Sync_Required if necessary for atomic variable + -- Set Atomic_Sync_Required if necessary for atomic variable. Note that + -- this processing does NOT apply to Volatile_Full_Access variables. if Nkind_In (N, N_Identifier, N_Expanded_Name) and then Ekind (E) = E_Variable Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 223559) +++ exp_ch4.adb (working copy) @@ -7313,12 +7313,12 @@ -- Where the component type is elementary we can use a block bit -- comparison (if supported on the target) exception in the case -- of floating-point (negative zero issues require element by - -- element comparison), and atomic types (where we must be sure + -- element comparison), and atomic/VFA types (where we must be sure -- to load elements independently) and possibly unaligned arrays. elsif Is_Elementary_Type (Component_Type (Typl)) and then not Is_Floating_Point_Type (Component_Type (Typl)) - and then not Is_Atomic (Component_Type (Typl)) + and then not Is_Atomic_Or_VFA (Component_Type (Typl)) and then not Is_Possibly_Unaligned_Object (Lhs) and then not Is_Possibly_Unaligned_Object (Rhs) and then Support_Composite_Compare_On_Target Index: errout.adb =================================================================== --- errout.adb (revision 223476) +++ errout.adb (working copy) @@ -3159,6 +3159,16 @@ return True; end if; + -- Similar processing for "volatile full access cannot be guaranteed" + + elsif Msg = "volatile full access to & cannot be guaranteed" then + if Is_Type (E) + and then Has_Volatile_Full_Access (E) + and then No (Get_Rep_Pragma (E, Name_Volatile_Full_Access)) + then + return True; + end if; + -- Processing for "Size too small" messages elsif Msg = "size for& too small, minimum allowed is ^" then Index: exp_aggr.adb =================================================================== --- exp_aggr.adb (revision 223476) +++ exp_aggr.adb (working copy) @@ -4175,7 +4175,7 @@ Ctyp := Component_Type (Ctyp); - if Is_Atomic (Ctyp) then + if Is_Atomic_Or_VFA (Ctyp) then return False; end if; end loop; @@ -5935,15 +5935,15 @@ -- Start of processing for Expand_Record_Aggregate begin - -- If the aggregate is to be assigned to an atomic variable, we have + -- If the aggregate is to be assigned to an atomic/VFA variable, we have -- to prevent a piecemeal assignment even if the aggregate is to be -- expanded. We create a temporary for the aggregate, and assign the -- temporary instead, so that the back end can generate an atomic move -- for it. - if Is_Atomic (Typ) + if Is_Atomic_Or_VFA (Typ) and then Comes_From_Source (Parent (N)) - and then Is_Atomic_Aggregate (N, Typ) + and then Is_Atomic_VFA_Aggregate (N, Typ) then return; Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 223557) +++ sem_ch13.adb (working copy) @@ -965,6 +965,13 @@ Set_Is_Volatile (E); end if; + -- Volatile_Full_Access + + when Aspect_Volatile_Full_Access => + if Has_Volatile_Full_Access (P) then + Set_Has_Volatile_Full_Access (E); + end if; + -- Volatile_Components when Aspect_Volatile_Components => @@ -1057,6 +1064,11 @@ return; end if; + when Aspect_Volatile_Full_Access => + if not Has_Volatile_Full_Access (Par) then + return; + end if; + when others => return; end case; @@ -1066,7 +1078,6 @@ Error_Msg_Name_1 := A_Name; Error_Msg_NE ("derived type& inherits aspect%, cannot cancel", Expr, E); - end Check_False_Aspect_For_Derived_Type; -- Start of processing for Make_Pragma_From_Boolean_Aspect @@ -11164,6 +11175,18 @@ Set_Is_Volatile (Typ); end if; + -- Volatile_Full_Access + + if not Has_Rep_Item (Typ, Name_Volatile_Full_Access, False) + and then Has_Rep_Pragma (Typ, Name_Volatile_Full_Access) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Volatile_Full_Access)) + then + Set_Has_Volatile_Full_Access (Typ); + Set_Treat_As_Volatile (Typ); + Set_Is_Volatile (Typ); + end if; + -- Inheritance for derived types only if Is_Derived_Type (Typ) then