Commit 0d6014fa by Arnaud Charlet

[multiple changes]

2016-04-18  Eric Botcazou  <ebotcazou@adacore.com>

	* layout.adb: Fix more minor typos in comments.

2016-04-18  Hristian Kirtchev  <kirtchev@adacore.com>

	* a-calend.ads, sem_prag.adb, sem_ch6.adb: Minor reformatting.

From-SVN: r235114
parent 539ca5ec
2016-04-18 Eric Botcazou <ebotcazou@adacore.com>
* layout.adb: Fix more minor typos in comments.
2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
* a-calend.ads, sem_prag.adb, sem_ch6.adb: Minor reformatting.
2016-04-18 Ed Schonberg <schonberg@adacore.com> 2016-04-18 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): In GNATprove * sem_ch6.adb (Analyze_Subprogram_Body_Helper): In GNATprove
......
...@@ -115,8 +115,9 @@ is ...@@ -115,8 +115,9 @@ is
Time_Error : exception; Time_Error : exception;
private private
-- Mark private part as SPARK_Mode Off to avoid accounting for variable -- Mark the private part as SPARK_Mode Off to avoid accounting for variable
-- Invalid_Time_Zone_Offset in abstract state. -- Invalid_Time_Zone_Offset in abstract state.
pragma SPARK_Mode (Off); pragma SPARK_Mode (Off);
pragma Inline (Clock); pragma Inline (Clock);
......
...@@ -3247,7 +3247,7 @@ package body Layout is ...@@ -3247,7 +3247,7 @@ package body Layout is
A := 2 * A; A := 2 * A;
end loop; end loop;
-- If alignment is currently not set, then we can safetly set it to -- If alignment is currently not set, then we can safely set it to
-- this new calculated value. -- this new calculated value.
if Unknown_Alignment (E) then if Unknown_Alignment (E) then
...@@ -3256,7 +3256,7 @@ package body Layout is ...@@ -3256,7 +3256,7 @@ package body Layout is
-- Cases where we have inherited an alignment -- Cases where we have inherited an alignment
-- For constructed types, always reset the alignment, these are -- For constructed types, always reset the alignment, these are
-- Generally invisible to the user anyway, and that way we are -- generally invisible to the user anyway, and that way we are
-- sure that no constructed types have weird alignments. -- sure that no constructed types have weird alignments.
elsif not Comes_From_Source (E) then elsif not Comes_From_Source (E) then
...@@ -3282,23 +3282,23 @@ package body Layout is ...@@ -3282,23 +3282,23 @@ package body Layout is
-- It seems quite bogus in this case to inherit an alignment of 1 -- It seems quite bogus in this case to inherit an alignment of 1
-- from the parent type Character. Furthermore, if that's what the -- from the parent type Character. Furthermore, if that's what the
-- programmer really wanted for some odd reason, then they could -- programmer really wanted for some odd reason, then he could
-- specify the alignment they wanted. -- specify the alignment directly.
-- Furthermore we really don't want to inherit the alignment in -- Furthermore we really don't want to inherit the alignment in
-- the case of a specified Object_Size for a subtype, since then -- the case of a specified Object_Size for a subtype, since then
-- there would be no way of overriding to give a reasonable value -- there would be no way of overriding to give a reasonable value
-- (we don't have an Object_Subtype attribute). Consider: -- (we don't have an Object_Subtype attribute). Consider:
-- subtype R is new Character; -- subtype R is Character;
-- for R'Object_Size use 16; -- for R'Object_Size use 16;
-- If we inherit the alignment of 1, then we have an odd -- If we inherit the alignment of 1, then we have an inefficient
-- inefficient alignment for the subtype, which cannot be fixed. -- alignment for the subtype, which cannot be fixed.
-- So we make the decision that if Size (or Object_Size) is given -- So we make the decision that if Size (or Object_Size) is given
-- (and, in the case of a first subtype, the alignment is not set -- (and, in the case of a first subtype, the alignment is not set
-- with a specific alignment clause). We reset the alignment to -- with a specific alignment clause), we reset the alignment to
-- the appropriate value for the specified size. This is a nice -- the appropriate value for the specified size. This is a nice
-- simple rule to implement and document. -- simple rule to implement and document.
...@@ -3311,15 +3311,15 @@ package body Layout is ...@@ -3311,15 +3311,15 @@ package body Layout is
-- type S is new R; -- type S is new R;
-- for S'Size use Character'Size; -- for S'Size use Character'Size;
-- Now the alignment of S is 1 instead of 2, as a result of -- Now the alignment of S is changed to 1 instead of 2 as a result
-- applying the above rule to the confirming rep clause for S. Not -- of applying the above rule to the confirming rep clause for S.
-- clear this is worth worrying about. If we recorded whether a -- Not clear this is worth worrying about. If we recorded whether
-- size clause was confirming we could avoid this, but right now -- a size clause was confirming we could avoid this, but right now
-- we have no way of doing that or easily figuring it out, so we -- we have no way of doing that or easily figuring it out, so we
-- don't bother. -- don't bother.
-- Historical note. In versions of GNAT prior to Nov 6th, 2011, an -- Historical note: in versions of GNAT prior to Nov 6th, 2011, an
-- odd distinction was made between inherited alignments greater -- odd distinction was made between inherited alignments larger
-- than the computed alignment (where the larger alignment was -- than the computed alignment (where the larger alignment was
-- inherited) and inherited alignments smaller than the computed -- inherited) and inherited alignments smaller than the computed
-- alignment (where the smaller alignment was overridden). This -- alignment (where the smaller alignment was overridden). This
...@@ -3337,7 +3337,7 @@ package body Layout is ...@@ -3337,7 +3337,7 @@ package body Layout is
-- for R'Alignment use 1; -- for R'Alignment use 1;
-- subtype S is R; -- subtype S is R;
-- Here we have R has a default Object_Size of 32, and a specified -- Here we have R with a default Object_Size of 32, and a specified
-- alignment of 1, and it seeems right for S to inherit both values. -- alignment of 1, and it seeems right for S to inherit both values.
else else
......
...@@ -3754,9 +3754,9 @@ package body Sem_Ch6 is ...@@ -3754,9 +3754,9 @@ package body Sem_Ch6 is
Build_Body_To_Inline (N, Spec_Id); Build_Body_To_Inline (N, Spec_Id);
end if; end if;
-- When generating code, inherited pre/postconditions are handled -- When generating code, inherited pre/postconditions are handled when
-- when expanding the corresponding contract. If GNATprove mode we -- expanding the corresponding contract. In GNATprove the annotations
-- must process them when the body is analyzed. -- must be processed when the body is analyzed.
if GNATprove_Mode if GNATprove_Mode
and then Present (Spec_Id) and then Present (Spec_Id)
......
...@@ -23198,8 +23198,8 @@ package body Sem_Prag is ...@@ -23198,8 +23198,8 @@ package body Sem_Prag is
if Class_Present (N) then if Class_Present (N) then
-- Verify that a class-wide condition is legal, i.e. the operation -- Verify that a class-wide condition is legal, i.e. the operation is
-- is a primitive of a tagged type. -- a primitive of a tagged type.
Disp_Typ := Find_Dispatching_Type (Spec_Id); Disp_Typ := Find_Dispatching_Type (Spec_Id);
...@@ -26045,61 +26045,32 @@ package body Sem_Prag is ...@@ -26045,61 +26045,32 @@ package body Sem_Prag is
Subp_Id : Entity_Id := Empty; Subp_Id : Entity_Id := Empty;
Inher_Id : Entity_Id := Empty) return Node_Id Inher_Id : Entity_Id := Empty) return Node_Id
is is
Map : Elist_Id;
-- List containing the following mappings
-- * Formal parameters of inherited subprogram Inher_Id and subprogram
-- Subp_Id.
--
-- * The dispatching type of Inher_Id and the dispatching type of
-- Subp_Id.
--
-- * Primitives of the dispatching type of Inher_Id and primitives of
-- the dispatching type of Subp_Id.
function Replace_Entity (N : Node_Id) return Traverse_Result;
-- Replace reference to formal of inherited operation or to primitive
-- operation of root type, with corresponding entity for derived type.
function Suppress_Reference (N : Node_Id) return Traverse_Result; function Suppress_Reference (N : Node_Id) return Traverse_Result;
-- Detect whether node N references a formal parameter subject to -- Detect whether node N references a formal parameter subject to
-- pragma Unreferenced. If this is the case, set Comes_From_Source -- pragma Unreferenced. If this is the case, set Comes_From_Source
-- to False to suppress the generation of a reference when analyzing -- to False to suppress the generation of a reference when analyzing
-- N later on. -- N later on.
------------------------
-- Suppress_Reference --
------------------------
function Suppress_Reference (N : Node_Id) return Traverse_Result is
Formal : Entity_Id;
begin
if Is_Entity_Name (N) and then Present (Entity (N)) then
Formal := Entity (N);
-- The formal parameter is subject to pragma Unreferenced.
-- Prevent the generation of a reference by resetting the
-- Comes_From_Source flag.
if Is_Formal (Formal)
and then Has_Pragma_Unreferenced (Formal)
then
Set_Comes_From_Source (N, False);
end if;
end if;
return OK;
end Suppress_Reference;
procedure Suppress_References is
new Traverse_Proc (Suppress_Reference);
-- Local variables
Loc : constant Source_Ptr := Sloc (Prag);
Prag_Nam : constant Name_Id := Pragma_Name (Prag);
Check_Prag : Node_Id;
Formals_Map : Elist_Id;
Inher_Formal : Entity_Id;
Msg_Arg : Node_Id;
Nam : Name_Id;
Subp_Formal : Entity_Id;
function Replace_Entity (N : Node_Id) return Traverse_Result;
-- Replace reference to formal of inherited operation or to primitive
-- operation of root type, with corresponding entity for derived type.
-------------------- --------------------
-- Replace_Entity -- -- Replace_Entity --
-------------------- --------------------
function Replace_Entity (N : Node_Id) return Traverse_Result function Replace_Entity (N : Node_Id) return Traverse_Result is
is
Elmt : Elmt_Id; Elmt : Elmt_Id;
New_E : Entity_Id; New_E : Entity_Id;
...@@ -26112,9 +26083,9 @@ package body Sem_Prag is ...@@ -26112,9 +26083,9 @@ package body Sem_Prag is
(Nkind (Parent (N)) /= N_Attribute_Reference (Nkind (Parent (N)) /= N_Attribute_Reference
or else Attribute_Name (Parent (N)) /= Name_Class) or else Attribute_Name (Parent (N)) /= Name_Class)
then then
-- The replacement does not apply to dispatching calls within -- The replacement does not apply to dispatching calls within the
-- the condition, but only to calls whose static tag is that -- condition, but only to calls whose static tag is that of the
-- of the parent type. -- parent type.
if Is_Subprogram (Entity (N)) if Is_Subprogram (Entity (N))
and then Nkind (Parent (N)) = N_Function_Call and then Nkind (Parent (N)) = N_Function_Call
...@@ -26126,7 +26097,7 @@ package body Sem_Prag is ...@@ -26126,7 +26097,7 @@ package body Sem_Prag is
-- Loop to find out if entity has a renaming -- Loop to find out if entity has a renaming
New_E := Empty; New_E := Empty;
Elmt := First_Elmt (Formals_Map); Elmt := First_Elmt (Map);
while Present (Elmt) loop while Present (Elmt) loop
if Node (Elmt) = Entity (N) then if Node (Elmt) = Entity (N) then
New_E := Node (Next_Elmt (Elmt)); New_E := Node (Next_Elmt (Elmt));
...@@ -26142,7 +26113,7 @@ package body Sem_Prag is ...@@ -26142,7 +26113,7 @@ package body Sem_Prag is
end if; end if;
if not Is_Abstract_Subprogram (Inher_Id) if not Is_Abstract_Subprogram (Inher_Id)
and then Nkind (N) = N_Function_Call and then Nkind (N) = N_Function_Call
and then Present (Entity (Name (N))) and then Present (Entity (Name (N)))
and then Is_Abstract_Subprogram (Entity (Name (N))) and then Is_Abstract_Subprogram (Entity (Name (N)))
then then
...@@ -26157,99 +26128,139 @@ package body Sem_Prag is ...@@ -26157,99 +26128,139 @@ package body Sem_Prag is
return OK; return OK;
end Replace_Entity; end Replace_Entity;
------------------------
-- Suppress_Reference --
------------------------
function Suppress_Reference (N : Node_Id) return Traverse_Result is
Formal : Entity_Id;
begin
if Is_Entity_Name (N) and then Present (Entity (N)) then
Formal := Entity (N);
-- The formal parameter is subject to pragma Unreferenced.
-- Prevent the generation of a reference by resetting the
-- Comes_From_Source flag.
if Is_Formal (Formal)
and then Has_Pragma_Unreferenced (Formal)
then
Set_Comes_From_Source (N, False);
end if;
end if;
return OK;
end Suppress_Reference;
procedure Replace_Condition_Entities is procedure Replace_Condition_Entities is
new Traverse_Proc (Replace_Entity); new Traverse_Proc (Replace_Entity);
procedure Suppress_References is
new Traverse_Proc (Suppress_Reference);
-- Local variables
Loc : constant Source_Ptr := Sloc (Prag);
Prag_Nam : constant Name_Id := Pragma_Name (Prag);
Check_Prag : Node_Id;
Inher_Formal : Entity_Id;
Msg_Arg : Node_Id;
Nam : Name_Id;
Subp_Formal : Entity_Id;
-- Start of processing for Build_Pragma_Check_Equivalent -- Start of processing for Build_Pragma_Check_Equivalent
begin begin
Formals_Map := No_Elist; Map := No_Elist;
-- When the pre- or postcondition is inherited, map the formals of -- When the pre- or postcondition is inherited, map the formals of the
-- the inherited subprogram to those of the current subprogram. -- inherited subprogram to those of the current subprogram. In addition,
-- In addition, map primitive operations of the parent type into the -- map primitive operations of the parent type into the corresponding
-- corresponding primitive operations of the descendant. -- primitive operations of the descendant.
if Present (Inher_Id) then if Present (Inher_Id) then
pragma Assert (Present (Subp_Id)); pragma Assert (Present (Subp_Id));
Formals_Map := New_Elmt_List; Map := New_Elmt_List;
-- Create a mapping <inherited formal> => <subprogram formal> -- Create a mapping <inherited formal> => <subprogram formal>
Inher_Formal := First_Formal (Inher_Id); Inher_Formal := First_Formal (Inher_Id);
Subp_Formal := First_Formal (Subp_Id); Subp_Formal := First_Formal (Subp_Id);
while Present (Inher_Formal) and then Present (Subp_Formal) loop while Present (Inher_Formal) and then Present (Subp_Formal) loop
Append_Elmt (Inher_Formal, Formals_Map); Append_Elmt (Inher_Formal, Map);
Append_Elmt (Subp_Formal, Formals_Map); Append_Elmt (Subp_Formal, Map);
Next_Formal (Inher_Formal); Next_Formal (Inher_Formal);
Next_Formal (Subp_Formal); Next_Formal (Subp_Formal);
end loop; end loop;
-- Map primitive operations of the parent type into the corresponding -- Map primitive operations of the parent type to the corresponding
-- operations of the descendant. The descendant type might not be -- operations of the descendant. Note that the descendant type may
-- frozen yet, so we cannot use the dispatch table directly. -- not be frozen yet, so we cannot use the dispatch table directly.
declare declare
T : constant Entity_Id := Find_Dispatching_Type (Subp_Id); Old_Typ : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
Old_T : constant Entity_Id := Find_Dispatching_Type (Inher_Id); Typ : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
D : Node_Id; Decl : Node_Id;
E : Entity_Id; Old_Prim : Entity_Id;
Old_E : Entity_Id; Prim : Entity_Id;
begin begin
D := First (List_Containing (Unit_Declaration_Node (Subp_Id))); Decl := First (List_Containing (Unit_Declaration_Node (Subp_Id)));
-- Look for primitive operations of the current type that have -- Look for primitive operations of the current type that have
-- overridden an operation of the type related to the original -- overridden an operation of the type related to the original
-- class-wide precondition. There may be several intermediate -- class-wide precondition. There may be several intermediate
-- overridings between them. -- overridings between them.
while Present (D) loop while Present (Decl) loop
if Nkind (D) = N_Subprogram_Declaration then if Nkind (Decl) = N_Subprogram_Declaration then
E := Defining_Entity (D); Prim := Defining_Entity (Decl);
if Is_Subprogram (E)
and then Present (Overridden_Operation (E)) if Is_Subprogram (Prim)
and then Find_Dispatching_Type (E) = T and then Present (Overridden_Operation (Prim))
and then Find_Dispatching_Type (Prim) = Typ
then then
Old_E := Overridden_Operation (E); Old_Prim := Overridden_Operation (Prim);
while Present (Overridden_Operation (Old_E)) while Present (Overridden_Operation (Old_Prim))
and then Scope (Old_E) /= Scope (Inher_Id) and then Scope (Old_Prim) /= Scope (Inher_Id)
loop loop
Old_E := Overridden_Operation (Old_E); Old_Prim := Overridden_Operation (Old_Prim);
end loop; end loop;
Append_Elmt (Old_E, Formals_Map); Append_Elmt (Old_Prim, Map);
Append_Elmt (E, Formals_Map); Append_Elmt (Prim, Map);
end if; end if;
end if; end if;
Next (D); Next (Decl);
end loop; end loop;
E := First_Entity (Scope (Subp_Id)); Prim := First_Entity (Scope (Subp_Id));
while Present (E) loop while Present (Prim) loop
if not Comes_From_Source (E) if not Comes_From_Source (Prim)
and then Ekind (E) = E_Function and then Ekind (Prim) = E_Function
and then Present (Alias (E)) and then Present (Alias (Prim))
then then
Old_E := Alias (E); Old_Prim := Alias (Prim);
while Present (Alias (Old_E)) while Present (Alias (Old_Prim))
and then Scope (Old_E) /= Scope (Inher_Id) and then Scope (Old_Prim) /= Scope (Inher_Id)
loop loop
Old_E := Alias (Old_E); Old_Prim := Alias (Old_Prim);
end loop; end loop;
Append_Elmt (Old_E, Formals_Map); Append_Elmt (Old_Prim, Map);
Append_Elmt (E, Formals_Map); Append_Elmt (Prim, Map);
end if; end if;
Next_Entity (E);
Next_Entity (Prim);
end loop; end loop;
if Formals_Map /= No_Elist then if Map /= No_Elist then
Append_Elmt (Old_T, Formals_Map); Append_Elmt (Old_Typ, Map);
Append_Elmt (T, Formals_Map); Append_Elmt (Typ, Map);
end if; end if;
end; end;
end if; end if;
...@@ -26257,14 +26268,14 @@ package body Sem_Prag is ...@@ -26257,14 +26268,14 @@ package body Sem_Prag is
-- Copy the original pragma while performing substitutions (if -- Copy the original pragma while performing substitutions (if
-- applicable). -- applicable).
Check_Prag := New_Copy_Tree (Source => Prag); Check_Prag := New_Copy_Tree (Source => Prag);
if Formals_Map /= No_Elist then if Map /= No_Elist then
Replace_Condition_Entities (Check_Prag); Replace_Condition_Entities (Check_Prag);
end if; end if;
-- Mark the pragma as being internally generated and reset the -- Mark the pragma as being internally generated and reset the Analyzed
-- Analyzed flag. -- flag.
Set_Analyzed (Check_Prag, False); Set_Analyzed (Check_Prag, False);
Set_Comes_From_Source (Check_Prag, False); Set_Comes_From_Source (Check_Prag, False);
...@@ -26294,8 +26305,8 @@ package body Sem_Prag is ...@@ -26294,8 +26305,8 @@ package body Sem_Prag is
Nam := Prag_Nam; Nam := Prag_Nam;
end if; end if;
-- Convert the copy into pragma Check by correcting the name and -- Convert the copy into pragma Check by correcting the name and adding
-- adding a check_kind argument. -- a check_kind argument.
Set_Pragma_Identifier Set_Pragma_Identifier
(Check_Prag, Make_Identifier (Loc, Name_Check)); (Check_Prag, Make_Identifier (Loc, Name_Check));
...@@ -26795,7 +26806,7 @@ package body Sem_Prag is ...@@ -26795,7 +26806,7 @@ package body Sem_Prag is
Bod : Node_Id) Bod : Node_Id)
is is
Parent_Subp : constant Entity_Id := Overridden_Operation (Subp); Parent_Subp : constant Entity_Id := Overridden_Operation (Subp);
Prags : constant Node_Id := Contract (Parent_Subp); Prags : constant Node_Id := Contract (Parent_Subp);
Prag : Node_Id; Prag : Node_Id;
begin begin
...@@ -26806,15 +26817,15 @@ package body Sem_Prag is ...@@ -26806,15 +26817,15 @@ package body Sem_Prag is
Prag := Pre_Post_Conditions (Prags); Prag := Pre_Post_Conditions (Prags);
while Present (Prag) loop while Present (Prag) loop
if Pragma_Name (Prag) = Name_Precondition if Nam_In (Pragma_Name (Prag), Name_Precondition,
or else Pragma_Name (Prag) = Name_Postcondition Name_Postcondition)
then then
if No (Declarations (Bod)) then if No (Declarations (Bod)) then
Set_Declarations (Bod, Empty_List); Set_Declarations (Bod, Empty_List);
end if; end if;
Append (Build_Pragma_Check_Equivalent (Prag, Subp, Parent_Subp), Append_To (Declarations (Bod),
To => Declarations (Bod)); Build_Pragma_Check_Equivalent (Prag, Subp, Parent_Subp));
end if; end if;
Prag := Next_Pragma (Prag); Prag := Next_Pragma (Prag);
......
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