+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
-- Local Subprograms --
-----------------------
+ -- All local subprograms require comments ???
+
function Equivalent_Keys
(Key : Key_Type;
Node : Node_Type) return Boolean;
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
function "=" (Left, Right : Map) return Boolean is
begin
-
if Length (Left) /= Length (Right) then
return False;
end if;
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
end loop;
return True;
-
end;
-
end "=";
------------
-- Start of processing for Assign
begin
-
if Target'Address = Source'Address then
return;
end if;
"Source length exceeds Target capacity";
end if;
- Clear (Target); -- checks busy bits
+ -- Check busy bits
+
+ Clear (Target);
Insert_Elements (Source);
end Assign;
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;
X : Count_Type;
begin
-
Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
if X = 0 then
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";
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
"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;
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
declare
LN : Node_Type renames Left.Nodes (CLeft.Node);
-
begin
return Equivalent_Keys (LN.Key, Right);
end;
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
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
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);
-- 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);
not Container.Nodes (Position.Node).Has_Element then
return False;
end if;
+
return True;
end Has_Element;
-- 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;
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;
return Result;
end New_Node;
- -- Start of processing for Insert
+ -- Start of processing for Insert
begin
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;
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);
B : Natural renames Container'Unrestricted_Access.Busy;
- -- Start of processing for Iterate
+ -- Start of processing for Iterate
begin
B := B + 1;
----------
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;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
+
return C;
end Left;
X, Y : Count_Type;
begin
-
if Target'Address = Source'Address then
return;
end if;
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;
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;
(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";
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;
declare
K : Key_Type renames N.Key;
E : Element_Type renames N.Element;
-
begin
Process (K, E);
exception
-- 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);
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;
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";
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";
Capacity : Count_Type)
is
begin
-
if Capacity > Container.Capacity then
raise Capacity_Error with "requested capacity is too large";
end if;
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;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
+
return C;
end Right;
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;
Right.Nodes (CuR.Node).Key) then
return False;
end if;
+
CuL := Next (Left, CuL);
CuR := Next (Right, CuR);
end loop;
end if;
if X = Container.Nodes (X).Next then
- -- to prevent unnecessary looping
+
+ -- Prevent unnecessary looping
+
return False;
end if;
-- Local Subprograms --
-----------------------
+ -- All need comments ???
+
procedure Difference
(Left, Right : Set;
Target : in out Set);
function "=" (Left, Right : Set) return Boolean is
begin
-
if Length (Left) /= Length (Right) then
return False;
end if;
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;
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;
procedure Clear (Container : in out Set) is
begin
-
HT_Ops.Clear (Container);
end Clear;
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;
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;
Position : in out Cursor)
is
begin
-
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
SN : Nodes_Type renames Source.Nodes;
begin
-
if Target'Address = Source'Address then
Clear (Target);
return;
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
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);
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);
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);
end if;
end Process;
- -- Start of processing for Difference
+ -- Start of processing for Difference
begin
Iterate (Left);
function Difference (Left, Right : Set) return Set is
C : Count_Type;
H : Hash_Type;
+
begin
if Left'Address = Right'Address then
return Empty_Set;
C := Length (Left);
H := Default_Modulus (C);
+
return S : Set (C, H) do
Difference (Left, Right, Target => S);
end return;
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";
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
end loop;
end Find_Equivalent_Key;
- -- Start of processing of Equivalent_Sets
+ -- Start of processing of Equivalent_Sets
begin
return Is_Equivalent (Left, Right);
-- 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
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
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
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;
(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;
-----------
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;
----------
(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;
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;
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;
------------------
TN : Nodes_Type renames Target.Nodes;
begin
-
if Target'Address = Source'Address then
return;
end if;
end if;
end Process;
- -- Start of processing for Intersection
+ -- Start of processing for Intersection
begin
Iterate (Left);
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);
-- 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;
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;
end if;
Subset_Node := First (Subset).Node;
-
while Subset_Node /= 0 loop
declare
N : Node_Type renames Subset_Nodes (Subset_Node);
B : Natural renames Container'Unrestricted_Access.Busy;
- -- Start of processing for Iterate
+ -- Start of processing for Iterate
begin
B := B + 1;
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;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
+
return C;
end Left;
-- 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;
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;
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;
pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
declare
-
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
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
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;
(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";
New_Item : Element_Type)
is
begin
-
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor equals No_Element";
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;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
+
return C;
end Right;
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;
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 --
N : Node_Type renames Source.Nodes (Source_Node);
X : Count_Type;
B : Boolean;
-
begin
if Is_In (Target, N) then
Delete (Target, N.Element);
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;
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
C := Length (Left) + Length (Right);
H := Default_Modulus (C);
+
return S : Set (C, H) do
Difference (Left, Right, S);
Difference (Right, Left, S);
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
is
X : Count_Type;
begin
-
Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
Free (Container, X);
end Exclude;
(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;
---------
"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);
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
(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;
(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;
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;
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;
-- 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;
-- Local Subprograms --
-----------------------
+ -- All need comments ???
+
generic
with procedure Set_Element (Node : in out Node_Type);
procedure Generic_Allocate
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;
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;
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 "=";
------------
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 --
function New_Node return Count_Type is
Result : Count_Type;
-
begin
Allocate (Target, Result);
return Result;
-- Start of processing for Assign
begin
-
if Target'Address = Source'Address then
return;
end if;
-------------
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
procedure Clear (Container : in out Map) is
begin
-
Tree_Operations.Clear_Tree (Container);
end Clear;
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
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";
end Delete;
procedure Delete (Container : in out Map; Key : Key_Type) is
-
X : constant Node_Access := Key_Ops.Find (Container, Key);
begin
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);
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);
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);
----------
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
end if;
return (Node => Container.First);
-
end First;
-------------------
-----------
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
(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;
Inserted : out Boolean)
is
function New_Node return Node_Access;
+ -- Comment ???
procedure Insert_Post is
new Key_Ops.Generic_Insert_Post (New_Node);
return X;
end New_Node;
- -- Start of processing for Insert
+ -- Start of processing for Insert
begin
Insert_Sans_Hint
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;
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;
--------------
if Length (Container) = 0 then
return No_Element;
end if;
+
return (Node => Container.Last);
end Last;
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;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
+
return C;
end Left;
X : Node_Access;
begin
-
if Target'Address = Source'Address then
return;
end if;
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.
-- ???
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
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
"Position cursor of Query_Element is bad");
declare
-
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
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;
New_Item : Element_Type)
is
begin
-
declare
Node : constant Node_Access := Key_Ops.Find (Container, Key);
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";
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);
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;
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;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
+
return C;
end Right;
-- 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;
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;
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;
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";
"Position cursor of Update_Element is bad");
declare
-
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
-- Local Subprograms --
-----------------------
+ -- Comments needed???
+
generic
with procedure Set_Element (Node : in out Node_Type);
procedure Generic_Allocate
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;
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;
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 "=";
------------
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 --
function New_Node return Count_Type is
Result : Count_Type;
-
begin
Allocate (Target, Result);
return Result;
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
-------------
function Ceiling (Container : Set; Item : Element_Type) return Cursor is
-
Node : constant Count_Type := Element_Keys.Ceiling (Container, Item);
begin
end if;
return (Node => Node);
-
end Ceiling;
-----------
----------
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;
Node := Node + 1;
end loop;
end if;
+
return Target;
end Copy;
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;
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;
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);
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);
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
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;
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
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);
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);
----------
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
end if;
return (Node => Node);
-
end Find;
-----------
end if;
return (Node => Container.First);
-
end First;
-------------------
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
-- 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);
(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;
-------------
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
------------
procedure Delete (Container : in out Set; Key : Key_Type) is
-
X : constant Count_Type := Key_Keys.Find (Container, Key);
begin
-------------
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
-------------
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);
----------
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;
-----------
-----------
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;
-------------------------
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;
-----------------------------------
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";
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;
-------------
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
Node : out Count_Type;
Inserted : out Boolean)
is
-
procedure Set_Element (Node : in out Node_Type);
function New_Node return Count_Type;
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 --
function New_Node return Count_Type is
Result : Count_Type;
-
begin
Allocate (Container, Result);
return Result;
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
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 --
function New_Node return Count_Type is
Result : Count_Type;
-
begin
Allocate (Dst_Set, Result);
return Result;
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
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;
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;
-------------
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);
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;
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;
------------------
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;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
+
return C;
end Left;
X : Count_Type;
begin
-
if Target'Address = Source'Address then
return;
end if;
function Overlap (Left, Right : Set) return Boolean is
begin
return Set_Ops.Set_Overlap (Left, Right);
-
end Overlap;
------------
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;
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;
"bad cursor in Query_Element");
declare
-
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
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;
-------------
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
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;
Result : Count_Type;
Inserted : Boolean;
- -- Start of processing for Insert
+ -- Start of processing for Insert
begin
if Item < NN (Node).Element
New_Item : Element_Type)
is
begin
-
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor has no element";
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);
B : Natural renames Container'Unrestricted_Access.Busy;
- -- Start of processing for Reverse_Iterate
+ -- Start of processing for Reverse_Iterate
begin
B := B + 1;
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;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
+
return C;
end Right;
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;
LNode := Next (Left, LNode);
RNode := Next (Right, RNode);
end loop;
- return False;
+ return False;
end Strict_Equal;
--------------------------
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;
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);
Element_Type'Write (Stream, Node.Element);
end Write_Element;
- -- Start of processing for Write
+ -- Start of processing for Write
begin
Write_Elements (Stream, Container);
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;
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;
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
-- --
------------------------------------------------------------------------------
+with Atree; use Atree;
with Output; use Output;
with Put_ALFA;
+with Sinfo; use Sinfo;
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 --
-----------
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.
-- Body_Is_In_ALFA Flag251
-- Is_Processed_Transient Flag252
- -- (unused) Flag253
+ -- Is_Postcondition_Proc Flag253
-- (unused) Flag254
-----------------------
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);
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);
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));
-- 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
-- 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)
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;
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);
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);
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);
-- Decision entry
- when 'I' | 'E' | 'P' | 'W' | 'X' =>
+ when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
Dtyp := C;
Skip_Spaces;
-- --
-- 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- --
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
-------------------
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' =>
-- 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;
------------------------------
-- 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.
(Parameter_Specifications (Specification (N)), 'X');
Set_Statement_Entry;
- -- Subprogram_Body
+ -- Task or subprogram body
+
+ when N_Task_Body | N_Subprogram_Body =>
+ Set_Statement_Entry;
+ 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_Subprogram_Body =>
+ when N_Protected_Body =>
Set_Statement_Entry;
- Traverse_Subprogram_Body (N);
+ 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
Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
end Traverse_Package_Declaration;
- ------------------------------
- -- Traverse_Subprogram_Body --
- ------------------------------
+ -----------------------------
+ -- Traverse_Protected_Body --
+ -----------------------------
+
+ 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_Body (N : Node_Id) is
+ 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 --
-- --
-- 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- --
-- Decision
- when 'I' | 'E' | 'P' | 'W' | 'X' =>
+ when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
Start := Start + 1;
-- For disabled pragma, skip decision output
-- --
-- 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- --
-- 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
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.
projects / gcc.git / commitdiff