OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2011-08-03  Thomas Quinot  <quinot@adacore.com>

	* scos.adb, get_scos.adb, put_scos.adb
	New code letter for decisions: G (entry guard)
	* par_sco.adb
	(Traverse_Subprogram_Body): Rename to...
	(Traverse_Subprogram_Or_Task_Body): New subrpogram.
	(Traverse_Protected_Body): New subprogram
	(Traverse_Declarations_Or_Statements): Add traversal of task bodies,
	protected bodies and entry bodies.

2011-08-03  Yannick Moy  <moy@adacore.com>

	* einfo.adb, einfo.ads (Is_Postcondition_Proc): new flag for procedure
	entities with get/set subprograms, which is set on procedure entities
	generated by the compiler for a postcondition.
	* sem_ch6.adb (Process_PPCs): set new flag on postcondition procedures
	* alfa.adb, alfa.ads (Get_Entity_For_Decl): new function returning the
	entity for a declaration
	(Get_Unique_Entity_For_Decl): new function returning an entity which
	represents a declaration, so that matching spec and body have the same
	entity.

2011-08-03  Robert Dewar  <dewar@adacore.com>

	* a-except-2005.adb, a-cfhama.adb, a-cfhase.adb, a-cfhase.ads,
	a-cforma.adb, a-cforse.ads, a-cforse.adb: Minor reformatting

2011-08-03  Yannick Moy  <moy@adacore.com>

	* lib-xref-alfa.adb (Detect_And_Add_ALFA_Scope): make the subprogram
	library-level because retriction No_Implicit_Dynamic_Code in the
	front-end prevents its definition as a local subprogram
	(Traverse_Compilation_Unit): extract new procedure from Add_ALFA_File,
	for reuse in other contexts
	(Traverse_Declarations_Or_Statements,
	Traverse_Handled_Statement_Sequence, Traverse_Package_Body,
	Traverse_Package_Declaration, Traverse_Subprogram_Body): make all these
	procedures take a callback parameter to be called on all declarations
	* lib-xref.ads
	(Traverse_All_Compilation_Units): new generic function to traverse a
	compilation unit and call a callback parameter on all declarations

From-SVN: r177284
This commit is contained in:
Arnaud Charlet 2011-08-03 17:12:06 +02:00
parent f9ad6b6231
commit 5ffe0bab81
17 changed files with 562 additions and 460 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
gcc/ada/ChangeLog
View File

@ -1,3 +1,46 @@
2011-08-03 Thomas Quinot <quinot@adacore.com>
* scos.adb, get_scos.adb, put_scos.adb
New code letter for decisions: G (entry guard)
* par_sco.adb
(Traverse_Subprogram_Body): Rename to...
(Traverse_Subprogram_Or_Task_Body): New subrpogram.
(Traverse_Protected_Body): New subprogram
(Traverse_Declarations_Or_Statements): Add traversal of task bodies,
protected bodies and entry bodies.
2011-08-03 Yannick Moy <moy@adacore.com>
* einfo.adb, einfo.ads (Is_Postcondition_Proc): new flag for procedure
entities with get/set subprograms, which is set on procedure entities
generated by the compiler for a postcondition.
* sem_ch6.adb (Process_PPCs): set new flag on postcondition procedures
* alfa.adb, alfa.ads (Get_Entity_For_Decl): new function returning the
entity for a declaration
(Get_Unique_Entity_For_Decl): new function returning an entity which
represents a declaration, so that matching spec and body have the same
entity.
2011-08-03 Robert Dewar <dewar@adacore.com>
* a-except-2005.adb, a-cfhama.adb, a-cfhase.adb, a-cfhase.ads,
a-cforma.adb, a-cforse.ads, a-cforse.adb: Minor reformatting
2011-08-03 Yannick Moy <moy@adacore.com>
* lib-xref-alfa.adb (Detect_And_Add_ALFA_Scope): make the subprogram
library-level because retriction No_Implicit_Dynamic_Code in the
front-end prevents its definition as a local subprogram
(Traverse_Compilation_Unit): extract new procedure from Add_ALFA_File,
for reuse in other contexts
(Traverse_Declarations_Or_Statements,
Traverse_Handled_Statement_Sequence, Traverse_Package_Body,
Traverse_Package_Declaration, Traverse_Subprogram_Body): make all these
procedures take a callback parameter to be called on all declarations
* lib-xref.ads
(Traverse_All_Compilation_Units): new generic function to traverse a
compilation unit and call a callback parameter on all declarations
2011-08-03 Javier Miranda <miranda@adacore.com>
* sem_prag.adb (Process_Interface_Name): Allow duplicated export names

136
gcc/ada/a-cfhama.adb
View File

@ -41,6 +41,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
-- Local Subprograms --
-----------------------
-- All local subprograms require comments ???
function Equivalent_Keys
(Key : Key_Type;
Node : Node_Type) return Boolean;
@ -73,10 +75,10 @@ package body Ada.Containers.Formal_Hashed_Maps is
package HT_Ops is
new Hash_Tables.Generic_Bounded_Operations
(HT_Types => HT_Types,
Hash_Node => Hash_Node,
Next => Next,
Set_Next => Set_Next);
(HT_Types => HT_Types,
Hash_Node => Hash_Node,
Next => Next,
Set_Next => Set_Next);
package Key_Ops is
new Hash_Tables.Generic_Bounded_Keys
@ -93,7 +95,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
function "=" (Left, Right : Map) return Boolean is
begin
if Length (Left) /= Length (Right) then
return False;
end if;
@ -103,13 +104,15 @@ package body Ada.Containers.Formal_Hashed_Maps is
end if;
declare
Node : Count_Type := Left.First.Node;
Node : Count_Type;
ENode : Count_Type;
begin
begin
Node := Left.First.Node;
while Node /= 0 loop
ENode := Find (Container => Right,
Key => Left.Nodes (Node).Key).Node;
if ENode = 0 or else
Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
then
@ -120,9 +123,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
end loop;
return True;
end;
end "=";
------------
@ -149,7 +150,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
-- Start of processing for Assign
begin
if Target'Address = Source'Address then
return;
end if;
@ -159,7 +159,9 @@ package body Ada.Containers.Formal_Hashed_Maps is
"Source length exceeds Target capacity";
end if;
Clear (Target); -- checks busy bits
-- Check busy bits
Clear (Target);
Insert_Elements (Source);
end Assign;
@ -201,27 +203,33 @@ package body Ada.Containers.Formal_Hashed_Maps is
is
C : constant Count_Type :=
Count_Type'Max (Capacity, Source.Capacity);
H : Hash_Type := 1;
N : Count_Type := 1;
H : Hash_Type;
N : Count_Type;
Target : Map (C, Source.Modulus);
Cu : Cursor;
begin
begin
Target.Length := Source.Length;
Target.Free := Source.Free;
H := 1;
while H <= Source.Modulus loop
Target.Buckets (H) := Source.Buckets (H);
H := H + 1;
end loop;
N := 1;
while N <= Source.Capacity loop
Target.Nodes (N) := Source.Nodes (N);
N := N + 1;
end loop;
while N <= C loop
Cu := (Node => N);
Free (Target, Cu.Node);
N := N + 1;
end loop;
return Target;
end Copy;
@ -242,7 +250,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
X : Count_Type;
begin
Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
if X = 0 then
@ -254,7 +261,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Delete has no element";
@ -306,14 +312,18 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Equivalent_Keys
(Key : Key_Type;
Node : Node_Type) return Boolean is
Node : Node_Type) return Boolean
is
begin
return Equivalent_Keys (Key, Node.Key);
end Equivalent_Keys;
function Equivalent_Keys (Left : Map; CLeft : Cursor;
Right : Map; CRight : Cursor)
return Boolean is
function Equivalent_Keys
(Left : Map;
CLeft : Cursor;
Right : Map;
CRight : Cursor) return Boolean
is
begin
if not Has_Element (Left, CLeft) then
raise Constraint_Error with
@ -331,10 +341,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
"Right cursor of Equivalent_Keys is bad");
declare
LN : Node_Type renames Left.Nodes (CLeft.Node);
RN : Node_Type renames Right.Nodes (CRight.Node);
begin
return Equivalent_Keys (LN.Key, RN.Key);
end;
@ -343,7 +351,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Equivalent_Keys
(Left : Map;
CLeft : Cursor;
Right : Key_Type) return Boolean is
Right : Key_Type) return Boolean
is
begin
if not Has_Element (Left, CLeft) then
raise Constraint_Error with
@ -355,7 +364,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
declare
LN : Node_Type renames Left.Nodes (CLeft.Node);
begin
return Equivalent_Keys (LN.Key, Right);
end;
@ -364,7 +372,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Equivalent_Keys
(Left : Key_Type;
Right : Map;
CRight : Cursor) return Boolean is
CRight : Cursor) return Boolean
is
begin
if Has_Element (Right, CRight) then
raise Constraint_Error with
@ -399,7 +408,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Find (Container : Map; Key : Key_Type) return Cursor is
Node : constant Count_Type :=
Key_Ops.Find (Container, Key);
Key_Ops.Find (Container, Key);
begin
if Node = 0 then
@ -422,17 +431,13 @@ package body Ada.Containers.Formal_Hashed_Maps is
end if;
return (Node => Node);
end First;
----------
-- Free --
----------
procedure Free
(HT : in out Map;
X : Count_Type)
is
procedure Free (HT : in out Map; X : Count_Type) is
begin
HT.Nodes (X).Has_Element := False;
HT_Ops.Free (HT, X);
@ -442,10 +447,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
-- Generic_Allocate --
----------------------
procedure Generic_Allocate
(HT : in out Map;
Node : out Count_Type)
is
procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is
procedure Allocate is
new HT_Ops.Generic_Allocate (Set_Element);
@ -465,6 +467,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
not Container.Nodes (Position.Node).Has_Element then
return False;
end if;
return True;
end Has_Element;
@ -472,8 +475,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
-- Hash_Node --
---------------
function Hash_Node
(Node : Node_Type) return Hash_Type is
function Hash_Node (Node : Node_Type) return Hash_Type is
begin
return Hash (Node.Key);
end Hash_Node;
@ -537,6 +539,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
procedure Assign_Key (Node : in out Node_Type) is
begin
Node.Key := Key;
-- What is following commented out line doing here ???
-- Node.Element := New_Item;
end Assign_Key;
@ -551,7 +555,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
return Result;
end New_Node;
-- Start of processing for Insert
-- Start of processing for Insert
begin
@ -598,10 +602,9 @@ package body Ada.Containers.Formal_Hashed_Maps is
return Result;
end New_Node;
-- Start of processing for Insert
-- Start of processing for Insert
begin
Local_Insert (Container, Key, Position.Node, Inserted);
end Insert;
@ -639,8 +642,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
procedure Iterate
(Container : Map;
Process :
not null access procedure (Container : Map; Position : Cursor))
Process : not null
access procedure (Container : Map; Position : Cursor))
is
procedure Process_Node (Node : Count_Type);
pragma Inline (Process_Node);
@ -658,7 +661,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Iterate
-- Start of processing for Iterate
begin
B := B + 1;
@ -695,14 +698,18 @@ package body Ada.Containers.Formal_Hashed_Maps is
----------
function Left (Container : Map; Position : Cursor) return Map is
Curs : Cursor := Position;
C : Map (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Curs : Cursor;
C : Map (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
Curs := Position;
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
@ -712,6 +719,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
@ -736,7 +744,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
X, Y : Count_Type;
begin
if Target'Address = Source'Address then
return;
end if;
@ -816,6 +823,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Overlap (Left, Right : Map) return Boolean is
Left_Node : Count_Type;
Left_Nodes : Nodes_Type renames Left.Nodes;
begin
if Length (Right) = 0 or Length (Left) = 0 then
return False;
@ -826,12 +834,10 @@ package body Ada.Containers.Formal_Hashed_Maps is
end if;
Left_Node := First (Left).Node;
while Left_Node /= 0 loop
declare
N : Node_Type renames Left_Nodes (Left_Node);
E : Key_Type renames N.Key;
begin
if Find (Right, E).Node /= 0 then
return True;
@ -852,10 +858,9 @@ package body Ada.Containers.Formal_Hashed_Maps is
(Container : in out Map;
Position : Cursor;
Process : not null access
procedure (Key : Key_Type; Element : Element_Type))
procedure (Key : Key_Type; Element : Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Query_Element has no element";
@ -864,8 +869,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
declare
N : Node_Type renames Container.Nodes (Position.Node);
N : Node_Type renames Container.Nodes (Position.Node);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
@ -876,7 +880,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
declare
K : Key_Type renames N.Key;
E : Element_Type renames N.Element;
begin
Process (K, E);
exception
@ -909,8 +912,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
-- Read_Node --
---------------
function Read_Node (Stream : not null access Root_Stream_Type'Class)
return Count_Type
function Read_Node
(Stream : not null access Root_Stream_Type'Class) return Count_Type
is
procedure Read_Element (Node : in out Node_Type);
pragma Inline (Read_Element);
@ -925,14 +928,15 @@ package body Ada.Containers.Formal_Hashed_Maps is
Node : Count_Type;
-- Start of processing for Read_Node
-- Start of processing for Read_Node
begin
Allocate (Container, Node);
return Node;
end Read_Node;
-- Start of processing for Read
-- Start of processing for Read
begin
Read_Nodes (Stream, Container);
end Read;
@ -957,7 +961,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
if Node = 0 then
raise Constraint_Error with
"attempt to replace key not in map";
@ -986,7 +989,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
New_Item : Element_Type)
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Replace_Element has no element";
@ -1012,7 +1014,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
Capacity : Count_Type)
is
begin
if Capacity > Container.Capacity then
raise Capacity_Error with "requested capacity is too large";
end if;
@ -1024,14 +1025,16 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Right (Container : Map; Position : Cursor) return Map is
Curs : Cursor := First (Container);
C : Map (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
C : Map (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
@ -1041,6 +1044,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
@ -1060,6 +1064,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Strict_Equal (Left, Right : Map) return Boolean is
CuL : Cursor := First (Left);
CuR : Cursor := First (Right);
begin
if Length (Left) /= Length (Right) then
return False;
@ -1073,6 +1078,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
Right.Nodes (CuR.Node).Key) then
return False;
end if;
CuL := Next (Left, CuL);
CuR := Next (Right, CuR);
end loop;
@ -1173,7 +1179,9 @@ package body Ada.Containers.Formal_Hashed_Maps is
end if;
if X = Container.Nodes (X).Next then
-- to prevent unnecessary looping
-- Prevent unnecessary looping
return False;
end if;

197
gcc/ada/a-cfhase.adb
View File

@ -41,6 +41,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
-- Local Subprograms --
-----------------------
-- All need comments ???
procedure Difference
(Left, Right : Set;
Target : in out Set);
@ -117,7 +119,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
function "=" (Left, Right : Set) return Boolean is
begin
if Length (Left) /= Length (Right) then
return False;
end if;
@ -127,14 +128,15 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
declare
Node : Count_Type := First (Left).Node;
Node : Count_Type;
ENode : Count_Type;
begin
begin
Node := First (Left).Node;
while Node /= 0 loop
ENode := Find (Container => Right,
Item => Left.Nodes (Node).Element).Node;
if ENode = 0 or else
if ENode = 0 or else
Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
then
return False;
@ -173,10 +175,9 @@ package body Ada.Containers.Formal_Hashed_Sets is
pragma Assert (B);
end Insert_Element;
-- Start of processing for Assign
-- Start of processing for Assign
begin
if Target'Address = Source'Address then
return;
end if;
@ -204,7 +205,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
procedure Clear (Container : in out Set) is
begin
HT_Ops.Clear (Container);
end Clear;
@ -226,28 +226,34 @@ package body Ada.Containers.Formal_Hashed_Sets is
Capacity : Count_Type := 0) return Set
is
C : constant Count_Type :=
Count_Type'Max (Capacity, Source.Capacity);
H : Hash_Type := 1;
N : Count_Type := 1;
Count_Type'Max (Capacity, Source.Capacity);
H : Hash_Type;
N : Count_Type;
Target : Set (C, Source.Modulus);
Cu : Cursor;
begin
begin
Target.Length := Source.Length;
Target.Free := Source.Free;
H := 1;
while H <= Source.Modulus loop
Target.Buckets (H) := Source.Buckets (H);
H := H + 1;
end loop;
N := 1;
while N <= Source.Capacity loop
Target.Nodes (N) := Source.Nodes (N);
N := N + 1;
end loop;
while N <= C loop
Cu := (Node => N);
Free (Target, Cu.Node);
N := N + 1;
end loop;
return Target;
end Copy;
@ -271,12 +277,12 @@ package body Ada.Containers.Formal_Hashed_Sets is
X : Count_Type;
begin
Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
if X = 0 then
raise Constraint_Error with "attempt to delete element not in set";
end if;
Free (Container, X);
end Delete;
@ -285,7 +291,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
Position : in out Cursor)
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -317,7 +322,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
SN : Nodes_Type renames Source.Nodes;
begin
if Target'Address = Source'Address then
Clear (Target);
return;
@ -337,8 +341,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
if Src_Length >= Target.Length then
Tgt_Node := HT_Ops.First (Target);
while Tgt_Node /= 0 loop
if Element_Keys.Find (Source,
TN (Tgt_Node).Element) /= 0 then
if Element_Keys.Find (Source, TN (Tgt_Node).Element) /= 0 then
declare
X : constant Count_Type := Tgt_Node;
begin
@ -346,10 +349,12 @@ package body Ada.Containers.Formal_Hashed_Sets is
HT_Ops.Delete_Node_Sans_Free (Target, X);
Free (Target, X);
end;
else
Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
end if;
end loop;
return;
else
Src_Node := HT_Ops.First (Source);
@ -357,8 +362,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
while Src_Node /= Src_Last loop
Tgt_Node := Element_Keys.Find
(Target, SN (Src_Node).Element);
Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element);
if Tgt_Node /= 0 then
HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node);
@ -386,7 +390,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
E : Element_Type renames Left.Nodes (L_Node).Element;
X : Count_Type;
B : Boolean;
begin
if Find (Right, E).Node = 0 then
Insert (Target, E, X, B);
@ -394,7 +397,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
end Process;
-- Start of processing for Difference
-- Start of processing for Difference
begin
Iterate (Left);
@ -403,6 +406,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Difference (Left, Right : Set) return Set is
C : Count_Type;
H : Hash_Type;
begin
if Left'Address = Right'Address then
return Empty_Set;
@ -418,6 +422,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
C := Length (Left);
H := Default_Modulus (C);
return S : Set (C, H) do
Difference (Left, Right, Target => S);
end return;
@ -429,7 +434,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Element
(Container : Set;
Position : Cursor) return Element_Type is
Position : Cursor) return Element_Type
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor equals No_Element";
@ -464,10 +470,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
L_Node : Node_Type) return Boolean
is
R_Index : constant Hash_Type :=
Element_Keys.Index (R_HT, L_Node.Element);
Element_Keys.Index (R_HT, L_Node.Element);
R_Node : Count_Type := R_HT.Buckets (R_Index);
RN : Nodes_Type renames R_HT.Nodes;
begin
@ -485,7 +489,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
end loop;
end Find_Equivalent_Key;
-- Start of processing of Equivalent_Sets
-- Start of processing of Equivalent_Sets
begin
return Is_Equivalent (Left, Right);
@ -495,9 +499,12 @@ package body Ada.Containers.Formal_Hashed_Sets is
-- Equivalent_Elements --
-------------------------
function Equivalent_Elements (Left : Set; CLeft : Cursor;
Right : Set; CRight : Cursor)
return Boolean is
function Equivalent_Elements
(Left : Set;
CLeft : Cursor;
Right : Set;
CRight : Cursor) return Boolean
is
begin
if not Has_Element (Left, CLeft) then
raise Constraint_Error with
@ -525,7 +532,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Equivalent_Elements
(Left : Set;
CLeft : Cursor;
Right : Element_Type) return Boolean is
Right : Element_Type) return Boolean
is
begin
if not Has_Element (Left, CLeft) then
raise Constraint_Error with
@ -545,7 +553,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Equivalent_Elements
(Left : Element_Type;
Right : Set;
CRight : Cursor) return Boolean is
CRight : Cursor) return Boolean
is
begin
if not Has_Element (Right, CRight) then
raise Constraint_Error with
@ -563,14 +572,17 @@ package body Ada.Containers.Formal_Hashed_Sets is
end;
end Equivalent_Elements;
-- What does the following comment signify???
-- NOT MODIFIED
---------------------
-- Equivalent_Keys --
---------------------
function Equivalent_Keys (Key : Element_Type; Node : Node_Type)
return Boolean is
function Equivalent_Keys
(Key : Element_Type;
Node : Node_Type) return Boolean
is
begin
return Equivalent_Elements (Key, Node.Element);
end Equivalent_Keys;
@ -597,15 +609,14 @@ package body Ada.Containers.Formal_Hashed_Sets is
(Container : Set;
Item : Element_Type) return Cursor
is
Node : constant Count_Type :=
Element_Keys.Find (Container, Item);
Node : constant Count_Type := Element_Keys.Find (Container, Item);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
return (Node => Node);
end Find;
-----------
@ -614,13 +625,13 @@ package body Ada.Containers.Formal_Hashed_Sets is
function First (Container : Set) return Cursor is
Node : constant Count_Type := HT_Ops.First (Container);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
end First;
----------
@ -644,10 +655,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
(HT : in out Set;
Node : out Count_Type)
is
procedure Allocate is
new HT_Ops.Generic_Allocate (Set_Element);
procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element);
begin
Allocate (HT, Node);
HT.Nodes (Node).Has_Element := True;
@ -659,10 +667,12 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Has_Element (Container : Set; Position : Cursor) return Boolean is
begin
if Position.Node = 0 or else
not Container.Nodes (Position.Node).Has_Element then
if Position.Node = 0
or else not Container.Nodes (Position.Node).Has_Element
then
return False;
end if;
return True;
end Has_Element;
@ -767,12 +777,10 @@ package body Ada.Containers.Formal_Hashed_Sets is
return Result;
end New_Node;
-- Start of processing for Insert
-- Start of processing for Insert
begin
Local_Insert (Container, New_Item, Node, Inserted);
end Insert;
------------------
@ -787,7 +795,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
TN : Nodes_Type renames Target.Nodes;
begin
if Target'Address = Source'Address then
return;
end if;
@ -845,7 +852,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
end Process;
-- Start of processing for Intersection
-- Start of processing for Intersection
begin
Iterate (Left);
@ -862,6 +869,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
C := Count_Type'Min (Length (Left), Length (Right)); -- ???
H := Default_Modulus (C);
return S : Set (C, H) do
if Length (Left) /= 0 and Length (Right) /= 0 then
Intersection (Left, Right, Target => S);
@ -882,8 +890,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
-- Is_In --
-----------
function Is_In (HT : Set;
Key : Node_Type) return Boolean is
function Is_In (HT : Set; Key : Node_Type) return Boolean is
begin
return Element_Keys.Find (HT, Key.Element) /= 0;
end Is_In;
@ -895,6 +902,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
Subset_Node : Count_Type;
Subset_Nodes : Nodes_Type renames Subset.Nodes;
begin
if Subset'Address = Of_Set'Address then
return True;
@ -905,7 +913,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
Subset_Node := First (Subset).Node;
while Subset_Node /= 0 loop
declare
N : Node_Type renames Subset_Nodes (Subset_Node);
@ -949,7 +956,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Iterate
-- Start of processing for Iterate
begin
B := B + 1;
@ -971,13 +978,15 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Left (Container : Set; Position : Cursor) return Set is
Curs : Cursor := Position;
C : Set (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
C : Set (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
@ -987,6 +996,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
@ -1003,12 +1013,13 @@ package body Ada.Containers.Formal_Hashed_Sets is
-- Move --
----------
-- Comments???
procedure Move (Target : in out Set; Source : in out Set) is
NN : HT_Types.Nodes_Type renames Source.Nodes;
X, Y : Count_Type;
begin
if Target'Address = Source'Address then
return;
end if;
@ -1079,6 +1090,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Overlap (Left, Right : Set) return Boolean is
Left_Node : Count_Type;
Left_Nodes : Nodes_Type renames Left.Nodes;
begin
if Length (Right) = 0 or Length (Left) = 0 then
return False;
@ -1089,12 +1101,10 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
Left_Node := First (Left).Node;
while Left_Node /= 0 loop
declare
N : Node_Type renames Left_Nodes (Left_Node);
E : Element_Type renames N.Element;
begin
if Find (Right, E).Node /= 0 then
return True;
@ -1125,7 +1135,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
@ -1171,8 +1180,11 @@ package body Ada.Containers.Formal_Hashed_Sets is
procedure Read_Element (Node : in out Node_Type);
pragma Inline (Read_Element);
procedure Allocate is
new Generic_Allocate (Read_Element);
procedure Allocate is new Generic_Allocate (Read_Element);
------------------
-- Read_Element --
------------------
procedure Read_Element (Node : in out Node_Type) is
begin
@ -1181,16 +1193,16 @@ package body Ada.Containers.Formal_Hashed_Sets is
Node : Count_Type;
-- Start of processing for Read_Node
-- Start of processing for Read_Node
begin
Allocate (Container, Node);
return Node;
end Read_Node;
-- Start of processing for Read
begin
-- Start of processing for Read
begin
Read_Nodes (Stream, Container);
end Read;
@ -1210,11 +1222,9 @@ package body Ada.Containers.Formal_Hashed_Sets is
(Container : in out Set;
New_Item : Element_Type)
is
Node : constant Count_Type :=
Element_Keys.Find (Container, New_Item);
Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
begin
if Node = 0 then
raise Constraint_Error with
"attempt to replace element not in set";
@ -1238,7 +1248,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
New_Item : Element_Type)
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor equals No_Element";
@ -1270,14 +1279,16 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Right (Container : Set; Position : Cursor) return Set is
Curs : Cursor := First (Container);
C : Set (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
C : Set (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
@ -1287,6 +1298,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
@ -1315,17 +1327,20 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Strict_Equal (Left, Right : Set) return Boolean is
CuL : Cursor := First (Left);
CuR : Cursor := First (Right);
begin
if Length (Left) /= Length (Right) then
return False;
end if;
while CuL.Node /= 0 or CuR.Node /= 0 loop
if CuL.Node /= CuR.Node or else
Left.Nodes (CuL.Node).Element /=
Right.Nodes (CuR.Node).Element then
if CuL.Node /= CuR.Node
or else Left.Nodes (CuL.Node).Element /=
Right.Nodes (CuR.Node).Element
then
return False;
end if;
CuL := Next (Left, CuL);
CuR := Next (Right, CuR);
end loop;
@ -1344,8 +1359,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
procedure Process (Source_Node : Count_Type);
pragma Inline (Process);
procedure Iterate is
new HT_Ops.Generic_Iteration (Process);
procedure Iterate is new HT_Ops.Generic_Iteration (Process);
-------------
-- Process --
@ -1355,7 +1369,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
N : Node_Type renames Source.Nodes (Source_Node);
X : Count_Type;
B : Boolean;
begin
if Is_In (Target, N) then
Delete (Target, N.Element);
@ -1365,10 +1378,9 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
end Process;
-- Start of processing for Symmetric_Difference
-- Start of processing for Symmetric_Difference
begin
if Target'Address = Source'Address then
Clear (Target);
return;
@ -1383,8 +1395,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
Iterate (Source);
Iterate (Source);
end Symmetric_Difference;
function Symmetric_Difference (Left, Right : Set) return Set is
@ -1406,6 +1418,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
C := Length (Left) + Length (Right);
H := Default_Modulus (C);
return S : Set (C, H) do
Difference (Left, Right, S);
Difference (Right, Left, S);
@ -1523,8 +1536,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
return False;
end if;
X := S.Buckets (Element_Keys.Index (S,
N (Position.Node).Element));
X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element));
for J in 1 .. S.Length loop
if X = Position.Node then
@ -1684,7 +1696,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
is
X : Count_Type;
begin
Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
Free (Container, X);
end Exclude;
@ -1697,16 +1708,9 @@ package body Ada.Containers.Formal_Hashed_Sets is
(Container : Set;
Key : Key_Type) return Cursor
is
Node : constant Count_Type :=
Key_Keys.Find (Container, Key);
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
return (if Node = 0 then No_Element else (Node => Node));
end Find;
---------
@ -1720,8 +1724,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
"Position cursor has no element";
end if;
pragma Assert (Vet (Container, Position),
"bad cursor in function Key");
pragma Assert
(Vet (Container, Position), "bad cursor in function Key");
declare
N : Node_Type renames Container.Nodes (Position.Node);
@ -1739,8 +1743,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
Key : Key_Type;
New_Item : Element_Type)
is
Node : constant Count_Type :=
Key_Keys.Find (Container, Key);
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if Node = 0 then
@ -1759,7 +1762,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
(Container : in out Set;
Position : Cursor;
Process : not null access
procedure (Element : in out Element_Type))
procedure (Element : in out Element_Type))
is
Indx : Hash_Type;
N : Nodes_Type renames Container.Nodes;
@ -1775,13 +1778,13 @@ package body Ada.Containers.Formal_Hashed_Sets is
(Vet (Container, Position),
"bad cursor in Update_Element_Preserving_Key");
-- Record bucket now, in case key is changed.
-- Record bucket now, in case key is changed
Indx := HT_Ops.Index (Container.Buckets, N (Position.Node));
declare
E : Element_Type renames N (Position.Node).Element;
K : constant Key_Type := Key (E);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
@ -1807,7 +1810,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
end;
-- Key was modified, so remove this node from set.
-- Key was modified, so remove this node from set
if Container.Buckets (Indx) = Position.Node then
Container.Buckets (Indx) := N (Position.Node).Next;

1
gcc/ada/a-cfhase.ads
View File

@ -68,6 +68,7 @@ package Ada.Containers.Formal_Hashed_Sets is
pragma Pure;
type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
-- why is this commented out ???
-- pragma Preelaborable_Initialization (Set);
type Cursor is private;

142
gcc/ada/a-cforma.adb
View File

@ -43,8 +43,8 @@ package body Ada.Containers.Formal_Ordered_Maps is
-- These subprograms provide a functional interface to access fields
-- of a node, and a procedural interface for modifying these values.
function Color (Node : Node_Type)
return Ada.Containers.Red_Black_Trees.Color_Type;
function Color
(Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type;
pragma Inline (Color);
function Left_Son (Node : Node_Type) return Count_Type;
@ -74,6 +74,8 @@ package body Ada.Containers.Formal_Ordered_Maps is
-- Local Subprograms --
-----------------------
-- All need comments ???
generic
with procedure Set_Element (Node : in out Node_Type);
procedure Generic_Allocate
@ -99,8 +101,8 @@ package body Ada.Containers.Formal_Ordered_Maps is
package Tree_Operations is
new Red_Black_Trees.Generic_Bounded_Operations
(Tree_Types => Tree_Types,
Left => Left_Son,
Right => Right_Son);
Left => Left_Son,
Right => Right_Son);
use Tree_Operations;
@ -117,10 +119,10 @@ package body Ada.Containers.Formal_Ordered_Maps is
function "=" (Left, Right : Map) return Boolean is
Lst : Count_Type;
Node : Count_Type := First (Left).Node;
Node : Count_Type;
ENode : Count_Type;
begin
begin
if Length (Left) /= Length (Right) then
return False;
end if;
@ -130,18 +132,21 @@ package body Ada.Containers.Formal_Ordered_Maps is
end if;
Lst := Next (Left, Last (Left).Node);
Node := First (Left).Node;
while Node /= Lst loop
ENode := Find (Right, Left.Nodes (Node).Key).Node;
if ENode = 0 or else
Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
then
return False;
end if;
Node := Next (Left, Node);
end loop;
return True;
end "=";
------------
@ -167,19 +172,17 @@ package body Ada.Containers.Formal_Ordered_Maps is
function New_Node return Count_Type;
pragma Inline (New_Node);
procedure Insert_Post is
new Key_Ops.Generic_Insert_Post (New_Node);
procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node);
procedure Unconditional_Insert_Sans_Hint is
new Key_Ops.Generic_Unconditional_Insert (Insert_Post);
new Key_Ops.Generic_Unconditional_Insert (Insert_Post);
procedure Unconditional_Insert_Avec_Hint is
new Key_Ops.Generic_Unconditional_Insert_With_Hint
(Insert_Post,
Unconditional_Insert_Sans_Hint);
new Key_Ops.Generic_Unconditional_Insert_With_Hint
(Insert_Post,
Unconditional_Insert_Sans_Hint);
procedure Allocate is
new Generic_Allocate (Set_Element);
procedure Allocate is new Generic_Allocate (Set_Element);
--------------
-- New_Node --
@ -187,7 +190,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
function New_Node return Count_Type is
Result : Count_Type;
begin
Allocate (Target, Result);
return Result;
@ -218,7 +220,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
-- Start of processing for Assign
begin
if Target'Address = Source'Address then
return;
end if;
@ -236,9 +237,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
-------------
function Ceiling (Container : Map; Key : Key_Type) return Cursor is
Node : constant Count_Type :=
Key_Ops.Ceiling (Container, Key);
Node : constant Count_Type := Key_Ops.Ceiling (Container, Key);
begin
if Node = 0 then
@ -254,7 +253,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Clear (Container : in out Map) is
begin
Tree_Operations.Clear_Tree (Container);
end Clear;
@ -283,6 +281,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
function Copy (Source : Map; Capacity : Count_Type := 0) return Map is
Node : Count_Type := 1;
N : Count_Type;
begin
return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do
if Length (Source) > 0 then
@ -325,7 +324,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Delete has no element";
@ -340,7 +338,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
end Delete;
procedure Delete (Container : in out Map; Key : Key_Type) is
X : constant Node_Access := Key_Ops.Find (Container, Key);
begin
@ -358,9 +355,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Delete_First (Container : in out Map) is
X : constant Node_Access := First (Container).Node;
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Maps.Free (Container, X);
@ -373,9 +368,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Delete_Last (Container : in out Map) is
X : constant Node_Access := Last (Container).Node;
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Maps.Free (Container, X);
@ -432,9 +425,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Exclude (Container : in out Map; Key : Key_Type) is
X : constant Node_Access := Key_Ops.Find (Container, Key);
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Maps.Free (Container, X);
@ -446,9 +437,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
----------
function Find (Container : Map; Key : Key_Type) return Cursor is
Node : constant Count_Type :=
Key_Ops.Find (Container, Key);
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
if Node = 0 then
@ -469,7 +458,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
end if;
return (Node => Container.First);
end First;
-------------------
@ -503,9 +491,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
-----------
function Floor (Container : Map; Key : Key_Type) return Cursor is
Node : constant Count_Type :=
Key_Ops.Floor (Container, Key);
Node : constant Count_Type := Key_Ops.Floor (Container, Key);
begin
if Node = 0 then
@ -536,10 +522,8 @@ package body Ada.Containers.Formal_Ordered_Maps is
(Tree : in out Tree_Types.Tree_Type'Class;
Node : out Count_Type)
is
procedure Allocate is
new Tree_Operations.Generic_Allocate (Set_Element);
begin
Allocate (Tree, Node);
Tree.Nodes (Node).Has_Element := True;
@ -596,6 +580,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
Inserted : out Boolean)
is
function New_Node return Node_Access;
-- Comment ???
procedure Insert_Post is
new Key_Ops.Generic_Insert_Post (New_Node);
@ -624,7 +609,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
return X;
end New_Node;
-- Start of processing for Insert
-- Start of processing for Insert
begin
Insert_Sans_Hint
@ -676,6 +661,10 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Initialize (Node : in out Node_Type);
procedure Allocate_Node is new Generic_Allocate (Initialize);
----------------
-- Initialize --
----------------
procedure Initialize (Node : in out Node_Type) is
begin
Node.Key := Key;
@ -683,19 +672,17 @@ package body Ada.Containers.Formal_Ordered_Maps is
X : Node_Access;
-- Start of processing for New_Node
begin
Allocate_Node (Container, X);
return X;
end New_Node;
-- Start of processing for Insert
-- Start of processing for Insert
begin
Insert_Sans_Hint
(Container,
Key,
Position.Node,
Inserted);
Insert_Sans_Hint (Container, Key, Position.Node, Inserted);
end Insert;
--------------
@ -801,6 +788,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
if Length (Container) = 0 then
return No_Element;
end if;
return (Node => Container.Last);
end Last;
@ -836,13 +824,14 @@ package body Ada.Containers.Formal_Ordered_Maps is
function Left (Container : Map; Position : Cursor) return Map is
Curs : Cursor := Position;
C : Map (Container.Capacity) :=
Copy (Container, Container.Capacity);
C : Map (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
@ -852,6 +841,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
@ -882,7 +872,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
X : Node_Access;
begin
if Target'Address = Source'Address then
return;
end if;
@ -904,7 +893,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
exit when X = 0;
-- Here we insert a copy of the source element into the target, and
-- then delete the element from the source. Another possibility is
-- then delete the element from the source. Another possibility is
-- that delete it first (and hang onto its index), then insert it.
-- ???
@ -946,20 +935,15 @@ package body Ada.Containers.Formal_Ordered_Maps is
function Overlap (Left, Right : Map) return Boolean is
begin
if Length (Left) = 0 or Length (Right) = 0 then
return False;
end if;
declare
L_Node : Count_Type := First (Left).Node;
R_Node : Count_Type := First (Right).Node;
L_Last : constant Count_Type :=
Next (Left, Last (Left).Node);
R_Last : constant Count_Type :=
Next (Right, Last (Right).Node);
L_Node : Count_Type := First (Left).Node;
R_Node : Count_Type := First (Right).Node;
L_Last : constant Count_Type := Next (Left, Last (Left).Node);
R_Last : constant Count_Type := Next (Right, Last (Right).Node);
begin
if Left'Address = Right'Address then
@ -973,11 +957,10 @@ package body Ada.Containers.Formal_Ordered_Maps is
return False;
end if;
if Left.Nodes (L_Node).Key
< Right.Nodes (R_Node).Key then
if Left.Nodes (L_Node).Key < Right.Nodes (R_Node).Key then
L_Node := Next (Left, L_Node);
elsif Right.Nodes (R_Node).Key
< Left.Nodes (L_Node).Key then
elsif Right.Nodes (R_Node).Key < Left.Nodes (L_Node).Key then
R_Node := Next (Right, R_Node);
else
@ -1052,7 +1035,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
"Position cursor of Query_Element is bad");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
@ -1106,9 +1088,9 @@ package body Ada.Containers.Formal_Ordered_Maps is
Element_Type'Read (Stream, Node.Element);
end Read_Element;
-- Start of processing for Read
begin
-- Start of processing for Read
begin
Read_Elements (Stream, Container);
end Read;
@ -1130,7 +1112,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
New_Item : Element_Type)
is
begin
declare
Node : constant Node_Access := Key_Ops.Find (Container, Key);
@ -1163,7 +1144,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
New_Item : Element_Type)
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Replace_Element has no element";
@ -1186,8 +1166,8 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Reverse_Iterate
(Container : Map;
Process :
not null access procedure (Container : Map; Position : Cursor))
Process : not null access procedure (Container : Map;
Position : Cursor))
is
procedure Process_Node (Node : Node_Access);
pragma Inline (Process_Node);
@ -1206,14 +1186,13 @@ package body Ada.Containers.Formal_Ordered_Maps is
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Reverse_Iterate
-- Start of processing for Reverse_Iterate
begin
B := B + 1;
begin
Local_Reverse_Iterate (Container);
exception
when others =>
B := B - 1;
@ -1229,13 +1208,14 @@ package body Ada.Containers.Formal_Ordered_Maps is
function Right (Container : Map; Position : Cursor) return Map is
Curs : Cursor := First (Container);
C : Map (Container.Capacity) :=
Copy (Container, Container.Capacity);
C : Map (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
@ -1246,6 +1226,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
@ -1262,10 +1243,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
-- Set_Color --
---------------
procedure Set_Color
(Node : in out Node_Type;
Color : Color_Type)
is
procedure Set_Color (Node : in out Node_Type; Color : Color_Type) is
begin
Node.Color := Color;
end Set_Color;
@ -1304,6 +1282,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
function Strict_Equal (Left, Right : Map) return Boolean is
LNode : Count_Type := First (Left).Node;
RNode : Count_Type := First (Right).Node;
begin
if Length (Left) /= Length (Right) then
return False;
@ -1314,15 +1293,16 @@ package body Ada.Containers.Formal_Ordered_Maps is
return True;
end if;
if Left.Nodes (LNode).Element /=
Right.Nodes (RNode).Element or
Left.Nodes (LNode).Key /= Right.Nodes (RNode).Key then
if Left.Nodes (LNode).Element /= Right.Nodes (RNode).Element
or else Left.Nodes (LNode).Key /= Right.Nodes (RNode).Key
then
exit;
end if;
LNode := Next (Left, LNode);
RNode := Next (Right, RNode);
end loop;
return False;
end Strict_Equal;
@ -1337,7 +1317,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
Element : in out Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Update_Element has no element";
@ -1347,7 +1326,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
"Position cursor of Update_Element is bad");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;

230
gcc/ada/a-cforse.adb
View File

@ -77,6 +77,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
-- Local Subprograms --
-----------------------
-- Comments needed???
generic
with procedure Set_Element (Node : in out Node_Type);
procedure Generic_Allocate
@ -122,8 +124,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
package Tree_Operations is
new Red_Black_Trees.Generic_Bounded_Operations
(Tree_Types,
Left => Left_Son,
Right => Right_Son);
Left => Left_Son,
Right => Right_Son);
use Tree_Operations;
@ -148,10 +150,10 @@ package body Ada.Containers.Formal_Ordered_Sets is
function "=" (Left, Right : Set) return Boolean is
Lst : Count_Type;
Node : Count_Type := First (Left).Node;
Node : Count_Type;
ENode : Count_Type;
begin
begin
if Length (Left) /= Length (Right) then
return False;
end if;
@ -161,18 +163,20 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
Lst := Next (Left, Last (Left).Node);
Node := First (Left).Node;
while Node /= Lst loop
ENode := Find (Right, Left.Nodes (Node).Element).Node;
if ENode = 0 or else
Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
if ENode = 0
or else Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
then
return False;
end if;
Node := Next (Left, Node);
end loop;
return True;
end "=";
------------
@ -206,11 +210,10 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Unconditional_Insert_Avec_Hint is
new Element_Keys.Generic_Unconditional_Insert_With_Hint
(Insert_Post,
Unconditional_Insert_Sans_Hint);
(Insert_Post,
Unconditional_Insert_Sans_Hint);
procedure Allocate is
new Generic_Allocate (Set_Element);
procedure Allocate is new Generic_Allocate (Set_Element);
--------------
-- New_Node --
@ -218,7 +221,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
function New_Node return Count_Type is
Result : Count_Type;
begin
Allocate (Target, Result);
return Result;
@ -233,9 +235,11 @@ package body Ada.Containers.Formal_Ordered_Sets is
Node.Element := SN.Element;
end Set_Element;
-- Local variables
Target_Node : Count_Type;
-- Start of processing for Append_Element
-- Start of processing for Append_Element
begin
Unconditional_Insert_Avec_Hint
@ -266,7 +270,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
-------------
function Ceiling (Container : Set; Item : Element_Type) return Cursor is
Node : constant Count_Type := Element_Keys.Ceiling (Container, Item);
begin
@ -275,7 +278,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return (Node => Node);
end Ceiling;
-----------
@ -313,17 +315,19 @@ package body Ada.Containers.Formal_Ordered_Sets is
----------
function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
Node : Count_Type := 1;
N : Count_Type;
Node : Count_Type;
N : Count_Type;
Target : Set (Count_Type'Max (Source.Capacity, Capacity));
begin
if Length (Source) > 0 then
Target.Length := Source.Length;
Target.Root := Source.Root;
Target.First := Source.First;
Target.Last := Source.Last;
Target.Free := Source.Free;
Target.Root := Source.Root;
Target.First := Source.First;
Target.Last := Source.Last;
Target.Free := Source.Free;
Node := 1;
while Node <= Source.Capacity loop
Target.Nodes (Node).Element :=
Source.Nodes (Node).Element;
@ -346,6 +350,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Node := Node + 1;
end loop;
end if;
return Target;
end Copy;
@ -355,7 +360,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -373,7 +377,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
X : constant Count_Type := Element_Keys.Find (Container, Item);
begin
if X = 0 then
raise Constraint_Error with "attempt to delete element not in set";
end if;
@ -388,9 +391,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Delete_First (Container : in out Set) is
X : constant Count_Type := Container.First;
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Sets.Free (Container, X);
@ -403,9 +404,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Delete_Last (Container : in out Set) is
X : constant Count_Type := Container.Last;
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Sets.Free (Container, X);
@ -419,7 +418,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Difference (Target : in out Set; Source : Set) is
begin
Set_Ops.Set_Difference (Target, Source);
end Difference;
function Difference (Left, Right : Set) return Set is
@ -437,9 +435,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return S : Set (Length (Left)) do
Assign (S,
Set_Ops.Set_Difference (Left, Right));
Assign (S, Set_Ops.Set_Difference (Left, Right));
end return;
end Difference;
@ -484,7 +480,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Equivalent_Sets (Left, Right : Set) return Boolean is
function Is_Equivalent_Node_Node
(L, R : Node_Type) return Boolean;
(L, R : Node_Type) return Boolean;
pragma Inline (Is_Equivalent_Node_Node);
function Is_Equivalent is
@ -505,7 +501,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
end Is_Equivalent_Node_Node;
-- Start of processing for Equivalent_Sets
-- Start of processing for Equivalent_Sets
begin
return Is_Equivalent (Left, Right);
@ -517,9 +513,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Exclude (Container : in out Set; Item : Element_Type) is
X : constant Count_Type := Element_Keys.Find (Container, Item);
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Sets.Free (Container, X);
@ -531,9 +525,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
----------
function Find (Container : Set; Item : Element_Type) return Cursor is
Node : constant Count_Type :=
Element_Keys.Find (Container, Item);
Node : constant Count_Type := Element_Keys.Find (Container, Item);
begin
if Node = 0 then
@ -541,7 +533,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return (Node => Node);
end Find;
-----------
@ -555,7 +546,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return (Node => Container.First);
end First;
-------------------
@ -582,10 +572,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Floor (Container : Set; Item : Element_Type) return Cursor is
begin
declare
Node : constant Count_Type :=
Element_Keys.Floor (Container, Item);
Node : constant Count_Type := Element_Keys.Floor (Container, Item);
begin
if Node = 0 then
@ -600,10 +588,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
-- Free --
----------
procedure Free
(Tree : in out Set;
X : Count_Type)
is
procedure Free (Tree : in out Set; X : Count_Type) is
begin
Tree.Nodes (X).Has_Element := False;
Tree_Operations.Free (Tree, X);
@ -617,10 +602,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
(Tree : in out Tree_Types.Tree_Type'Class;
Node : out Count_Type)
is
procedure Allocate is
new Tree_Operations.Generic_Allocate (Set_Element);
begin
Allocate (Tree, Node);
Tree.Nodes (Node).Has_Element := True;
@ -662,8 +645,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
-------------
function Ceiling (Container : Set; Key : Key_Type) return Cursor is
Node : constant Count_Type :=
Key_Keys.Ceiling (Container, Key);
Node : constant Count_Type := Key_Keys.Ceiling (Container, Key);
begin
if Node = 0 then
@ -687,7 +669,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
------------
procedure Delete (Container : in out Set; Key : Key_Type) is
X : constant Count_Type := Key_Keys.Find (Container, Key);
begin
@ -704,8 +685,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
-------------
function Element (Container : Set; Key : Key_Type) return Element_Type is
Node : constant Count_Type :=
Key_Keys.Find (Container, Key);
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if Node = 0 then
@ -739,9 +719,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
-------------
procedure Exclude (Container : in out Set; Key : Key_Type) is
X : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if X /= 0 then
Delete_Node_Sans_Free (Container, X);
@ -754,15 +732,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
----------
function Find (Container : Set; Key : Key_Type) return Cursor is
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
return (if Node = 0 then No_Element else (Node => Node));
end Find;
-----------
@ -770,17 +742,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
-----------
function Floor (Container : Set; Key : Key_Type) return Cursor is
Node : constant Count_Type :=
Key_Keys.Floor (Container, Key);
Node : constant Count_Type := Key_Keys.Floor (Container, Key);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
return (if Node = 0 then No_Element else (Node => Node));
end Floor;
-------------------------
@ -838,15 +802,13 @@ package body Ada.Containers.Formal_Ordered_Sets is
New_Item : Element_Type)
is
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if not Has_Element (Container, (Node => Node)) then
raise Constraint_Error with
"attempt to replace key not in set";
else
Replace_Element (Container, Node, New_Item);
end if;
Replace_Element (Container, Node, New_Item);
end Replace;
-----------------------------------
@ -859,7 +821,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
Process : not null access procedure (Element : in out Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor has no element";
@ -918,9 +879,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
begin
if Position.Node = 0 then
return False;
else
return Container.Nodes (Position.Node).Has_Element;
end if;
return Container.Nodes (Position.Node).Has_Element;
end Has_Element;
-------------
@ -959,13 +920,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Inserted : out Boolean)
is
begin
Insert_Sans_Hint
(Container,
New_Item,
Position.Node,
Inserted);
Insert_Sans_Hint (Container, New_Item, Position.Node, Inserted);
end Insert;
procedure Insert
@ -994,7 +949,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
Node : out Count_Type;
Inserted : out Boolean)
is
procedure Set_Element (Node : in out Node_Type);
function New_Node return Count_Type;
@ -1006,8 +960,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Conditional_Insert_Sans_Hint is
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
procedure Allocate is
new Generic_Allocate (Set_Element);
procedure Allocate is new Generic_Allocate (Set_Element);
--------------
-- New_Node --
@ -1015,7 +968,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
function New_Node return Count_Type is
Result : Count_Type;
begin
Allocate (Container, Result);
return Result;
@ -1030,7 +982,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Node.Element := New_Item;
end Set_Element;
-- Start of processing for Insert_Sans_Hint
-- Start of processing for Insert_Sans_Hint
begin
Conditional_Insert_Sans_Hint
@ -1066,11 +1018,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Local_Insert_With_Hint is
new Element_Keys.Generic_Conditional_Insert_With_Hint
(Insert_Post,
Insert_Sans_Hint);
(Insert_Post, Insert_Sans_Hint);
procedure Allocate is
new Generic_Allocate (Set_Element);
procedure Allocate is new Generic_Allocate (Set_Element);
--------------
-- New_Node --
@ -1078,7 +1028,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
function New_Node return Count_Type is
Result : Count_Type;
begin
Allocate (Dst_Set, Result);
return Result;
@ -1093,7 +1042,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Node.Element := Src_Node.Element;
end Set_Element;
-- Start of processing for Insert_With_Hint
-- Start of processing for Insert_With_Hint
begin
Local_Insert_With_Hint
@ -1120,8 +1069,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return S : Set (Count_Type'Min (Length (Left), Length (Right))) do
Assign (S, Set_Ops.Set_Intersection
(Left, Right));
Assign (S, Set_Ops.Set_Intersection (Left, Right));
end return;
end Intersection;
@ -1175,8 +1123,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
begin
return Set_Ops.Set_Subset (Subset,
Of_Set => Of_Set);
return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set);
end Is_Subset;
-------------
@ -1185,8 +1132,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Iterate
(Container : Set;
Process :
not null access procedure (Container : Set; Position : Cursor))
Process : not null access procedure (Container : Set;
Position : Cursor))
is
procedure Process_Node (Node : Count_Type);
pragma Inline (Process_Node);
@ -1203,9 +1150,11 @@ package body Ada.Containers.Formal_Ordered_Sets is
Process (Container, (Node => Node));
end Process_Node;
-- Local variables
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of prccessing for Iterate
-- Start of prccessing for Iterate
begin
B := B + 1;
@ -1227,12 +1176,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Last (Container : Set) return Cursor is
begin
if Length (Container) = 0 then
return No_Element;
end if;
return (Node => Container.Last);
return (if Length (Container) = 0
then No_Element
else (Node => Container.Last));
end Last;
------------------
@ -1258,13 +1204,14 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Left (Container : Set; Position : Cursor) return Set is
Curs : Cursor := Position;
C : Set (Container.Capacity) :=
Copy (Container, Container.Capacity);
C : Set (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
@ -1274,6 +1221,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
@ -1304,7 +1252,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
X : Count_Type;
begin
if Target'Address = Source'Address then
return;
end if;
@ -1363,7 +1310,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Overlap (Left, Right : Set) return Boolean is
begin
return Set_Ops.Set_Overlap (Left, Right);
end Overlap;
------------
@ -1394,14 +1340,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
declare
Node : constant Count_Type :=
Tree_Operations.Previous (Container, Position.Node);
Tree_Operations.Previous (Container, Position.Node);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
return (if Node = 0 then No_Element else (Node => Node));
end;
end Previous;
@ -1420,7 +1361,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
Process : not null access procedure (Element : Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
@ -1429,7 +1369,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
"bad cursor in Query_Element");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
@ -1477,9 +1416,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
Element_Type'Read (Stream, Node.Element);
end Read_Element;
-- Start of processing for Read
begin
-- Start of processing for Read
begin
Read_Elements (Stream, Container);
end Read;
@ -1496,9 +1435,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
-------------
procedure Replace (Container : in out Set; New_Item : Element_Type) is
Node : constant Count_Type :=
Element_Keys.Find (Container, New_Item);
Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
begin
if Node = 0 then
@ -1547,14 +1484,12 @@ package body Ada.Containers.Formal_Ordered_Sets is
function New_Node return Count_Type is
N : Node_Type renames NN (Node);
begin
N.Element := Item;
N.Color := Red;
N.Parent := 0;
N.Right := 0;
N.Left := 0;
N.Color := Red;
N.Parent := 0;
N.Right := 0;
N.Left := 0;
return Node;
end New_Node;
@ -1562,7 +1497,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Result : Count_Type;
Inserted : Boolean;
-- Start of processing for Insert
-- Start of processing for Insert
begin
if Item < NN (Node).Element
@ -1620,7 +1555,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
New_Item : Element_Type)
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor has no element";
@ -1638,8 +1572,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Reverse_Iterate
(Container : Set;
Process :
not null access procedure (Container : Set; Position : Cursor))
Process : not null access procedure (Container : Set;
Position : Cursor))
is
procedure Process_Node (Node : Count_Type);
pragma Inline (Process_Node);
@ -1658,7 +1592,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Reverse_Iterate
-- Start of processing for Reverse_Iterate
begin
B := B + 1;
@ -1680,14 +1614,15 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Right (Container : Set; Position : Cursor) return Set is
Curs : Cursor := First (Container);
C : Set (Container.Capacity) :=
Copy (Container, Container.Capacity);
C : Set (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
@ -1697,6 +1632,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
@ -1755,6 +1691,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Strict_Equal (Left, Right : Set) return Boolean is
LNode : Count_Type := First (Left).Node;
RNode : Count_Type := First (Right).Node;
begin
if Length (Left) /= Length (Right) then
return False;
@ -1773,8 +1710,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
LNode := Next (Left, LNode);
RNode := Next (Right, RNode);
end loop;
return False;
return False;
end Strict_Equal;
--------------------------
@ -1801,9 +1738,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return S : Set (Length (Left) + Length (Right)) do
Assign (S,
Set_Ops.Set_Symmetric_Difference (Left,
Right));
Assign (S, Set_Ops.Set_Symmetric_Difference (Left, Right));
end return;
end Symmetric_Difference;
@ -1814,7 +1749,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
function To_Set (New_Item : Element_Type) return Set is
Node : Count_Type;
Inserted : Boolean;
begin
return S : Set (Capacity => 1) do
Insert_Sans_Hint (S, New_Item, Node, Inserted);
@ -1879,7 +1813,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Element_Type'Write (Stream, Node.Element);
end Write_Element;
-- Start of processing for Write
-- Start of processing for Write
begin
Write_Elements (Stream, Container);

3
gcc/ada/a-cforse.ads
View File

@ -67,6 +67,7 @@ package Ada.Containers.Formal_Ordered_Sets is
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
type Set (Capacity : Count_Type) is tagged private;
-- why is this commented out ???
-- pragma Preelaborable_Initialization (Set);
type Cursor is private;
@ -276,7 +277,7 @@ private
new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
type Set (Capacity : Count_Type) is
new Tree_Types.Tree_Type (Capacity) with null record;
new Tree_Types.Tree_Type (Capacity) with null record;
use Red_Black_Trees;
use Ada.Streams;

6
gcc/ada/a-except-2005.adb
View File

@ -895,9 +895,11 @@ package body Ada.Exceptions is
Prefix : constant String := "adjust/finalize raised ";
Orig_Msg : constant String := Exception_Message (X);
Orig_Prefix_Length : constant Natural :=
Integer'Min (Prefix'Length, Orig_Msg'Length);
Integer'Min
(Prefix'Length, Orig_Msg'Length);
Orig_Prefix : String renames Orig_Msg
(Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
(Orig_Msg'First ..
Orig_Msg'First + Orig_Prefix_Length - 1);
begin
-- Message already has the proper prefix, just re-raise

70
gcc/ada/alfa.adb
View File

@ -23,8 +23,10 @@
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Output; use Output;
with Put_ALFA;
with Sinfo; use Sinfo;
package body ALFA is
@ -153,6 +155,74 @@ package body ALFA is
ALFA_Xref_Table.Init;
end Initialize_ALFA_Tables;
-------------------------
-- Get_Entity_For_Decl --
-------------------------
function Get_Entity_For_Decl (N : Node_Id) return Entity_Id is
E : Entity_Id := Empty;
begin
case Nkind (N) is
when N_Subprogram_Declaration |
N_Subprogram_Body |
N_Package_Declaration =>
E := Defining_Unit_Name (Specification (N));
when N_Package_Body =>
E := Defining_Unit_Name (N);
when N_Object_Declaration =>
E := Defining_Identifier (N);
when others =>
null;
end case;
if Nkind (E) = N_Defining_Program_Unit_Name then
E := Defining_Identifier (E);
end if;
return E;
end Get_Entity_For_Decl;
--------------------------------
-- Get_Unique_Entity_For_Decl --
--------------------------------
function Get_Unique_Entity_For_Decl (N : Node_Id) return Entity_Id is
E : Entity_Id := Empty;
begin
case Nkind (N) is
when N_Subprogram_Declaration |
N_Package_Declaration =>
E := Defining_Unit_Name (Specification (N));
when N_Package_Body =>
E := Corresponding_Spec (N);
when N_Subprogram_Body =>
if Acts_As_Spec (N) then
E := Defining_Unit_Name (Specification (N));
else
E := Corresponding_Spec (N);
end if;
when N_Object_Declaration =>
E := Defining_Identifier (N);
when others =>
null;
end case;
if Nkind (E) = N_Defining_Program_Unit_Name then
E := Defining_Identifier (E);
end if;
return E;
end Get_Unique_Entity_For_Decl;
-----------
-- palfa --
-----------

7
gcc/ada/alfa.ads
View File

@ -323,6 +323,13 @@ package ALFA is
procedure Initialize_ALFA_Tables;
-- Reset tables for a new compilation
function Get_Entity_For_Decl (N : Node_Id) return Entity_Id;
-- Return the entity for declaration N
function Get_Unique_Entity_For_Decl (N : Node_Id) return Entity_Id;
-- Return the entity which represents declaration N, so that matching
-- declaration and body have the same entity.
procedure palfa;
-- Debugging procedure to output contents of ALFA binary tables in the
-- format in which they appear in an ALI file.

15
gcc/ada/einfo.adb
View File

@ -521,7 +521,7 @@ package body Einfo is
-- Body_Is_In_ALFA Flag251
-- Is_Processed_Transient Flag252
-- (unused) Flag253
-- Is_Postcondition_Proc Flag253
-- (unused) Flag254
-----------------------
@ -1976,6 +1976,12 @@ package body Einfo is
return Flag138 (Id);
end Is_Packed_Array_Type;
function Is_Postcondition_Proc (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Procedure);
return Flag253 (Id);
end Is_Postcondition_Proc;
function Is_Potentially_Use_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@ -4494,6 +4500,12 @@ package body Einfo is
Set_Flag138 (Id, V);
end Set_Is_Packed_Array_Type;
procedure Set_Is_Postcondition_Proc (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
Set_Flag253 (Id, V);
end Set_Is_Postcondition_Proc;
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@ -7563,6 +7575,7 @@ package body Einfo is
W ("Is_Package_Body_Entity", Flag160 (Id));
W ("Is_Packed", Flag51 (Id));
W ("Is_Packed_Array_Type", Flag138 (Id));
W ("Is_Postcondition_Proc", Flag253 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Primitive", Flag218 (Id));

9
gcc/ada/einfo.ads
View File

@ -2563,6 +2563,10 @@ package Einfo is
-- an entity, then the Original_Array_Type field of this entity points
-- to the original array type for which this is the packed array type.
-- Is_Postcondition_Proc (Flag253)
-- Present in procedures. Set if entity is a procedure generated by the
-- compiler for a postcondition.
-- Is_Potentially_Use_Visible (Flag9)
-- Present in all entities. Set if entity is potentially use visible,
-- i.e. it is defined in a package that appears in a currently active
@ -5521,6 +5525,7 @@ package Einfo is
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
-- Is_Postcondition_Proc (Flag253) (non-generic case only)
-- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
@ -6213,6 +6218,7 @@ package Einfo is
function Is_Package_Body_Entity (Id : E) return B;
function Is_Packed (Id : E) return B;
function Is_Packed_Array_Type (Id : E) return B;
function Is_Postcondition_Proc (Id : E) return B;
function Is_Potentially_Use_Visible (Id : E) return B;
function Is_Preelaborated (Id : E) return B;
function Is_Primitive (Id : E) return B;
@ -6807,6 +6813,7 @@ package Einfo is
procedure Set_Is_Package_Body_Entity (Id : E; V : B := True);
procedure Set_Is_Packed (Id : E; V : B := True);
procedure Set_Is_Packed_Array_Type (Id : E; V : B := True);
procedure Set_Is_Postcondition_Proc (Id : E; V : B := True);
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
procedure Set_Is_Preelaborated (Id : E; V : B := True);
procedure Set_Is_Primitive (Id : E; V : B := True);
@ -7535,6 +7542,7 @@ package Einfo is
pragma Inline (Is_Overloadable);
pragma Inline (Is_Packed);
pragma Inline (Is_Packed_Array_Type);
pragma Inline (Is_Postcondition_Proc);
pragma Inline (Is_Potentially_Use_Visible);
pragma Inline (Is_Preelaborated);
pragma Inline (Is_Primitive);
@ -7946,6 +7954,7 @@ package Einfo is
pragma Inline (Set_Is_Package_Body_Entity);
pragma Inline (Set_Is_Packed);
pragma Inline (Set_Is_Packed_Array_Type);
pragma Inline (Set_Is_Postcondition_Proc);
pragma Inline (Set_Is_Potentially_Use_Visible);
pragma Inline (Set_Is_Preelaborated);
pragma Inline (Set_Is_Primitive);

2
gcc/ada/get_scos.adb
View File

@ -307,7 +307,7 @@ begin
-- Decision entry
when 'I' | 'E' | 'P' | 'W' | 'X' =>
when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
Dtyp := C;
Skip_Spaces;

145
gcc/ada/par_sco.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2009-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -126,7 +126,8 @@ package body Par_SCO is
procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
procedure Traverse_Package_Body (N : Node_Id);
procedure Traverse_Package_Declaration (N : Node_Id);
procedure Traverse_Subprogram_Body (N : Node_Id);
procedure Traverse_Protected_Body (N : Node_Id);
procedure Traverse_Subprogram_Or_Task_Body (N : Node_Id);
procedure Traverse_Subprogram_Declaration (N : Node_Id);
-- Traverse the corresponding construct, generating SCO table entries
@ -439,6 +440,9 @@ package body Par_SCO is
-------------------
procedure Output_Header (T : Character) is
Loc : Source_Ptr := No_Location;
-- Node whose sloc is used for the decision
begin
case T is
when 'I' | 'E' | 'W' =>
@ -446,55 +450,47 @@ package body Par_SCO is
-- For IF, EXIT, WHILE, the token SLOC can be found from
-- the SLOC of the parent of the expression.
Set_Table_Entry
(C1 => T,
C2 => ' ',
From => Sloc (Parent (N)),
To => No_Location,
Last => False);
Loc := Sloc (Parent (N));
when 'P' =>
when 'G' | 'P' =>
-- For entry, the token sloc is from the N_Entry_Body.
-- For PRAGMA, we must get the location from the pragma node.
-- Argument N is the pragma argument, and we have to go up two
-- levels (through the pragma argument association) to get to
-- the pragma node itself.
declare
Loc : constant Source_Ptr := Sloc (Parent (Parent (N)));
begin
Set_Table_Entry
(C1 => 'P',
C2 => 'd',
From => Loc,
To => No_Location,
Last => False);
-- For pragmas we also must make an entry in the hash table
-- for later access by Set_SCO_Pragma_Enabled. We set the
-- pragma as disabled above, the call will change C2 to 'e'
-- to enable the pragma header entry.
Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
end;
Loc := Sloc (Parent (Parent (N)));
when 'X' =>
-- For an expression, no Sloc
Set_Table_Entry
(C1 => 'X',
C2 => ' ',
From => No_Location,
To => No_Location,
Last => False);
null;
-- No other possibilities
when others =>
raise Program_Error;
end case;
Set_Table_Entry
(C1 => T,
C2 => ' ',
From => Loc,
To => No_Location,
Last => False);
if T = 'P' then
-- For pragmas we also must make an entry in the hash table
-- for later access by Set_SCO_Pragma_Enabled. We set the
-- pragma as disabled now, the call will change C2 to 'e'
-- to enable the pragma header entry.
SCO_Table.Table (SCO_Table.Last).C2 := 'd';
Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
end if;
end Output_Header;
------------------------------
@ -773,30 +769,34 @@ package body Par_SCO is
-- Traverse the unit
if Nkind (Lu) = N_Subprogram_Body then
Traverse_Subprogram_Body (Lu);
case Nkind (Lu) is
when N_Protected_Body =>
Traverse_Protected_Body (Lu);
elsif Nkind (Lu) = N_Subprogram_Declaration then
Traverse_Subprogram_Declaration (Lu);
when N_Subprogram_Body | N_Task_Body =>
Traverse_Subprogram_Or_Task_Body (Lu);
elsif Nkind (Lu) = N_Package_Declaration then
Traverse_Package_Declaration (Lu);
when N_Subprogram_Declaration =>
Traverse_Subprogram_Declaration (Lu);
elsif Nkind (Lu) = N_Package_Body then
Traverse_Package_Body (Lu);
when N_Package_Declaration =>
Traverse_Package_Declaration (Lu);
elsif Nkind (Lu) = N_Generic_Package_Declaration then
Traverse_Generic_Package_Declaration (Lu);
when N_Package_Body =>
Traverse_Package_Body (Lu);
elsif Nkind (Lu) in N_Generic_Instantiation then
Traverse_Generic_Instantiation (Lu);
when N_Generic_Package_Declaration =>
Traverse_Generic_Package_Declaration (Lu);
-- All other cases of compilation units (e.g. renamings), generate
-- no SCO information.
when N_Generic_Instantiation =>
Traverse_Generic_Instantiation (Lu);
else
null;
end if;
when others =>
-- All other cases of compilation units (e.g. renamings), generate
-- no SCO information.
null;
end case;
-- Make entry for new unit in unit tables, we will fill in the file
-- name and dependency numbers later.
@ -1144,11 +1144,31 @@ package body Par_SCO is
(Parameter_Specifications (Specification (N)), 'X');
Set_Statement_Entry;
-- Subprogram_Body
-- Task or subprogram body
when N_Subprogram_Body =>
when N_Task_Body | N_Subprogram_Body =>
Set_Statement_Entry;
Traverse_Subprogram_Body (N);
Traverse_Subprogram_Or_Task_Body (N);
-- Entry body
when N_Entry_Body =>
declare
Cond : constant Node_Id :=
Condition (Entry_Body_Formal_Part (N));
begin
Set_Statement_Entry;
if Present (Cond) then
Process_Decisions_Defer (Cond, 'G');
end if;
Traverse_Subprogram_Or_Task_Body (N);
end;
-- Protected body
when N_Protected_Body =>
Set_Statement_Entry;
Traverse_Protected_Body (N);
-- Exit statement, which is an exit statement in the SCO sense,
-- so it is included in the current statement sequence, but
@ -1485,15 +1505,24 @@ package body Par_SCO is
Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
end Traverse_Package_Declaration;
------------------------------
-- Traverse_Subprogram_Body --
------------------------------
-----------------------------
-- Traverse_Protected_Body --
-----------------------------
procedure Traverse_Subprogram_Body (N : Node_Id) is
procedure Traverse_Protected_Body (N : Node_Id) is
begin
Traverse_Declarations_Or_Statements (Declarations (N));
end Traverse_Protected_Body;
--------------------------------------
-- Traverse_Subprogram_Or_Task_Body --
--------------------------------------
procedure Traverse_Subprogram_Or_Task_Body (N : Node_Id) is
begin
Traverse_Declarations_Or_Statements (Declarations (N));
Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
end Traverse_Subprogram_Body;
end Traverse_Subprogram_Or_Task_Body;
-------------------------------------
-- Traverse_Subprogram_Declaration --

6
gcc/ada/put_scos.adb
View File

@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P U T _ S C O S --
-- P U T _ S C O S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -142,7 +142,7 @@ begin
-- Decision
when 'I' | 'E' | 'P' | 'W' | 'X' =>
when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
Start := Start + 1;
-- For disabled pragma, skip decision output

7
gcc/ada/scos.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2009-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -228,12 +228,13 @@ package SCOs is
-- I decision in IF statement or conditional expression
-- E decision in EXIT WHEN statement
-- G decision in entry guard
-- P decision in pragma Assert/Check/Pre_Condition/Post_Condition
-- W decision in WHILE iteration scheme
-- X decision appearing in some other expression context
-- For I, E, P, W, sloc is the source location of the IF, EXIT, PRAGMA or
-- WHILE token.
-- For I, E, G, P, W, sloc is the source location of the IF, EXIT,
-- ENTRY, PRAGMA or WHILE token, respectively
-- For X, sloc is omitted

3
gcc/ada/sem_ch6.adb
View File

@ -9550,6 +9550,9 @@ package body Sem_Ch6 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Plist)));
Set_Ekind (Post_Proc, E_Procedure);
Set_Is_Postcondition_Proc (Post_Proc);
-- If this is a procedure, set the Postcondition_Proc attribute on
-- the proper defining entity for the subprogram.