+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:
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;
end if;
loop
- Curr := Next (HT, Prev);
+ Curr := Next (HT.Nodes (Prev));
if Curr = 0 then
raise Program_Error with
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;
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
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
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);
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);
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);
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;
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
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
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
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
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,
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.
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;
-- 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,
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
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
-- 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
-- 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
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
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
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);
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);
OSDN Git Service
