Commit ec40b86c by Hristian Kirtchev Committed by Arnaud Charlet

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

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb, exp_ch6.adb, binde.adb, sem_disp.adb, s-fileio.adb:
	Minor reformatting.

From-SVN: r247179
parent ca1f6b29
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb, exp_ch6.adb, binde.adb, sem_disp.adb, s-fileio.adb:
Minor reformatting.
2017-04-25 Bob Duff <duff@adacore.com> 2017-04-25 Bob Duff <duff@adacore.com>
* sem_prag.adb (No_Return): Give an error if the pragma applies * sem_prag.adb (No_Return): Give an error if the pragma applies
......
...@@ -2235,7 +2235,7 @@ package body Binde is ...@@ -2235,7 +2235,7 @@ package body Binde is
begin begin
while S /= No_Successor loop while S /= No_Successor loop
if UNR.Table (Succ.Table (S).After).Elab_Position <= if UNR.Table (Succ.Table (S).After).Elab_Position <=
UNR.Table (U).Elab_Position UNR.Table (U).Elab_Position
then then
OK := False; OK := False;
Write_Line (Msg & " elab order failed"); Write_Line (Msg & " elab order failed");
......
...@@ -159,14 +159,16 @@ package body Exp_Ch6 is ...@@ -159,14 +159,16 @@ package body Exp_Ch6 is
-- we have an infinite recursion. -- we have an infinite recursion.
procedure Expand_Actuals procedure Expand_Actuals
(N : Node_Id; Subp : Entity_Id; Post_Call : out List_Id); (N : Node_Id;
-- Return in Post_Call a list of actions to take place after the call. Subp : Entity_Id;
-- The call will later be rewritten as an Expression_With_Actions, Post_Call : out List_Id);
-- with the Post_Call actions inserted, and the call inside. -- Return a list of actions to take place after the call in Post_Call. The
-- call will later be rewritten as an Expression_With_Actions, with the
-- Post_Call actions inserted, and the call inside.
-- --
-- For each actual of an in-out or out parameter which is a numeric -- For each actual of an in-out or out parameter which is a numeric (view)
-- (view) conversion of the form T (A), where A denotes a variable, -- conversion of the form T (A), where A denotes a variable, we insert the
-- we insert the declaration: -- declaration:
-- --
-- Temp : T[ := T (A)]; -- Temp : T[ := T (A)];
-- --
...@@ -197,12 +199,7 @@ package body Exp_Ch6 is ...@@ -197,12 +199,7 @@ package body Exp_Ch6 is
-- based on the predicates of the actual type. -- based on the predicates of the actual type.
procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id); procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id);
-- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals -- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals.
procedure Insert_Post_Call_Actions
(N : Node_Id; Post_Call : List_Id);
-- Insert the Post_Call list (previously produced by
-- Expand_Actuals/Expand_Call_Helper) into the tree.
procedure Expand_Ctrl_Function_Call (N : Node_Id); procedure Expand_Ctrl_Function_Call (N : Node_Id);
-- N is a function call which returns a controlled object. Transform the -- N is a function call which returns a controlled object. Transform the
...@@ -236,6 +233,10 @@ package body Exp_Ch6 is ...@@ -236,6 +233,10 @@ package body Exp_Ch6 is
-- Returns True if the given subtype is unconstrained and has one or more -- Returns True if the given subtype is unconstrained and has one or more
-- access discriminants. -- access discriminants.
procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id);
-- Insert the Post_Call list previously produced by routine Expand_Actuals
-- or Expand_Call_Helper into the tree.
procedure Rewrite_Function_Call_For_C (N : Node_Id); procedure Rewrite_Function_Call_For_C (N : Node_Id);
-- When generating C code, replace a call to a function that returns an -- When generating C code, replace a call to a function that returns an
-- array into the generated procedure with an additional out parameter. -- array into the generated procedure with an additional out parameter.
...@@ -1155,7 +1156,9 @@ package body Exp_Ch6 is ...@@ -1155,7 +1156,9 @@ package body Exp_Ch6 is
-------------------- --------------------
procedure Expand_Actuals procedure Expand_Actuals
(N : Node_Id; Subp : Entity_Id; Post_Call : out List_Id) (N : Node_Id;
Subp : Entity_Id;
Post_Call : out List_Id)
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Actual : Node_Id; Actual : Node_Id;
...@@ -7220,27 +7223,24 @@ package body Exp_Ch6 is ...@@ -7220,27 +7223,24 @@ package body Exp_Ch6 is
-- Insert_Post_Call_Actions -- -- Insert_Post_Call_Actions --
------------------------------ ------------------------------
procedure Insert_Post_Call_Actions procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id) is
(N : Node_Id; Post_Call : List_Id)
is
begin begin
if Is_Empty_List (Post_Call) then if Is_Empty_List (Post_Call) then
return; return;
end if; end if;
-- Cases where the call is not a member of a statement list. -- Cases where the call is not a member of a statement list. This
-- This includes the case where the call is an actual in another -- includes the case where the call is an actual in another function
-- function call or indexing, i.e. an expression context as well. -- call or indexing, i.e. an expression context as well.
if not Is_List_Member (N) if not Is_List_Member (N)
or else Nkind_In (Parent (N), N_Function_Call, N_Indexed_Component) or else Nkind_In (Parent (N), N_Function_Call, N_Indexed_Component)
then then
-- In Ada 2012 the call may be a function call in an expression -- In Ada 2012 the call may be a function call in an expression
-- (since OUT and IN OUT parameters are now allowed for such -- (since OUT and IN OUT parameters are now allowed for such calls).
-- calls). The write-back of (in)-out parameters is handled -- The write-back of (in)-out parameters is handled by the back-end,
-- by the back-end, but the constraint checks generated when -- but the constraint checks generated when subtypes of formal and
-- subtypes of formal and actual don't match must be inserted -- actual don't match must be inserted in the form of assignments.
-- in the form of assignments.
if Nkind (Original_Node (N)) = N_Function_Call then if Nkind (Original_Node (N)) = N_Function_Call then
pragma Assert (Ada_Version >= Ada_2012); pragma Assert (Ada_Version >= Ada_2012);
...@@ -7252,8 +7252,8 @@ package body Exp_Ch6 is ...@@ -7252,8 +7252,8 @@ package body Exp_Ch6 is
-- Insert_Actions_After (P, Post_Call), but that doesn't work -- Insert_Actions_After (P, Post_Call), but that doesn't work
-- for Ada 2012. If we are in the middle of an expression, e.g. -- for Ada 2012. If we are in the middle of an expression, e.g.
-- the condition of an IF, this call would insert after the IF -- the condition of an IF, this call would insert after the IF
-- statement, which is much too late to be doing the write -- statement, which is much too late to be doing the write back.
-- back. For example: -- For example:
-- if Clobber (X) then -- if Clobber (X) then
-- Put_Line (X'Img); -- Put_Line (X'Img);
...@@ -7261,9 +7261,9 @@ package body Exp_Ch6 is ...@@ -7261,9 +7261,9 @@ package body Exp_Ch6 is
-- goto Junk -- goto Junk
-- end if; -- end if;
-- Now assume Clobber changes X, if we put the write back -- Now assume Clobber changes X, if we put the write back after
-- after the IF, the Put_Line gets the wrong value and the -- the IF, the Put_Line gets the wrong value and the goto causes
-- goto causes the write back to be skipped completely. -- the write back to be skipped completely.
-- To deal with this, we replace the call by -- To deal with this, we replace the call by
...@@ -7304,10 +7304,10 @@ package body Exp_Ch6 is ...@@ -7304,10 +7304,10 @@ package body Exp_Ch6 is
Set_Analyzed (Name, False); Set_Analyzed (Name, False);
end; end;
-- If not the special Ada 2012 case of a function call, then -- If not the special Ada 2012 case of a function call, then we must
-- we must have the triggering statement of a triggering -- have the triggering statement of a triggering alternative or an
-- alternative or an entry call alternative, and we can add -- entry call alternative, and we can add the post call stuff to the
-- the post call stuff to the corresponding statement list. -- corresponding statement list.
else else
declare declare
...@@ -7315,8 +7315,8 @@ package body Exp_Ch6 is ...@@ -7315,8 +7315,8 @@ package body Exp_Ch6 is
begin begin
P := Parent (N); P := Parent (N);
pragma Assert (Nkind_In (P, N_Triggering_Alternative, pragma Assert (Nkind_In (P, N_Entry_Call_Alternative,
N_Entry_Call_Alternative)); N_Triggering_Alternative));
if Is_Non_Empty_List (Statements (P)) then if Is_Non_Empty_List (Statements (P)) then
Insert_List_Before_And_Analyze Insert_List_Before_And_Analyze
...@@ -7327,8 +7327,8 @@ package body Exp_Ch6 is ...@@ -7327,8 +7327,8 @@ package body Exp_Ch6 is
end; end;
end if; end if;
-- Otherwise, normal case where N is in a statement sequence, -- Otherwise, normal case where N is in a statement sequence, just put
-- just put the post-call stuff after the call statement. -- the post-call stuff after the call statement.
else else
Insert_Actions_After (N, Post_Call); Insert_Actions_After (N, Post_Call);
......
...@@ -296,14 +296,15 @@ package body System.File_IO is ...@@ -296,14 +296,15 @@ package body System.File_IO is
Temp : access Temp_File_Record_Ptr := Temp_Files'Access; Temp : access Temp_File_Record_Ptr := Temp_Files'Access;
-- Note the double indirection here -- Note the double indirection here
Discard : int;
New_Temp : Temp_File_Record_Ptr; New_Temp : Temp_File_Record_Ptr;
Discard : int;
begin begin
while Temp.all.all.File /= File loop while Temp.all.all.File /= File loop
Temp := Temp.all.all.Next'Access; Temp := Temp.all.all.Next'Access;
end loop; end loop;
Discard := unlink (Temp.all.all.Name'Address); Discard := unlink (Temp.all.all.Name'Address);
New_Temp := Temp.all.all.Next; New_Temp := Temp.all.all.Next;
Free (Temp.all); Free (Temp.all);
Temp.all := New_Temp; Temp.all := New_Temp;
......
...@@ -967,8 +967,8 @@ package body Sem_Disp is ...@@ -967,8 +967,8 @@ package body Sem_Disp is
Error_Msg_Name_2 := Chars (E); Error_Msg_Name_2 := Chars (E);
Error_Msg_Sloc := Sloc (E); Error_Msg_Sloc := Sloc (E);
Error_Msg_N Error_Msg_N
("?j?primitive of type % defined after private " & ("?j?primitive of type % defined after private extension "
"extension % #?", Prim); & "% #?", Prim);
Error_Msg_Name_1 := Chars (Prim); Error_Msg_Name_1 := Chars (Prim);
Error_Msg_Name_2 := Chars (E); Error_Msg_Name_2 := Chars (E);
Error_Msg_N Error_Msg_N
...@@ -989,6 +989,8 @@ package body Sem_Disp is ...@@ -989,6 +989,8 @@ package body Sem_Disp is
Ovr_Subp : Entity_Id := Empty; Ovr_Subp : Entity_Id := Empty;
Tagged_Type : Entity_Id; Tagged_Type : Entity_Id;
-- Start of processing for Check_Dispatching_Operation
begin begin
if not Ekind_In (Subp, E_Function, E_Procedure) then if not Ekind_In (Subp, E_Function, E_Procedure) then
return; return;
...@@ -1080,8 +1082,8 @@ package body Sem_Disp is ...@@ -1080,8 +1082,8 @@ package body Sem_Disp is
then then
Error_Msg_N ("??declaration of& is too late!", Subp); Error_Msg_N ("??declaration of& is too late!", Subp);
Error_Msg_NE -- CODEFIX?? Error_Msg_NE -- CODEFIX??
("\??spec should appear immediately after declaration " ("\??spec should appear immediately after declaration of "
& "of & !", Subp, Typ); & "& !", Subp, Typ);
exit; exit;
end if; end if;
...@@ -1109,8 +1111,8 @@ package body Sem_Disp is ...@@ -1109,8 +1111,8 @@ package body Sem_Disp is
then then
Error_Msg_N ("??declaration of& is too late!", Subp); Error_Msg_N ("??declaration of& is too late!", Subp);
Error_Msg_NE Error_Msg_NE
("\??spec should appear immediately after declaration " ("\??spec should appear immediately after declaration of "
& "of & !", Subp, Typ); & "& !", Subp, Typ);
end if; end if;
end if; end if;
end; end;
......
...@@ -4219,9 +4219,9 @@ package body Sem_Prag is ...@@ -4219,9 +4219,9 @@ package body Sem_Prag is
function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
Typ : constant Entity_Id := Find_Dispatching_Type (E); Typ : constant Entity_Id := Find_Dispatching_Type (E);
Prev : Entity_Id := Overridden_Operation (E);
Cont : Node_Id; Cont : Node_Id;
Prag : Node_Id; Prag : Node_Id;
Prev : Entity_Id := Overridden_Operation (E);
begin begin
-- Check ancestors on the overriding operation to examine the -- Check ancestors on the overriding operation to examine the
...@@ -4240,9 +4240,9 @@ package body Sem_Prag is ...@@ -4240,9 +4240,9 @@ package body Sem_Prag is
end loop; end loop;
end if; end if;
-- For a type derived from a generic formal type, the -- For a type derived from a generic formal type, the operation
-- operation inheriting the condition is a renaming, not -- inheriting the condition is a renaming, not an overriding of
-- an overriding of the operation of the formal. -- the operation of the formal.
if Is_Generic_Type (Find_Dispatching_Type (Prev)) then if Is_Generic_Type (Find_Dispatching_Type (Prev)) then
Prev := Alias (Prev); Prev := Alias (Prev);
...@@ -7399,20 +7399,21 @@ package body Sem_Prag is ...@@ -7399,20 +7399,21 @@ package body Sem_Prag is
or else Ekind (E) = E_Variable or else Ekind (E) = E_Variable
-- A component as well. The entity does not have its -- A component as well. The entity does not have its Ekind
-- Ekind set until the enclosing record declaration is -- set until the enclosing record declaration is fully
-- fully analyzed. -- analyzed.
or else Nkind (Parent (E)) = N_Component_Declaration or else Nkind (Parent (E)) = N_Component_Declaration
-- An access to subprogram is also allowed -- An access to subprogram is also allowed
or else (Is_Access_Type (E) or else
and then Ekind (Designated_Type (E)) = E_Subprogram_Type) (Is_Access_Type (E)
and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
-- Allow internal call to set convention of subprogram type -- Allow internal call to set convention of subprogram type
or else (Ekind (E) = E_Subprogram_Type) or else Ekind (E) = E_Subprogram_Type
then then
null; null;
...@@ -8084,8 +8085,8 @@ package body Sem_Prag is ...@@ -8084,8 +8085,8 @@ package body Sem_Prag is
N_Subprogram_Body N_Subprogram_Body
then then
Error_Pragma Error_Pragma
("pragma% requires separate spec" & ("pragma% requires separate spec and must come before "
" and must come before body"); & "body");
end if; end if;
-- Test result type if given, note that the result type -- Test result type if given, note that the result type
...@@ -8097,14 +8098,14 @@ package body Sem_Prag is ...@@ -8097,14 +8098,14 @@ package body Sem_Prag is
Match := False; Match := False;
elsif Etype (Def_Id) /= Standard_Void_Type elsif Etype (Def_Id) /= Standard_Void_Type
and then and then Nam_In (Pname, Name_Export_Procedure,
Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure) Name_Import_Procedure)
then then
Match := False; Match := False;
-- Test parameter types if given. Note that this parameter -- Test parameter types if given. Note that this parameter has
-- has not been analyzed (and must not be, since it is -- not been analyzed (and must not be, since it is semantic
-- semantic nonsense), so we get it as the parser left it. -- nonsense), so we get it as the parser left it.
elsif Present (Arg_Parameter_Types) then elsif Present (Arg_Parameter_Types) then
Check_Matching_Types : declare Check_Matching_Types : declare
...@@ -8119,8 +8120,8 @@ package body Sem_Prag is ...@@ -8119,8 +8120,8 @@ package body Sem_Prag is
Match := False; Match := False;
end if; end if;
-- A list of one type, e.g. (List) is parsed as -- A list of one type, e.g. (List) is parsed as a
-- a parenthesized expression. -- parenthesized expression.
elsif Nkind (Arg_Parameter_Types) /= N_Aggregate elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
and then Paren_Count (Arg_Parameter_Types) = 1 and then Paren_Count (Arg_Parameter_Types) = 1
...@@ -18176,7 +18177,8 @@ package body Sem_Prag is ...@@ -18176,7 +18177,8 @@ package body Sem_Prag is
while Present (E) while Present (E)
and then Scope (E) = Current_Scope and then Scope (E) = Current_Scope
loop loop
if Ekind_In (E, E_Procedure, E_Generic_Procedure) then if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
-- Check that the pragma is not applied to a body. -- Check that the pragma is not applied to a body.
-- First check the specless body case, to give a -- First check the specless body case, to give a
-- different error message. These checks do not apply -- different error message. These checks do not apply
...@@ -18189,8 +18191,8 @@ package body Sem_Prag is ...@@ -18189,8 +18191,8 @@ package body Sem_Prag is
and then not Relaxed_RM_Semantics and then not Relaxed_RM_Semantics
then then
Error_Pragma Error_Pragma
("pragma% requires separate spec" & ("pragma% requires separate spec and must come "
" and must come before body"); & "before body");
end if; end if;
-- Now the "specful" body case -- Now the "specful" body case
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