Commit 06f6c43f by Arnaud Charlet

[multiple changes]

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

	* sem_ch12.adb (Copy_Generic_Node): Handle the special
	qualification installed for universal literals that act as
	operands in binary or unary operators.	(Qualify_Operand): Mark
	the qualification to signal the instantiation mechanism how to
	handle global reference propagation.
	* sinfo.adb (Is_Qualified_Universal_Literal): New routine.
	(Set_Is_Qualified_Universal_Literal): New routine.
	* sinfo.ads New attribute Is_Qualified_Universal_Literal along
	with occurrences in nodes.
	(Is_Qualified_Universal_Literal):
	New routine along with pragma Inline.
	(Set_Is_Qualified_Universal_Literal): New routine along with
	pragma Inline.

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

	* sem.adb (Do_Analyze): Save and restore Style_Max_Line_Length
	so that the corresponding checks are preserved across compilations
	that include System.Constants in their context.

2016-04-20  Gary Dismukes  <dismukes@adacore.com>

	* sem_type.adb: Minor typo fix and reformatting.
	* a-conhel.ads: Update comment.

2016-04-20  Bob Duff  <duff@adacore.com>

	* a-cihama.adb, a-cihase.adb, a-coinve.adb (Copy): Rewrite the
	code so it doesn't trigger an "uninit var" warning.

From-SVN: r235256
parent 71129dde
2016-04-20 Hristian Kirtchev <kirtchev@adacore.com> 2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch12.adb (Copy_Generic_Node): Handle the special
qualification installed for universal literals that act as
operands in binary or unary operators. (Qualify_Operand): Mark
the qualification to signal the instantiation mechanism how to
handle global reference propagation.
* sinfo.adb (Is_Qualified_Universal_Literal): New routine.
(Set_Is_Qualified_Universal_Literal): New routine.
* sinfo.ads New attribute Is_Qualified_Universal_Literal along
with occurrences in nodes.
(Is_Qualified_Universal_Literal):
New routine along with pragma Inline.
(Set_Is_Qualified_Universal_Literal): New routine along with
pragma Inline.
2016-04-20 Ed Schonberg <schonberg@adacore.com>
* sem.adb (Do_Analyze): Save and restore Style_Max_Line_Length
so that the corresponding checks are preserved across compilations
that include System.Constants in their context.
2016-04-20 Gary Dismukes <dismukes@adacore.com>
* sem_type.adb: Minor typo fix and reformatting.
* a-conhel.ads: Update comment.
2016-04-20 Bob Duff <duff@adacore.com>
* a-cihama.adb, a-cihase.adb, a-coinve.adb (Copy): Rewrite the
code so it doesn't trigger an "uninit var" warning.
2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
* sem_attr.ads Add new table Universal_Type_Attribute. * sem_attr.ads Add new table Universal_Type_Attribute.
* sem_util.adb (Yields_Universal_Type): Use a table lookup when * sem_util.adb (Yields_Universal_Type): Use a table lookup when
checking attributes. checking attributes.
......
...@@ -274,17 +274,17 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ...@@ -274,17 +274,17 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
C : Count_Type; C : Count_Type;
begin begin
if Capacity = 0 then if Capacity < Source.Length then
C := Source.Length; if Checks and then Capacity /= 0 then
elsif Capacity >= Source.Length then
C := Capacity;
elsif Checks then
raise Capacity_Error raise Capacity_Error
with "Requested capacity is less than Source length"; with "Requested capacity is less than Source length";
end if; end if;
C := Source.Length;
else
C := Capacity;
end if;
return Target : Map do return Target : Map do
Target.Reserve_Capacity (C); Target.Reserve_Capacity (C);
Target.Assign (Source); Target.Assign (Source);
......
...@@ -264,17 +264,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -264,17 +264,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
C : Count_Type; C : Count_Type;
begin begin
if Capacity = 0 then if Capacity < Source.Length then
C := Source.Length; if Checks and then Capacity /= 0 then
elsif Capacity >= Source.Length then
C := Capacity;
elsif Checks then
raise Capacity_Error raise Capacity_Error
with "Requested capacity is less than Source length"; with "Requested capacity is less than Source length";
end if; end if;
C := Source.Length;
else
C := Capacity;
end if;
return Target : Set do return Target : Set do
Target.Reserve_Capacity (C); Target.Reserve_Capacity (C);
Target.Assign (Source); Target.Assign (Source);
......
...@@ -376,15 +376,15 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -376,15 +376,15 @@ package body Ada.Containers.Indefinite_Vectors is
C : Count_Type; C : Count_Type;
begin begin
if Capacity = 0 then if Capacity < Source.Length then
C := Source.Length; if Checks and then Capacity /= 0 then
raise Capacity_Error
with "Requested capacity is less than Source length";
end if;
elsif Capacity >= Source.Length then C := Source.Length;
else
C := Capacity; C := Capacity;
elsif Checks then
raise Capacity_Error with
"Requested capacity is less than Source length";
end if; end if;
return Target : Vector do return Target : Vector do
......
...@@ -55,8 +55,6 @@ package Ada.Containers.Helpers is ...@@ -55,8 +55,6 @@ package Ada.Containers.Helpers is
package Generic_Implementation is package Generic_Implementation is
-- Generic package used in the implementation of containers. -- Generic package used in the implementation of containers.
-- ???????????????????Currently used by Vectors; not yet by all other
-- containers.
-- This needs to be generic so that the 'Enabled attribute will return -- This needs to be generic so that the 'Enabled attribute will return
-- the value that is relevant at the point where a container generic is -- the value that is relevant at the point where a container generic is
......
...@@ -53,6 +53,7 @@ with Sem_Prag; use Sem_Prag; ...@@ -53,6 +53,7 @@ with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Stand; use Stand; with Stand; use Stand;
with Stylesw; use Stylesw;
with Uintp; use Uintp; with Uintp; use Uintp;
with Uname; use Uname; with Uname; use Uname;
...@@ -1316,6 +1317,13 @@ package body Sem is ...@@ -1316,6 +1317,13 @@ package body Sem is
procedure Do_Analyze is procedure Do_Analyze is
Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-- Generally style checks are preserved across compilations, with
-- one exception: s-oscons.ads, which allows arbitrary long lines
-- unconditionally, and has no restore mechanism, because it is
-- intended as a lowest-level Pure package.
Save_Max_Line : constant Int := Style_Max_Line_Length;
List : Elist_Id; List : Elist_Id;
begin begin
...@@ -1346,6 +1354,7 @@ package body Sem is ...@@ -1346,6 +1354,7 @@ package body Sem is
Pop_Scope; Pop_Scope;
Restore_Scope_Stack (List); Restore_Scope_Stack (List);
Ghost_Mode := Save_Ghost_Mode; Ghost_Mode := Save_Ghost_Mode;
Style_Max_Line_Length := Save_Max_Line;
end Do_Analyze; end Do_Analyze;
-- Local variables -- Local variables
......
...@@ -7293,6 +7293,20 @@ package body Sem_Ch12 is ...@@ -7293,6 +7293,20 @@ package body Sem_Ch12 is
Set_Entity (New_N, Entity (Assoc)); Set_Entity (New_N, Entity (Assoc));
Check_Private_View (N); Check_Private_View (N);
-- The node is a reference to a global type and acts as the
-- subtype mark of a qualified expression created in order
-- to aid resolution of accidental overloading in instances.
-- Since N is a reference to a type, the Associated_Node of
-- N denotes an entity rather than another identifier. See
-- Qualify_Universal_Operands for details.
elsif Nkind (N) = N_Identifier
and then Nkind (Parent (N)) = N_Qualified_Expression
and then Subtype_Mark (Parent (N)) = N
and then Is_Qualified_Universal_Literal (Parent (N))
then
Set_Entity (New_N, Assoc);
-- The name in the call may be a selected component if the -- The name in the call may be a selected component if the
-- call has not been analyzed yet, as may be the case for -- call has not been analyzed yet, as may be the case for
-- pre/post conditions in a generic unit. -- pre/post conditions in a generic unit.
...@@ -13982,6 +13996,7 @@ package body Sem_Ch12 is ...@@ -13982,6 +13996,7 @@ package body Sem_Ch12 is
Loc : constant Source_Ptr := Sloc (Opnd); Loc : constant Source_Ptr := Sloc (Opnd);
Typ : constant Entity_Id := Etype (Actual); Typ : constant Entity_Id := Etype (Actual);
Mark : Node_Id; Mark : Node_Id;
Qual : Node_Id;
begin begin
-- Qualify the operand when it is of a universal type. Note that -- Qualify the operand when it is of a universal type. Note that
...@@ -14007,10 +14022,19 @@ package body Sem_Ch12 is ...@@ -14007,10 +14022,19 @@ package body Sem_Ch12 is
Mark := Qualify_Type (Loc, Typ); Mark := Qualify_Type (Loc, Typ);
end if; end if;
Rewrite (Opnd, Qual :=
Make_Qualified_Expression (Loc, Make_Qualified_Expression (Loc,
Subtype_Mark => Mark, Subtype_Mark => Mark,
Expression => Relocate_Node (Opnd))); Expression => Relocate_Node (Opnd));
-- Mark the qualification to distinguish it from other source
-- constructs and signal the instantiation mechanism that this
-- node requires special processing. See Copy_Generic_Node for
-- details.
Set_Is_Qualified_Universal_Literal (Qual);
Rewrite (Opnd, Qual);
end if; end if;
end Qualify_Operand; end Qualify_Operand;
......
...@@ -1481,8 +1481,8 @@ package body Sem_Type is ...@@ -1481,8 +1481,8 @@ package body Sem_Type is
elsif Rop_Typ = F2_Typ then elsif Rop_Typ = F2_Typ then
return Matching_Types (Lop_Typ, F1_Typ); return Matching_Types (Lop_Typ, F1_Typ);
-- Otherwise this is not a good match bechause each operand-formal -- Otherwise this is not a good match because each operand-formal
-- pair is compatible only on base type basis which is not specific -- pair is compatible only on base-type basis, which is not specific
-- enough. -- enough.
else else
......
...@@ -1982,6 +1982,14 @@ package body Sinfo is ...@@ -1982,6 +1982,14 @@ package body Sinfo is
return Flag7 (N); return Flag7 (N);
end Is_Protected_Subprogram_Body; end Is_Protected_Subprogram_Body;
function Is_Qualified_Universal_Literal
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Qualified_Expression);
return Flag4 (N);
end Is_Qualified_Universal_Literal;
function Is_Static_Coextension function Is_Static_Coextension
(N : Node_Id) return Boolean is (N : Node_Id) return Boolean is
begin begin
...@@ -5229,6 +5237,14 @@ package body Sinfo is ...@@ -5229,6 +5237,14 @@ package body Sinfo is
Set_Flag7 (N, Val); Set_Flag7 (N, Val);
end Set_Is_Protected_Subprogram_Body; end Set_Is_Protected_Subprogram_Body;
procedure Set_Is_Qualified_Universal_Literal
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Qualified_Expression);
Set_Flag4 (N, Val);
end Set_Is_Qualified_Universal_Literal;
procedure Set_Is_Static_Coextension procedure Set_Is_Static_Coextension
(N : Node_Id; Val : Boolean := True) is (N : Node_Id; Val : Boolean := True) is
begin begin
......
...@@ -1710,6 +1710,12 @@ package Sinfo is ...@@ -1710,6 +1710,12 @@ package Sinfo is
-- handler to make sure that the associated protected object is unlocked -- handler to make sure that the associated protected object is unlocked
-- when the subprogram completes. -- when the subprogram completes.
-- Is_Qualified_Universal_Literal (Flag4-Sem)
-- Present in N_Qualified_Expression nodes. Set when the qualification is
-- converting a universal literal to a specific type. Such qualifiers aid
-- the resolution of accidental overloading of binary or unary operators
-- which may occur in instances.
-- Is_Static_Coextension (Flag14-Sem) -- Is_Static_Coextension (Flag14-Sem)
-- Present in N_Allocator nodes. Set if the allocator is a coextension -- Present in N_Allocator nodes. Set if the allocator is a coextension
-- of an object allocated on the stack rather than the heap. -- of an object allocated on the stack rather than the heap.
...@@ -4542,6 +4548,7 @@ package Sinfo is ...@@ -4542,6 +4548,7 @@ package Sinfo is
-- Subtype_Mark (Node4) -- Subtype_Mark (Node4)
-- Expression (Node3) expression or aggregate -- Expression (Node3) expression or aggregate
-- plus fields for expression -- plus fields for expression
-- Is_Qualified_Universal_Literal (Flag4-Sem)
-------------------- --------------------
-- 4.8 Allocator -- -- 4.8 Allocator --
...@@ -9399,6 +9406,9 @@ package Sinfo is ...@@ -9399,6 +9406,9 @@ package Sinfo is
function Is_Protected_Subprogram_Body function Is_Protected_Subprogram_Body
(N : Node_Id) return Boolean; -- Flag7 (N : Node_Id) return Boolean; -- Flag7
function Is_Qualified_Universal_Literal
(N : Node_Id) return Boolean; -- Flag4
function Is_Static_Coextension function Is_Static_Coextension
(N : Node_Id) return Boolean; -- Flag14 (N : Node_Id) return Boolean; -- Flag14
...@@ -10437,6 +10447,9 @@ package Sinfo is ...@@ -10437,6 +10447,9 @@ package Sinfo is
procedure Set_Is_Protected_Subprogram_Body procedure Set_Is_Protected_Subprogram_Body
(N : Node_Id; Val : Boolean := True); -- Flag7 (N : Node_Id; Val : Boolean := True); -- Flag7
procedure Set_Is_Qualified_Universal_Literal
(N : Node_Id; Val : Boolean := True); -- Flag4
procedure Set_Is_Static_Coextension procedure Set_Is_Static_Coextension
(N : Node_Id; Val : Boolean := True); -- Flag14 (N : Node_Id; Val : Boolean := True); -- Flag14
...@@ -12819,6 +12832,7 @@ package Sinfo is ...@@ -12819,6 +12832,7 @@ package Sinfo is
pragma Inline (Is_Power_Of_2_For_Shift); pragma Inline (Is_Power_Of_2_For_Shift);
pragma Inline (Is_Prefixed_Call); pragma Inline (Is_Prefixed_Call);
pragma Inline (Is_Protected_Subprogram_Body); pragma Inline (Is_Protected_Subprogram_Body);
pragma Inline (Is_Qualified_Universal_Literal);
pragma Inline (Is_Static_Coextension); pragma Inline (Is_Static_Coextension);
pragma Inline (Is_Static_Expression); pragma Inline (Is_Static_Expression);
pragma Inline (Is_Subprogram_Descriptor); pragma Inline (Is_Subprogram_Descriptor);
...@@ -13160,6 +13174,7 @@ package Sinfo is ...@@ -13160,6 +13174,7 @@ package Sinfo is
pragma Inline (Set_Is_Power_Of_2_For_Shift); pragma Inline (Set_Is_Power_Of_2_For_Shift);
pragma Inline (Set_Is_Prefixed_Call); pragma Inline (Set_Is_Prefixed_Call);
pragma Inline (Set_Is_Protected_Subprogram_Body); pragma Inline (Set_Is_Protected_Subprogram_Body);
pragma Inline (Set_Is_Qualified_Universal_Literal);
pragma Inline (Set_Is_Static_Coextension); pragma Inline (Set_Is_Static_Coextension);
pragma Inline (Set_Is_Static_Expression); pragma Inline (Set_Is_Static_Expression);
pragma Inline (Set_Is_Subprogram_Descriptor); pragma Inline (Set_Is_Subprogram_Descriptor);
......
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