Commit dc36a7e3 by Robert Dewar Committed by Arnaud Charlet

exp_util.adb, [...]: Minor reformatting.

2011-09-02  Robert Dewar  <dewar@adacore.com>

	* exp_util.adb, exp_ch9.adb, sem_attr.adb, sem_ch6.adb: Minor
	reformatting.

From-SVN: r178450
parent d5aa443c
2011-09-02 Robert Dewar <dewar@adacore.com>
* exp_util.adb, exp_ch9.adb, sem_attr.adb, sem_ch6.adb: Minor
reformatting.
2011-09-02 Hristian Kirtchev <kirtchev@adacore.com> 2011-09-02 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch9.adb (Install_Private_Data_Declarations): Add guards * exp_ch9.adb (Install_Private_Data_Declarations): Add guards
......
...@@ -12481,11 +12481,11 @@ package body Exp_Ch9 is ...@@ -12481,11 +12481,11 @@ package body Exp_Ch9 is
or else Has_Interfaces (Protect_Rec) or else Has_Interfaces (Protect_Rec)
or else or else
((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp)) ((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp))
and then not Restriction_Active (No_Dynamic_Attachment)) and then not Restriction_Active (No_Dynamic_Attachment))
then then
declare declare
Pkg_Id : constant RTU_Id := Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp);
Corresponding_Runtime_Package (Ptyp);
Called_Subp : RE_Id; Called_Subp : RE_Id;
begin begin
...@@ -12536,8 +12536,7 @@ package body Exp_Ch9 is ...@@ -12536,8 +12536,7 @@ package body Exp_Ch9 is
Append_To (Args, Append_To (Args,
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix => New_Reference_To (P_Arr, Loc),
New_Reference_To (P_Arr, Loc),
Attribute_Name => Name_Unrestricted_Access)); Attribute_Name => Name_Unrestricted_Access));
-- Build_Entry_Names generation flag. When set to true, the -- Build_Entry_Names generation flag. When set to true, the
......
...@@ -1526,14 +1526,14 @@ package body Exp_Util is ...@@ -1526,14 +1526,14 @@ package body Exp_Util is
or else Present (Interface_List (Parent (Typ))) or else Present (Interface_List (Parent (Typ)))
or else or else
(((Has_Attach_Handler (Typ) and then not Restricted_Profile) (((Has_Attach_Handler (Typ) and then not Restricted_Profile)
or else Has_Interrupt_Handler (Typ)) or else Has_Interrupt_Handler (Typ))
and then not Restriction_Active (No_Dynamic_Attachment)) and then not Restriction_Active (No_Dynamic_Attachment))
then then
if Abort_Allowed if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Typ) > 1 or else Number_Entries (Typ) > 1
or else (Has_Attach_Handler (Typ) or else (Has_Attach_Handler (Typ)
and then not Restricted_Profile) and then not Restricted_Profile)
then then
Pkg_Id := System_Tasking_Protected_Objects_Entries; Pkg_Id := System_Tasking_Protected_Objects_Entries;
else else
...@@ -1560,10 +1560,8 @@ package body Exp_Util is ...@@ -1560,10 +1560,8 @@ package body Exp_Util is
if Act_ST = Etype (Exp) then if Act_ST = Etype (Exp) then
return; return;
else else
Rewrite (Exp, Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
Convert_To (Act_ST, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Act_ST); Analyze_And_Resolve (Exp, Act_ST);
end if; end if;
end Convert_To_Actual_Subtype; end Convert_To_Actual_Subtype;
...@@ -1644,7 +1642,6 @@ package body Exp_Util is ...@@ -1644,7 +1642,6 @@ package body Exp_Util is
Name_Req : Boolean := False) return Node_Id Name_Req : Boolean := False) return Node_Id
is is
New_Exp : Node_Id; New_Exp : Node_Id;
begin begin
Remove_Side_Effects (Exp, Name_Req); Remove_Side_Effects (Exp, Name_Req);
New_Exp := New_Copy_Tree (Exp); New_Exp := New_Copy_Tree (Exp);
......
...@@ -4939,12 +4939,15 @@ package body Sem_Attr is ...@@ -4939,12 +4939,15 @@ package body Sem_Attr is
-- all scope checks and checks for aliased views are omitted. -- all scope checks and checks for aliased views are omitted.
when Attribute_Unrestricted_Access => when Attribute_Unrestricted_Access =>
-- If from source, deal with relevant restrictions
if Comes_From_Source (N) then if Comes_From_Source (N) then
Check_Restriction (No_Unchecked_Access, N); Check_Restriction (No_Unchecked_Access, N);
if Nkind (P) in N_Has_Entity if Nkind (P) in N_Has_Entity
and then Present (Entity (P)) and then Present (Entity (P))
and then Is_Object (Entity (P)) and then Is_Object (Entity (P))
then then
Check_Restriction (No_Implicit_Aliasing, N); Check_Restriction (No_Implicit_Aliasing, N);
end if; end if;
......
...@@ -5462,23 +5462,25 @@ package body Sem_Ch6 is ...@@ -5462,23 +5462,25 @@ package body Sem_Ch6 is
-- Inherited : constant Subprogram_List := -- Inherited : constant Subprogram_List :=
-- Inherited_Subprograms (Spec_Id); -- Inherited_Subprograms (Spec_Id);
-- List of subprograms inherited by this subprogram -- -- List of subprograms inherited by this subprogram
-- Code is currently commented out as, in some cases, it causes crashes
-- because Direct_Primitive_Operations is not available for a private
-- type???
Last_Postcondition : Node_Id := Empty; Last_Postcondition : Node_Id := Empty;
-- Last postcondition on the subprogram, or else Empty if either no -- Last postcondition on the subprogram, or else Empty if either no
-- postcondition or only inherited postconditions. -- postcondition or only inherited postconditions.
Attribute_Result_Mentioned : Boolean := False; Attribute_Result_Mentioned : Boolean := False;
-- Whether attribute 'Result is mentioned in a postcondition -- Whether attribute 'Result is mentioned in a postcondition
Post_State_Mentioned : Boolean := False; Post_State_Mentioned : Boolean := False;
-- Whether some expression mentioned in a postcondition can have a -- Whether some expression mentioned in a postcondition can have a
-- different value in the post-state than in the pre-state. -- different value in the post-state than in the pre-state.
function Check_Attr_Result (N : Node_Id) return Traverse_Result; function Check_Attr_Result (N : Node_Id) return Traverse_Result;
-- Check whether N is a reference to the attribute 'Result, and if so -- Check if N is a reference to the attribute 'Result, and if so set
-- set Attribute_Result_Mentioned and return Abandon. Otherwise return -- Attribute_Result_Mentioned and return Abandon. Otherwise return OK.
-- OK.
function Check_Post_State (N : Node_Id) return Traverse_Result; function Check_Post_State (N : Node_Id) return Traverse_Result;
-- Check whether the value of evaluating N can be different in the -- Check whether the value of evaluating N can be different in the
...@@ -5487,9 +5489,7 @@ package body Sem_Ch6 is ...@@ -5487,9 +5489,7 @@ package body Sem_Ch6 is
-- reference to attribute 'Old, in order to ignore its prefix, which -- reference to attribute 'Old, in order to ignore its prefix, which
-- is precisely evaluated in the pre-state. Otherwise return OK. -- is precisely evaluated in the pre-state. Otherwise return OK.
procedure Process_Post_Conditions procedure Process_Post_Conditions (Spec : Node_Id; Class : Boolean);
(Spec : Node_Id;
Class : Boolean);
-- This processes the Spec_PPC_List from Spec, processing any -- This processes the Spec_PPC_List from Spec, processing any
-- postconditions from the list. If Class is True, then only -- postconditions from the list. If Class is True, then only
-- postconditions marked with Class_Present are considered. The -- postconditions marked with Class_Present are considered. The
...@@ -5506,8 +5506,7 @@ package body Sem_Ch6 is ...@@ -5506,8 +5506,7 @@ package body Sem_Ch6 is
function Check_Attr_Result (N : Node_Id) return Traverse_Result is function Check_Attr_Result (N : Node_Id) return Traverse_Result is
begin begin
if Nkind (N) = N_Attribute_Reference if Nkind (N) = N_Attribute_Reference
and then and then Get_Attribute_Id (Attribute_Name (N)) = Attribute_Result
Get_Attribute_Id (Attribute_Name (N)) = Attribute_Result
then then
Attribute_Result_Mentioned := True; Attribute_Result_Mentioned := True;
return Abandon; return Abandon;
...@@ -5531,6 +5530,7 @@ package body Sem_Ch6 is ...@@ -5531,6 +5530,7 @@ package body Sem_Ch6 is
when N_Identifier | when N_Identifier |
N_Expanded_Name => N_Expanded_Name =>
declare declare
E : constant Entity_Id := Entity (N); E : constant Entity_Id := Entity (N);
begin begin
...@@ -5583,7 +5583,7 @@ package body Sem_Ch6 is ...@@ -5583,7 +5583,7 @@ package body Sem_Ch6 is
loop loop
Arg := First (Pragma_Argument_Associations (Prag)); Arg := First (Pragma_Argument_Associations (Prag));
-- Since pre- and postconditions are listed in reverse order, the -- Since pre- and post-conditions are listed in reverse order, the
-- first postcondition in the list is the last in the source. -- first postcondition in the list is the last in the source.
if Pragma_Name (Prag) = Name_Postcondition if Pragma_Name (Prag) = Name_Postcondition
...@@ -5607,7 +5607,7 @@ package body Sem_Ch6 is ...@@ -5607,7 +5607,7 @@ package body Sem_Ch6 is
and then not Class and then not Class
then then
Post_State_Mentioned := False; Post_State_Mentioned := False;
Ignored := Find_Post_State (Arg); Ignored := Find_Post_State (Arg);
if not Post_State_Mentioned then if not Post_State_Mentioned then
Error_Msg_N ("?postcondition only refers to pre-state", Error_Msg_N ("?postcondition only refers to pre-state",
...@@ -5635,7 +5635,7 @@ package body Sem_Ch6 is ...@@ -5635,7 +5635,7 @@ package body Sem_Ch6 is
-- Code is currently commented out as, in some cases, it causes crashes -- Code is currently commented out as, in some cases, it causes crashes
-- because Direct_Primitive_Operations is not available for a private -- because Direct_Primitive_Operations is not available for a private
-- type. This may cause more warnings to be issued than necessary. -- type. This may cause more warnings to be issued than necessary. ???
-- for J in Inherited'Range loop -- for J in Inherited'Range loop
-- if Present (Spec_PPC_List (Contract (Inherited (J)))) then -- if Present (Spec_PPC_List (Contract (Inherited (J)))) then
...@@ -5662,8 +5662,8 @@ package body Sem_Ch6 is ...@@ -5662,8 +5662,8 @@ package body Sem_Ch6 is
procedure Check_Subprogram_Order (N : Node_Id) is procedure Check_Subprogram_Order (N : Node_Id) is
function Subprogram_Name_Greater (S1, S2 : String) return Boolean; function Subprogram_Name_Greater (S1, S2 : String) return Boolean;
-- This is used to check if S1 > S2 in the sense required by this -- This is used to check if S1 > S2 in the sense required by this test,
-- test, for example nameab < namec, but name2 < name10. -- for example nameab < namec, but name2 < name10.
----------------------------- -----------------------------
-- Subprogram_Name_Greater -- -- Subprogram_Name_Greater --
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment