Commit c70cf4f8 by Arnaud Charlet

[multiple changes]

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

	* freeze.adb, ghost.adb, sem_ch13.adb: Minor reformatting.

2016-07-04  Pascal Obry  <obry@adacore.com>

	* g-forstr.ads: More documentation for the Formatted_String
	support.

2016-07-04  Justin Squirek  <squirek@adacore.com>

	* sem_ch7.adb (Install_Parent_Private_Declarations): When
	instantiating a child unit, do not install private declaration of
	a non-generic ancestor of the generic that is also an ancestor
	of the current unit: its private part will be installed when
	private part of ancestor itself is analyzed.

2016-07-04  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Instantiate_Object): In SPARK mode add a guard
	to verify that the actual is an object reference before checking
	for volatility.
	(Check_Generic_Child_Unit): Prevent cascaded errors when prefix
	is illegal.

From-SVN: r237969
parent d4b56371
2016-07-04 Hristian Kirtchev <kirtchev@adacore.com>
* freeze.adb, ghost.adb, sem_ch13.adb: Minor reformatting.
2016-07-04 Pascal Obry <obry@adacore.com>
* g-forstr.ads: More documentation for the Formatted_String
support.
2016-07-04 Justin Squirek <squirek@adacore.com>
* sem_ch7.adb (Install_Parent_Private_Declarations): When
instantiating a child unit, do not install private declaration of
a non-generic ancestor of the generic that is also an ancestor
of the current unit: its private part will be installed when
private part of ancestor itself is analyzed.
2016-07-04 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Instantiate_Object): In SPARK mode add a guard
to verify that the actual is an object reference before checking
for volatility.
(Check_Generic_Child_Unit): Prevent cascaded errors when prefix
is illegal.
2016-07-04 Gary Dismukes <dismukes@adacore.com> 2016-07-04 Gary Dismukes <dismukes@adacore.com>
* sem_ch12.ads, freeze.adb: Minor reformatting and typo fixes. * sem_ch12.ads, freeze.adb: Minor reformatting and typo fixes.
......
...@@ -3561,32 +3561,11 @@ package body Freeze is ...@@ -3561,32 +3561,11 @@ package body Freeze is
Junk : Boolean; Junk : Boolean;
pragma Warnings (Off, Junk); pragma Warnings (Off, Junk);
Rec_Pushed : Boolean := False;
-- Set True if the record type scope Rec has been pushed on the scope
-- stack. Needed for the analysis of delayed aspects specified to the
-- components of Rec.
SSO_ADC : Node_Id;
-- Scalar_Storage_Order attribute definition clause for the record
Unplaced_Component : Boolean := False;
-- Set True if we find at least one component with no component
-- clause (used to warn about useless Pack pragmas).
Placed_Component : Boolean := False;
-- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas, and also
-- to detect cases where Implicit_Packing may have an effect).
Aliased_Component : Boolean := False; Aliased_Component : Boolean := False;
-- Set True if we find at least one component which is aliased. This -- Set True if we find at least one component which is aliased. This
-- is used to prevent Implicit_Packing of the record, since packing -- is used to prevent Implicit_Packing of the record, since packing
-- cannot modify the size of alignment of an aliased component. -- cannot modify the size of alignment of an aliased component.
SSO_ADC_Component : Boolean := False;
-- Set True if we find at least one component whose type has a
-- Scalar_Storage_Order attribute definition clause.
All_Elem_Components : Boolean := True; All_Elem_Components : Boolean := True;
-- Set False if we encounter a component of a composite type -- Set False if we encounter a component of a composite type
...@@ -3601,10 +3580,31 @@ package body Freeze is ...@@ -3601,10 +3580,31 @@ package body Freeze is
-- Accumulates total Esize values of all elementary components. Used -- Accumulates total Esize values of all elementary components. Used
-- for processing of Implicit_Packing. -- for processing of Implicit_Packing.
Placed_Component : Boolean := False;
-- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas, and also
-- to detect cases where Implicit_Packing may have an effect).
Rec_Pushed : Boolean := False;
-- Set True if the record type scope Rec has been pushed on the scope
-- stack. Needed for the analysis of delayed aspects specified to the
-- components of Rec.
Sized_Component_Total_RM_Size : Uint := Uint_0; Sized_Component_Total_RM_Size : Uint := Uint_0;
-- Accumulates total RM_Size values of all sized components. Used -- Accumulates total RM_Size values of all sized components. Used
-- for processing of Implicit_Packing. -- for processing of Implicit_Packing.
SSO_ADC : Node_Id;
-- Scalar_Storage_Order attribute definition clause for the record
SSO_ADC_Component : Boolean := False;
-- Set True if we find at least one component whose type has a
-- Scalar_Storage_Order attribute definition clause.
Unplaced_Component : Boolean := False;
-- Set True if we find at least one component with no component
-- clause (used to warn about useless Pack pragmas).
function Check_Allocator (N : Node_Id) return Node_Id; function Check_Allocator (N : Node_Id) return Node_Id;
-- If N is an allocator, possibly wrapped in one or more level of -- If N is an allocator, possibly wrapped in one or more level of
-- qualified expression(s), return the inner allocator node, else -- qualified expression(s), return the inner allocator node, else
...@@ -4419,10 +4419,12 @@ package body Freeze is ...@@ -4419,10 +4419,12 @@ package body Freeze is
-- packing is required for it, as we are sure in this case that -- packing is required for it, as we are sure in this case that
-- the back end cannot do the expected layout without packing. -- the back end cannot do the expected layout without packing.
and then ((All_Elem_Components and then
and then RM_Size (Rec) < Elem_Component_Total_Esize) ((All_Elem_Components
or else (not All_Elem_Components and then RM_Size (Rec) < Elem_Component_Total_Esize)
and then not All_Storage_Unit_Components)) or else
(not All_Elem_Components
and then not All_Storage_Unit_Components))
-- And the total RM size cannot be greater than the specified size -- And the total RM size cannot be greater than the specified size
-- since otherwise packing will not get us where we have to be. -- since otherwise packing will not get us where we have to be.
...@@ -5461,20 +5463,21 @@ package body Freeze is ...@@ -5461,20 +5463,21 @@ package body Freeze is
-- the RM_Size of the component type. -- the RM_Size of the component type.
if RM_Size (E) = Num_Elmts * Rsiz then if RM_Size (E) = Num_Elmts * Rsiz then
-- For implicit packing mode, just set the component -- For implicit packing mode, just set the component
-- size and Freeze_Array_Type will do the rest. -- size and Freeze_Array_Type will do the rest.
if Implicit_Packing then if Implicit_Packing then
Set_Component_Size (Btyp, Rsiz); Set_Component_Size (Btyp, Rsiz);
-- Otherwise give an error message -- Otherwise give an error message
else else
Error_Msg_NE Error_Msg_NE
("size given for& too small", SZ, E); ("size given for& too small", SZ, E);
Error_Msg_N -- CODEFIX Error_Msg_N -- CODEFIX
("\use explicit pragma Pack " ("\use explicit pragma Pack or use pragma "
& "or use pragma Implicit_Packing", SZ); & "Implicit_Packing", SZ);
end if; end if;
end if; end if;
end if; end if;
......
...@@ -144,7 +144,12 @@ package GNAT.Formatted_String is ...@@ -144,7 +144,12 @@ package GNAT.Formatted_String is
use Ada; use Ada;
type Formatted_String (<>) is private; type Formatted_String (<>) is private;
-- A format string as defined for printf routine -- A format string as defined for printf routine. This string is the
-- actual format for all the parameters added with the "&" routines below.
-- Note that a Formatted_String object can't be reused as it serves as
-- recipient for the final result. That is, each use of "&" will build
-- incrementally the final result string which can be retrieved with
-- the "-" routine below.
Format_Error : exception; Format_Error : exception;
-- Raised for every mismatch between the parameter and the expected format -- Raised for every mismatch between the parameter and the expected format
......
...@@ -1177,6 +1177,8 @@ package body Ghost is ...@@ -1177,6 +1177,8 @@ package body Ghost is
-- A freeze node for an ignored ghost entity must be pruned as -- A freeze node for an ignored ghost entity must be pruned as
-- well, to prevent meaningless references in the back end. -- well, to prevent meaningless references in the back end.
-- ??? the freeze node itself should be ignored ghost
elsif Nkind (N) = N_Freeze_Entity elsif Nkind (N) = N_Freeze_Entity
and then Is_Ignored_Ghost_Entity (Entity (N)) and then Is_Ignored_Ghost_Entity (Entity (N))
then then
......
...@@ -6695,17 +6695,23 @@ package body Sem_Ch12 is ...@@ -6695,17 +6695,23 @@ package body Sem_Ch12 is
elsif Nkind (Gen_Id) = N_Expanded_Name then elsif Nkind (Gen_Id) = N_Expanded_Name then
-- Entity already present, analyze prefix, whose meaning may be -- Entity already present, analyze prefix, whose meaning may be an
-- an instance in the current context. If it is an instance of -- instance in the current context. If it is an instance of a
-- a relative within another, the proper parent may still have -- relative within another, the proper parent may still have to be
-- to be installed, if they are not of the same generation. -- installed, if they are not of the same generation.
Analyze (Prefix (Gen_Id)); Analyze (Prefix (Gen_Id));
-- In the unlikely case that a local declaration hides the name -- Prevent cascaded errors
-- of the parent package, locate it on the homonym chain. If the
-- context is an instance of the parent, the renaming entity is if Etype (Prefix (Gen_Id)) = Any_Type then
-- flagged as such. return;
end if;
-- In the unlikely case that a local declaration hides the name of
-- the parent package, locate it on the homonym chain. If the context
-- is an instance of the parent, the renaming entity is flagged as
-- such.
Inst_Par := Entity (Prefix (Gen_Id)); Inst_Par := Entity (Prefix (Gen_Id));
while Present (Inst_Par) while Present (Inst_Par)
...@@ -10681,10 +10687,11 @@ package body Sem_Ch12 is ...@@ -10681,10 +10687,11 @@ package body Sem_Ch12 is
-- An effectively volatile object cannot be used as an actual in a -- An effectively volatile object cannot be used as an actual in a
-- generic instantiation (SPARK RM 7.1.3(7)). The following check is -- generic instantiation (SPARK RM 7.1.3(7)). The following check is
-- relevant only when SPARK_Mode is on as it is not a standard Ada -- relevant only when SPARK_Mode is on as it is not a standard Ada
-- legality rule. -- legality rule, and also verifies that the actual is an object.
if SPARK_Mode = On if SPARK_Mode = On
and then Present (Actual) and then Present (Actual)
and then Is_Object_Reference (Actual)
and then Is_Effectively_Volatile_Object (Actual) and then Is_Effectively_Volatile_Object (Actual)
then then
Error_Msg_N Error_Msg_N
......
...@@ -12049,7 +12049,7 @@ package body Sem_Ch13 is ...@@ -12049,7 +12049,7 @@ package body Sem_Ch13 is
Subp_Decl := Subp_Decl :=
Make_Subprogram_Renaming_Declaration (Loc, Make_Subprogram_Renaming_Declaration (Loc,
Specification => Build_Spec, Specification => Build_Spec,
Name => New_Occurrence_Of (Subp, Loc)); Name => New_Occurrence_Of (Subp, Loc));
if Defer_Declaration then if Defer_Declaration then
Set_TSS (Base_Type (Ent), Subp_Id); Set_TSS (Base_Type (Ent), Subp_Id);
...@@ -12057,7 +12057,6 @@ package body Sem_Ch13 is ...@@ -12057,7 +12057,6 @@ package body Sem_Ch13 is
else else
if From_Aspect_Specification (N) then if From_Aspect_Specification (N) then
Append_Freeze_Action (Ent, Subp_Decl); Append_Freeze_Action (Ent, Subp_Decl);
else else
Insert_Action (N, Subp_Decl); Insert_Action (N, Subp_Decl);
end if; end if;
......
...@@ -1392,7 +1392,7 @@ package body Sem_Ch7 is ...@@ -1392,7 +1392,7 @@ package body Sem_Ch7 is
-- If one of the non-generic parents is itself on the scope -- If one of the non-generic parents is itself on the scope
-- stack, do not install its private declarations: they are -- stack, do not install its private declarations: they are
-- installed in due time when the private part of that parent -- installed in due time when the private part of that parent
-- is analyzed. This is delicate ??? -- is analyzed.
else else
while Present (Inst_Par) while Present (Inst_Par)
...@@ -1400,11 +1400,20 @@ package body Sem_Ch7 is ...@@ -1400,11 +1400,20 @@ package body Sem_Ch7 is
and then (not In_Open_Scopes (Inst_Par) and then (not In_Open_Scopes (Inst_Par)
or else not In_Private_Part (Inst_Par)) or else not In_Private_Part (Inst_Par))
loop loop
Install_Private_Declarations (Inst_Par); if Nkind (Inst_Node) = N_Formal_Package_Declaration
Set_Use (Private_Declarations or else
(Specification not Is_Ancestor_Package
(Unit_Declaration_Node (Inst_Par)))); (Inst_Par, Cunit_Entity (Current_Sem_Unit))
Inst_Par := Scope (Inst_Par); then
Install_Private_Declarations (Inst_Par);
Set_Use
(Private_Declarations
(Specification
(Unit_Declaration_Node (Inst_Par))));
Inst_Par := Scope (Inst_Par);
else
exit;
end if;
end loop; end loop;
exit; exit;
......
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