diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-08-01 09:25:46 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-08-01 09:25:46 +0000 |
commit | 0b424e9be6f961c9be3446505fe32d62edcc22a8 (patch) | |
tree | 4ad614e2c8327baf70062e1362be345789d1a42d | |
parent | 69b6b231df3bd6836ed8734b1a52b975aa1eb7c8 (diff) | |
download | gcc-0b424e9be6f961c9be3446505fe32d62edcc22a8.tar.gz |
2011-08-01 Robert Dewar <dewar@adacore.com>
* aspects.ads (Boolean_Aspects): New subtype.
* exp_ch13.adb (Expand_Freeze_Entity): Fix errors in handling aspects
for derived types in cases where the parent type and derived type have
aspects.
* freeze.adb (Freeze_Entity): Fix problems in handling derived type
with aspects when parent type also has aspects.
(Freeze_Entity): Deal with delay of boolean aspects (must evaluate
boolean expression at this point).
* sem_ch13.adb (Analyze_Aspect_Specifications): Delay all aspects in
accordance with final decision on the Ada 2012 feature.
* sinfo.ads, sinfo.adb (Is_Boolean_Aspect): New flag.
2011-08-01 Matthew Heaney <heaney@adacore.com>
* a-chtgbo.adb (Delete_Node_Sans_Free): Replace iterator with selector.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177005 138bc75d-0d04-0410-961f-82ee72b054a4
-rw-r--r-- | gcc/ada/ChangeLog | 18 | ||||
-rw-r--r-- | gcc/ada/a-chtgbo.adb | 6 | ||||
-rwxr-xr-x | gcc/ada/aspects.ads | 80 | ||||
-rw-r--r-- | gcc/ada/exp_ch13.adb | 8 | ||||
-rw-r--r-- | gcc/ada/freeze.adb | 42 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 114 | ||||
-rw-r--r-- | gcc/ada/sinfo.adb | 16 | ||||
-rw-r--r-- | gcc/ada/sinfo.ads | 13 |
8 files changed, 150 insertions, 147 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 12ba03bd771..3d054405b6c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2011-08-01 Robert Dewar <dewar@adacore.com> + + * aspects.ads (Boolean_Aspects): New subtype. + * exp_ch13.adb (Expand_Freeze_Entity): Fix errors in handling aspects + for derived types in cases where the parent type and derived type have + aspects. + * freeze.adb (Freeze_Entity): Fix problems in handling derived type + with aspects when parent type also has aspects. + (Freeze_Entity): Deal with delay of boolean aspects (must evaluate + boolean expression at this point). + * sem_ch13.adb (Analyze_Aspect_Specifications): Delay all aspects in + accordance with final decision on the Ada 2012 feature. + * sinfo.ads, sinfo.adb (Is_Boolean_Aspect): New flag. + +2011-08-01 Matthew Heaney <heaney@adacore.com> + + * a-chtgbo.adb (Delete_Node_Sans_Free): Replace iterator with selector. + 2011-08-01 Pascal Obry <obry@adacore.com> * a-stzunb-shared.adb, a-strunb-shared.adb, a-stwiun-shared.adb: diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb index 700ca2ebd51..b19668e1391 100644 --- a/gcc/ada/a-chtgbo.adb +++ b/gcc/ada/a-chtgbo.adb @@ -78,7 +78,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is end if; if Prev = X then - HT.Buckets (Indx) := Next (HT, Prev); + HT.Buckets (Indx) := Next (HT.Nodes (Prev)); HT.Length := HT.Length - 1; return; end if; @@ -89,7 +89,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is end if; loop - Curr := Next (HT, Prev); + Curr := Next (HT.Nodes (Prev)); if Curr = 0 then raise Program_Error with @@ -97,7 +97,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is end if; if Curr = X then - Set_Next (HT.Nodes (Prev), Next => Next (HT, Curr)); + Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr))); HT.Length := HT.Length - 1; return; end if; diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 9f44197dd42..6dabef3dfcc 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -43,51 +43,56 @@ package Aspects is type Aspect_Id is (No_Aspect, -- Dummy entry for no aspect - Aspect_Ada_2005, -- GNAT - Aspect_Ada_2012, -- GNAT Aspect_Address, Aspect_Alignment, - Aspect_Atomic, - Aspect_Atomic_Components, Aspect_Bit_Order, Aspect_Component_Size, - Aspect_Discard_Names, Aspect_External_Tag, - Aspect_Favor_Top_Level, -- GNAT - Aspect_Inline, - Aspect_Inline_Always, -- GNAT Aspect_Input, Aspect_Invariant, Aspect_Machine_Radix, - Aspect_No_Return, Aspect_Object_Size, -- GNAT Aspect_Output, - Aspect_Pack, - Aspect_Persistent_BSS, -- GNAT Aspect_Post, Aspect_Pre, - Aspect_Predicate, -- GNAT??? - Aspect_Preelaborable_Initialization, - Aspect_Pure_Function, -- GNAT + Aspect_Predicate, Aspect_Read, - Aspect_Shared, -- GNAT (equivalent to Atomic) Aspect_Size, Aspect_Storage_Pool, Aspect_Storage_Size, Aspect_Stream_Size, Aspect_Suppress, + Aspect_Unsuppress, + Aspect_Value_Size, -- GNAT + Aspect_Warnings, + Aspect_Write, + + -- Remaining aspects have a static boolean value that turns the aspect + -- on or off. They all correspond to pragmas, and the flag Aspect_Cancel + -- is set on the pragma if the corresponding aspect is False. + + Aspect_Ada_2005, -- GNAT + Aspect_Ada_2012, -- GNAT + Aspect_Atomic, + Aspect_Atomic_Components, + Aspect_Discard_Names, + Aspect_Favor_Top_Level, -- GNAT + Aspect_Inline, + Aspect_Inline_Always, -- GNAT + Aspect_No_Return, + Aspect_Pack, + Aspect_Persistent_BSS, -- GNAT + Aspect_Preelaborable_Initialization, + Aspect_Pure_Function, -- GNAT + Aspect_Shared, -- GNAT (equivalent to Atomic) Aspect_Suppress_Debug_Info, -- GNAT Aspect_Unchecked_Union, Aspect_Universal_Aliasing, -- GNAT Aspect_Unmodified, -- GNAT Aspect_Unreferenced, -- GNAT Aspect_Unreferenced_Objects, -- GNAT - Aspect_Unsuppress, - Aspect_Value_Size, -- GNAT Aspect_Volatile, - Aspect_Volatile_Components, - Aspect_Warnings, - Aspect_Write); -- GNAT + Aspect_Volatile_Components); -- The following array indicates aspects that accept 'Class @@ -98,6 +103,16 @@ package Aspects is Aspect_Post => True, others => False); + -- The following subtype defines aspects accepting an optional static + -- boolean parameter indicating if the aspect should be active or + -- cancelling. If the parameter is missing the effective value is True, + -- enabling the aspect. If the parameter is present it must be a static + -- expression of type Standard.Boolean. If the value is True, then the + -- aspect is enabled. If it is False, the aspect is disabled. + + subtype Boolean_Aspects is + Aspect_Id range Aspect_Ada_2005 .. Aspect_Id'Last; + -- The following type is used for indicating allowed expression forms type Aspect_Expression is @@ -109,51 +124,30 @@ package Aspects is Aspect_Argument : constant array (Aspect_Id) of Aspect_Expression := (No_Aspect => Optional, - Aspect_Ada_2005 => Optional, - Aspect_Ada_2012 => Optional, Aspect_Address => Expression, Aspect_Alignment => Expression, - Aspect_Atomic => Optional, - Aspect_Atomic_Components => Optional, Aspect_Bit_Order => Expression, Aspect_Component_Size => Expression, - Aspect_Discard_Names => Optional, Aspect_External_Tag => Expression, - Aspect_Favor_Top_Level => Optional, - Aspect_Inline => Optional, - Aspect_Inline_Always => Optional, Aspect_Input => Name, Aspect_Invariant => Expression, Aspect_Machine_Radix => Expression, - Aspect_No_Return => Optional, Aspect_Object_Size => Expression, Aspect_Output => Name, - Aspect_Persistent_BSS => Optional, - Aspect_Pack => Optional, Aspect_Post => Expression, Aspect_Pre => Expression, Aspect_Predicate => Expression, - Aspect_Preelaborable_Initialization => Optional, - Aspect_Pure_Function => Optional, Aspect_Read => Name, - Aspect_Shared => Optional, Aspect_Size => Expression, Aspect_Storage_Pool => Name, Aspect_Storage_Size => Expression, Aspect_Stream_Size => Expression, Aspect_Suppress => Name, - Aspect_Suppress_Debug_Info => Optional, - Aspect_Unchecked_Union => Optional, - Aspect_Universal_Aliasing => Optional, - Aspect_Unmodified => Optional, - Aspect_Unreferenced => Optional, - Aspect_Unreferenced_Objects => Optional, Aspect_Unsuppress => Name, Aspect_Value_Size => Expression, - Aspect_Volatile => Optional, - Aspect_Volatile_Components => Optional, Aspect_Warnings => Name, - Aspect_Write => Name); + Aspect_Write => Name, + Boolean_Aspects => Optional); function Get_Aspect_Id (Name : Name_Id) return Aspect_Id; pragma Inline (Get_Aspect_Id); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index f3de66c6a12..47e39c4f38b 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -232,9 +232,13 @@ package body Exp_Ch13 is Ritem : Node_Id; begin + -- Look for aspect specs for this entity + Ritem := First_Rep_Item (E); while Present (Ritem) loop - if Nkind (Ritem) = N_Aspect_Specification then + if Nkind (Ritem) = N_Aspect_Specification + and then Entity (Ritem) = E + then Aitem := Aspect_Rep_Item (Ritem); pragma Assert (Is_Delayed_Aspect (Aitem)); Insert_Before (N, Aitem); @@ -288,7 +292,7 @@ package body Exp_Ch13 is if Ekind (E_Scope) = E_Protected_Type or else (Ekind (E_Scope) = E_Task_Type - and then not Has_Completion (E_Scope)) + and then not Has_Completion (E_Scope)) then E_Scope := Scope (E_Scope); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 9ef3a55a508..545175f8ffd 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2370,24 +2370,58 @@ package body Freeze is end; end if; - -- Deal with delayed aspect specifications. At the point of occurrence - -- of the aspect definition, we preanalyzed the argument, to capture - -- the visibility at that point, but the actual analysis of the aspect + -- Deal with delayed aspect specifications. The analysis of the aspect -- is required to be delayed to the freeze point, so we evaluate the -- pragma or attribute definition clause in the tree at this point. + -- We also have to deal with the case of Boolean aspects, where the + -- value of the Boolean expression is represented by the setting of + -- the Aspect_Cancel flag on the pragma. + if Has_Delayed_Aspects (E) then declare Ritem : Node_Id; Aitem : Node_Id; begin + -- Look for aspect specification entries for this entity + Ritem := First_Rep_Item (E); while Present (Ritem) loop - if Nkind (Ritem) = N_Aspect_Specification then + if Nkind (Ritem) = N_Aspect_Specification + and then Entity (Ritem) = E + then Aitem := Aspect_Rep_Item (Ritem); pragma Assert (Is_Delayed_Aspect (Aitem)); Set_Parent (Aitem, Ritem); + + -- Deal with Boolean case, if no expression, True, otherwise + -- analyze the expression, check it is static, and if its + -- value is False, set Aspect_Cancel for the related pragma. + + if Is_Boolean_Aspect (Ritem) then + declare + Expr : constant Node_Id := Expression (Ritem); + + begin + if Present (Expr) then + Analyze_And_Resolve (Expr, Standard_Boolean); + + if not Is_OK_Static_Expression (Expr) then + Error_Msg_Name_1 := Chars (Identifier (Ritem)); + Error_Msg_N + ("expression for % aspect must be static", + Expr); + + elsif Is_False (Expr_Value (Expr)) then + Set_Aspect_Cancel (Aitem); + end if; + end if; + end; + end if; + + -- Analyze the pragma after possibly setting Aspect_Cancel + Analyze (Aitem); end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 128b398bf7b..dc4b03dcc98 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -740,7 +740,6 @@ package body Sem_Ch13 is Nam : constant Name_Id := Chars (Id); A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); Anod : Node_Id; - T : Entity_Id; Eloc : Source_Ptr := Sloc (Expr); -- Source location of expression, modified when we split PPC's @@ -811,31 +810,12 @@ package body Sem_Ch13 is raise Program_Error; -- Aspects taking an optional boolean argument. For all of - -- these we just create a matching pragma and insert it, - -- setting flag Cancel_Aspect if the expression is False. - - when Aspect_Ada_2005 | - Aspect_Ada_2012 | - Aspect_Atomic | - Aspect_Atomic_Components | - Aspect_Discard_Names | - Aspect_Favor_Top_Level | - Aspect_Inline | - Aspect_Inline_Always | - Aspect_No_Return | - Aspect_Pack | - Aspect_Persistent_BSS | - Aspect_Preelaborable_Initialization | - Aspect_Pure_Function | - Aspect_Shared | - Aspect_Suppress_Debug_Info | - Aspect_Unchecked_Union | - Aspect_Universal_Aliasing | - Aspect_Unmodified | - Aspect_Unreferenced | - Aspect_Unreferenced_Objects | - Aspect_Volatile | - Aspect_Volatile_Components => + -- these we just create a matching pragma and insert it. When + -- the aspect is processed to insert the pragma, the expression + -- is analyzed, setting Cancel_Aspect if the value is False. + + when Boolean_Aspects => + Set_Is_Boolean_Aspect (Aspect); -- Build corresponding pragma node @@ -845,32 +825,17 @@ package body Sem_Ch13 is Pragma_Identifier => Make_Identifier (Sloc (Id), Chars (Id))); - -- Deal with missing expression case, delay never needed + -- No delay required if no expression (nothing to delay!) if No (Expr) then Delay_Required := False; - -- Expression is present + -- Expression is present, delay is required. Note that + -- even if the expression is "True", some idiot might + -- define True as False before the freeze point! else - Preanalyze_Spec_Expression (Expr, Standard_Boolean); - - -- If preanalysis gives a static expression, we don't - -- need to delay (this will happen often in practice). - - if Is_OK_Static_Expression (Expr) then - Delay_Required := False; - - if Is_False (Expr_Value (Expr)) then - Set_Aspect_Cancel (Aitem); - end if; - - -- If we don't get a static expression, then delay, the - -- expression may turn out static by freeze time. - - else - Delay_Required := True; - end if; + Delay_Required := True; end if; -- Aspects corresponding to attribute definition clauses @@ -880,30 +845,17 @@ package body Sem_Ch13 is Aspect_Bit_Order | Aspect_Component_Size | Aspect_External_Tag | + Aspect_Input | Aspect_Machine_Radix | Aspect_Object_Size | + Aspect_Output | + Aspect_Read | Aspect_Size | Aspect_Storage_Pool | Aspect_Storage_Size | Aspect_Stream_Size | - Aspect_Value_Size => - - -- Preanalyze the expression with the appropriate type - - case A_Id is - when Aspect_Address => - T := RTE (RE_Address); - when Aspect_Bit_Order => - T := RTE (RE_Bit_Order); - when Aspect_External_Tag => - T := Standard_String; - when Aspect_Storage_Pool => - T := Class_Wide_Type (RTE (RE_Root_Storage_Pool)); - when others => - T := Any_Integer; - end case; - - Preanalyze_Spec_Expression (Expr, T); + Aspect_Value_Size | + Aspect_Write => -- Construct the attribute definition clause @@ -913,16 +865,9 @@ package body Sem_Ch13 is Chars => Chars (Id), Expression => Relocate_Node (Expr)); - -- We do not need a delay if we have a static expression - - if Is_OK_Static_Expression (Expression (Aitem)) then - Delay_Required := False; - -- Here a delay is required - else - Delay_Required := True; - end if; + Delay_Required := True; -- Aspects corresponding to pragmas with two arguments, where -- the first argument is a local name referring to the entity, @@ -946,27 +891,6 @@ package body Sem_Ch13 is Delay_Required := False; - -- Aspects corresponding to stream routines - - when Aspect_Input | - Aspect_Output | - Aspect_Read | - Aspect_Write => - - -- Construct the attribute definition clause - - Aitem := - Make_Attribute_Definition_Clause (Loc, - Name => Ent, - Chars => Chars (Id), - Expression => Relocate_Node (Expr)); - - -- These are always delayed (typically the subprogram that - -- is referenced cannot have been declared yet, since it has - -- a reference to the type for which this aspect is defined. - - Delay_Required := True; - -- Aspects corresponding to pragmas with two arguments, where -- the second argument is a local name referring to the entity, -- and the first argument is the aspect definition expression. @@ -985,7 +909,7 @@ package body Sem_Ch13 is Class_Present => Class_Present (Aspect)); -- We don't have to play the delay game here, since the only - -- values are check names which don't get analyzed anyway. + -- values are ON/OFF which don't get analyzed anyway. Delay_Required := False; @@ -1015,7 +939,7 @@ package body Sem_Ch13 is -- these conditions together in a complex OR expression if Pname = Name_Postcondition - or else not Class_Present (Aspect) + or else not Class_Present (Aspect) then while Nkind (Expr) = N_And_Then loop Insert_After (Aspect, diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 64d06083292..5729924cceb 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1696,6 +1696,14 @@ package body Sinfo is return Flag7 (N); end Is_Asynchronous_Call_Block; + function Is_Boolean_Aspect + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification); + return Flag16 (N); + end Is_Boolean_Aspect; + function Is_Component_Left_Opnd (N : Node_Id) return Boolean is begin @@ -4716,6 +4724,14 @@ package body Sinfo is Set_Flag7 (N, Val); end Set_Is_Asynchronous_Call_Block; + procedure Set_Is_Boolean_Aspect + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification); + Set_Flag16 (N, Val); + end Set_Is_Boolean_Aspect; + procedure Set_Is_Component_Left_Opnd (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 8a6690360f2..e582d7bac08 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1252,6 +1252,10 @@ package Sinfo is -- expansion of an asynchronous entry call. Such a block needs cleanup -- handler to assure that the call is cancelled. + -- Is_Boolean_Aspect (Flag16-Sem) + -- Present in N_Aspect_Specification node. Set if the aspect is for a + -- boolean aspect (i.e. Aspect_Id is in Boolean_Aspect subtype). + -- Is_Component_Left_Opnd (Flag13-Sem) -- Is_Component_Right_Opnd (Flag14-Sem) -- Present in concatenation nodes, to indicate that the corresponding @@ -6543,6 +6547,7 @@ package Sinfo is -- Class_Present (Flag6) Set if 'Class present -- Next_Rep_Item (Node5-Sem) -- Split_PPC (Flag17) Set if split pre/post attribute + -- Is_Boolean_Aspect (Flag16-Sem) -- Note: Aspect_Specification is an Ada 2012 feature @@ -8487,6 +8492,9 @@ package Sinfo is function Is_Asynchronous_Call_Block (N : Node_Id) return Boolean; -- Flag7 + function Is_Boolean_Aspect + (N : Node_Id) return Boolean; -- Flag16 + function Is_Component_Left_Opnd (N : Node_Id) return Boolean; -- Flag13 @@ -9450,6 +9458,9 @@ package Sinfo is procedure Set_Is_Asynchronous_Call_Block (N : Node_Id; Val : Boolean := True); -- Flag7 + procedure Set_Is_Boolean_Aspect + (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Is_Component_Left_Opnd (N : Node_Id; Val : Boolean := True); -- Flag13 @@ -11793,6 +11804,7 @@ package Sinfo is pragma Inline (Iterator_Specification); pragma Inline (Is_Accessibility_Actual); pragma Inline (Is_Asynchronous_Call_Block); + pragma Inline (Is_Boolean_Aspect); pragma Inline (Is_Component_Left_Opnd); pragma Inline (Is_Component_Right_Opnd); pragma Inline (Is_Controlling_Actual); @@ -12110,6 +12122,7 @@ package Sinfo is pragma Inline (Set_Iterator_Specification); pragma Inline (Set_Is_Accessibility_Actual); pragma Inline (Set_Is_Asynchronous_Call_Block); + pragma Inline (Set_Is_Boolean_Aspect); pragma Inline (Set_Is_Component_Left_Opnd); pragma Inline (Set_Is_Component_Right_Opnd); pragma Inline (Set_Is_Controlling_Actual); |