+2011-08-03 Robert Dewar <dewar@adacore.com>
+
+ * gnatcmd.adb, prj-proc.adb, mlib-prj.adb, prj.adb, makeutl.ads,
+ prj-util.adb, prj-util.ads, prj-conf.adb, prj-env.adb: Minor
+ reformatting.
+
+2011-08-03 Javier Miranda <miranda@adacore.com>
+
+ * exp_util.adb (Is_VM_By_Copy_Actual): Include N_Slide nodes as actuals
+ that must be passed by copy in VM targets.
+
+2011-08-03 Emmanuel Briot <briot@adacore.com>
+
+ * prj.ads, prj-nmsc.adb (Files_Htable): removed this htable, which
+ duplicates a similar htable now in the project tree.
+
+2011-08-03 Claire Dross <dross@adacore.com>
+
+ * a-cfdlli.adb, a-cfhama.adb, a-cfhase.adb, a-cforma.adb, a-cforse.adb,
+ a-cofove.adb ("=", Length, Is_Empty, Clear, Assign, Copy, Element,
+ Replace_Element, Query_Element, Update_Element, Move, Insert, Prepend,
+ Append, Delete, Delete_First, Delete_Last, Reverse_Element, Swap,
+ Splice, First, First_Element, Last, Last_Element, Next, Previous, Find,
+ Reverse_Find, Contains, Has_Element, Iterate, Reverse_Iterate, Capacity,
+ Reserve_Length, Length, Strict_Equal, Left, Right): Data-structure
+ update.
+
+2011-08-03 Arnaud Charlet <charlet@adacore.com>
+
+ * s-taprop-posix.adb, s-taprop-linux.adb, s-taprop-tru64.adb
+ (ATCB_Key): Removed, not always used.
+ * s-tpopsp-posix.adb, s-tpopsp-posix-foreign.adb (ATCB_Key): Moved from
+ s-taprop-posix.adb.
+ * s-tpopsp-tls.adb: New file.
+ * gcc-interface/Makefile.in: Use TLS implementation of s-tpopsp.adb on
+ x86/x64/ia64/powerpc/sparc Linux.
+
+2011-08-03 Arnaud Charlet <charlet@adacore.com>
+
+ * system-aix.ads, system-aix64.ads: Set ZCX_By_Default to True.
+ * gcc-interface/Makefile.in: Switch to ZCX by default on AIX ports.
+
+2011-08-03 Thomas Quinot <quinot@adacore.com>
+
+ * rtsfind.ads, exp_dist.adb, exp_dist.ads
+ (Build_From_Any_Call, Build_To_Any_Call, Build_TypeCode_Call):
+ Fix type selection for mapping integer types to PolyORB types.
+
+2011-08-03 Bob Duff <duff@adacore.com>
+
+ * sem_ch7.adb: Minor comment clarification.
+
+2011-08-03 Bob Duff <duff@adacore.com>
+
+ * sem_ch13.adb (Analyze_Enumeration_Representation_Clause): If we get
+ an error analyzing a choice, skip further processing. Further
+ processing could cause a crash or cascade errors.
+
2011-08-03 Emmanuel Briot <briot@adacore.com>
* gnatcmd.adb, prj-proc.adb, prj-proc.ads, make.adb, mlib-prj.adb,
-- --
-- B o d y --
-- --
--- Copyright (C) 2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-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- --
(Container : in out List;
New_Node : out Count_Type);
- function Copy
- (Source : Plain_List;
- Capacity : Count_Type := 0) return PList_Access;
-
- function Find_Between
- (Container : Plain_List;
- Item : Element_Type;
- From : Count_Type;
- To : Count_Type;
- Bg : Count_Type) return Cursor;
-
- function Element_Unchecked
- (Container : List;
- Position : Count_Type) return Element_Type;
-
procedure Free
- (Container : in out Plain_List;
+ (Container : in out List;
X : Count_Type);
- function Has_Element_Base
- (Container : Plain_List;
- Position : Cursor) return Boolean;
-
procedure Insert_Internal
(Container : in out List;
Before : Count_Type;
New_Node : Count_Type);
- procedure Iterate_Between
- (Container : List;
- From : Count_Type;
- To : Count_Type;
- Process :
- not null access procedure (Container : List; Position : Cursor));
-
- function Next_Unchecked
- (Container : List;
- Position : Count_Type) return Count_Type;
-
- procedure Query_Element_Plain
- (Container : Plain_List; Position : Cursor;
- Process : not null access procedure (Element : Element_Type));
-
- function Reverse_Find_Between
- (Container : Plain_List;
- Item : Element_Type;
- From : Count_Type;
- To : Count_Type) return Cursor;
-
- procedure Reverse_Iterate_Between
- (Container : List;
- From : Count_Type;
- To : Count_Type;
- Process :
- not null access procedure (Container : List; Position : Cursor));
-
function Vet (L : List; Position : Cursor) return Boolean;
- procedure Write_Between
- (Stream : not null access Root_Stream_Type'Class;
- Item : Plain_List;
- Length : Count_Type;
- From : Count_Type;
- To : Count_Type);
-
---------
-- "=" --
---------
end if;
LI := Left.First;
- RI := Right.First;
+ RI := Left.First;
while LI /= 0 loop
- if Element_Unchecked (Left, LI) /= Element_Unchecked (Right, LI) then
+ if Left.Nodes (LI).Element /= Right.Nodes (LI).Element then
return False;
end if;
- LI := Next_Unchecked (Left, LI);
- RI := Next_Unchecked (Right, RI);
+ LI := Left.Nodes (LI).Next;
+ RI := Right.Nodes (RI).Next;
end loop;
return True;
New_Item : Element_Type;
New_Node : out Count_Type)
is
- ContainerP : Plain_List renames Container.Plain.all;
- begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
-
- declare
- N : Node_Array renames Container.Plain.all.Nodes;
+ N : Node_Array renames Container.Nodes;
- begin
- if ContainerP.Free >= 0 then
- New_Node := ContainerP.Free;
- N (New_Node).Element := New_Item;
- ContainerP.Free := N (New_Node).Next;
+ begin
+ if Container.Free >= 0 then
+ New_Node := Container.Free;
+ N (New_Node).Element := New_Item;
+ Container.Free := N (New_Node).Next;
- else
- New_Node := abs ContainerP.Free;
- N (New_Node).Element := New_Item;
- ContainerP.Free := ContainerP.Free - 1;
- end if;
- end;
+ else
+ New_Node := abs Container.Free;
+ N (New_Node).Element := New_Item;
+ Container.Free := Container.Free - 1;
+ end if;
end Allocate;
procedure Allocate
(Container : in out List;
New_Node : out Count_Type)
is
- ContainerP : Plain_List renames Container.Plain.all;
- begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
-
- declare
- N : Node_Array renames ContainerP.Nodes;
+ N : Node_Array renames Container.Nodes;
- begin
- if ContainerP.Free >= 0 then
- New_Node := ContainerP.Free;
- ContainerP.Free := N (New_Node).Next;
+ begin
+ if Container.Free >= 0 then
+ New_Node := Container.Free;
+ Container.Free := N (New_Node).Next;
- else
- New_Node := abs ContainerP.Free;
- ContainerP.Free := ContainerP.Free - 1;
- end if;
- end;
+ else
+ New_Node := abs Container.Free;
+ Container.Free := Container.Free - 1;
+ end if;
end Allocate;
------------
------------
procedure Assign (Target : in out List; Source : List) is
+ N : Node_Array renames Source.Nodes;
+ J : Count_Type;
+
begin
- if Target.K /= Plain or Source.K /= Plain then
- raise Program_Error with "cannot modify part of container";
+ if Target'Address = Source'Address then
+ return;
end if;
- declare
- N : Node_Array renames Source.Plain.Nodes;
- J : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Source.Length then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
+ if Target.Capacity < Source.Length then
+ raise Constraint_Error with -- ???
+ "Source length exceeds Target capacity";
+ end if;
- Clear (Target);
+ Clear (Target);
- J := Source.First;
- while J /= 0 loop
- Append (Target, N (J).Element);
- J := N (J).Next;
- end loop;
- end;
+ J := Source.First;
+ while J /= 0 loop
+ Append (Target, N (J).Element);
+ J := N (J).Next;
+ end loop;
end Assign;
-----------
-----------
procedure Clear (Container : in out List) is
+ N : Node_Array renames Container.Nodes;
+ X : Count_Type;
+
begin
- if Container.K /= Plain then
- raise Constraint_Error;
+ if Container.Length = 0 then
+ pragma Assert (Container.First = 0);
+ pragma Assert (Container.Last = 0);
+ pragma Assert (Container.Busy = 0);
+ pragma Assert (Container.Lock = 0);
+ return;
end if;
- declare
- N : Node_Array renames Container.Plain.Nodes;
- X : Count_Type;
-
- begin
- if Container.Length = 0 then
- pragma Assert (Container.First = 0);
- pragma Assert (Container.Last = 0);
- pragma Assert (Container.Plain.Busy = 0);
- pragma Assert (Container.Plain.Lock = 0);
- return;
- end if;
-
- pragma Assert (Container.First >= 1);
- pragma Assert (Container.Last >= 1);
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
+ pragma Assert (Container.First >= 1);
+ pragma Assert (Container.Last >= 1);
+ pragma Assert (N (Container.First).Prev = 0);
+ pragma Assert (N (Container.Last).Next = 0);
- if Container.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is busy)";
- end if;
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
- while Container.Length > 1 loop
- X := Container.First;
+ while Container.Length > 1 loop
+ X := Container.First;
- Container.First := N (X).Next;
- N (Container.First).Prev := 0;
+ Container.First := N (X).Next;
+ N (Container.First).Prev := 0;
- Container.Length := Container.Length - 1;
+ Container.Length := Container.Length - 1;
- Free (Container.Plain.all, X);
- end loop;
+ Free (Container, X);
+ end loop;
- X := Container.First;
+ X := Container.First;
- Container.First := 0;
- Container.Last := 0;
- Container.Length := 0;
+ Container.First := 0;
+ Container.Last := 0;
+ Container.Length := 0;
- Free (Container.Plain.all, X);
- end;
+ Free (Container, X);
end Clear;
--------------
----------
function Copy
- (Source : Plain_List;
- Capacity : Count_Type := 0) return PList_Access
+ (Source : List;
+ Capacity : Count_Type := 0) return List
is
C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity);
- P : PList_Access;
N : Count_Type := 1;
+ P : List (C);
begin
- P := new Plain_List (C);
while N <= Source.Capacity loop
P.Nodes (N).Prev := Source.Nodes (N).Prev;
P.Nodes (N).Next := Source.Nodes (N).Next;
N := N + 1;
end loop;
P.Free := Source.Free;
+ P.Length := Source.Length;
+ P.First := Source.First;
+ P.Last := Source.Last;
if P.Free >= 0 then
N := Source.Capacity + 1;
while N <= C loop
- Free (P.all, N);
+ Free (P, N);
N := N + 1;
end loop;
end if;
return P;
end Copy;
- function Copy
- (Source : List;
- Capacity : Count_Type := 0) return List
- is
- Cap : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity);
- begin
- case Source.K is
- when Plain =>
- return (Capacity => Cap,
- Length => Source.Length,
- Plain => Copy (Source.Plain.all, Cap),
- First => Source.First,
- Last => Source.Last,
- others => <>);
- when Part =>
- declare
- Target : List (Capacity => Cap);
- C : Cursor;
- P : Cursor;
- begin
- Target := (Capacity => Cap,
- Length => Source.Part.LLength,
- Plain => Copy (Source.Plain.all, Cap),
- First => Source.Part.LFirst,
- Last => Source.Part.LLast,
- others => <>);
- C := (Node => Target.First);
- while C.Node /= Source.First loop
- P := Next (Target, C);
- Delete (Container => Target, Position => C);
- C := P;
- end loop;
- if Source.Last /= 0 then
- C := (Node => Source.Plain.all.Nodes (Source.Last).Next);
- while C.Node /= 0 loop
- P := Next (Target, C);
- Delete (Container => Target, Position => C);
- C := P;
- end loop;
- end if;
- return Target;
- end;
- end case;
- end Copy;
-
------------
-- Delete --
------------
Position : in out Cursor;
Count : Count_Type := 1)
is
+ N : Node_Array renames Container.Nodes;
+ X : Count_Type;
+
begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
+ if not Has_Element (Container => Container,
+ Position => Position) then
+ raise Constraint_Error with
+ "Position cursor has no element";
end if;
- declare
- N : Node_Array renames Container.Plain.Nodes;
- X : Count_Type;
-
- begin
- if not Has_Element (Container => Container,
- Position => Position) then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in Delete");
- pragma Assert (Container.First >= 1);
- pragma Assert (Container.Last >= 1);
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
+ pragma Assert (Vet (Container, Position), "bad cursor in Delete");
+ pragma Assert (Container.First >= 1);
+ pragma Assert (Container.Last >= 1);
+ pragma Assert (N (Container.First).Prev = 0);
+ pragma Assert (N (Container.Last).Next = 0);
- if Position.Node = Container.First then
- Delete_First (Container, Count);
- Position := No_Element;
- return;
- end if;
+ if Position.Node = Container.First then
+ Delete_First (Container, Count);
+ Position := No_Element;
+ return;
+ end if;
- if Count = 0 then
- Position := No_Element;
- return;
- end if;
+ if Count = 0 then
+ Position := No_Element;
+ return;
+ end if;
- if Container.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is busy)";
- end if;
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
- for Index in 1 .. Count loop
- pragma Assert (Container.Length >= 2);
+ for Index in 1 .. Count loop
+ pragma Assert (Container.Length >= 2);
- X := Position.Node;
- Container.Length := Container.Length - 1;
+ X := Position.Node;
+ Container.Length := Container.Length - 1;
- if X = Container.Last then
- Position := No_Element;
+ if X = Container.Last then
+ Position := No_Element;
- Container.Last := N (X).Prev;
- N (Container.Last).Next := 0;
+ Container.Last := N (X).Prev;
+ N (Container.Last).Next := 0;
- Free (Container.Plain.all, X);
- return;
- end if;
+ Free (Container, X);
+ return;
+ end if;
- Position.Node := N (X).Next;
- pragma Assert (N (Position.Node).Prev >= 0);
+ Position.Node := N (X).Next;
+ pragma Assert (N (Position.Node).Prev >= 0);
- N (N (X).Next).Prev := N (X).Prev;
- N (N (X).Prev).Next := N (X).Next;
+ N (N (X).Next).Prev := N (X).Prev;
+ N (N (X).Prev).Next := N (X).Next;
- Free (Container.Plain.all, X);
- end loop;
- Position := No_Element;
- end;
+ Free (Container, X);
+ end loop;
+ Position := No_Element;
end Delete;
------------------
(Container : in out List;
Count : Count_Type := 1)
is
+ N : Node_Array renames Container.Nodes;
+ X : Count_Type;
+
begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
+ if Count >= Container.Length then
+ Clear (Container);
+ return;
end if;
- declare
- N : Node_Array renames Container.Plain.Nodes;
- X : Count_Type;
-
- begin
- if Count >= Container.Length then
- Clear (Container);
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
+ if Count = 0 then
+ return;
+ end if;
- if Container.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is busy)";
- end if;
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
- for I in 1 .. Count loop
- X := Container.First;
- pragma Assert (N (N (X).Next).Prev = Container.First);
+ for I in 1 .. Count loop
+ X := Container.First;
+ pragma Assert (N (N (X).Next).Prev = Container.First);
- Container.First := N (X).Next;
- N (Container.First).Prev := 0;
+ Container.First := N (X).Next;
+ N (Container.First).Prev := 0;
- Container.Length := Container.Length - 1;
+ Container.Length := Container.Length - 1;
- Free (Container.Plain.all, X);
- end loop;
- end;
+ Free (Container, X);
+ end loop;
end Delete_First;
-----------------
(Container : in out List;
Count : Count_Type := 1)
is
+ N : Node_Array renames Container.Nodes;
+ X : Count_Type;
+
begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
+ if Count >= Container.Length then
+ Clear (Container);
+ return;
end if;
- declare
- N : Node_Array renames Container.Plain.Nodes;
- X : Count_Type;
-
- begin
- if Count >= Container.Length then
- Clear (Container);
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
+ if Count = 0 then
+ return;
+ end if;
- if Container.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is busy)";
- end if;
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
- for I in 1 .. Count loop
- X := Container.Last;
- pragma Assert (N (N (X).Prev).Next = Container.Last);
+ for I in 1 .. Count loop
+ X := Container.Last;
+ pragma Assert (N (N (X).Prev).Next = Container.Last);
- Container.Last := N (X).Prev;
- N (Container.Last).Next := 0;
+ Container.Last := N (X).Prev;
+ N (Container.Last).Next := 0;
- Container.Length := Container.Length - 1;
+ Container.Length := Container.Length - 1;
- Free (Container.Plain.all, X);
- end loop;
- end;
+ Free (Container, X);
+ end loop;
end Delete_Last;
-------------
-- Element --
-------------
- function Element_Unchecked
- (Container : List;
- Position : Count_Type) return Element_Type is
- begin
- case Container.K is
- when Plain =>
- return Container.Plain.Nodes (Position).Element;
- when others =>
- return Container.Plain.all.Nodes (Position).Element;
- end case;
- end Element_Unchecked;
-
function Element
(Container : List;
Position : Cursor) return Element_Type is
"Position cursor has no element";
end if;
- return Element_Unchecked (Container => Container,
- Position => Position.Node);
+ return Container.Nodes (Position.Node).Element;
end Element;
----------
-- Find --
----------
- function Find_Between
- (Container : Plain_List;
- Item : Element_Type;
- From : Count_Type;
- To : Count_Type;
- Bg : Count_Type) return Cursor
- is
- Nodes : Node_Array renames Container.Nodes;
- Node : Count_Type := Bg;
- begin
- while Node /= From loop
- if Node = 0 or else Node = To then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
- Node := Nodes (Node).Next;
- end loop;
- while Node /= Nodes (To).Next loop
- if Nodes (Node).Element = Item then
- return (Node => Node);
- end if;
- Node := Nodes (Node).Next;
- end loop;
-
- return No_Element;
- end Find_Between;
-
function Find
(Container : List;
Item : Element_Type;
From := Container.First;
end if;
if Position.Node /= 0 and then
- not Has_Element_Base (Container.Plain.all, Position) then
+ not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor has no element";
end if;
- return Find_Between (Container => Container.Plain.all,
- Item => Item,
- From => From,
- To => Container.Last,
- Bg => Container.First);
+
+ while From /= 0 loop
+ if Container.Nodes (From).Element = Item then
+ return (Node => From);
+ end if;
+ From := Container.Nodes (From).Next;
+ end loop;
+
+ return No_Element;
end Find;
-----------
if F = 0 then
raise Constraint_Error with "list is empty";
else
- return Element_Unchecked (Container, F);
+ return Container.Nodes (F).Element;
end if;
end First_Element;
----------
procedure Free
- (Container : in out Plain_List;
+ (Container : in out List;
X : Count_Type)
is
pragma Assert (X > 0);
---------------
function Is_Sorted (Container : List) return Boolean is
- Nodes : Node_Array renames Container.Plain.all.Nodes;
+ Nodes : Node_Array renames Container.Nodes;
Node : Count_Type := Container.First;
begin
for I in 2 .. Container.Length loop
(Target : in out List;
Source : in out List)
is
+ LN : Node_Array renames Target.Nodes;
+ RN : Node_Array renames Source.Nodes;
+ LI : Cursor;
+ RI : Cursor;
+
begin
- if Target.K /= Plain or Source.K /= Plain then
- raise Program_Error with "cannot modify part of container";
+ if Target'Address = Source'Address then
+ return;
end if;
- declare
- LN : Node_Array renames Target.Plain.Nodes;
- RN : Node_Array renames Source.Plain.Nodes;
- LI : Cursor;
- RI : Cursor;
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Target (list is busy)";
+ end if;
- begin
- if Target'Address = Source'Address then
- return;
- end if;
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Source (list is busy)";
+ end if;
- if Target.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Target (list is busy)";
- end if;
+ LI := First (Target);
+ RI := First (Source);
+ while RI.Node /= 0 loop
+ pragma Assert (RN (RI.Node).Next = 0
+ or else not (RN (RN (RI.Node).Next).Element <
+ RN (RI.Node).Element));
- if Source.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
+ if LI.Node = 0 then
+ Splice (Target, No_Element, Source);
+ return;
end if;
- LI := First (Target);
- RI := First (Source);
- while RI.Node /= 0 loop
- pragma Assert (RN (RI.Node).Next = 0
- or else not (RN (RN (RI.Node).Next).Element <
- RN (RI.Node).Element));
-
- if LI.Node = 0 then
- Splice (Target, No_Element, Source);
- return;
- end if;
-
- pragma Assert (LN (LI.Node).Next = 0
- or else not (LN (LN (LI.Node).Next).Element <
- LN (LI.Node).Element));
+ pragma Assert (LN (LI.Node).Next = 0
+ or else not (LN (LN (LI.Node).Next).Element <
+ LN (LI.Node).Element));
- if RN (RI.Node).Element < LN (LI.Node).Element then
- declare
- RJ : Cursor := RI;
- pragma Warnings (Off, RJ);
- begin
- RI.Node := RN (RI.Node).Next;
- Splice (Target, LI, Source, RJ);
- end;
+ if RN (RI.Node).Element < LN (LI.Node).Element then
+ declare
+ RJ : Cursor := RI;
+ pragma Warnings (Off, RJ);
+ begin
+ RI.Node := RN (RI.Node).Next;
+ Splice (Target, LI, Source, RJ);
+ end;
- else
- LI.Node := LN (LI.Node).Next;
- end if;
- end loop;
- end;
+ else
+ LI.Node := LN (LI.Node).Next;
+ end if;
+ end loop;
end Merge;
----------
----------
procedure Sort (Container : in out List) is
- begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
-
- declare
- N : Node_Array renames Container.Plain.Nodes;
-
- procedure Partition (Pivot, Back : Count_Type);
- procedure Sort (Front, Back : Count_Type);
+ N : Node_Array renames Container.Nodes;
- ---------------
- -- Partition --
- ---------------
+ procedure Partition (Pivot, Back : Count_Type);
+ procedure Sort (Front, Back : Count_Type);
- procedure Partition (Pivot, Back : Count_Type) is
- Node : Count_Type := N (Pivot).Next;
+ ---------------
+ -- Partition --
+ ---------------
- begin
- while Node /= Back loop
- if N (Node).Element < N (Pivot).Element then
- declare
- Prev : constant Count_Type := N (Node).Prev;
- Next : constant Count_Type := N (Node).Next;
+ procedure Partition (Pivot, Back : Count_Type) is
+ Node : Count_Type := N (Pivot).Next;
- begin
- N (Prev).Next := Next;
-
- if Next = 0 then
- Container.Last := Prev;
- else
- N (Next).Prev := Prev;
- end if;
-
- N (Node).Next := Pivot;
- N (Node).Prev := N (Pivot).Prev;
+ begin
+ while Node /= Back loop
+ if N (Node).Element < N (Pivot).Element then
+ declare
+ Prev : constant Count_Type := N (Node).Prev;
+ Next : constant Count_Type := N (Node).Next;
- N (Pivot).Prev := Node;
+ begin
+ N (Prev).Next := Next;
- if N (Node).Prev = 0 then
- Container.First := Node;
- else
- N (N (Node).Prev).Next := Node;
- end if;
+ if Next = 0 then
+ Container.Last := Prev;
+ else
+ N (Next).Prev := Prev;
+ end if;
- Node := Next;
- end;
+ N (Node).Next := Pivot;
+ N (Node).Prev := N (Pivot).Prev;
- else
- Node := N (Node).Next;
- end if;
- end loop;
- end Partition;
+ N (Pivot).Prev := Node;
- ----------
- -- Sort --
- ----------
+ if N (Node).Prev = 0 then
+ Container.First := Node;
+ else
+ N (N (Node).Prev).Next := Node;
+ end if;
- procedure Sort (Front, Back : Count_Type) is
- Pivot : Count_Type;
+ Node := Next;
+ end;
- begin
- if Front = 0 then
- Pivot := Container.First;
else
- Pivot := N (Front).Next;
+ Node := N (Node).Next;
end if;
+ end loop;
+ end Partition;
- if Pivot /= Back then
- Partition (Pivot, Back);
- Sort (Front, Pivot);
- Sort (Pivot, Back);
- end if;
- end Sort;
+ ----------
+ -- Sort --
+ ----------
- -- Start of processing for Sort
+ procedure Sort (Front, Back : Count_Type) is
+ Pivot : Count_Type;
begin
- if Container.Length <= 1 then
- return;
+ if Front = 0 then
+ Pivot := Container.First;
+ else
+ Pivot := N (Front).Next;
end if;
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- if Container.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is busy)";
+ if Pivot /= Back then
+ Partition (Pivot, Back);
+ Sort (Front, Pivot);
+ Sort (Pivot, Back);
end if;
+ end Sort;
- Sort (Front => 0, Back => 0);
+ -- Start of processing for Sort
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end;
+ begin
+ if Container.Length <= 1 then
+ return;
+ end if;
+
+ pragma Assert (N (Container.First).Prev = 0);
+ pragma Assert (N (Container.Last).Next = 0);
+
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
+
+ Sort (Front => 0, Back => 0);
+
+ pragma Assert (N (Container.First).Prev = 0);
+ pragma Assert (N (Container.Last).Next = 0);
end Sort;
end Generic_Sorting;
-- Has_Element --
-----------------
- function Has_Element_Base (Container : Plain_List; Position : Cursor)
- return Boolean
- is
- begin
- return Container.Nodes (Position.Node).Prev /= -1;
- end Has_Element_Base;
-
function Has_Element (Container : List; Position : Cursor) return Boolean is
begin
if Position.Node = 0 then
return False;
end if;
-
- case Container.K is
- when Plain =>
- return Container.Plain.Nodes (Position.Node).Prev /= -1;
- when Part =>
- declare
- Current : Count_Type := Container.First;
- begin
- if Container.Plain.Nodes (Position.Node).Prev = -1 then
- return False;
- end if;
- while Current /= 0 loop
- if Current = Position.Node then
- return True;
- end if;
- Current := Next_Unchecked (Container, Current);
- end loop;
- return False;
- end;
- end case;
+ return Container.Nodes (Position.Node).Prev /= -1;
end Has_Element;
------------
begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
-
if Before.Node /= 0 then
null;
pragma Assert (Vet (Container, Before), "bad cursor in Insert");
raise Constraint_Error with "new length exceeds capacity";
end if;
- if Container.Plain.Busy > 0 then
+ if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
-
if Before.Node /= 0 then
null;
pragma Assert (Vet (Container, Before), "bad cursor in Insert");
raise Constraint_Error with "new length exceeds capacity";
end if;
- if Container.Plain.Busy > 0 then
+ if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
Before : Count_Type;
New_Node : Count_Type)
is
- begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
-
- declare
- N : Node_Array renames Container.Plain.Nodes;
+ N : Node_Array renames Container.Nodes;
- begin
- if Container.Length = 0 then
- pragma Assert (Before = 0);
- pragma Assert (Container.First = 0);
- pragma Assert (Container.Last = 0);
+ begin
+ if Container.Length = 0 then
+ pragma Assert (Before = 0);
+ pragma Assert (Container.First = 0);
+ pragma Assert (Container.Last = 0);
- Container.First := New_Node;
- Container.Last := New_Node;
+ Container.First := New_Node;
+ Container.Last := New_Node;
- N (Container.First).Prev := 0;
- N (Container.Last).Next := 0;
+ N (Container.First).Prev := 0;
+ N (Container.Last).Next := 0;
- elsif Before = 0 then
- pragma Assert (N (Container.Last).Next = 0);
+ elsif Before = 0 then
+ pragma Assert (N (Container.Last).Next = 0);
- N (Container.Last).Next := New_Node;
- N (New_Node).Prev := Container.Last;
+ N (Container.Last).Next := New_Node;
+ N (New_Node).Prev := Container.Last;
- Container.Last := New_Node;
- N (Container.Last).Next := 0;
+ Container.Last := New_Node;
+ N (Container.Last).Next := 0;
- elsif Before = Container.First then
- pragma Assert (N (Container.First).Prev = 0);
+ elsif Before = Container.First then
+ pragma Assert (N (Container.First).Prev = 0);
- N (Container.First).Prev := New_Node;
- N (New_Node).Next := Container.First;
+ N (Container.First).Prev := New_Node;
+ N (New_Node).Next := Container.First;
- Container.First := New_Node;
- N (Container.First).Prev := 0;
+ Container.First := New_Node;
+ N (Container.First).Prev := 0;
- else
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
+ else
+ pragma Assert (N (Container.First).Prev = 0);
+ pragma Assert (N (Container.Last).Next = 0);
- N (New_Node).Next := Before;
- N (New_Node).Prev := N (Before).Prev;
+ N (New_Node).Next := Before;
+ N (New_Node).Prev := N (Before).Prev;
- N (N (Before).Prev).Next := New_Node;
- N (Before).Prev := New_Node;
- end if;
+ N (N (Before).Prev).Next := New_Node;
+ N (Before).Prev := New_Node;
+ end if;
- Container.Length := Container.Length + 1;
- end;
+ Container.Length := Container.Length + 1;
end Insert_Internal;
--------------
-- Iterate --
-------------
- procedure Iterate_Between
+ procedure Iterate
(Container : List;
- From : Count_Type;
- To : Count_Type;
Process :
- not null access procedure (Container : List; Position : Cursor))
+ not null access procedure (Container : List; Position : Cursor))
is
- C : Plain_List renames Container.Plain.all;
- N : Node_Array renames C.Nodes;
+ C : List renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
- Node : Count_Type := From;
+ Node : Count_Type := Container.First;
begin
B := B + 1;
begin
- while Node /= N (To).Next loop
- pragma Assert (N (Node).Prev >= 0);
- Process (Container, Position => (Node => Node));
- Node := N (Node).Next;
+ while Node /= 0 loop
+ Process (Container, (Node => Node));
+ Node := Container.Nodes (Node).Next;
end loop;
exception
when others =>
end;
B := B - 1;
- end Iterate_Between;
-
- procedure Iterate
- (Container : List;
- Process :
- not null access procedure (Container : List; Position : Cursor))
- is
- begin
- if Container.Length = 0 then
- return;
- end if;
- Iterate_Between (Container, Container.First, Container.Last, Process);
end Iterate;
----------
if L = 0 then
raise Constraint_Error with "list is empty";
else
- return Element_Unchecked (Container, L);
+ return Container.Nodes (L).Element;
end if;
end Last_Element;
----------
function Left (Container : List; Position : Cursor) return List is
- L : Count_Type := 0;
- C : Count_Type := Container.First;
- LLe : Count_Type;
- LF : Count_Type;
- LLa : Count_Type;
+ Curs : Cursor := Position;
+ C : List (Container.Capacity) := Copy (Container, Container.Capacity);
+ Node : Count_Type;
begin
- case Container.K is
- when Plain =>
- LLe := Container.Length;
- LF := Container.First;
- LLa := Container.Last;
- when Part =>
- LLe := Container.Part.LLength;
- LF := Container.Part.LFirst;
- LLa := Container.Part.LLast;
- end case;
- if Position.Node = 0 then
- return (Capacity => Container.Capacity,
- K => Part,
- Length => Container.Length,
- First => Container.First,
- Last => Container.Last,
- Plain => Container.Plain,
- Part => (LLength => LLe, LFirst => LF, LLast => LLa));
- else
- while C /= Position.Node loop
- if C = Container.Last or C = 0 then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
- C := Next_Unchecked (Container, C);
- L := L + 1;
- end loop;
- if L = 0 then
- return (Capacity => Container.Capacity,
- K => Part,
- Length => 0,
- First => 0,
- Last => 0,
- Plain => Container.Plain,
- Part => (LLength => LLe, LFirst => LF, LLast => LLa));
- else
- return (Capacity => Container.Capacity,
- K => Part,
- Length => L,
- First => Container.First,
- Last => Container.Plain.Nodes (C).Prev,
- Plain => Container.Plain,
- Part => (LLength => LLe, LFirst => LF, LLast => LLa));
- end if;
+ if Curs = No_Element then
+ return C;
end if;
+ if not Has_Element (Container, Curs) then
+ raise Constraint_Error;
+ end if;
+
+ while Curs.Node /= 0 loop
+ Node := Curs.Node;
+ Delete (C, Curs);
+ Curs := Next (Container, (Node => Node));
+ end loop;
+ return C;
end Left;
------------
(Target : in out List;
Source : in out List)
is
+ N : Node_Array renames Source.Nodes;
+ X : Count_Type;
+
begin
- if Target.K /= Plain or Source.K /= Plain then
- raise Program_Error with "cannot modify part of container";
+ if Target'Address = Source'Address then
+ return;
end if;
- declare
-
- N : Node_Array renames Source.Plain.Nodes;
- X : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Source.Length then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
+ if Target.Capacity < Source.Length then
+ raise Constraint_Error with -- ???
+ "Source length exceeds Target capacity";
+ end if;
- if Source.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
- end if;
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Source (list is busy)";
+ end if;
- Clear (Target);
+ Clear (Target);
- while Source.Length > 0 loop
- X := Source.First;
- Append (Target, N (X).Element); -- optimize away???
+ while Source.Length > 0 loop
+ X := Source.First;
+ Append (Target, N (X).Element); -- optimize away???
- Source.First := N (X).Next;
- N (Source.First).Prev := 0;
+ Source.First := N (X).Next;
+ N (Source.First).Prev := 0;
- Source.Length := Source.Length - 1;
- Free (Source.Plain.all, X);
- end loop;
- end;
+ Source.Length := Source.Length - 1;
+ Free (Source, X);
+ end loop;
end Move;
----------
if not Has_Element (Container, Position) then
raise Program_Error with "Position cursor has no element";
end if;
- return (Node => Next_Unchecked (Container, Position.Node));
+ return (Node => Container.Nodes (Position.Node).Next);
end Next;
- function Next_Unchecked (Container : List; Position : Count_Type)
- return Count_Type
- is
- begin
- case Container.K is
- when Plain =>
- return Container.Plain.Nodes (Position).Next;
- when Part =>
- if Position = Container.Last then
- return 0;
- else
- return Container.Plain.Nodes (Position).Next;
- end if;
- end case;
- end Next_Unchecked;
-
-------------
-- Prepend --
-------------
if not Has_Element (Container, Position) then
raise Program_Error with "Position cursor has no element";
end if;
-
- case Container.K is
- when Plain =>
- return (Node => Container.Plain.Nodes (Position.Node).Prev);
- when Part =>
- if Container.First = Position.Node then
- return No_Element;
- else
- return (Node => Container.Plain.Nodes (Position.Node).Prev);
- end if;
- end case;
+ return (Node => Container.Nodes (Position.Node).Prev);
end Previous;
-------------------
-- Query_Element --
-------------------
- procedure Query_Element_Plain
- (Container : Plain_List; Position : Cursor;
+ procedure Query_Element
+ (Container : List; Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
- C : Plain_List renames Container'Unrestricted_Access.all;
+ C : List renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+
B := B + 1;
L := L + 1;
L := L - 1;
B := B - 1;
- end Query_Element_Plain;
-
- procedure Query_Element
- (Container : List; Position : Cursor;
- 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;
- Query_Element_Plain (Container.Plain.all, Position, Process);
end Query_Element;
----------
New_Item : Element_Type)
is
begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Container.Plain.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (list is locked)";
end if;
"bad cursor in Replace_Element");
declare
- N : Node_Array renames Container.Plain.Nodes;
+ N : Node_Array renames Container.Nodes;
begin
N (Position.Node).Element := New_Item;
end;
----------------------
procedure Reverse_Elements (Container : in out List) is
- begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
-
- declare
- N : Node_Array renames Container.Plain.Nodes;
- I : Count_Type := Container.First;
- J : Count_Type := Container.Last;
+ N : Node_Array renames Container.Nodes;
+ I : Count_Type := Container.First;
+ J : Count_Type := Container.Last;
- procedure Swap (L, R : Count_Type);
+ procedure Swap (L, R : Count_Type);
- ----------
- -- Swap --
- ----------
+ ----------
+ -- Swap --
+ ----------
- procedure Swap (L, R : Count_Type) is
- LN : constant Count_Type := N (L).Next;
- LP : constant Count_Type := N (L).Prev;
+ procedure Swap (L, R : Count_Type) is
+ LN : constant Count_Type := N (L).Next;
+ LP : constant Count_Type := N (L).Prev;
- RN : constant Count_Type := N (R).Next;
- RP : constant Count_Type := N (R).Prev;
+ RN : constant Count_Type := N (R).Next;
+ RP : constant Count_Type := N (R).Prev;
- begin
- if LP /= 0 then
- N (LP).Next := R;
- end if;
+ begin
+ if LP /= 0 then
+ N (LP).Next := R;
+ end if;
- if RN /= 0 then
- N (RN).Prev := L;
- end if;
+ if RN /= 0 then
+ N (RN).Prev := L;
+ end if;
- N (L).Next := RN;
- N (R).Prev := LP;
+ N (L).Next := RN;
+ N (R).Prev := LP;
- if LN = R then
- pragma Assert (RP = L);
+ if LN = R then
+ pragma Assert (RP = L);
- N (L).Prev := R;
- N (R).Next := L;
+ N (L).Prev := R;
+ N (R).Next := L;
- else
- N (L).Prev := RP;
- N (RP).Next := L;
+ else
+ N (L).Prev := RP;
+ N (RP).Next := L;
- N (R).Next := LN;
- N (LN).Prev := R;
- end if;
- end Swap;
+ N (R).Next := LN;
+ N (LN).Prev := R;
+ end if;
+ end Swap;
- -- Start of processing for Reverse_Elements
+ -- Start of processing for Reverse_Elements
- begin
- if Container.Length <= 1 then
- return;
- end if;
+ begin
+ if Container.Length <= 1 then
+ return;
+ end if;
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
+ pragma Assert (N (Container.First).Prev = 0);
+ pragma Assert (N (Container.Last).Next = 0);
- if Container.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is busy)";
- end if;
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
- Container.First := J;
- Container.Last := I;
- loop
- Swap (L => I, R => J);
+ Container.First := J;
+ Container.Last := I;
+ loop
+ Swap (L => I, R => J);
- J := N (J).Next;
- exit when I = J;
+ J := N (J).Next;
+ exit when I = J;
- I := N (I).Prev;
- exit when I = J;
+ I := N (I).Prev;
+ exit when I = J;
- Swap (L => J, R => I);
+ Swap (L => J, R => I);
- I := N (I).Next;
- exit when I = J;
+ I := N (I).Next;
+ exit when I = J;
- J := N (J).Prev;
- exit when I = J;
- end loop;
+ J := N (J).Prev;
+ exit when I = J;
+ end loop;
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end;
+ pragma Assert (N (Container.First).Prev = 0);
+ pragma Assert (N (Container.Last).Next = 0);
end Reverse_Elements;
------------------
-- Reverse_Find --
------------------
- function Reverse_Find_Between
- (Container : Plain_List;
- Item : Element_Type;
- From : Count_Type;
- To : Count_Type) return Cursor
- is
- Nodes : Node_Array renames Container.Nodes;
- Node : Count_Type := To;
- begin
- while Node /= Nodes (From).Prev loop
- if Nodes (Node).Element = Item then
- return (Node => Node);
- end if;
- Node := Nodes (Node).Prev;
- end loop;
-
- return No_Element;
- end Reverse_Find_Between;
-
function Reverse_Find
(Container : List;
Item : Element_Type;
if Container.Length = 0 then
return No_Element;
end if;
- return Reverse_Find_Between (Container => Container.Plain.all,
- Item => Item,
- From => CFirst,
- To => Container.Last);
+
+ while CFirst /= 0 loop
+ if Container.Nodes (CFirst).Element = Item then
+ return (Node => CFirst);
+ end if;
+ CFirst := Container.Nodes (CFirst).Prev;
+ end loop;
+
+ return No_Element;
end Reverse_Find;
---------------------
-- Reverse_Iterate --
---------------------
- procedure Reverse_Iterate_Between
+ procedure Reverse_Iterate
(Container : List;
- From : Count_Type;
- To : Count_Type;
Process :
- not null access procedure (Container : List; Position : Cursor))
+ not null access procedure (Container : List; Position : Cursor))
is
- C : Plain_List renames Container.Plain.all;
- N : Node_Array renames C.Nodes;
+ C : List renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
- Node : Count_Type := To;
+ Node : Count_Type := Container.Last;
begin
B := B + 1;
begin
- while Node /= N (From).Prev loop
- pragma Assert (N (Node).Prev >= 0);
- Process (Container, Position => (Node => Node));
- Node := N (Node).Prev;
+ while Node /= 0 loop
+ Process (Container, (Node => Node));
+ Node := Container.Nodes (Node).Prev;
end loop;
exception
end;
B := B - 1;
- end Reverse_Iterate_Between;
-
- procedure Reverse_Iterate
- (Container : List;
- Process :
- not null access procedure (Container : List; Position : Cursor))
- is
- begin
- if Container.Length = 0 then
- return;
- end if;
- Reverse_Iterate_Between
- (Container, Container.First, Container.Last, Process);
end Reverse_Iterate;
-----------
-----------
function Right (Container : List; Position : Cursor) return List is
- L : Count_Type := 0;
- C : Count_Type := Container.First;
- LLe : Count_Type;
- LF : Count_Type;
- LLa : Count_Type;
+ Curs : Cursor := First (Container);
+ C : List (Container.Capacity) := Copy (Container, Container.Capacity);
+ Node : Count_Type;
begin
- case Container.K is
- when Plain =>
- LLe := Container.Length;
- LF := Container.First;
- LLa := Container.Last;
- when Part =>
- LLe := Container.Part.LLength;
- LF := Container.Part.LFirst;
- LLa := Container.Part.LLast;
- end case;
- if Position.Node = 0 then
- return (Capacity => Container.Capacity,
- K => Part,
- Length => 0,
- First => 0,
- Last => 0,
- Plain => Container.Plain,
- Part => (LLength => LLe, LFirst => LF, LLast => LLa));
- else
- while C /= Position.Node loop
- if C = Container.Last or C = 0 then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
- C := Next_Unchecked (Container, C);
- L := L + 1;
- end loop;
- return (Capacity => Container.Capacity,
- K => Part,
- Length => Container.Length - L,
- First => Position.Node,
- Last => Container.Last,
- Plain => Container.Plain,
- Part => (LLength => LLe, LFirst => LF, LLast => LLa));
+ 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;
+
+ while Curs.Node /= Position.Node loop
+ Node := Curs.Node;
+ Delete (C, Curs);
+ Curs := Next (Container, (Node => Node));
+ end loop;
+ return C;
end Right;
------------
Before : Cursor;
Source : in out List)
is
+ SN : Node_Array renames Source.Nodes;
+
begin
- if Target.K /= Plain or Source.K /= Plain then
- raise Program_Error with "cannot modify part of container";
+ if Before.Node /= 0 then
+ null;
+ pragma Assert (Vet (Target, Before), "bad cursor in Splice");
end if;
- declare
- SN : Node_Array renames Source.Plain.Nodes;
-
- begin
- if Before.Node /= 0 then
- null;
- pragma Assert (Vet (Target, Before), "bad cursor in Splice");
- end if;
-
- if Target'Address = Source'Address
- or else Source.Length = 0
- then
- return;
- end if;
+ if Target'Address = Source'Address
+ or else Source.Length = 0
+ then
+ return;
+ end if;
- pragma Assert (SN (Source.First).Prev = 0);
- pragma Assert (SN (Source.Last).Next = 0);
+ pragma Assert (SN (Source.First).Prev = 0);
+ pragma Assert (SN (Source.Last).Next = 0);
- if Target.Length > Count_Type'Base'Last - Source.Length then
- raise Constraint_Error with "new length exceeds maximum";
- end if;
+ if Target.Length > Count_Type'Base'Last - Source.Length then
+ raise Constraint_Error with "new length exceeds maximum";
+ end if;
- if Target.Length + Source.Length > Target.Capacity then
- raise Constraint_Error;
- end if;
+ if Target.Length + Source.Length > Target.Capacity then
+ raise Constraint_Error;
+ end if;
- if Target.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Target (list is busy)";
- end if;
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Target (list is busy)";
+ end if;
- if Source.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors of Source (list is busy)";
- end if;
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Source (list is busy)";
+ end if;
- loop
- Insert (Target, Before, SN (Source.Last).Element);
- Delete_Last (Source);
- exit when Is_Empty (Source);
- end loop;
- end;
+ loop
+ Insert (Target, Before, SN (Source.Last).Element);
+ Delete_Last (Source);
+ exit when Is_Empty (Source);
+ end loop;
end Splice;
procedure Splice
Target_Position : Cursor;
begin
- if Target.K /= Plain or Source.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
if Target'Address = Source'Address then
Splice (Target, Before, Position);
raise Constraint_Error;
end if;
- if Target.Plain.Busy > 0 then
+ if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors of Target (list is busy)";
end if;
- if Source.Plain.Busy > 0 then
+ if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)";
end if;
Insert
(Container => Target,
Before => Before,
- New_Item => Source.Plain.Nodes (Position.Node).Element,
+ New_Item => Source.Nodes (Position.Node).Element,
Position => Target_Position);
Delete (Source, Position);
Before : Cursor;
Position : Cursor)
is
+ N : Node_Array renames Container.Nodes;
+
begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
+ if Before.Node /= 0 then
+ null;
+ pragma Assert (Vet (Container, Before),
+ "bad Before cursor in Splice");
end if;
- declare
- N : Node_Array renames Container.Plain.Nodes;
+ if Position.Node = 0 then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
- begin
- if Before.Node /= 0 then
- null;
- pragma Assert (Vet (Container, Before),
- "bad Before cursor in Splice");
- end if;
+ pragma Assert (Vet (Container, Position),
+ "bad Position cursor in Splice");
- if Position.Node = 0 then
- raise Constraint_Error with "Position cursor has no element";
- end if;
+ if Position.Node = Before.Node
+ or else N (Position.Node).Next = Before.Node
+ then
+ return;
+ end if;
- pragma Assert (Vet (Container, Position),
- "bad Position cursor in Splice");
+ pragma Assert (Container.Length >= 2);
- if Position.Node = Before.Node
- or else N (Position.Node).Next = Before.Node
- then
- return;
- end if;
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
- pragma Assert (Container.Length >= 2);
+ if Before.Node = 0 then
+ pragma Assert (Position.Node /= Container.Last);
- if Container.Plain.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with elements (list is busy)";
+ if Position.Node = Container.First then
+ Container.First := N (Position.Node).Next;
+ N (Container.First).Prev := 0;
+
+ else
+ N (N (Position.Node).Prev).Next := N (Position.Node).Next;
+ N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
end if;
- if Before.Node = 0 then
- pragma Assert (Position.Node /= Container.Last);
+ N (Container.Last).Next := Position.Node;
+ N (Position.Node).Prev := Container.Last;
- if Position.Node = Container.First then
- Container.First := N (Position.Node).Next;
- N (Container.First).Prev := 0;
+ Container.Last := Position.Node;
+ N (Container.Last).Next := 0;
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
+ return;
+ end if;
- N (Container.Last).Next := Position.Node;
- N (Position.Node).Prev := Container.Last;
+ if Before.Node = Container.First then
+ pragma Assert (Position.Node /= Container.First);
- Container.Last := Position.Node;
+ if Position.Node = Container.Last then
+ Container.Last := N (Position.Node).Prev;
N (Container.Last).Next := 0;
- return;
+ else
+ N (N (Position.Node).Prev).Next := N (Position.Node).Next;
+ N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
end if;
- if Before.Node = Container.First then
- pragma Assert (Position.Node /= Container.First);
-
- if Position.Node = Container.Last then
- Container.Last := N (Position.Node).Prev;
- N (Container.Last).Next := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
+ N (Container.First).Prev := Position.Node;
+ N (Position.Node).Next := Container.First;
- N (Container.First).Prev := Position.Node;
- N (Position.Node).Next := Container.First;
+ Container.First := Position.Node;
+ N (Container.First).Prev := 0;
- Container.First := Position.Node;
- N (Container.First).Prev := 0;
-
- return;
- end if;
+ return;
+ end if;
- if Position.Node = Container.First then
- Container.First := N (Position.Node).Next;
- N (Container.First).Prev := 0;
+ if Position.Node = Container.First then
+ Container.First := N (Position.Node).Next;
+ N (Container.First).Prev := 0;
- elsif Position.Node = Container.Last then
- Container.Last := N (Position.Node).Prev;
- N (Container.Last).Next := 0;
+ elsif Position.Node = Container.Last then
+ Container.Last := N (Position.Node).Prev;
+ N (Container.Last).Next := 0;
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
+ else
+ N (N (Position.Node).Prev).Next := N (Position.Node).Next;
+ N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
+ end if;
- N (N (Before.Node).Prev).Next := Position.Node;
- N (Position.Node).Prev := N (Before.Node).Prev;
+ N (N (Before.Node).Prev).Next := Position.Node;
+ N (Position.Node).Prev := N (Before.Node).Prev;
- N (Before.Node).Prev := Position.Node;
- N (Position.Node).Next := Before.Node;
+ N (Before.Node).Prev := Position.Node;
+ N (Position.Node).Next := Before.Node;
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end;
+ pragma Assert (N (Container.First).Prev = 0);
+ pragma Assert (N (Container.Last).Next = 0);
end Splice;
------------------
begin
while CL /= 0 or CR /= 0 loop
if CL /= CR or else
- Element_Unchecked (Left, CL) /= Element_Unchecked (Right, CL) then
+ Left.Nodes (CL).Element /= Right.Nodes (CL).Element then
return False;
end if;
- CL := Next_Unchecked (Left, CL);
- CR := Next_Unchecked (Right, CR);
+ CL := Left.Nodes (CL).Next;
+ CR := Right.Nodes (CR).Next;
end loop;
return True;
end Strict_Equal;
I, J : Cursor)
is
begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
if I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
return;
end if;
- if Container.Plain.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (list is locked)";
end if;
pragma Assert (Vet (Container, J), "bad J cursor in Swap");
declare
- NN : Node_Array renames Container.Plain.Nodes;
+ NN : Node_Array renames Container.Nodes;
NI : Node_Type renames NN (I.Node);
NJ : Node_Type renames NN (J.Node);
I_Next, J_Next : Cursor;
begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
if I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
return;
end if;
- if Container.Plain.Busy > 0 then
+ if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
Process : not null access procedure (Element : in out Element_Type))
is
begin
- if Container.K /= Plain then
- raise Program_Error with "cannot modify part of container";
- end if;
if Position.Node = 0 then
raise Constraint_Error with "Position cursor has no element";
"bad cursor in Update_Element");
declare
- B : Natural renames Container.Plain.Busy;
- L : Natural renames Container.Plain.Lock;
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
declare
- N : Node_Type renames Container.Plain.Nodes (Position.Node);
+ N : Node_Type renames Container.Nodes (Position.Node);
begin
Process (N.Element);
exception
---------
function Vet (L : List; Position : Cursor) return Boolean is
+ N : Node_Array renames L.Nodes;
+
begin
- if L.K /= Plain then
- raise Program_Error with "cannot modify part of container";
+ if L.Length = 0 then
+ return False;
end if;
- declare
- N : Node_Array renames L.Plain.Nodes;
+ if L.First = 0 then
+ return False;
+ end if;
- begin
- if L.Length = 0 then
- return False;
- end if;
+ if L.Last = 0 then
+ return False;
+ end if;
- if L.First = 0 then
- return False;
- end if;
+ if Position.Node > L.Capacity then
+ return False;
+ end if;
- if L.Last = 0 then
- return False;
- end if;
+ if N (Position.Node).Prev < 0
+ or else N (Position.Node).Prev > L.Capacity
+ then
+ return False;
+ end if;
- if Position.Node > L.Capacity then
- return False;
- end if;
+ if N (Position.Node).Next > L.Capacity then
+ return False;
+ end if;
- if N (Position.Node).Prev < 0
- or else N (Position.Node).Prev > L.Capacity
- then
- return False;
- end if;
+ if N (L.First).Prev /= 0 then
+ return False;
+ end if;
- if N (Position.Node).Next > L.Capacity then
- return False;
- end if;
+ if N (L.Last).Next /= 0 then
+ return False;
+ end if;
- if N (L.First).Prev /= 0 then
- return False;
- end if;
+ if N (Position.Node).Prev = 0
+ and then Position.Node /= L.First
+ then
+ return False;
+ end if;
- if N (L.Last).Next /= 0 then
- return False;
- end if;
+ if N (Position.Node).Next = 0
+ and then Position.Node /= L.Last
+ then
+ return False;
+ end if;
- if N (Position.Node).Prev = 0
- and then Position.Node /= L.First
- then
- return False;
- end if;
+ if L.Length = 1 then
+ return L.First = L.Last;
+ end if;
- if N (Position.Node).Next = 0
- and then Position.Node /= L.Last
- then
- return False;
- end if;
+ if L.First = L.Last then
+ return False;
+ end if;
- if L.Length = 1 then
- return L.First = L.Last;
- end if;
+ if N (L.First).Next = 0 then
+ return False;
+ end if;
- if L.First = L.Last then
- return False;
- end if;
+ if N (L.Last).Prev = 0 then
+ return False;
+ end if;
- if N (L.First).Next = 0 then
- return False;
- end if;
+ if N (N (L.First).Next).Prev /= L.First then
+ return False;
+ end if;
- if N (L.Last).Prev = 0 then
- return False;
- end if;
+ if N (N (L.Last).Prev).Next /= L.Last then
+ return False;
+ end if;
- if N (N (L.First).Next).Prev /= L.First then
+ if L.Length = 2 then
+ if N (L.First).Next /= L.Last then
return False;
end if;
- if N (N (L.Last).Prev).Next /= L.Last then
+ if N (L.Last).Prev /= L.First then
return False;
end if;
- if L.Length = 2 then
- if N (L.First).Next /= L.Last then
- return False;
- end if;
+ return True;
+ end if;
- if N (L.Last).Prev /= L.First then
- return False;
- end if;
+ if N (L.First).Next = L.Last then
+ return False;
+ end if;
- return True;
- end if;
+ if N (L.Last).Prev = L.First then
+ return False;
+ end if;
- if N (L.First).Next = L.Last then
- return False;
- end if;
+ if Position.Node = L.First then
+ return True;
+ end if;
- if N (L.Last).Prev = L.First then
- return False;
- end if;
+ if Position.Node = L.Last then
+ return True;
+ end if;
- if Position.Node = L.First then
- return True;
- end if;
+ if N (Position.Node).Next = 0 then
+ return False;
+ end if;
- if Position.Node = L.Last then
- return True;
- end if;
+ if N (Position.Node).Prev = 0 then
+ return False;
+ end if;
- if N (Position.Node).Next = 0 then
- return False;
- end if;
+ if N (N (Position.Node).Next).Prev /= Position.Node then
+ return False;
+ end if;
- if N (Position.Node).Prev = 0 then
- return False;
- end if;
+ if N (N (Position.Node).Prev).Next /= Position.Node then
+ return False;
+ end if;
- if N (N (Position.Node).Next).Prev /= Position.Node then
+ if L.Length = 3 then
+ if N (L.First).Next /= Position.Node then
return False;
end if;
- if N (N (Position.Node).Prev).Next /= Position.Node then
+ if N (L.Last).Prev /= Position.Node then
return False;
end if;
+ end if;
- if L.Length = 3 then
- if N (L.First).Next /= Position.Node then
- return False;
- end if;
-
- if N (L.Last).Prev /= Position.Node then
- return False;
- end if;
- end if;
-
- return True;
- end;
+ return True;
end Vet;
-----------
-- Write --
-----------
- procedure Write_Between
+ procedure Write
(Stream : not null access Root_Stream_Type'Class;
- Item : Plain_List;
- Length : Count_Type;
- From : Count_Type;
- To : Count_Type) is
-
+ Item : List)
+ is
N : Node_Array renames Item.Nodes;
Node : Count_Type;
begin
- Count_Type'Base'Write (Stream, Length);
+ Count_Type'Base'Write (Stream, Item.Length);
- Node := From;
- while Node /= N (To).Next loop
+ Node := Item.First;
+ while Node /= 0 loop
Element_Type'Write (Stream, N (Node).Element);
Node := N (Node).Next;
end loop;
- end Write_Between;
-
- procedure Write
- (Stream : not null access Root_Stream_Type'Class;
- Item : List)
- is
- begin
- Write_Between
- (Stream, Item.Plain.all, Item.Length, Item.First, Item.Last);
end Write;
procedure Write
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
type Node_Array is array (Count_Type range <>) of Node_Type;
function "=" (L, R : Node_Array) return Boolean is abstract;
- type List_Access is access all List;
- for List_Access'Storage_Size use 0;
-
- type Kind is (Plain, Part);
-
- type Plain_List (Capacity : Count_Type) is record
+ type List (Capacity : Count_Type) is tagged record
Nodes : Node_Array (1 .. Capacity) := (others => <>);
Free : Count_Type'Base := -1;
Busy : Natural := 0;
Lock : Natural := 0;
- end record;
-
- type PList_Access is access Plain_List;
-
- type Part_List is record
- LLength : Count_Type := 0;
- LFirst : Count_Type := 0;
- LLast : Count_Type := 0;
- end record;
-
- type List (Capacity : Count_Type) is tagged record
- K : Kind := Plain;
Length : Count_Type := 0;
First : Count_Type := 0;
Last : Count_Type := 0;
- Part : Part_List;
- Plain : PList_Access := new Plain_List'(Capacity, others => <>);
end record;
use Ada.Streams;
-- --
-- B o d y --
-- --
--- Copyright (C) 2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-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- --
Node : Node_Type) return Boolean;
pragma Inline (Equivalent_Keys);
- function Find_Between
- (HT : Hash_Table_Type;
- Key : Key_Type;
- From : Count_Type;
- To : Count_Type) return Count_Type;
-
procedure Free
- (HT : in out Hash_Table_Type;
+ (HT : in out Map;
X : Count_Type);
generic
with procedure Set_Element (Node : in out Node_Type);
procedure Generic_Allocate
- (HT : in out Hash_Table_Type;
+ (HT : in out Map;
Node : out Count_Type);
function Hash_Node (Node : Node_Type) return Hash_Type;
pragma Inline (Hash_Node);
- function Next_Unchecked
- (Container : Map;
- Position : Cursor) return Cursor;
-
function Next (Node : Node_Type) return Count_Type;
pragma Inline (Next);
end if;
declare
- Node : Count_Type := First (Left).Node;
+ Node : Count_Type := Left.First.Node;
ENode : Count_Type;
- Last : Count_Type;
begin
- if Left.K = Plain then
- Last := 0;
- else
- Last := HT_Ops.Next (Left.HT.all, Left.Last);
- end if;
-
- while Node /= Last loop
+ while Node /= 0 loop
ENode := Find (Container => Right,
- Key => Left.HT.Nodes (Node).Key).Node;
+ Key => Left.Nodes (Node).Key).Node;
if ENode = 0 or else
- Right.HT.Nodes (ENode).Element /= Left.HT.Nodes (Node).Element
+ Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
then
return False;
end if;
- Node := HT_Ops.Next (Left.HT.all, Node);
+ Node := HT_Ops.Next (Left, Node);
end loop;
return True;
--------------------
procedure Insert_Element (Source_Node : Count_Type) is
- N : Node_Type renames Source.HT.Nodes (Source_Node);
+ N : Node_Type renames Source.Nodes (Source_Node);
begin
Target.Insert (N.Key, N.Element);
end Insert_Element;
-- Start of processing for Assign
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Target'Address = Source'Address then
return;
Clear (Target); -- checks busy bits
- case Source.K is
- when Plain =>
- Insert_Elements (Source.HT.all);
- when Part =>
- declare
- N : Count_Type := Source.First;
- begin
- while N /= HT_Ops.Next (Source.HT.all, Source.Last) loop
- Insert_Element (N);
- N := HT_Ops.Next (Source.HT.all, N);
- end loop;
- end;
- end case;
+ Insert_Elements (Source);
end Assign;
--------------
function Capacity (Container : Map) return Count_Type is
begin
- return Container.HT.Nodes'Length;
+ return Container.Nodes'Length;
end Capacity;
-----------
procedure Clear (Container : in out Map) is
begin
-
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- HT_Ops.Clear (Container.HT.all);
+ HT_Ops.Clear (Container);
end Clear;
--------------
Target : Map (C, Source.Modulus);
Cu : Cursor;
begin
- if (Source.K = Part and Source.Length = 0) or
- Source.HT.Length = 0 then
- return Target;
- end if;
- Target.HT.Length := Source.HT.Length;
- Target.HT.Free := Source.HT.Free;
+ Target.Length := Source.Length;
+ Target.Free := Source.Free;
while H <= Source.Modulus loop
- Target.HT.Buckets (H) := Source.HT.Buckets (H);
+ Target.Buckets (H) := Source.Buckets (H);
H := H + 1;
end loop;
while N <= Source.Capacity loop
- Target.HT.Nodes (N) := Source.HT.Nodes (N);
+ Target.Nodes (N) := Source.Nodes (N);
N := N + 1;
end loop;
while N <= C loop
Cu := (Node => N);
- Free (Target.HT.all, Cu.Node);
+ Free (Target, Cu.Node);
N := N + 1;
end loop;
- if Source.K = Part then
- N := HT_Ops.First (Target.HT.all);
- while N /= Source.First loop
- Cu := (Node => N);
- N := HT_Ops.Next (Target.HT.all, N);
- Delete (Target, Cu);
- end loop;
- N := HT_Ops.Next (Target.HT.all, Source.Last);
- while N /= 0 loop
- Cu := (Node => N);
- N := HT_Ops.Next (Target.HT.all, N);
- Delete (Target, Cu);
- end loop;
- end if;
return Target;
end Copy;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- Key_Ops.Delete_Key_Sans_Free (Container.HT.all, Key, X);
+ Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
if X = 0 then
raise Constraint_Error with "attempt to delete key not in map";
end if;
- Free (Container.HT.all, X);
+ Free (Container, X);
end Delete;
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Delete has no element";
end if;
- if Container.HT.Busy > 0 then
+ if Container.Busy > 0 then
raise Program_Error with
"Delete attempted to tamper with elements (map is busy)";
end if;
pragma Assert (Vet (Container, Position), "bad cursor in Delete");
- HT_Ops.Delete_Node_Sans_Free (Container.HT.all, Position.Node);
+ HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
- Free (Container.HT.all, Position.Node);
+ Free (Container, Position.Node);
end Delete;
-------------
"no element available because key not in map";
end if;
- return Container.HT.Nodes (Node).Element;
+ return Container.Nodes (Node).Element;
end Element;
function Element (Container : Map; Position : Cursor) return Element_Type is
pragma Assert (Vet (Container, Position),
"bad cursor in function Element");
- return Container.HT.Nodes (Position.Node).Element;
+ return Container.Nodes (Position.Node).Element;
end Element;
---------------------
"Right cursor of Equivalent_Keys is bad");
declare
- LT : Hash_Table_Type renames Left.HT.all;
- RT : Hash_Table_Type renames Right.HT.all;
- LN : Node_Type renames LT.Nodes (CLeft.Node);
- RN : Node_Type renames RT.Nodes (CRight.Node);
+ LN : Node_Type renames Left.Nodes (CLeft.Node);
+ RN : Node_Type renames Right.Nodes (CRight.Node);
begin
return Equivalent_Keys (LN.Key, RN.Key);
"Left cursor in Equivalent_Keys is bad");
declare
- LT : Hash_Table_Type renames Left.HT.all;
- LN : Node_Type renames LT.Nodes (CLeft.Node);
+ LN : Node_Type renames Left.Nodes (CLeft.Node);
begin
return Equivalent_Keys (LN.Key, Right);
"Right cursor of Equivalent_Keys is bad");
declare
- RT : Hash_Table_Type renames Right.HT.all;
- RN : Node_Type renames RT.Nodes (CRight.Node);
+ RN : Node_Type renames Right.Nodes (CRight.Node);
begin
return Equivalent_Keys (Left, RN.Key);
procedure Exclude (Container : in out Map; Key : Key_Type) is
X : Count_Type;
begin
-
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- Key_Ops.Delete_Key_Sans_Free (Container.HT.all, Key, X);
- Free (Container.HT.all, X);
+ Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+ Free (Container, X);
end Exclude;
----------
-- Find --
----------
- function Find_Between
- (HT : Hash_Table_Type;
- Key : Key_Type;
- From : Count_Type;
- To : Count_Type) return Count_Type is
-
- Indx : Hash_Type;
- Indx_From : constant Hash_Type :=
- Key_Ops.Index (HT, HT.Nodes (From).Key);
- Indx_To : constant Hash_Type :=
- Key_Ops.Index (HT, HT.Nodes (To).Key);
- Node : Count_Type;
- To_Node : Count_Type;
-
- begin
-
- Indx := Key_Ops.Index (HT, Key);
-
- if Indx < Indx_From or Indx > Indx_To then
- return 0;
- end if;
-
- if Indx = Indx_From then
- Node := From;
- else
- Node := HT.Buckets (Indx);
- end if;
-
- if Indx = Indx_To then
- To_Node := HT.Nodes (To).Next;
- else
- To_Node := 0;
- end if;
-
- while Node /= To_Node loop
- if Equivalent_Keys (Key, HT.Nodes (Node)) then
- return Node;
- end if;
- Node := HT.Nodes (Node).Next;
- end loop;
- return 0;
- end Find_Between;
function Find (Container : Map; Key : Key_Type) return Cursor is
+ Node : constant Count_Type :=
+ Key_Ops.Find (Container, Key);
+
begin
- case Container.K is
- when Plain =>
- declare
- Node : constant Count_Type :=
- Key_Ops.Find (Container.HT.all, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
- when Part =>
- if Container.Length = 0 then
- return No_Element;
- end if;
+ if Node = 0 then
+ return No_Element;
+ end if;
- return (Node => Find_Between (Container.HT.all, Key,
- Container.First, Container.Last));
- end case;
+ return (Node => Node);
end Find;
-----------
-----------
function First (Container : Map) return Cursor is
+ Node : constant Count_Type := HT_Ops.First (Container);
+
begin
- case Container.K is
- when Plain =>
- declare
- Node : constant Count_Type := HT_Ops.First (Container.HT.all);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
- when Part =>
- declare
- Node : constant Count_Type := Container.First;
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
- end case;
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+
end First;
----------
----------
procedure Free
- (HT : in out Hash_Table_Type;
+ (HT : in out Map;
X : Count_Type)
is
begin
----------------------
procedure Generic_Allocate
- (HT : in out Hash_Table_Type;
+ (HT : in out Map;
Node : out Count_Type)
is
function Has_Element (Container : Map; Position : Cursor) return Boolean is
begin
if Position.Node = 0 or else
- not Container.HT.Nodes (Position.Node).Has_Element then
+ not Container.Nodes (Position.Node).Has_Element then
return False;
end if;
-
- if Container.K = Plain then
- return True;
- end if;
-
- declare
- Lst_Index : constant Hash_Type :=
- Key_Ops.Index (Container.HT.all,
- Container.HT.Nodes (Container.Last).Key);
- Fst_Index : constant Hash_Type :=
- Key_Ops.Index (Container.HT.all,
- Container.HT.Nodes (Container.First).Key);
- Index : constant Hash_Type :=
- Key_Ops.Index (Container.HT.all,
- Container.HT.Nodes (Position.Node).Key);
- Lst_Node : Count_Type;
- Node : Count_Type;
- begin
-
- if Index < Fst_Index or Index > Lst_Index then
- return False;
- end if;
-
- if Index > Fst_Index and Index < Lst_Index then
- return True;
- end if;
-
- if Index = Fst_Index then
- Node := Container.First;
- else
- Node := Container.HT.Buckets (Index);
- end if;
-
- if Index = Lst_Index then
- Lst_Node := Container.HT.Nodes (Container.Last).Next;
- else
- Lst_Node := 0;
- end if;
-
- while Node /= Lst_Node loop
- if Position.Node = Node then
- return True;
- end if;
- Node := HT_Ops.Next (Container.HT.all, Node);
- end loop;
-
- return False;
- end;
+ return True;
end Has_Element;
---------------
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
- if Container.HT.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"Include attempted to tamper with cursors (map is locked)";
end if;
declare
- N : Node_Type renames Container.HT.Nodes (Position.Node);
+ N : Node_Type renames Container.Nodes (Position.Node);
begin
N.Key := Key;
N.Element := New_Item;
Position : out Cursor;
Inserted : out Boolean)
is
- begin
+ procedure Assign_Key (Node : in out Node_Type);
+ pragma Inline (Assign_Key);
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
- declare
- procedure Assign_Key (Node : in out Node_Type);
- pragma Inline (Assign_Key);
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
- function New_Node return Count_Type;
- pragma Inline (New_Node);
+ procedure Local_Insert is
+ new Key_Ops.Generic_Conditional_Insert (New_Node);
- procedure Local_Insert is
- new Key_Ops.Generic_Conditional_Insert (New_Node);
-
- procedure Allocate is
- new Generic_Allocate (Assign_Key);
+ procedure Allocate is
+ new Generic_Allocate (Assign_Key);
- -----------------
- -- Assign_Key --
- -----------------
+ -----------------
+ -- Assign_Key --
+ -----------------
- procedure Assign_Key (Node : in out Node_Type) is
- begin
- Node.Key := Key;
- -- Node.Element := New_Item;
- end Assign_Key;
+ procedure Assign_Key (Node : in out Node_Type) is
+ begin
+ Node.Key := Key;
+ -- Node.Element := New_Item;
+ end Assign_Key;
- --------------
- -- New_Node --
- --------------
+ --------------
+ -- New_Node --
+ --------------
- function New_Node return Count_Type is
- Result : Count_Type;
- begin
- Allocate (Container.HT.all, Result);
- return Result;
- end New_Node;
+ function New_Node return Count_Type is
+ Result : Count_Type;
+ begin
+ Allocate (Container, Result);
+ return Result;
+ end New_Node;
- -- Start of processing for Insert
+ -- Start of processing for Insert
- begin
+ begin
- Local_Insert (Container.HT.all, Key, Position.Node, Inserted);
- end;
+ Local_Insert (Container, Key, Position.Node, Inserted);
end Insert;
procedure Insert
Position : out Cursor;
Inserted : out Boolean)
is
- begin
-
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
- declare
- procedure Assign_Key (Node : in out Node_Type);
- pragma Inline (Assign_Key);
+ procedure Assign_Key (Node : in out Node_Type);
+ pragma Inline (Assign_Key);
- function New_Node return Count_Type;
- pragma Inline (New_Node);
+ function New_Node return Count_Type;
+ pragma Inline (New_Node);
- procedure Local_Insert is
- new Key_Ops.Generic_Conditional_Insert (New_Node);
+ procedure Local_Insert is
+ new Key_Ops.Generic_Conditional_Insert (New_Node);
- procedure Allocate is
- new Generic_Allocate (Assign_Key);
+ procedure Allocate is
+ new Generic_Allocate (Assign_Key);
- -----------------
- -- Assign_Key --
- -----------------
+ -----------------
+ -- Assign_Key --
+ -----------------
- procedure Assign_Key (Node : in out Node_Type) is
- begin
- Node.Key := Key;
- Node.Element := New_Item;
- end Assign_Key;
+ procedure Assign_Key (Node : in out Node_Type) is
+ begin
+ Node.Key := Key;
+ Node.Element := New_Item;
+ end Assign_Key;
- --------------
- -- New_Node --
- --------------
+ --------------
+ -- New_Node --
+ --------------
- function New_Node return Count_Type is
- Result : Count_Type;
- begin
- Allocate (Container.HT.all, Result);
- return Result;
- end New_Node;
+ function New_Node return Count_Type is
+ Result : Count_Type;
+ begin
+ Allocate (Container, Result);
+ return Result;
+ end New_Node;
- -- Start of processing for Insert
+ -- Start of processing for Insert
- begin
+ begin
- Local_Insert (Container.HT.all, Key, Position.Node, Inserted);
- end;
+ Local_Insert (Container, Key, Position.Node, Inserted);
end Insert;
procedure Insert
Process (Container, (Node => Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.HT.Busy;
+ B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Iterate
B := B + 1;
begin
- case Container.K is
- when Plain =>
- Local_Iterate (Container.HT.all);
- when Part =>
-
- if Container.Length = 0 then
- return;
- end if;
-
- declare
- Node : Count_Type := Container.First;
- begin
- while Node /= Container.HT.Nodes (Container.Last).Next loop
- Process_Node (Node);
- Node := HT_Ops.Next (Container.HT.all, Node);
- end loop;
- end;
- end case;
+ Local_Iterate (Container);
exception
when others =>
B := B - 1;
pragma Assert (Vet (Container, Position), "bad cursor in function Key");
- return Container.HT.Nodes (Position.Node).Key;
+ return Container.Nodes (Position.Node).Key;
end Key;
----------
----------
function Left (Container : Map; Position : Cursor) return Map is
- Lst : Count_Type;
- Fst : constant Count_Type := First (Container).Node;
- L : Count_Type := 0;
- C : Count_Type := Fst;
+ Curs : Cursor := Position;
+ C : Map (Container.Capacity, Container.Modulus) :=
+ Copy (Container, Container.Capacity);
+ Node : Count_Type;
begin
- while C /= Position.Node loop
- if C = 0 or C = Container.Last then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
- Lst := C;
- C := HT_Ops.Next (Container.HT.all, C);
- L := L + 1;
- end loop;
- if L = 0 then
- return (Capacity => Container.Capacity,
- Modulus => Container.Modulus,
- K => Part,
- HT => Container.HT,
- Length => 0,
- First => 0,
- Last => 0);
- else
- return (Capacity => Container.Capacity,
- Modulus => Container.Modulus,
- K => Part,
- HT => Container.HT,
- Length => L,
- First => Fst,
- Last => Lst);
+ if Curs = No_Element then
+ return C;
end if;
+ if not Has_Element (Container, Curs) then
+ raise Constraint_Error;
+ end if;
+
+ while Curs.Node /= 0 loop
+ Node := Curs.Node;
+ Delete (C, Curs);
+ Curs := Next (Container, (Node => Node));
+ end loop;
+ return C;
end Left;
------------
function Length (Container : Map) return Count_Type is
begin
- case Container.K is
- when Plain =>
- return Container.HT.Length;
- when Part =>
- return Container.Length;
- end case;
+ return Container.Length;
end Length;
----------
(Target : in out Map;
Source : in out Map)
is
- HT : HT_Types.Hash_Table_Type renames Source.HT.all;
- NN : HT_Types.Nodes_Type renames HT.Nodes;
+ NN : HT_Types.Nodes_Type renames Source.Nodes;
X, Y : Count_Type;
begin
- if Target.K /= Plain or Source.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Target'Address = Source'Address then
return;
end if;
"Source length exceeds Target capacity";
end if;
- if HT.Busy > 0 then
+ if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)";
end if;
Clear (Target);
- if HT.Length = 0 then
+ if Source.Length = 0 then
return;
end if;
- X := HT_Ops.First (HT);
+ X := HT_Ops.First (Source);
while X /= 0 loop
Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
- Y := HT_Ops.Next (HT, X);
+ Y := HT_Ops.Next (Source, X);
- HT_Ops.Delete_Node_Sans_Free (HT, X);
- Free (HT, X);
+ HT_Ops.Delete_Node_Sans_Free (Source, X);
+ Free (Source, X);
X := Y;
end loop;
return Node.Next;
end Next;
- function Next_Unchecked
- (Container : Map;
- Position : Cursor) return Cursor
- is
- HT : Hash_Table_Type renames Container.HT.all;
- Node : constant Count_Type := HT_Ops.Next (HT, Position.Node);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- if Container.K = Part and then Container.Last = Position.Node then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Next_Unchecked;
-
function Next (Container : Map; Position : Cursor) return Cursor is
begin
if Position.Node = 0 then
pragma Assert (Vet (Container, Position), "bad cursor in function Next");
- return Next_Unchecked (Container, Position);
+ declare
+ Node : constant Count_Type := HT_Ops.Next (Container, Position.Node);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
end Next;
procedure Next (Container : Map; Position : in out Cursor) is
function Overlap (Left, Right : Map) return Boolean is
Left_Node : Count_Type;
- Left_Nodes : Nodes_Type renames Left.HT.Nodes;
- To_Node : Count_Type;
+ Left_Nodes : Nodes_Type renames Left.Nodes;
begin
if Length (Right) = 0 or Length (Left) = 0 then
return False;
Left_Node := First (Left).Node;
- if Left.K = Plain then
- To_Node := 0;
- else
- To_Node := Left.HT.Nodes (Left.Last).Next;
- end if;
-
- while Left_Node /= To_Node loop
+ while Left_Node /= 0 loop
declare
N : Node_Type renames Left_Nodes (Left_Node);
E : Key_Type renames N.Key;
end if;
end;
- Left_Node := HT_Ops.Next (Left.HT.all, Left_Node);
+ Left_Node := HT_Ops.Next (Left, Left_Node);
end loop;
return False;
procedure (Key : Key_Type; Element : Element_Type))
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with
pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
declare
- HT : Hash_Table_Type renames Container.HT.all;
- N : Node_Type renames HT.Nodes (Position.Node);
+ N : Node_Type renames Container.Nodes (Position.Node);
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
B := B + 1;
-- Start of processing for Read_Node
begin
- Allocate (Container.HT.all, Node);
+ Allocate (Container, Node);
return Node;
end Read_Node;
-- Start of processing for Read
- Result : HT_Access;
begin
- if Container.K /= Plain then
- raise Constraint_Error;
- end if;
-
- if Container.HT = null then
- Result := new HT_Types.Hash_Table_Type (Container.Capacity,
- Container.Modulus);
- else
- Result := Container.HT;
- end if;
-
- Read_Nodes (Stream, Result.all);
- Container.HT := Result;
+ Read_Nodes (Stream, Container);
end Read;
procedure Read
Key : Key_Type;
New_Item : Element_Type)
is
- Node : constant Count_Type := Key_Ops.Find (Container.HT.all, Key);
+ Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Node = 0 then
raise Constraint_Error with
"attempt to replace key not in map";
end if;
- if Container.HT.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"Replace attempted to tamper with cursors (map is locked)";
end if;
declare
- N : Node_Type renames Container.HT.Nodes (Node);
+ N : Node_Type renames Container.Nodes (Node);
begin
N.Key := Key;
N.Element := New_Item;
New_Item : Element_Type)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Replace_Element has no element";
end if;
- if Container.HT.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"Replace_Element attempted to tamper with cursors (map is locked)";
end if;
pragma Assert (Vet (Container, Position),
"bad cursor in Replace_Element");
- Container.HT.Nodes (Position.Node).Element := New_Item;
+ Container.Nodes (Position.Node).Element := New_Item;
end Replace_Element;
----------------------
Capacity : Count_Type)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Capacity > Container.Capacity then
raise Capacity_Error with "requested capacity is too large";
-----------
function Right (Container : Map; Position : Cursor) return Map is
- Last : Count_Type;
- Lst : Count_Type;
- L : Count_Type := 0;
- C : Count_Type := Position.Node;
+ Curs : Cursor := First (Container);
+ C : Map (Container.Capacity, Container.Modulus) :=
+ Copy (Container, Container.Capacity);
+ Node : Count_Type;
begin
-
- if C = 0 then
- return (Capacity => Container.Capacity,
- Modulus => Container.Modulus,
- K => Part,
- HT => Container.HT,
- Length => 0,
- First => 0,
- Last => 0);
- end if;
-
- if Container.K = Plain then
- Lst := 0;
- else
- Lst := HT_Ops.Next (Container.HT.all, Container.Last);
+ if Curs = No_Element then
+ Clear (C);
+ return C;
end if;
-
- if C = Lst then
- raise Constraint_Error with
- "Position cursor has no element";
+ if Position /= No_Element and not Has_Element (Container, Position) then
+ raise Constraint_Error;
end if;
- while C /= Lst loop
- if C = 0 then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
- Last := C;
- C := HT_Ops.Next (Container.HT.all, C);
- L := L + 1;
+ while Curs.Node /= Position.Node loop
+ Node := Curs.Node;
+ Delete (C, Curs);
+ Curs := Next (Container, (Node => Node));
end loop;
-
- return (Capacity => Container.Capacity,
- Modulus => Container.Modulus,
- K => Part,
- HT => Container.HT,
- Length => L,
- First => Position.Node,
- Last => Last);
+ return C;
end Right;
--------------
while CuL.Node /= 0 or CuR.Node /= 0 loop
if CuL.Node /= CuR.Node or else
- (Left.HT.Nodes (CuL.Node).Element /=
- Right.HT.Nodes (CuR.Node).Element or
- Left.HT.Nodes (CuL.Node).Key /=
- Right.HT.Nodes (CuR.Node).Key) then
+ (Left.Nodes (CuL.Node).Element /=
+ Right.Nodes (CuR.Node).Element or
+ Left.Nodes (CuL.Node).Key /=
+ Right.Nodes (CuR.Node).Key) then
return False;
end if;
- CuL := Next_Unchecked (Left, CuL);
- CuR := Next_Unchecked (Right, CuR);
+ CuL := Next (Left, CuL);
+ CuR := Next (Right, CuR);
end loop;
return True;
Element : in out Element_Type))
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Update_Element has no element";
"bad cursor in Update_Element");
declare
- HT : Hash_Table_Type renames Container.HT.all;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
declare
- N : Node_Type renames HT.Nodes (Position.Node);
+ N : Node_Type renames Container.Nodes (Position.Node);
K : Key_Type renames N.Key;
E : Element_Type renames N.Element;
end if;
declare
- M : HT_Types.Hash_Table_Type renames Container.HT.all;
X : Count_Type;
begin
- if M.Length = 0 then
+ if Container.Length = 0 then
return False;
end if;
- if M.Capacity = 0 then
+ if Container.Capacity = 0 then
return False;
end if;
- if M.Buckets'Length = 0 then
+ if Container.Buckets'Length = 0 then
return False;
end if;
- if Position.Node > M.Capacity then
+ if Position.Node > Container.Capacity then
return False;
end if;
- if M.Nodes (Position.Node).Next = Position.Node then
+ if Container.Nodes (Position.Node).Next = Position.Node then
return False;
end if;
- X := M.Buckets (Key_Ops.Index (M, M.Nodes (Position.Node).Key));
+ X := Container.Buckets
+ (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key));
- for J in 1 .. M.Length loop
+ for J in 1 .. Container.Length loop
if X = Position.Node then
return True;
end if;
return False;
end if;
- if X = M.Nodes (X).Next then -- to prevent unnecessary looping
+ if X = Container.Nodes (X).Next then
+ -- to prevent unnecessary looping
return False;
end if;
- X := M.Nodes (X).Next;
+ X := Container.Nodes (X).Next;
end loop;
return False;
-- Start of processing for Write
begin
- Write_Nodes (Stream, Container.HT.all);
+ Write_Nodes (Stream, Container);
end Write;
procedure Write
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
pragma Pure;
type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
- -- pragma Preelaborable_Initialization (Map);
- -- why is this commented out???
+ pragma Preelaborable_Initialization (Map);
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
package HT_Types is new
Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types
- (Node_Type);
+ (Node_Type);
- type HT_Access is access all HT_Types.Hash_Table_Type;
-
- type Kind is (Plain, Part);
-
- type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged record
- HT : HT_Access := new HT_Types.Hash_Table_Type (Capacity, Modulus);
- K : Kind := Plain;
- Length : Count_Type := 0;
- First : Count_Type := 0;
- Last : Count_Type := 0;
- end record;
+ type Map (Capacity : Count_Type; Modulus : Hash_Type) is
+ new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
use HT_Types;
use Ada.Streams;
-- --
-- B o d y --
-- --
--- Copyright (C) 2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-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 Difference
(Left, Right : Set;
- Target : in out Hash_Table_Type);
+ Target : in out Set);
function Equivalent_Keys
(Key : Element_Type;
pragma Inline (Equivalent_Keys);
procedure Free
- (HT : in out Hash_Table_Type;
+ (HT : in out Set;
X : Count_Type);
generic
with procedure Set_Element (Node : in out Node_Type);
procedure Generic_Allocate
- (HT : in out Hash_Table_Type;
+ (HT : in out Set;
Node : out Count_Type);
function Hash_Node (Node : Node_Type) return Hash_Type;
pragma Inline (Hash_Node);
procedure Insert
- (Container : in out Hash_Table_Type;
+ (Container : in out Set;
New_Item : Element_Type;
Node : out Count_Type;
Inserted : out Boolean);
procedure Intersection
- (Left : Hash_Table_Type;
+ (Left : Set;
Right : Set;
- Target : in out Hash_Table_Type);
+ Target : in out Set);
function Is_In
- (HT : HT_Types.Hash_Table_Type;
+ (HT : Set;
Key : Node_Type) return Boolean;
pragma Inline (Is_In);
procedure Set_Element (Node : in out Node_Type; Item : Element_Type);
pragma Inline (Set_Element);
- function Next_Unchecked
- (Container : Set;
- Position : Cursor) return Cursor;
-
function Next (Node : Node_Type) return Count_Type;
pragma Inline (Next);
declare
Node : Count_Type := First (Left).Node;
ENode : Count_Type;
- Last : Count_Type;
begin
- if Left.K = Plain then
- Last := 0;
- else
- Last := HT_Ops.Next (Left.HT.all, Left.Last);
- end if;
-
- while Node /= Last loop
+ while Node /= 0 loop
ENode := Find (Container => Right,
- Item => Left.HT.Nodes (Node).Element).Node;
+ Item => Left.Nodes (Node).Element).Node;
if ENode = 0 or else
- Right.HT.Nodes (ENode).Element /= Left.HT.Nodes (Node).Element
+ Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
then
return False;
end if;
- Node := HT_Ops.Next (Left.HT.all, Node);
+ Node := HT_Ops.Next (Left, Node);
end loop;
return True;
--------------------
procedure Insert_Element (Source_Node : Count_Type) is
- N : Node_Type renames Source.HT.Nodes (Source_Node);
+ N : Node_Type renames Source.Nodes (Source_Node);
X : Count_Type;
B : Boolean;
begin
- Insert (Target.HT.all, N.Element, X, B);
+ Insert (Target, N.Element, X, B);
pragma Assert (B);
end Insert_Element;
-- Start of processing for Assign
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Target'Address = Source'Address then
return;
raise Storage_Error with "not enough capacity"; -- SE or CE? ???
end if;
- HT_Ops.Clear (Target.HT.all);
-
- case Source.K is
- when Plain =>
- Insert_Elements (Source.HT.all);
- when Part =>
- declare
- N : Count_Type := Source.First;
- begin
- while N /= HT_Ops.Next (Source.HT.all, Source.Last) loop
- Insert_Element (N);
- N := HT_Ops.Next (Source.HT.all, N);
- end loop;
- end;
- end case;
+ HT_Ops.Clear (Target);
+ Insert_Elements (Source);
end Assign;
--------------
function Capacity (Container : Set) return Count_Type is
begin
- return Container.HT.Nodes'Length;
+ return Container.Nodes'Length;
end Capacity;
-----------
procedure Clear (Container : in out Set) is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- HT_Ops.Clear (Container.HT.all);
+ HT_Ops.Clear (Container);
end Clear;
--------------
Target : Set (C, Source.Modulus);
Cu : Cursor;
begin
- if (Source.K = Part and Source.Length = 0) or
- Source.HT.Length = 0 then
- return Target;
- end if;
- Target.HT.Length := Source.HT.Length;
- Target.HT.Free := Source.HT.Free;
+ Target.Length := Source.Length;
+ Target.Free := Source.Free;
while H <= Source.Modulus loop
- Target.HT.Buckets (H) := Source.HT.Buckets (H);
+ Target.Buckets (H) := Source.Buckets (H);
H := H + 1;
end loop;
while N <= Source.Capacity loop
- Target.HT.Nodes (N) := Source.HT.Nodes (N);
+ Target.Nodes (N) := Source.Nodes (N);
N := N + 1;
end loop;
while N <= C loop
Cu := (Node => N);
- Free (Target.HT.all, Cu.Node);
+ Free (Target, Cu.Node);
N := N + 1;
end loop;
- if Source.K = Part then
- N := HT_Ops.First (Target.HT.all);
- while N /= Source.First loop
- Cu := (Node => N);
- N := HT_Ops.Next (Target.HT.all, N);
- Delete (Target, Cu);
- end loop;
- N := HT_Ops.Next (Target.HT.all, Source.Last);
- while N /= 0 loop
- Cu := (Node => N);
- N := HT_Ops.Next (Target.HT.all, N);
- Delete (Target, Cu);
- end loop;
- end if;
return Target;
end Copy;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- Element_Keys.Delete_Key_Sans_Free (Container.HT.all, Item, X);
+ 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.HT.all, X);
+ Free (Container, X);
end Delete;
procedure Delete
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Container.HT.Busy > 0 then
+ if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
pragma Assert (Vet (Container, Position), "bad cursor in Delete");
- HT_Ops.Delete_Node_Sans_Free (Container.HT.all, Position.Node);
- Free (Container.HT.all, Position.Node);
+ HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ Free (Container, Position.Node);
Position := No_Element;
end Delete;
is
Tgt_Node, Src_Node, Src_Last, Src_Length : Count_Type;
- TN : Nodes_Type renames Target.HT.Nodes;
- SN : Nodes_Type renames Source.HT.Nodes;
+ TN : Nodes_Type renames Target.Nodes;
+ SN : Nodes_Type renames Source.Nodes;
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Target'Address = Source'Address then
Clear (Target);
return;
end if;
- case Source.K is
- when Plain =>
- Src_Length := Source.HT.Length;
- when Part =>
- Src_Length := Source.Length;
- end case;
+ Src_Length := Source.Length;
if Src_Length = 0 then
return;
end if;
- if Target.HT.Busy > 0 then
+ if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
- case Source.K is
- when Plain =>
- if Src_Length >= Target.HT.Length then
- Tgt_Node := HT_Ops.First (Target.HT.all);
- while Tgt_Node /= 0 loop
- if Element_Keys.Find (Source.HT.all,
- TN (Tgt_Node).Element) /= 0 then
- declare
- X : constant Count_Type := Tgt_Node;
- begin
- Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target.HT.all, X);
- Free (Target.HT.all, X);
- end;
- else
- Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node);
- end if;
- end loop;
- 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
+ declare
+ X : constant Count_Type := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target, X);
+ Free (Target, X);
+ end;
else
- Src_Node := HT_Ops.First (Source.HT.all);
- Src_Last := 0;
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
end if;
- when Part =>
- Src_Node := Source.First;
- Src_Last := HT_Ops.Next (Source.HT.all, Source.Last);
- end case;
+ end loop;
+ return;
+ else
+ Src_Node := HT_Ops.First (Source);
+ Src_Last := 0;
+ end if;
+
while Src_Node /= Src_Last loop
Tgt_Node := Element_Keys.Find
- (Target.HT.all, SN (Src_Node).Element);
+ (Target, SN (Src_Node).Element);
if Tgt_Node /= 0 then
- HT_Ops.Delete_Node_Sans_Free (Target.HT.all, Tgt_Node);
- Free (Target.HT.all, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node);
+ Free (Target, Tgt_Node);
end if;
- Src_Node := HT_Ops.Next (Source.HT.all, Src_Node);
+ Src_Node := HT_Ops.Next (Source, Src_Node);
end loop;
end Difference;
procedure Difference
(Left, Right : Set;
- Target : in out Hash_Table_Type)
+ Target : in out Set)
is
procedure Process (L_Node : Count_Type);
-------------
procedure Process (L_Node : Count_Type) is
- E : Element_Type renames Left.HT.Nodes (L_Node).Element;
+ E : Element_Type renames Left.Nodes (L_Node).Element;
X : Count_Type;
B : Boolean;
-- Start of processing for Difference
begin
- if Left.K = Plain then
- Iterate (Left.HT.all);
- else
-
- if Left.Length = 0 then
- return;
- end if;
-
- declare
- Node : Count_Type := Left.First;
- begin
- while Node /= Left.HT.Nodes (Left.Last).Next loop
- Process (Node);
- Node := HT_Ops.Next (Left.HT.all, Node);
- end loop;
- end;
- end if;
+ Iterate (Left);
end Difference;
function Difference (Left, Right : Set) return Set is
C : Count_Type;
H : Hash_Type;
- S : Set (C, H);
begin
if Left'Address = Right'Address then
return Empty_Set;
C := Length (Left);
H := Default_Modulus (C);
- Difference (Left, Right, Target => S.HT.all);
- return S;
+ return S : Set (C, H) do
+ Difference (Left, Right, Target => S);
+ end return;
end Difference;
-------------
pragma Assert (Vet (Container, Position),
"bad cursor in function Element");
- declare
- HT : Hash_Table_Type renames Container.HT.all;
- begin
- return HT.Nodes (Position.Node).Element;
- end;
+ return Container.Nodes (Position.Node).Element;
end Element;
---------------------
---------------------
function Equivalent_Sets (Left, Right : Set) return Boolean is
- begin
- if Left.K = Plain and Right.K = Plain then
- declare
-
- function Find_Equivalent_Key
- (R_HT : Hash_Table_Type'Class;
- L_Node : Node_Type) return Boolean;
- pragma Inline (Find_Equivalent_Key);
-
- function Is_Equivalent is
- new HT_Ops.Generic_Equal (Find_Equivalent_Key);
-
- -------------------------
- -- Find_Equivalent_Key --
- -------------------------
-
- function Find_Equivalent_Key
- (R_HT : Hash_Table_Type'Class;
- L_Node : Node_Type) return Boolean
- is
- R_Index : constant Hash_Type :=
- 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
- loop
- if R_Node = 0 then
- return False;
- end if;
-
- if Equivalent_Elements (L_Node.Element,
- RN (R_Node).Element) then
- return True;
- end if;
-
- R_Node := HT_Ops.Next (R_HT, R_Node);
- end loop;
- end Find_Equivalent_Key;
-
- -- Start of processing of Equivalent_Sets
-
- begin
- return Is_Equivalent (Left.HT.all, Right.HT.all);
- end;
- else
- declare
- function Equal_Between
- (L : Hash_Table_Type; R : Set;
- From : Count_Type; To : Count_Type) return Boolean;
+ function Find_Equivalent_Key
+ (R_HT : Hash_Table_Type'Class;
+ L_Node : Node_Type) return Boolean;
+ pragma Inline (Find_Equivalent_Key);
- -- To and From are valid and Length are equal
- function Equal_Between
- (L : Hash_Table_Type; R : Set;
- From : Count_Type; To : Count_Type) return Boolean
- is
- L_Index : Hash_Type;
- To_Index : constant Hash_Type :=
- Element_Keys.Index (L, L.Nodes (To).Element);
- L_Node : Count_Type := From;
+ function Is_Equivalent is
+ new HT_Ops.Generic_Equal (Find_Equivalent_Key);
- begin
-
- L_Index := Element_Keys.Index (L, L.Nodes (From).Element);
-
- -- For each node of hash table L, search for an equivalent
- -- node in hash table R.
-
- while L_Index /= To_Index or else
- L_Node /= HT_Ops.Next (L, To) loop
- pragma Assert (L_Node /= 0);
+ -------------------------
+ -- Find_Equivalent_Key --
+ -------------------------
- if Find (R, L.Nodes (L_Node).Element).Node = 0 then
- return False;
- end if;
+ function Find_Equivalent_Key
+ (R_HT : Hash_Table_Type'Class;
+ L_Node : Node_Type) return Boolean
+ is
+ R_Index : constant Hash_Type :=
+ Element_Keys.Index (R_HT, L_Node.Element);
- L_Node := L.Nodes (L_Node).Next;
+ R_Node : Count_Type := R_HT.Buckets (R_Index);
- if L_Node = 0 then
- -- We have exhausted the nodes in this bucket
- -- Find the next bucket
+ RN : Nodes_Type renames R_HT.Nodes;
- loop
- L_Index := L_Index + 1;
- L_Node := L.Buckets (L_Index);
- exit when L_Node /= 0;
- end loop;
- end if;
- end loop;
-
- return True;
- end Equal_Between;
-
- begin
- if Length (Left) /= Length (Right) then
+ begin
+ loop
+ if R_Node = 0 then
return False;
end if;
- if Length (Left) = 0 then
+
+ if Equivalent_Elements (L_Node.Element,
+ RN (R_Node).Element) then
return True;
end if;
- if Left.K = Part then
- return Equal_Between (Left.HT.all, Right,
- Left.First, Left.Last);
- else
- return Equal_Between (Right.HT.all, Left,
- Right.First, Right.Last);
- end if;
- end;
- end if;
+
+ R_Node := HT_Ops.Next (R_HT, R_Node);
+ end loop;
+ end Find_Equivalent_Key;
+
+ -- Start of processing of Equivalent_Sets
+
+ begin
+ return Is_Equivalent (Left, Right);
end Equivalent_Sets;
-------------------------
"bad Right cursor in Equivalent_Elements");
declare
- LN : Node_Type renames Left.HT.Nodes (CLeft.Node);
- RN : Node_Type renames Right.HT.Nodes (CRight.Node);
+ LN : Node_Type renames Left.Nodes (CLeft.Node);
+ RN : Node_Type renames Right.Nodes (CRight.Node);
begin
return Equivalent_Elements (LN.Element, RN.Element);
end;
"Left cursor in Equivalent_Elements is bad");
declare
- LN : Node_Type renames Left.HT.Nodes (CLeft.Node);
+ LN : Node_Type renames Left.Nodes (CLeft.Node);
begin
return Equivalent_Elements (LN.Element, Right);
end;
"Right cursor of Equivalent_Elements is bad");
declare
- RN : Node_Type renames Right.HT.Nodes (CRight.Node);
+ RN : Node_Type renames Right.Nodes (CRight.Node);
begin
return Equivalent_Elements (Left, RN.Element);
end;
is
X : Count_Type;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
- Element_Keys.Delete_Key_Sans_Free (Container.HT.all, Item, X);
- Free (Container.HT.all, X);
+ Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
+ Free (Container, X);
end Exclude;
----------
(Container : Set;
Item : Element_Type) return Cursor
is
- begin
- case Container.K is
- when Plain =>
- declare
- Node : constant Count_Type :=
- Element_Keys.Find (Container.HT.all, Item);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
- return (Node => Node);
- end;
- when Part =>
- declare
- function Find_Between
- (HT : Hash_Table_Type;
- Key : Element_Type;
- From : Count_Type;
- To : Count_Type) return Count_Type;
-
- function Find_Between
- (HT : Hash_Table_Type;
- Key : Element_Type;
- From : Count_Type;
- To : Count_Type) return Count_Type is
-
- Indx : Hash_Type;
- Indx_From : constant Hash_Type :=
- Element_Keys.Index (HT,
- HT.Nodes (From).Element);
- Indx_To : constant Hash_Type :=
- Element_Keys.Index (HT,
- HT.Nodes (To).Element);
- Node : Count_Type;
- To_Node : Count_Type;
-
- begin
-
- Indx := Element_Keys.Index (HT, Key);
-
- if Indx < Indx_From or Indx > Indx_To then
- return 0;
- end if;
-
- if Indx = Indx_From then
- Node := From;
- else
- Node := HT.Buckets (Indx);
- end if;
-
- if Indx = Indx_To then
- To_Node := HT.Nodes (To).Next;
- else
- To_Node := 0;
- end if;
-
- while Node /= To_Node loop
- if Equivalent_Keys (Key, HT.Nodes (Node)) then
- return Node;
- end if;
- Node := HT.Nodes (Node).Next;
- end loop;
- return 0;
- end Find_Between;
- begin
+ Node : constant Count_Type :=
+ Element_Keys.Find (Container, Item);
- if Container.Length = 0 then
- return No_Element;
- end if;
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+ return (Node => Node);
- return (Node => Find_Between (Container.HT.all, Item,
- Container.First, Container.Last));
- end;
- end case;
end Find;
-----------
-----------
function First (Container : Set) return Cursor is
+ Node : constant Count_Type := HT_Ops.First (Container);
begin
- case Container.K is
- when Plain =>
- declare
- Node : constant Count_Type := HT_Ops.First (Container.HT.all);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
- when Part =>
- declare
- Node : constant Count_Type := Container.First;
+ if Node = 0 then
+ return No_Element;
+ end if;
- begin
- if Node = 0 then
- return No_Element;
- end if;
+ return (Node => Node);
- return (Node => Node);
- end;
- end case;
end First;
----------
----------
procedure Free
- (HT : in out Hash_Table_Type;
+ (HT : in out Set;
X : Count_Type)
is
begin
----------------------
procedure Generic_Allocate
- (HT : in out Hash_Table_Type;
+ (HT : in out Set;
Node : out Count_Type)
is
function Has_Element (Container : Set; Position : Cursor) return Boolean is
begin
if Position.Node = 0 or else
- not Container.HT.Nodes (Position.Node).Has_Element then
+ not Container.Nodes (Position.Node).Has_Element then
return False;
end if;
-
- if Container.K = Plain then
- return True;
- end if;
-
- declare
- Lst_Index : constant Hash_Type :=
- Element_Keys.Index (Container.HT.all,
- Container.HT.Nodes
- (Container.Last).Element);
- Fst_Index : constant Hash_Type :=
- Element_Keys.Index (Container.HT.all,
- Container.HT.Nodes
- (Container.First).Element);
- Index : constant Hash_Type :=
- Element_Keys.Index (Container.HT.all,
- Container.HT.Nodes
- (Position.Node).Element);
- Lst_Node : Count_Type;
- Node : Count_Type;
- begin
-
- if Index < Fst_Index or Index > Lst_Index then
- return False;
- end if;
-
- if Index > Fst_Index and Index < Lst_Index then
- return True;
- end if;
-
- if Index = Fst_Index then
- Node := Container.First;
- else
- Node := Container.HT.Buckets (Index);
- end if;
-
- if Index = Lst_Index then
- Lst_Node := Container.HT.Nodes (Container.Last).Next;
- else
- Lst_Node := 0;
- end if;
-
- while Node /= Lst_Node loop
- if Position.Node = Node then
- return True;
- end if;
- Node := HT_Ops.Next (Container.HT.all, Node);
- end loop;
-
- return False;
- end;
+ return True;
end Has_Element;
---------------
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- if Container.HT.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
- Container.HT.Nodes (Position.Node).Element := New_Item;
+ Container.Nodes (Position.Node).Element := New_Item;
end if;
end Include;
Inserted : out Boolean)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- Insert (Container.HT.all, New_Item, Position.Node, Inserted);
+ Insert (Container, New_Item, Position.Node, Inserted);
end Insert;
procedure Insert
end Insert;
procedure Insert
- (Container : in out Hash_Table_Type;
+ (Container : in out Set;
New_Item : Element_Type;
Node : out Count_Type;
Inserted : out Boolean)
Source : Set)
is
Tgt_Node : Count_Type;
- TN : Nodes_Type renames Target.HT.Nodes;
+ TN : Nodes_Type renames Target.Nodes;
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Target'Address = Source'Address then
return;
end if;
- if Source.HT.Length = 0 then
+ if Source.Length = 0 then
Clear (Target);
return;
end if;
- if Target.HT.Busy > 0 then
+ if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
- Tgt_Node := HT_Ops.First (Target.HT.all);
+ Tgt_Node := HT_Ops.First (Target);
while Tgt_Node /= 0 loop
if Find (Source, TN (Tgt_Node).Element).Node /= 0 then
- Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node);
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
else
declare
X : constant Count_Type := Tgt_Node;
begin
- Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target.HT.all, X);
- Free (Target.HT.all, X);
+ Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target, X);
+ Free (Target, X);
end;
end if;
end loop;
end Intersection;
procedure Intersection
- (Left : Hash_Table_Type;
+ (Left : Set;
Right : Set;
- Target : in out Hash_Table_Type)
+ Target : in out Set)
is
procedure Process (L_Node : Count_Type);
function Intersection (Left, Right : Set) return Set is
C : Count_Type;
H : Hash_Type;
- X : Count_Type;
- B : Boolean;
begin
if Left'Address = Right'Address then
H := Default_Modulus (C);
return S : Set (C, H) do
if Length (Left) /= 0 and Length (Right) /= 0 then
- if Left.K = Plain then
- Intersection (Left.HT.all, Right, Target => S.HT.all);
- else
- C := Left.First;
- while C /= Left.HT.Nodes (Left.Last).Next loop
- pragma Assert (C /= 0);
- if Find (Right, Left.HT.Nodes (C).Element).Node /= 0 then
- Insert (S.HT.all, Left.HT.Nodes (C).Element, X, B);
- pragma Assert (B);
- end if;
- C := Left.HT.Nodes (C).Next;
- end loop;
- end if;
+ Intersection (Left, Right, Target => S);
end if;
end return;
end Intersection;
-- Is_In --
-----------
- function Is_In (HT : HT_Types.Hash_Table_Type;
+ function Is_In (HT : Set;
Key : Node_Type) return Boolean is
begin
return Element_Keys.Find (HT, Key.Element) /= 0;
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
Subset_Node : Count_Type;
- Subset_Nodes : Nodes_Type renames Subset.HT.Nodes;
- To_Node : Count_Type;
+ Subset_Nodes : Nodes_Type renames Subset.Nodes;
begin
if Subset'Address = Of_Set'Address then
return True;
Subset_Node := First (Subset).Node;
- if Subset.K = Plain then
- To_Node := 0;
- else
- To_Node := Subset.HT.Nodes (Subset.Last).Next;
- end if;
-
- while Subset_Node /= To_Node loop
+ while Subset_Node /= 0 loop
declare
N : Node_Type renames Subset_Nodes (Subset_Node);
E : Element_Type renames N.Element;
end if;
end;
- Subset_Node := HT_Ops.Next (Subset.HT.all, Subset_Node);
+ Subset_Node := HT_Ops.Next (Subset, Subset_Node);
end loop;
return True;
Process (Container, (Node => Node));
end Process_Node;
- B : Natural renames Container'Unrestricted_Access.HT.Busy;
+ B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Iterate
B := B + 1;
begin
- case Container.K is
- when Plain =>
- Iterate (Container.HT.all);
- when Part =>
-
- if Container.Length = 0 then
- return;
- end if;
-
- declare
- Node : Count_Type := Container.First;
- begin
- while Node /= Container.HT.Nodes (Container.Last).Next loop
- Process_Node (Node);
- Node := HT_Ops.Next (Container.HT.all, Node);
- end loop;
- end;
- end case;
+ Iterate (Container);
exception
when others =>
B := B - 1;
----------
function Left (Container : Set; Position : Cursor) return Set is
- Lst : Count_Type;
- Fst : constant Count_Type := First (Container).Node;
- L : Count_Type := 0;
- C : Count_Type := Fst;
+ Curs : Cursor := Position;
+ C : Set (Container.Capacity, Container.Modulus) :=
+ Copy (Container, Container.Capacity);
+ Node : Count_Type;
begin
- while C /= Position.Node loop
- if C = 0 or C = Container.Last then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
- Lst := C;
- C := HT_Ops.Next (Container.HT.all, C);
- L := L + 1;
- end loop;
- if L = 0 then
- return (Capacity => Container.Capacity,
- Modulus => Container.Modulus,
- K => Part,
- HT => Container.HT,
- Length => 0,
- First => 0,
- Last => 0);
- else
- return (Capacity => Container.Capacity,
- Modulus => Container.Modulus,
- K => Part,
- HT => Container.HT,
- Length => L,
- First => Fst,
- Last => Lst);
+ if Curs = No_Element then
+ return C;
+ end if;
+ if not Has_Element (Container, Curs) then
+ raise Constraint_Error;
end if;
+
+ while Curs.Node /= 0 loop
+ Node := Curs.Node;
+ Delete (C, Curs);
+ Curs := Next (Container, (Node => Node));
+ end loop;
+ return C;
end Left;
------------
function Length (Container : Set) return Count_Type is
begin
- case Container.K is
- when Plain =>
- return Container.HT.Length;
- when Part =>
- return Container.Length;
- end case;
+ return Container.Length;
end Length;
----------
----------
procedure Move (Target : in out Set; Source : in out Set) is
- HT : HT_Types.Hash_Table_Type renames Source.HT.all;
- NN : HT_Types.Nodes_Type renames HT.Nodes;
+ NN : HT_Types.Nodes_Type renames Source.Nodes;
X, Y : Count_Type;
begin
- if Target.K /= Plain or Source.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Target'Address = Source'Address then
return;
end if;
"Source length exceeds Target capacity";
end if;
- if HT.Busy > 0 then
+ if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)";
end if;
Clear (Target);
- if HT.Length = 0 then
+ if Source.Length = 0 then
return;
end if;
- X := HT_Ops.First (HT);
+ X := HT_Ops.First (Source);
while X /= 0 loop
Insert (Target, NN (X).Element); -- optimize???
- Y := HT_Ops.Next (HT, X);
+ Y := HT_Ops.Next (Source, X);
- HT_Ops.Delete_Node_Sans_Free (HT, X);
- Free (HT, X);
+ HT_Ops.Delete_Node_Sans_Free (Source, X);
+ Free (Source, X);
X := Y;
end loop;
return Node.Next;
end Next;
- function Next_Unchecked
- (Container : Set;
- Position : Cursor) return Cursor
- is
- HT : Hash_Table_Type renames Container.HT.all;
- Node : constant Count_Type := HT_Ops.Next (HT, Position.Node);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- if Container.K = Part and then Container.Last = Position.Node then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Next_Unchecked;
-
function Next (Container : Set; Position : Cursor) return Cursor is
begin
if Position.Node = 0 then
pragma Assert (Vet (Container, Position), "bad cursor in Next");
- return Next_Unchecked (Container, Position);
+ return (Node => HT_Ops.Next (Container, Position.Node));
end Next;
procedure Next (Container : Set; Position : in out Cursor) is
function Overlap (Left, Right : Set) return Boolean is
Left_Node : Count_Type;
- Left_Nodes : Nodes_Type renames Left.HT.Nodes;
- To_Node : Count_Type;
+ Left_Nodes : Nodes_Type renames Left.Nodes;
begin
if Length (Right) = 0 or Length (Left) = 0 then
return False;
Left_Node := First (Left).Node;
- if Left.K = Plain then
- To_Node := 0;
- else
- To_Node := Left.HT.Nodes (Left.Last).Next;
- end if;
-
- while Left_Node /= To_Node loop
+ while Left_Node /= 0 loop
declare
N : Node_Type renames Left_Nodes (Left_Node);
E : Element_Type renames N.Element;
end if;
end;
- Left_Node := HT_Ops.Next (Left.HT.all, Left_Node);
+ Left_Node := HT_Ops.Next (Left, Left_Node);
end loop;
return False;
Process : not null access procedure (Element : Element_Type))
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
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
- HT : Hash_Table_Type renames Container.HT.all;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
begin
- Process (HT.Nodes (Position.Node).Element);
+ Process (Container.Nodes (Position.Node).Element);
exception
when others =>
L := L - 1;
-- Start of processing for Read_Node
begin
- Allocate (Container.HT.all, Node);
+ Allocate (Container, Node);
return Node;
end Read_Node;
-- Start of processing for Read
- Result : HT_Access;
begin
- if Container.K /= Plain then
- raise Constraint_Error;
- end if;
- if Container.HT = null then
- Result := new HT_Types.Hash_Table_Type (Container.Capacity,
- Container.Modulus);
- else
- Result := Container.HT;
- end if;
-
- Read_Nodes (Stream, Result.all);
- Container.HT := Result;
+ Read_Nodes (Stream, Container);
end Read;
procedure Read
New_Item : Element_Type)
is
Node : constant Count_Type :=
- Element_Keys.Find (Container.HT.all, New_Item);
+ Element_Keys.Find (Container, New_Item);
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Node = 0 then
raise Constraint_Error with
"attempt to replace element not in set";
end if;
- if Container.HT.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
- Container.HT.Nodes (Node).Element := New_Item;
+ Container.Nodes (Node).Element := New_Item;
end Replace;
---------------------
New_Item : Element_Type)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with
pragma Assert (Vet (Container, Position),
"bad cursor in Replace_Element");
- Replace_Element (Container.HT.all, Position.Node, New_Item);
+ Replace_Element (Container, Position.Node, New_Item);
end Replace_Element;
----------------------
Capacity : Count_Type)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Capacity > Container.Capacity then
raise Constraint_Error with "requested capacity is too large";
end if;
-----------
function Right (Container : Set; Position : Cursor) return Set is
- Last : Count_Type;
- Lst : Count_Type;
- L : Count_Type := 0;
- C : Count_Type := Position.Node;
+ Curs : Cursor := First (Container);
+ C : Set (Container.Capacity, Container.Modulus) :=
+ Copy (Container, Container.Capacity);
+ Node : Count_Type;
begin
-
- if C = 0 then
- return (Capacity => Container.Capacity,
- Modulus => Container.Modulus,
- K => Part,
- HT => Container.HT,
- Length => 0,
- First => 0,
- Last => 0);
- end if;
-
- if Container.K = Plain then
- Lst := 0;
- else
- Lst := HT_Ops.Next (Container.HT.all, Container.Last);
+ if Curs = No_Element then
+ Clear (C);
+ return C;
end if;
-
- if C = Lst then
- raise Constraint_Error with
- "Position cursor has no element";
+ if Position /= No_Element and not Has_Element (Container, Position) then
+ raise Constraint_Error;
end if;
- while C /= Lst loop
- if C = 0 then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
- Last := C;
- C := HT_Ops.Next (Container.HT.all, C);
- L := L + 1;
+ while Curs.Node /= Position.Node loop
+ Node := Curs.Node;
+ Delete (C, Curs);
+ Curs := Next (Container, (Node => Node));
end loop;
-
- return (Capacity => Container.Capacity,
- Modulus => Container.Modulus,
- K => Part,
- HT => Container.HT,
- Length => L,
- First => Position.Node,
- Last => Last);
+ return C;
end Right;
------------------
while CuL.Node /= 0 or CuR.Node /= 0 loop
if CuL.Node /= CuR.Node or else
- Left.HT.Nodes (CuL.Node).Element /=
- Right.HT.Nodes (CuR.Node).Element then
+ Left.Nodes (CuL.Node).Element /=
+ Right.Nodes (CuR.Node).Element then
return False;
end if;
- CuL := Next_Unchecked (Left, CuL);
- CuR := Next_Unchecked (Right, CuR);
+ CuL := Next (Left, CuL);
+ CuR := Next (Right, CuR);
end loop;
return True;
-------------
procedure Process (Source_Node : Count_Type) is
- N : Node_Type renames Source.HT.Nodes (Source_Node);
+ N : Node_Type renames Source.Nodes (Source_Node);
X : Count_Type;
B : Boolean;
begin
- if Is_In (Target.HT.all, N) then
+ if Is_In (Target, N) then
Delete (Target, N.Element);
else
- Insert (Target.HT.all, N.Element, X, B);
+ Insert (Target, N.Element, X, B);
pragma Assert (B);
end if;
end Process;
-- Start of processing for Symmetric_Difference
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Target'Address = Source'Address then
Clear (Target);
return;
end if;
- if Target.HT.Busy > 0 then
+ if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
-
- if Source.K = Plain then
- Iterate (Source.HT.all);
- else
-
- if Source.Length = 0 then
- return;
- end if;
-
- declare
- Node : Count_Type := Source.First;
- begin
- while Node /= Source.HT.Nodes (Source.Last).Next loop
- Process (Node);
- Node := HT_Ops.Next (Source.HT.all, Node);
- end loop;
- end;
- end if;
+ Iterate (Source);
end Symmetric_Difference;
C := Length (Left) + Length (Right);
H := Default_Modulus (C);
return S : Set (C, H) do
- Difference (Left, Right, S.HT.all);
- Difference (Right, Left, S.HT.all);
+ Difference (Left, Right, S);
+ Difference (Right, Left, S);
end return;
end Symmetric_Difference;
begin
return S : Set (Capacity => 1, Modulus => 1) do
- Insert (S.HT.all, New_Item, X, B);
+ Insert (S, New_Item, X, B);
pragma Assert (B);
end return;
end To_Set;
-------------
procedure Process (Src_Node : Count_Type) is
- N : Node_Type renames Source.HT.Nodes (Src_Node);
+ N : Node_Type renames Source.Nodes (Src_Node);
E : Element_Type renames N.Element;
X : Count_Type;
B : Boolean;
begin
- Insert (Target.HT.all, E, X, B);
+ Insert (Target, E, X, B);
end Process;
-- Start of processing for Union
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Target'Address = Source'Address then
return;
end if;
- if Target.HT.Busy > 0 then
+ if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
-
- if Source.K = Plain then
- Iterate (Source.HT.all);
- else
-
- if Source.Length = 0 then
- return;
- end if;
-
- declare
- Node : Count_Type := Source.First;
- begin
- while Node /= Source.HT.Nodes (Source.Last).Next loop
- Process (Node);
- Node := HT_Ops.Next (Source.HT.all, Node);
- end loop;
- end;
- end if;
+ Iterate (Source);
end Union;
function Union (Left, Right : Set) return Set is
declare
S : Set renames Container;
- N : Nodes_Type renames S.HT.Nodes;
+ N : Nodes_Type renames S.Nodes;
X : Count_Type;
begin
return False;
end if;
- X := S.HT.Buckets (Element_Keys.Index (S.HT.all,
+ X := S.Buckets (Element_Keys.Index (S,
N (Position.Node).Element));
for J in 1 .. S.Length loop
-- Start of processing for Write
begin
- Write_Nodes (Stream, Container.HT.all);
+ Write_Nodes (Stream, Container);
end Write;
procedure Write
X : Count_Type;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
- Key_Keys.Delete_Key_Sans_Free (Container.HT.all, Key, X);
+ Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
if X = 0 then
raise Constraint_Error with "attempt to delete key not in set";
end if;
- Free (Container.HT.all, X);
+ Free (Container, X);
end Delete;
-------------
raise Constraint_Error with "key not in map";
end if;
- return Container.HT.Nodes (Node).Element;
+ return Container.Nodes (Node).Element;
end Element;
-------------------------
is
X : Count_Type;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
- Key_Keys.Delete_Key_Sans_Free (Container.HT.all, Key, X);
- Free (Container.HT.all, X);
+ Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
+ Free (Container, X);
end Exclude;
----------
(Container : Set;
Key : Key_Type) return Cursor
is
- begin
- if Container.K = Plain then
- declare
- Node : constant Count_Type :=
- Key_Keys.Find (Container.HT.all, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
- else
- declare
- function Find_Between
- (HT : Hash_Table_Type;
- Key : Key_Type;
- From : Count_Type;
- To : Count_Type) return Count_Type;
-
- function Find_Between
- (HT : Hash_Table_Type;
- Key : Key_Type;
- From : Count_Type;
- To : Count_Type) return Count_Type is
-
- Indx : Hash_Type;
- Indx_From : constant Hash_Type :=
- Key_Keys.Index (HT, Generic_Keys.Key
- (HT.Nodes (From).Element));
- Indx_To : constant Hash_Type :=
- Key_Keys.Index (HT, Generic_Keys.Key
- (HT.Nodes (To).Element));
- Node : Count_Type;
- To_Node : Count_Type;
-
- begin
-
- Indx := Key_Keys.Index (HT, Key);
-
- if Indx < Indx_From or Indx > Indx_To then
- return 0;
- end if;
-
- if Indx = Indx_From then
- Node := From;
- else
- Node := HT.Buckets (Indx);
- end if;
-
- if Indx = Indx_To then
- To_Node := HT.Nodes (To).Next;
- else
- To_Node := 0;
- end if;
-
- while Node /= To_Node loop
- if Equivalent_Key_Node (Key, HT.Nodes (Node)) then
- return Node;
- end if;
- Node := HT.Nodes (Node).Next;
- end loop;
+ Node : constant Count_Type :=
+ Key_Keys.Find (Container, Key);
- return 0;
- end Find_Between;
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
- begin
- if Container.Length = 0 then
- return No_Element;
- end if;
+ return (Node => Node);
- return (Node => Find_Between (Container.HT.all, Key,
- Container.First, Container.Last));
- end;
- end if;
end Find;
---------
"bad cursor in function Key");
declare
- HT : Hash_Table_Type renames Container.HT.all;
- N : Node_Type renames HT.Nodes (Position.Node);
+ N : Node_Type renames Container.Nodes (Position.Node);
begin
return Key (N.Element);
end;
Key : Key_Type;
New_Item : Element_Type)
is
+ Node : constant Count_Type :=
+ Key_Keys.Find (Container, Key);
+
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
+ if Node = 0 then
+ raise Constraint_Error with
+ "attempt to replace key not in set";
end if;
- declare
- Node : constant Count_Type :=
- Key_Keys.Find (Container.HT.all, Key);
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "attempt to replace key not in set";
- end if;
-
- Replace_Element (Container.HT.all, Node, New_Item);
- end;
+ Replace_Element (Container, Node, New_Item);
end Replace;
-----------------------------------
procedure (Element : in out Element_Type))
is
Indx : Hash_Type;
- N : Nodes_Type renames Container.HT.Nodes;
+ N : Nodes_Type renames Container.Nodes;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Position.Node = 0 then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
- -- ???
- -- if HT.Buckets = null
- -- or else HT.Buckets'Length = 0
- -- or else HT.Length = 0
- -- or else Position.Node.Next = Position.Node
- -- then
- -- raise Program_Error with
- -- "Position cursor is bad (set is empty)";
- -- end if;
-
pragma Assert
(Vet (Container, Position),
"bad cursor in Update_Element_Preserving_Key");
-- Record bucket now, in case key is changed.
- Indx := HT_Ops.Index (Container.HT.Buckets, N (Position.Node));
+ 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.HT.Busy;
- L : Natural renames Container.HT.Lock;
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
B := B + 1;
-- Key was modified, so remove this node from set.
- if Container.HT.Buckets (Indx) = Position.Node then
- Container.HT.Buckets (Indx) := N (Position.Node).Next;
+ if Container.Buckets (Indx) = Position.Node then
+ Container.Buckets (Indx) := N (Position.Node).Next;
else
declare
- Prev : Count_Type := Container.HT.Buckets (Indx);
+ Prev : Count_Type := Container.Buckets (Indx);
begin
while N (Prev).Next /= Position.Node loop
end if;
Container.Length := Container.Length - 1;
- Free (Container.HT.all, Position.Node);
+ Free (Container, Position.Node);
raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package HT_Types is new
Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type);
- type HT_Access is access all HT_Types.Hash_Table_Type;
-
- type Kind is (Plain, Part);
-
- type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged record
- HT : HT_Access :=
- new HT_Types.Hash_Table_Type'(Capacity, Modulus,
- others => <>);
- K : Kind := Plain;
- Length : Count_Type := 0;
- First : Count_Type := 0;
- Last : Count_Type := 0;
- end record;
+ type Set (Capacity : Count_Type; Modulus : Hash_Type) is
+ new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
use HT_Types;
use Ada.Streams;
-- --
-- B o d y --
-- --
--- Copyright (C) 2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-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- --
(Tree : in out Tree_Types.Tree_Type'Class;
Node : out Count_Type);
- procedure Free (Tree : in out Tree_Types.Tree_Type; X : Count_Type);
+ procedure Free (Tree : in out Map; X : Count_Type);
function Is_Greater_Key_Node
(Left : Key_Type;
Right : Node_Type) return Boolean;
pragma Inline (Is_Less_Key_Node);
- function Next_Unchecked
- (Container : Map;
- Position : Count_Type) return Count_Type;
-
--------------------------
-- Local Instantiations --
--------------------------
return True;
end if;
- Lst := Next (Left.Tree.all, Last (Left).Node);
+ Lst := Next (Left, Last (Left).Node);
while Node /= Lst loop
- ENode := Find (Right, Left.Tree.Nodes (Node).Key).Node;
+ ENode := Find (Right, Left.Nodes (Node).Key).Node;
if ENode = 0 or else
- Left.Tree.Nodes (Node).Element /= Right.Tree.Nodes (ENode).Element
+ Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
then
return False;
end if;
- Node := Next (Left.Tree.all, Node);
+ Node := Next (Left, Node);
end loop;
return True;
--------------------
procedure Append_Element (Source_Node : Count_Type) is
- SN : Node_Type renames Source.Tree.Nodes (Source_Node);
+ SN : Node_Type renames Source.Nodes (Source_Node);
procedure Set_Element (Node : in out Node_Type);
pragma Inline (Set_Element);
Result : Count_Type;
begin
- Allocate (Target.Tree.all, Result);
+ Allocate (Target, Result);
return Result;
end New_Node;
begin
Unconditional_Insert_Avec_Hint
- (Tree => Target.Tree.all,
+ (Tree => Target,
Hint => 0,
Key => SN.Key,
Node => Target_Node);
-- Start of processing for Assign
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Target'Address = Source'Address then
return;
raise Storage_Error with "not enough capacity"; -- SE or CE? ???
end if;
- Tree_Operations.Clear_Tree (Target.Tree.all);
-
- if Source.K = Plain then
- Append_Elements (Source.Tree.all);
- else
- declare
- X : Count_Type;
- begin
- X := Source.First;
- while X /= Next (Source.Tree.all, Source.Last) loop
- Append_Element (X);
- X := Next (Source.Tree.all, X);
- end loop;
- end;
- end if;
+ Tree_Operations.Clear_Tree (Target);
+ Append_Elements (Source);
end Assign;
-------------
-------------
function Ceiling (Container : Map; Key : Key_Type) return Cursor is
- begin
- if Container.K = Part then
- if Container.Length = 0 then
- return No_Element;
- end if;
+ Node : constant Count_Type :=
+ Key_Ops.Ceiling (Container, Key);
- if Key < Container.Tree.Nodes (Container.First).Key then
- return (Node => Container.First);
- end if;
-
- if Container.Tree.Nodes (Container.Last).Key < Key then
- return No_Element;
- end if;
+ begin
+ if Node = 0 then
+ return No_Element;
end if;
- declare
- Node : constant Count_Type :=
- Key_Ops.Ceiling (Container.Tree.all, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
+ return (Node => Node);
end Ceiling;
-----------
procedure Clear (Container : in out Map) is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
- Tree_Operations.Clear_Tree (Container.Tree.all);
+ 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;
- Cu : Cursor;
begin
return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do
if Length (Source) > 0 then
- Target.Tree.Length := Source.Tree.Length;
- Target.Tree.Root := Source.Tree.Root;
- Target.Tree.First := Source.Tree.First;
- Target.Tree.Last := Source.Tree.Last;
- Target.Tree.Free := Source.Tree.Free;
+ Target.Length := Source.Length;
+ Target.Root := Source.Root;
+ Target.First := Source.First;
+ Target.Last := Source.Last;
+ Target.Free := Source.Free;
while Node <= Source.Capacity loop
- Target.Tree.Nodes (Node).Element :=
- Source.Tree.Nodes (Node).Element;
- Target.Tree.Nodes (Node).Key :=
- Source.Tree.Nodes (Node).Key;
- Target.Tree.Nodes (Node).Parent :=
- Source.Tree.Nodes (Node).Parent;
- Target.Tree.Nodes (Node).Left :=
- Source.Tree.Nodes (Node).Left;
- Target.Tree.Nodes (Node).Right :=
- Source.Tree.Nodes (Node).Right;
- Target.Tree.Nodes (Node).Color :=
- Source.Tree.Nodes (Node).Color;
- Target.Tree.Nodes (Node).Has_Element :=
- Source.Tree.Nodes (Node).Has_Element;
+ Target.Nodes (Node).Element :=
+ Source.Nodes (Node).Element;
+ Target.Nodes (Node).Key :=
+ Source.Nodes (Node).Key;
+ Target.Nodes (Node).Parent :=
+ Source.Nodes (Node).Parent;
+ Target.Nodes (Node).Left :=
+ Source.Nodes (Node).Left;
+ Target.Nodes (Node).Right :=
+ Source.Nodes (Node).Right;
+ Target.Nodes (Node).Color :=
+ Source.Nodes (Node).Color;
+ Target.Nodes (Node).Has_Element :=
+ Source.Nodes (Node).Has_Element;
Node := Node + 1;
end loop;
while Node <= Target.Capacity loop
N := Node;
- Formal_Ordered_Maps.Free (Tree => Target.Tree.all, X => N);
+ Formal_Ordered_Maps.Free (Tree => Target, X => N);
Node := Node + 1;
end loop;
-
- if Source.K = Part then
- Node := Target.Tree.First;
- while Node /= Source.First loop
- Cu := (Node => Node);
- Node := Next (Target.Tree.all, Node);
- Delete (Target, Cu);
- end loop;
-
- Node := Next (Target.Tree.all, Source.Last);
-
- while Node /= 0 loop
- Cu := (Node => Node);
- Node := Next (Target.Tree.all, Node);
- Delete (Target, Cu);
- end loop;
- end if;
end if;
end return;
end Copy;
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Delete has no element";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"Position cursor of Delete is bad");
- Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all,
+ Tree_Operations.Delete_Node_Sans_Free (Container,
Position.Node);
- Formal_Ordered_Maps.Free (Container.Tree.all, Position.Node);
+ Formal_Ordered_Maps.Free (Container, Position.Node);
end Delete;
procedure Delete (Container : in out Map; Key : Key_Type) is
+
+ X : constant Node_Access := Key_Ops.Find (Container, Key);
+
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
+ if X = 0 then
+ raise Constraint_Error with "key not in map";
end if;
- declare
- X : constant Node_Access := Key_Ops.Find (Container.Tree.all, Key);
-
- begin
- if X = 0 then
- raise Constraint_Error with "key not in map";
- end if;
- Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
- Formal_Ordered_Maps.Free (Container.Tree.all, X);
- end;
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Formal_Ordered_Maps.Free (Container, X);
end Delete;
------------------
X : constant Node_Access := First (Container).Node;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
- Formal_Ordered_Maps.Free (Container.Tree.all, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Formal_Ordered_Maps.Free (Container, X);
end if;
end Delete_First;
X : constant Node_Access := Last (Container).Node;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
- Formal_Ordered_Maps.Free (Container.Tree.all, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Formal_Ordered_Maps.Free (Container, X);
end if;
end Delete_Last;
"Position cursor of function Element has no element";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"Position cursor of function Element is bad");
- return Container.Tree.Nodes (Position.Node).Element;
+ return Container.Nodes (Position.Node).Element;
end Element;
raise Constraint_Error with "key not in map";
end if;
- return Container.Tree.Nodes (Node).Element;
+ return Container.Nodes (Node).Element;
end Element;
---------------------
-------------
procedure Exclude (Container : in out Map; Key : Key_Type) is
- X : constant Node_Access := Key_Ops.Find (Container.Tree.all, Key);
+ X : constant Node_Access := Key_Ops.Find (Container, Key);
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
- Formal_Ordered_Maps.Free (Container.Tree.all, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Formal_Ordered_Maps.Free (Container, X);
end if;
end Exclude;
----------
function Find (Container : Map; Key : Key_Type) return Cursor is
- begin
- if Container.K = Part then
- if Container.Length = 0 then
- return No_Element;
- end if;
- if Key < Container.Tree.Nodes (Container.First).Key or
- Container.Tree.Nodes (Container.Last).Key < Key then
- return No_Element;
- end if;
- end if;
-
- declare
- Node : constant Count_Type :=
- Key_Ops.Find (Container.Tree.all, Key);
+ Node : constant Count_Type :=
+ Key_Ops.Find (Container, Key);
- begin
- if Node = 0 then
- return No_Element;
- end if;
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
- return (Node => Node);
- end;
+ return (Node => Node);
end Find;
-----------
return No_Element;
end if;
- if Container.K = Plain then
- return (Node => Container.Tree.First);
- else
- return (Node => Container.First);
- end if;
+ return (Node => Container.First);
end First;
raise Constraint_Error with "map is empty";
end if;
- return Container.Tree.Nodes (First (Container).Node).Element;
+ return Container.Nodes (First (Container).Node).Element;
end First_Element;
---------------
raise Constraint_Error with "map is empty";
end if;
- return Container.Tree.Nodes (First (Container).Node).Key;
+ return Container.Nodes (First (Container).Node).Key;
end First_Key;
-----------
-----------
function Floor (Container : Map; Key : Key_Type) return Cursor is
- begin
-
- if Container.K = Part then
- if Container.Length = 0 then
- return No_Element;
- end if;
- if Key < Container.Tree.Nodes (Container.First).Key then
- return No_Element;
- end if;
+ Node : constant Count_Type :=
+ Key_Ops.Floor (Container, Key);
- if Container.Tree.Nodes (Container.Last).Key < Key then
- return (Node => Container.Last);
- end if;
+ begin
+ if Node = 0 then
+ return No_Element;
end if;
- declare
- Node : constant Count_Type :=
- Key_Ops.Floor (Container.Tree.all, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
+ return (Node => Node);
end Floor;
----------
----------
procedure Free
- (Tree : in out Tree_Types.Tree_Type;
+ (Tree : in out Map;
X : Count_Type)
is
begin
return False;
end if;
- if not Container.Tree.Nodes (Position.Node).Has_Element then
- return False;
- end if;
-
- if Container.K = Plain then
- return True;
- end if;
-
- declare
- Key : constant Key_Type := Container.Tree.Nodes (Position.Node).Key;
- begin
-
- if Key < Container.Tree.Nodes (Container.First).Key or
- Container.Tree.Nodes (Container.Last).Key < Key then
- return False;
- end if;
-
- return True;
- end;
+ return Container.Nodes (Position.Node).Has_Element;
end Has_Element;
-------------
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
- if Container.Tree.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (map is locked)";
end if;
declare
- N : Node_Type renames Container.Tree.Nodes (Position.Node);
+ N : Node_Type renames Container.Nodes (Position.Node);
begin
N.Key := Key;
N.Element := New_Item;
Position : out Cursor;
Inserted : out Boolean)
is
- begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
+ function New_Node return Node_Access;
- declare
- function New_Node return Node_Access;
-
- procedure Insert_Post is
- new Key_Ops.Generic_Insert_Post (New_Node);
-
- procedure Insert_Sans_Hint is
- new Key_Ops.Generic_Conditional_Insert (Insert_Post);
-
- --------------
- -- New_Node --
- --------------
+ procedure Insert_Post is
+ new Key_Ops.Generic_Insert_Post (New_Node);
- function New_Node return Node_Access is
- procedure Initialize (Node : in out Node_Type);
- procedure Allocate_Node is new Generic_Allocate (Initialize);
+ procedure Insert_Sans_Hint is
+ new Key_Ops.Generic_Conditional_Insert (Insert_Post);
- procedure Initialize (Node : in out Node_Type) is
- begin
- Node.Key := Key;
- Node.Element := New_Item;
- end Initialize;
+ --------------
+ -- New_Node --
+ --------------
- X : Node_Access;
+ function New_Node return Node_Access is
+ procedure Initialize (Node : in out Node_Type);
+ procedure Allocate_Node is new Generic_Allocate (Initialize);
+ procedure Initialize (Node : in out Node_Type) is
begin
- Allocate_Node (Container.Tree.all, X);
- return X;
- end New_Node;
+ Node.Key := Key;
+ Node.Element := New_Item;
+ end Initialize;
- -- Start of processing for Insert
+ X : Node_Access;
begin
- Insert_Sans_Hint
- (Container.Tree.all,
- Key,
- Position.Node,
- Inserted);
- end;
+ Allocate_Node (Container, X);
+ return X;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Insert_Sans_Hint
+ (Container,
+ Key,
+ Position.Node,
+ Inserted);
end Insert;
procedure Insert
Position : out Cursor;
Inserted : out Boolean)
is
- begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- declare
- function New_Node return Node_Access;
-
- procedure Insert_Post is
- new Key_Ops.Generic_Insert_Post (New_Node);
-
- procedure Insert_Sans_Hint is
- new Key_Ops.Generic_Conditional_Insert (Insert_Post);
+ function New_Node return Node_Access;
- --------------
- -- New_Node --
- --------------
+ procedure Insert_Post is
+ new Key_Ops.Generic_Insert_Post (New_Node);
- function New_Node return Node_Access is
- procedure Initialize (Node : in out Node_Type);
- procedure Allocate_Node is new Generic_Allocate (Initialize);
+ procedure Insert_Sans_Hint is
+ new Key_Ops.Generic_Conditional_Insert (Insert_Post);
- procedure Initialize (Node : in out Node_Type) is
- begin
- Node.Key := Key;
- end Initialize;
+ --------------
+ -- New_Node --
+ --------------
- X : Node_Access;
+ function New_Node return Node_Access is
+ procedure Initialize (Node : in out Node_Type);
+ procedure Allocate_Node is new Generic_Allocate (Initialize);
+ procedure Initialize (Node : in out Node_Type) is
begin
- Allocate_Node (Container.Tree.all, X);
- return X;
- end New_Node;
+ Node.Key := Key;
+ end Initialize;
- -- Start of processing for Insert
+ X : Node_Access;
begin
- Insert_Sans_Hint
- (Container.Tree.all,
- Key,
- Position.Node,
- Inserted);
- end;
+ Allocate_Node (Container, X);
+ return X;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Insert_Sans_Hint
+ (Container,
+ Key,
+ Position.Node,
+ Inserted);
end Insert;
--------------
Process (Container, (Node => Node));
end Process_Node;
- B : Natural renames Container.Tree.all.Busy;
+ B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Iterate
B := B + 1;
begin
-
- if Container.K = Plain then
- Local_Iterate (Container.Tree.all);
- return;
- end if;
-
- if Container.Length = 0 then
- return;
- end if;
-
- declare
- FElt : constant Key_Type :=
- Container.Tree.Nodes (Container.First).Key;
- TElt : constant Key_Type :=
- Container.Tree.Nodes (Container.Last).Key;
-
- procedure Iterate (P : Count_Type);
-
- procedure Iterate (P : Count_Type) is
- X : Count_Type := P;
- begin
- while X /= 0 loop
- if Container.Tree.Nodes (X).Key < FElt then
- X := Container.Tree.Nodes (X).Right;
- elsif TElt < Container.Tree.Nodes (X).Key then
- X := Container.Tree.Nodes (X).Left;
- else
- Iterate (Container.Tree.Nodes (X).Left);
- Process_Node (X);
- X := Container.Tree.Nodes (X).Right;
- end if;
- end loop;
- end Iterate;
-
- begin
- Iterate (Container.Tree.Root);
- end;
-
+ Local_Iterate (Container);
exception
when others =>
B := B - 1;
"Position cursor of function Key has no element";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"Position cursor of function Key is bad");
- return Container.Tree.Nodes (Position.Node).Key;
+ return Container.Nodes (Position.Node).Key;
end Key;
----------
if Length (Container) = 0 then
return No_Element;
end if;
-
- if Container.K = Plain then
- return (Node => Container.Tree.Last);
- end if;
-
return (Node => Container.Last);
end Last;
raise Constraint_Error with "map is empty";
end if;
- return Container.Tree.Nodes (Last (Container).Node).Element;
+ return Container.Nodes (Last (Container).Node).Element;
end Last_Element;
--------------
raise Constraint_Error with "map is empty";
end if;
- return Container.Tree.Nodes (Last (Container).Node).Key;
+ return Container.Nodes (Last (Container).Node).Key;
end Last_Key;
----------
----------
function Left (Container : Map; Position : Cursor) return Map is
- Lst : Count_Type;
- Fst : constant Count_Type := First (Container).Node;
- L : Count_Type := 0;
- C : Count_Type := Fst;
+ Curs : Cursor := Position;
+ C : Map (Container.Capacity) :=
+ Copy (Container, Container.Capacity);
+ Node : Count_Type;
begin
- while C /= Position.Node loop
- if C = Last (Container).Node or C = 0 then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
- Lst := C;
- C := Next (Container.Tree.all, C);
- L := L + 1;
- end loop;
- if L = 0 then
- return (Capacity => Container.Capacity,
- K => Part,
- Tree => Container.Tree,
- Length => 0,
- First => 0,
- Last => 0);
- else
- return (Capacity => Container.Capacity,
- K => Part,
- Tree => Container.Tree,
- Length => L,
- First => Fst,
- Last => Lst);
+ if Curs = No_Element then
+ return C;
end if;
+ if not Has_Element (Container, Curs) then
+ raise Constraint_Error;
+ end if;
+
+ while Curs.Node /= 0 loop
+ Node := Curs.Node;
+ Delete (C, Curs);
+ Curs := Next (Container, (Node => Node));
+ end loop;
+ return C;
end Left;
--------------
function Length (Container : Map) return Count_Type is
begin
- if Container.K = Plain then
- return Container.Tree.Length;
- else
- return Container.Length;
- end if;
+ return Container.Length;
end Length;
----------
----------
procedure Move (Target : in out Map; Source : in out Map) is
- NN : Tree_Types.Nodes_Type renames Source.Tree.Nodes;
+ NN : Tree_Types.Nodes_Type renames Source.Nodes;
X : Node_Access;
begin
- if Target.K /= Plain or Source.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Target'Address = Source'Address then
return;
"Source length exceeds Target capacity";
end if;
- if Source.Tree.Busy > 0 then
+ if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)";
end if;
Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
- Tree_Operations.Delete_Node_Sans_Free (Source.Tree.all, X);
- Formal_Ordered_Maps.Free (Source.Tree.all, X);
+ Tree_Operations.Delete_Node_Sans_Free (Source, X);
+ Formal_Ordered_Maps.Free (Source, X);
end loop;
end Move;
-- Next --
----------
- function Next_Unchecked
- (Container : Map;
- Position : Count_Type) return Count_Type is
- begin
-
- if Container.K = Part and then
- (Container.Length = 0 or Position = Container.Last) then
- return 0;
- end if;
-
- return Tree_Operations.Next (Container.Tree.all, Position);
- end Next_Unchecked;
-
procedure Next (Container : Map; Position : in out Cursor) is
begin
Position := Next (Container, Position);
raise Constraint_Error;
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"bad cursor in Next");
- return (Node => Next_Unchecked (Container, Position.Node));
+ return (Node => Tree_Operations.Next (Container, Position.Node));
end Next;
-------------
R_Node : Count_Type := First (Right).Node;
L_Last : constant Count_Type :=
- Next (Left.Tree.all, Last (Left).Node);
+ Next (Left, Last (Left).Node);
R_Last : constant Count_Type :=
- Next (Right.Tree.all, Last (Right).Node);
+ Next (Right, Last (Right).Node);
begin
if Left'Address = Right'Address then
return False;
end if;
- if Left.Tree.Nodes (L_Node).Key
- < Right.Tree.Nodes (R_Node).Key then
- L_Node := Next (Left.Tree.all, L_Node);
- elsif Right.Tree.Nodes (R_Node).Key
- < Left.Tree.Nodes (L_Node).Key then
- R_Node := Next (Right.Tree.all, R_Node);
+ 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
+ R_Node := Next (Right, R_Node);
else
return True;
raise Constraint_Error;
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"bad cursor in Previous");
- if Container.K = Part and then
- (Container.Length = 0 or Position.Node = Container.First) then
- return No_Element;
- end if;
-
declare
- Tree : Tree_Types.Tree_Type renames Container.Tree.all;
Node : constant Count_Type :=
- Tree_Operations.Previous (Tree, Position.Node);
+ Tree_Operations.Previous (Container, Position.Node);
begin
if Node = 0 then
Element : Element_Type))
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Query_Element has no element";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"Position cursor of Query_Element is bad");
declare
- T : Tree_Types.Tree_Type renames Container.Tree.all;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
declare
- N : Node_Type renames T.Nodes (Position.Node);
+ N : Node_Type renames Container.Nodes (Position.Node);
K : Key_Type renames N.Key;
E : Element_Type renames N.Element;
end Read_Element;
-- Start of processing for Read
- Result : Tree_Type_Access;
begin
- if Container.K /= Plain then
- raise Constraint_Error;
- end if;
-
- if Container.Tree = null then
- Result := new Tree_Types.Tree_Type (Container.Capacity);
- else
- Result := Container.Tree;
- end if;
- Read_Elements (Stream, Result.all);
- Container.Tree := Result;
+ Read_Elements (Stream, Container);
end Read;
procedure Read
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
declare
- Node : constant Node_Access := Key_Ops.Find (Container.Tree.all, Key);
+ Node : constant Node_Access := Key_Ops.Find (Container, Key);
begin
if Node = 0 then
raise Constraint_Error with "key not in map";
end if;
- if Container.Tree.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (map is locked)";
end if;
declare
- N : Node_Type renames Container.Tree.Nodes (Node);
+ N : Node_Type renames Container.Nodes (Node);
begin
N.Key := Key;
N.Element := New_Item;
New_Item : Element_Type)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Replace_Element has no element";
end if;
- if Container.Tree.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (map is locked)";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"Position cursor of Replace_Element is bad");
- Container.Tree.Nodes (Position.Node).Element := New_Item;
+ Container.Nodes (Position.Node).Element := New_Item;
end Replace_Element;
---------------------
Process (Container, (Node => Node));
end Process_Node;
- B : Natural renames Container.Tree.Busy;
+ B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Reverse_Iterate
B := B + 1;
begin
-
- if Container.K = Plain then
- Local_Reverse_Iterate (Container.Tree.all);
- return;
- end if;
-
- if Container.Length = 0 then
- return;
- end if;
-
- declare
- FElt : constant Key_Type :=
- Container.Tree.Nodes (Container.First).Key;
- TElt : constant Key_Type :=
- Container.Tree.Nodes (Container.Last).Key;
-
- procedure Iterate (P : Count_Type);
-
- procedure Iterate (P : Count_Type) is
- X : Count_Type := P;
- begin
- while X /= 0 loop
- if Container.Tree.Nodes (X).Key < FElt then
- X := Container.Tree.Nodes (X).Right;
- elsif TElt < Container.Tree.Nodes (X).Key then
- X := Container.Tree.Nodes (X).Left;
- else
- Iterate (Container.Tree.Nodes (X).Right);
- Process_Node (X);
- X := Container.Tree.Nodes (X).Left;
- end if;
- end loop;
- end Iterate;
-
- begin
- Iterate (Container.Tree.Root);
- end;
+ Local_Reverse_Iterate (Container);
exception
when others =>
-----------
function Right (Container : Map; Position : Cursor) return Map is
- Lst : Count_Type;
- L : Count_Type := 0;
- C : Count_Type := Position.Node;
+ Curs : Cursor := First (Container);
+ C : Map (Container.Capacity) :=
+ Copy (Container, Container.Capacity);
+ Node : Count_Type;
begin
-
- if C = 0 then
- return (Capacity => Container.Capacity,
- K => Part,
- Tree => Container.Tree,
- Length => 0,
- First => 0,
- Last => 0);
- end if;
-
- if Container.K = Plain then
- Lst := 0;
- else
- Lst := Next (Container.Tree.all, Container.Last);
+ if Curs = No_Element then
+ Clear (C);
+ return C;
end if;
-
- if C = Lst then
- raise Constraint_Error with
- "Position cursor has no element";
+ if Position /= No_Element and not Has_Element (Container, Position) then
+ raise Constraint_Error;
end if;
- while C /= Lst loop
- if C = 0 then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
- C := Next (Container.Tree.all, C);
- L := L + 1;
+ while Curs.Node /= Position.Node loop
+ Node := Curs.Node;
+ Delete (C, Curs);
+ Curs := Next (Container, (Node => Node));
end loop;
-
- return (Capacity => Container.Capacity,
- K => Part,
- Tree => Container.Tree,
- Length => L,
- First => Position.Node,
- Last => Last (Container).Node);
+ return C;
end Right;
---------------
return True;
end if;
- if Left.Tree.Nodes (LNode).Element /=
- Right.Tree.Nodes (RNode).Element or
- Left.Tree.Nodes (LNode).Key /= Right.Tree.Nodes (RNode).Key then
+ if Left.Nodes (LNode).Element /=
+ Right.Nodes (RNode).Element or
+ Left.Nodes (LNode).Key /= Right.Nodes (RNode).Key then
exit;
end if;
- LNode := Next_Unchecked (Left, LNode);
- RNode := Next_Unchecked (Right, RNode);
+ LNode := Next (Left, LNode);
+ RNode := Next (Right, RNode);
end loop;
return False;
end Strict_Equal;
Element : in out Element_Type))
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Update_Element has no element";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"Position cursor of Update_Element is bad");
declare
- T : Tree_Types.Tree_Type renames Container.Tree.all;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
declare
- N : Node_Type renames T.Nodes (Position.Node);
+ N : Node_Type renames Container.Nodes (Position.Node);
K : Key_Type renames N.Key;
E : Element_Type renames N.Element;
-- Start of processing for Write
begin
- Write_Nodes (Stream, Container.Tree.all);
+ Write_Nodes (Stream, Container);
end Write;
procedure Write
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
type Map (Capacity : Count_Type) is tagged private;
- -- pragma Preelaborable_Initialization (Map);
+ pragma Preelaborable_Initialization (Map);
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
type Node_Type is record
Has_Element : Boolean := False;
- Parent : Node_Access;
- Left : Node_Access;
- Right : Node_Access;
+ Parent : Node_Access := 0;
+ Left : Node_Access := 0;
+ Right : Node_Access := 0;
Color : Red_Black_Trees.Color_Type := Red;
Key : Key_Type;
Element : Element_Type;
end record;
- type Kind is (Plain, Part);
-
package Tree_Types is
new Ada.Containers.Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
- type Tree_Type_Access is access all Tree_Types.Tree_Type;
-
- type Map (Capacity : Count_Type) is tagged record
- Tree : Tree_Type_Access := new Tree_Types.Tree_Type (Capacity);
- K : Kind := Plain;
- Length : Count_Type := 0;
- First : Count_Type := 0;
- Last : Count_Type := 0;
- end record;
+ type Map (Capacity : Count_Type) is
+ new Tree_Types.Tree_Type (Capacity) with null record;
use Ada.Streams;
- type Map_Access is access all Map;
- for Map_Access'Storage_Size use 0;
-
type Cursor is record
Node : Node_Access;
end record;
-- --
-- B o d y --
-- --
--- Copyright (C) 2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-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- --
(Tree : in out Tree_Types.Tree_Type'Class;
Node : out Count_Type);
- procedure Assign (Target : in out Tree_Types.Tree_Type;
- Source : Tree_Types.Tree_Type);
-
- procedure Clear (Container : in out Tree_Types.Tree_Type);
-
- procedure Free (Tree : in out Tree_Types.Tree_Type; X : Count_Type);
+ procedure Free (Tree : in out Set; X : Count_Type);
procedure Insert_Sans_Hint
- (Container : in out Tree_Types.Tree_Type;
+ (Container : in out Set;
New_Item : Element_Type;
Node : out Count_Type;
Inserted : out Boolean);
procedure Insert_With_Hint
- (Dst_Set : in out Tree_Types.Tree_Type;
+ (Dst_Set : in out Set;
Dst_Hint : Count_Type;
Src_Node : Node_Type;
Dst_Node : out Count_Type);
function Is_Less_Node_Node (L, R : Node_Type) return Boolean;
pragma Inline (Is_Less_Node_Node);
- generic
- with procedure Process (Node : Count_Type) is <>;
- procedure Iterate_Between (Tree : Tree_Types.Tree_Type;
- From : Count_Type;
- To : Count_Type);
-
- function Next_Unchecked
- (Container : Set;
- Position : Count_Type) return Count_Type;
-
procedure Replace_Element
- (Tree : in out Tree_Types.Tree_Type;
+ (Tree : in out Set;
Node : Count_Type;
Item : Element_Type);
package Set_Ops is
new Red_Black_Trees.Generic_Bounded_Set_Operations
(Tree_Operations => Tree_Operations,
- Set_Type => Tree_Types.Tree_Type,
+ Set_Type => Set,
Assign => Assign,
Insert_With_Hint => Insert_With_Hint,
Is_Less => Is_Less_Node_Node);
return True;
end if;
- Lst := Next (Left.Tree.all, Last (Left).Node);
+ Lst := Next (Left, Last (Left).Node);
while Node /= Lst loop
- ENode := Find (Right, Left.Tree.Nodes (Node).Element).Node;
+ ENode := Find (Right, Left.Nodes (Node).Element).Node;
if ENode = 0 or else
- Left.Tree.Nodes (Node).Element /= Right.Tree.Nodes (ENode).Element
+ Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
then
return False;
end if;
- Node := Next (Left.Tree.all, Node);
+ Node := Next (Left, Node);
end loop;
return True;
-- Assign --
------------
- procedure Assign (Target : in out Tree_Types.Tree_Type;
- Source : Tree_Types.Tree_Type) is
+ procedure Assign (Target : in out Set; Source : Set) is
procedure Append_Element (Source_Node : Count_Type);
procedure Append_Elements is
Append_Elements (Source);
end Assign;
- procedure Assign (Target : in out Set; Source : Set) is
- X : Count_Type;
- begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Length (Source) then
- raise Storage_Error with "not enough capacity"; -- SE or CE? ???
- end if;
-
- if Source.K = Plain then
- Assign (Target => Target.Tree.all, Source => Source.Tree.all);
- else
- declare
- procedure Append_Element (Source_Node : Count_Type);
-
- procedure Append_Element (Source_Node : Count_Type) is
- SN : Node_Type renames Source.Tree.Nodes (Source_Node);
-
- procedure Set_Element (Node : in out Node_Type);
- pragma Inline (Set_Element);
-
- function New_Node return Count_Type;
- pragma Inline (New_Node);
-
- procedure Insert_Post is
- new Element_Keys.Generic_Insert_Post (New_Node);
-
- procedure Unconditional_Insert_Sans_Hint is
- new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
-
- procedure Unconditional_Insert_Avec_Hint is
- new Element_Keys.Generic_Unconditional_Insert_With_Hint
- (Insert_Post,
- Unconditional_Insert_Sans_Hint);
-
- procedure Allocate is
- new Generic_Allocate (Set_Element);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Count_Type is
- Result : Count_Type;
-
- begin
- Allocate (Target.Tree.all, Result);
- return Result;
- end New_Node;
-
- -----------------
- -- Set_Element --
- -----------------
-
- procedure Set_Element (Node : in out Node_Type) is
- begin
- Node.Element := SN.Element;
- end Set_Element;
-
- Target_Node : Count_Type;
-
- -- Start of processing for Append_Element
-
- begin
- Unconditional_Insert_Avec_Hint
- (Tree => Target.Tree.all,
- Hint => 0,
- Key => SN.Element,
- Node => Target_Node);
- end Append_Element;
- begin
- Tree_Operations.Clear_Tree (Target.Tree.all);
- X := Source.First;
- while X /= Next (Source.Tree.all, Source.Last) loop
- Append_Element (X);
- X := Next (Source.Tree.all, X);
- end loop;
- end;
- end if;
- end Assign;
-
-------------
-- Ceiling --
-------------
function Ceiling (Container : Set; Item : Element_Type) return Cursor is
- begin
- if Container.K = Part then
- if Container.Length = 0 then
- return No_Element;
- end if;
+ Node : constant Count_Type := Element_Keys.Ceiling (Container, Item);
- if Item < Container.Tree.Nodes (Container.First).Element then
- return (Node => Container.First);
- end if;
-
- if Container.Tree.Nodes (Container.Last).Element < Item then
- return No_Element;
- end if;
+ begin
+ if Node = 0 then
+ return No_Element;
end if;
- declare
- Node : constant Count_Type :=
- Element_Keys.Ceiling (Container.Tree.all, Item);
+ return (Node => Node);
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
end Ceiling;
-----------
-- Clear --
-----------
- procedure Clear (Container : in out Tree_Types.Tree_Type) is
- begin
- Tree_Operations.Clear_Tree (Container);
- end Clear;
-
procedure Clear (Container : in out Set) is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- Clear (Container.Tree.all);
+ Tree_Operations.Clear_Tree (Container);
end Clear;
-----------
function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
Node : Count_Type := 1;
N : Count_Type;
- Cu : Cursor;
Target : Set (Count_Type'Max (Source.Capacity, Capacity));
begin
if Length (Source) > 0 then
- Target.Tree.Length := Source.Tree.Length;
- Target.Tree.Root := Source.Tree.Root;
- Target.Tree.First := Source.Tree.First;
- Target.Tree.Last := Source.Tree.Last;
- Target.Tree.Free := Source.Tree.Free;
+ Target.Length := Source.Length;
+ Target.Root := Source.Root;
+ Target.First := Source.First;
+ Target.Last := Source.Last;
+ Target.Free := Source.Free;
while Node <= Source.Capacity loop
- Target.Tree.Nodes (Node).Element :=
- Source.Tree.Nodes (Node).Element;
- Target.Tree.Nodes (Node).Parent :=
- Source.Tree.Nodes (Node).Parent;
- Target.Tree.Nodes (Node).Left :=
- Source.Tree.Nodes (Node).Left;
- Target.Tree.Nodes (Node).Right :=
- Source.Tree.Nodes (Node).Right;
- Target.Tree.Nodes (Node).Color :=
- Source.Tree.Nodes (Node).Color;
- Target.Tree.Nodes (Node).Has_Element :=
- Source.Tree.Nodes (Node).Has_Element;
+ Target.Nodes (Node).Element :=
+ Source.Nodes (Node).Element;
+ Target.Nodes (Node).Parent :=
+ Source.Nodes (Node).Parent;
+ Target.Nodes (Node).Left :=
+ Source.Nodes (Node).Left;
+ Target.Nodes (Node).Right :=
+ Source.Nodes (Node).Right;
+ Target.Nodes (Node).Color :=
+ Source.Nodes (Node).Color;
+ Target.Nodes (Node).Has_Element :=
+ Source.Nodes (Node).Has_Element;
Node := Node + 1;
end loop;
while Node <= Target.Capacity loop
N := Node;
- Formal_Ordered_Sets.Free (Tree => Target.Tree.all, X => N);
+ Formal_Ordered_Sets.Free (Tree => Target, X => N);
Node := Node + 1;
end loop;
-
- if Source.K = Part then
- Node := Target.Tree.First;
- while Node /= Source.First loop
- Cu := (Node => Node);
- Node := Next (Target.Tree.all, Node);
- Delete (Target, Cu);
- end loop;
-
- Node := Next (Target.Tree.all, Source.Last);
-
- while Node /= 0 loop
- Cu := (Node => Node);
- Node := Next (Target.Tree.all, Node);
- Delete (Target, Cu);
- end loop;
- end if;
- Node := 1;
-
end if;
return Target;
end Copy;
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"bad cursor in Delete");
- Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all,
+ Tree_Operations.Delete_Node_Sans_Free (Container,
Position.Node);
- Formal_Ordered_Sets.Free (Container.Tree.all, Position.Node);
+ Formal_Ordered_Sets.Free (Container, Position.Node);
Position := No_Element;
end Delete;
procedure Delete (Container : in out Set; Item : Element_Type) is
- X : constant Count_Type := Element_Keys.Find (Container.Tree.all, Item);
+ X : constant Count_Type := Element_Keys.Find (Container, Item);
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if X = 0 then
raise Constraint_Error with "attempt to delete element not in set";
end if;
- Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
- Formal_Ordered_Sets.Free (Container.Tree.all, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Formal_Ordered_Sets.Free (Container, X);
end Delete;
------------------
------------------
procedure Delete_First (Container : in out Set) is
- Tree : Tree_Types.Tree_Type renames Container.Tree.all;
- X : constant Count_Type := Tree.First;
+ X : constant Count_Type := Container.First;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Tree, X);
- Formal_Ordered_Sets.Free (Tree, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Formal_Ordered_Sets.Free (Container, X);
end if;
end Delete_First;
-----------------
procedure Delete_Last (Container : in out Set) is
- Tree : Tree_Types.Tree_Type renames Container.Tree.all;
- X : constant Count_Type := Tree.Last;
+ X : constant Count_Type := Container.Last;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Tree, X);
- Formal_Ordered_Sets.Free (Tree, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Formal_Ordered_Sets.Free (Container, X);
end if;
end Delete_Last;
procedure Difference (Target : in out Set; Source : Set) is
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- if Source.K = Plain then
- Set_Ops.Set_Difference (Target.Tree.all, Source.Tree.all);
- else
- declare
- Tgt : Count_Type := Target.Tree.First;
- Src : Count_Type := Source.First;
- begin
- if Target'Address = Source'Address then
- if Target.Tree.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
-
- Clear (Target.Tree.all);
- return;
- end if;
-
- if Source.Length = 0 then
- return;
- end if;
+ Set_Ops.Set_Difference (Target, Source);
- if Target.Tree.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
-
- loop
- if Tgt = 0 then
- return;
- end if;
-
- if Src = Next (Source.Tree.all, Source.Last) then
- return;
- end if;
-
- if Target.Tree.Nodes (Tgt).Element <
- Source.Tree.Nodes (Src).Element then
- Tgt := Next (Target.Tree.all, Tgt);
-
- elsif Source.Tree.Nodes (Src).Element <
- Target.Tree.Nodes (Tgt).Element then
- Src := Next (Source.Tree.all, Src);
-
- else
- declare
- X : constant Count_Type := Tgt;
- begin
- Tgt := Next (Target.Tree.all, Tgt);
- Delete_Node_Sans_Free (Target.Tree.all, X);
- Formal_Ordered_Sets.Free (Target.Tree.all, X);
- end;
-
- Src := Next (Source.Tree.all, Src);
- end if;
- end loop;
- end;
- end if;
end Difference;
function Difference (Left, Right : Set) return Set is
end if;
return S : Set (Length (Left)) do
- if Left.K = Plain and Right.K = Plain then
- Assign (S.Tree.all,
- Set_Ops.Set_Difference (Left.Tree.all, Right.Tree.all));
- else
- declare
- Tree : Tree_Types.Tree_Type renames S.Tree.all;
-
- L_Node : Count_Type := First (Left).Node;
- R_Node : Count_Type := First (Right).Node;
-
- L_Last : constant Count_Type := Next (Left.Tree.all,
- Last (Left).Node);
- R_Last : constant Count_Type := Next (Right.Tree.all,
- Last (Right).Node);
+ Assign (S,
+ Set_Ops.Set_Difference (Left, Right));
- Dst_Node : Count_Type;
-
- begin
- loop
- if L_Node = L_Last then
- return;
- end if;
-
- if R_Node = R_Last then
- while L_Node /= L_Last loop
- Insert_With_Hint
- (Dst_Set => Tree,
- Dst_Hint => 0,
- Src_Node => Left.Tree.Nodes (L_Node),
- Dst_Node => Dst_Node);
-
- L_Node := Next (Left.Tree.all, L_Node);
-
- end loop;
-
- return;
- end if;
-
- if Left.Tree.Nodes (L_Node).Element <
- Right.Tree.Nodes (R_Node).Element then
- Insert_With_Hint
- (Dst_Set => Tree,
- Dst_Hint => 0,
- Src_Node => Left.Tree.Nodes (L_Node),
- Dst_Node => Dst_Node);
-
- L_Node := Next (Left.Tree.all, L_Node);
-
- elsif Right.Tree.Nodes (R_Node).Element <
- Left.Tree.Nodes (L_Node).Element then
- R_Node := Next (Right.Tree.all, R_Node);
-
- else
- L_Node := Next (Left.Tree.all, L_Node);
- R_Node := Next (Right.Tree.all, R_Node);
- end if;
- end loop;
- end;
- end if;
end return;
end Difference;
raise Constraint_Error with "Position cursor has no element";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"bad cursor in Element");
declare
- N : Tree_Types.Nodes_Type renames Container.Tree.Nodes;
+ N : Tree_Types.Nodes_Type renames Container.Nodes;
begin
return N (Position.Node).Element;
end;
-- Start of processing for Equivalent_Sets
begin
- if Left.K = Plain and Right.K = Plain then
- return Is_Equivalent (Left.Tree.all, Right.Tree.all);
- end if;
-
- if Left'Address = Right'Address then
- return True;
- end if;
-
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- if Length (Left) = 0 then
- return True;
- end if;
-
- declare
- L_Node : Count_Type;
- R_Node : Count_Type;
-
- L_Last : constant Count_Type := Next (Left.Tree.all,
- Last (Left).Node);
- begin
-
- L_Node := First (Left).Node;
- R_Node := First (Right).Node;
- while L_Node /= L_Last loop
- if not Is_Equivalent_Node_Node (Left.Tree.Nodes (L_Node),
- Right.Tree.Nodes (R_Node)) then
- return False;
- end if;
-
- L_Node := Next (Left.Tree.all, L_Node);
- R_Node := Next (Right.Tree.all, R_Node);
- end loop;
-
- return True;
- end;
+ return Is_Equivalent (Left, Right);
end Equivalent_Sets;
-------------
-------------
procedure Exclude (Container : in out Set; Item : Element_Type) is
- X : constant Count_Type := Element_Keys.Find (Container.Tree.all, Item);
+ X : constant Count_Type := Element_Keys.Find (Container, Item);
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
- Formal_Ordered_Sets.Free (Container.Tree.all, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Formal_Ordered_Sets.Free (Container, X);
end if;
end Exclude;
----------
function Find (Container : Set; Item : Element_Type) return Cursor is
- begin
- if Container.K = Part then
- if Container.Length = 0 then
- return No_Element;
- end if;
+ Node : constant Count_Type :=
+ Element_Keys.Find (Container, Item);
- if Item < Container.Tree.Nodes (Container.First).Element or
- Container.Tree.Nodes (Container.Last).Element < Item then
- return No_Element;
- end if;
+ begin
+ if Node = 0 then
+ return No_Element;
end if;
- declare
- Node : constant Count_Type :=
- Element_Keys.Find (Container.Tree.all, Item);
+ return (Node => Node);
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
end Find;
-----------
return No_Element;
end if;
- if Container.K = Plain then
- return (Node => Container.Tree.First);
- else
- return (Node => Container.First);
- end if;
+ return (Node => Container.First);
end First;
end if;
declare
- N : Tree_Types.Nodes_Type renames Container.Tree.Nodes;
+ N : Tree_Types.Nodes_Type renames Container.Nodes;
begin
return N (Fst).Element;
end;
function Floor (Container : Set; Item : Element_Type) return Cursor is
begin
- if Container.K = Part then
- if Container.Length = 0 then
- return No_Element;
- end if;
-
- if Item < Container.Tree.Nodes (Container.First).Element then
- return No_Element;
- end if;
-
- if Container.Tree.Nodes (Container.Last).Element < Item then
- return (Node => Container.Last);
- end if;
- end if;
-
declare
Node : constant Count_Type :=
- Element_Keys.Floor (Container.Tree.all, Item);
+ Element_Keys.Floor (Container, Item);
begin
if Node = 0 then
----------
procedure Free
- (Tree : in out Tree_Types.Tree_Type;
+ (Tree : in out Set;
X : Count_Type)
is
begin
-------------
function Ceiling (Container : Set; Key : Key_Type) return Cursor is
- begin
-
- if Container.K = Part then
- if Container.Length = 0 then
- return No_Element;
- end if;
-
- if Key < Generic_Keys.Key
- (Container.Tree.Nodes (Container.First).Element) then
- return (Node => Container.First);
- end if;
+ Node : constant Count_Type :=
+ Key_Keys.Ceiling (Container, Key);
- if Generic_Keys.Key
- (Container.Tree.Nodes (Container.Last).Element) < Key then
- return No_Element;
- end if;
+ begin
+ if Node = 0 then
+ return No_Element;
end if;
- declare
- Node : constant Count_Type :=
- Key_Keys.Ceiling (Container.Tree.all, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
+ return (Node => Node);
end Ceiling;
--------------
------------
procedure Delete (Container : in out Set; Key : Key_Type) is
- begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
- declare
- X : constant Count_Type := Key_Keys.Find (Container.Tree.all, Key);
+ X : constant Count_Type := Key_Keys.Find (Container, Key);
- begin
- if X = 0 then
- raise Constraint_Error with "attempt to delete key not in set";
- end if;
+ begin
+ if X = 0 then
+ raise Constraint_Error with "attempt to delete key not in set";
+ end if;
- Delete_Node_Sans_Free (Container.Tree.all, X);
- Formal_Ordered_Sets.Free (Container.Tree.all, X);
- end;
+ Delete_Node_Sans_Free (Container, X);
+ Formal_Ordered_Sets.Free (Container, X);
end Delete;
-------------
-------------
function Element (Container : Set; Key : Key_Type) return Element_Type is
- begin
+ Node : constant Count_Type :=
+ Key_Keys.Find (Container, Key);
- if Container.K = Part then
- if Container.Length = 0 or else
- (Key < Generic_Keys.Key
- (Container.Tree.Nodes (Container.First).Element) or
- Generic_Keys.Key
- (Container.Tree.Nodes (Container.Last).Element) < Key) then
- raise Constraint_Error with "key not in set";
- end if;
+ begin
+ if Node = 0 then
+ raise Constraint_Error with "key not in set";
end if;
declare
- Node : constant Count_Type :=
- Key_Keys.Find (Container.Tree.all, Key);
-
+ N : Tree_Types.Nodes_Type renames Container.Nodes;
begin
- if Node = 0 then
- raise Constraint_Error with "key not in set";
- end if;
-
- declare
- N : Tree_Types.Nodes_Type renames Container.Tree.Nodes;
- begin
- return N (Node).Element;
- end;
+ return N (Node).Element;
end;
end Element;
-------------
procedure Exclude (Container : in out Set; Key : Key_Type) is
- begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- declare
- X : constant Count_Type := Key_Keys.Find (Container.Tree.all, Key);
+ X : constant Count_Type := Key_Keys.Find (Container, Key);
- begin
- if X /= 0 then
- Delete_Node_Sans_Free (Container.Tree.all, X);
- Formal_Ordered_Sets.Free (Container.Tree.all, X);
- end if;
- end;
+ begin
+ if X /= 0 then
+ Delete_Node_Sans_Free (Container, X);
+ Formal_Ordered_Sets.Free (Container, X);
+ end if;
end Exclude;
----------
----------
function Find (Container : Set; Key : Key_Type) return Cursor is
- begin
-
- if Container.K = Part then
- if Container.Length = 0 or else
- (Key < Generic_Keys.Key
- (Container.Tree.Nodes (Container.First).Element) or
- Generic_Keys.Key
- (Container.Tree.Nodes (Container.Last).Element) < Key) then
- return No_Element;
- end if;
- end if;
- declare
-
- Node : constant Count_Type := Key_Keys.Find (Container.Tree.all,
- Key);
+ Node : constant Count_Type := Key_Keys.Find (Container, Key);
- begin
- if Node = 0 then
- return No_Element;
- end if;
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
- return (Node => Node);
- end;
+ return (Node => Node);
end Find;
-----------
-----------
function Floor (Container : Set; Key : Key_Type) return Cursor is
- begin
- if Container.K = Part then
- if Container.Length = 0 or else
- Key < Generic_Keys.Key
- (Container.Tree.Nodes (Container.First).Element) then
- return No_Element;
- end if;
- if Generic_Keys.Key
- (Container.Tree.Nodes (Container.Last).Element) < Key then
- return (Node => Container.Last);
- end if;
- end if;
+ Node : constant Count_Type :=
+ Key_Keys.Floor (Container, Key);
- declare
- Node : constant Count_Type :=
- Key_Keys.Floor (Container.Tree.all, Key);
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
- begin
- if Node = 0 then
- return No_Element;
- end if;
+ return (Node => Node);
- return (Node => Node);
- end;
end Floor;
-------------------------
"Position cursor has no element";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"bad cursor in Key");
declare
- N : Tree_Types.Nodes_Type renames Container.Tree.Nodes;
+ N : Tree_Types.Nodes_Type renames Container.Nodes;
begin
return Key (N (Position.Node).Element);
end;
Key : Key_Type;
New_Item : Element_Type)
is
- Node : constant Count_Type := Key_Keys.Find (Container.Tree.all, Key);
+ Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, (Node => Node)) then
raise Constraint_Error with
"attempt to replace key not in set";
end if;
- Replace_Element (Container.Tree.all, Node, New_Item);
+ Replace_Element (Container, Node, New_Item);
end Replace;
-----------------------------------
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
- Tree : Tree_Types.Tree_Type renames Container.Tree.all;
-
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor has no element";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"bad cursor in Update_Element_Preserving_Key");
declare
- N : Tree_Types.Nodes_Type renames Container.Tree.Nodes;
+ N : Tree_Types.Nodes_Type renames Container.Nodes;
E : Element_Type renames N (Position.Node).Element;
K : constant Key_Type := Key (E);
- B : Natural renames Tree.Busy;
- L : Natural renames Tree.Lock;
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
B := B + 1;
declare
X : constant Count_Type := Position.Node;
begin
- Tree_Operations.Delete_Node_Sans_Free (Tree, X);
- Formal_Ordered_Sets.Free (Tree, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container, X);
+ Formal_Ordered_Sets.Free (Container, X);
end;
raise Program_Error with "key was modified";
return False;
end if;
- if not Container.Tree.Nodes (Position.Node).Has_Element then
- return False;
- end if;
-
- if Container.K = Plain then
- return True;
- end if;
-
- declare
- Elt : constant Element_Type :=
- Container.Tree.Nodes (Position.Node).Element;
- begin
-
- if Elt < Container.Tree.Nodes (Container.First).Element or
- Container.Tree.Nodes (Container.Last).Element < Elt then
- return False;
- end if;
-
- return True;
- end;
+ return Container.Nodes (Position.Node).Has_Element;
end Has_Element;
-------------
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- if Container.Tree.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
declare
- N : Tree_Types.Nodes_Type renames Container.Tree.Nodes;
+ N : Tree_Types.Nodes_Type renames Container.Nodes;
begin
N (Position.Node).Element := New_Item;
end;
Inserted : out Boolean)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
Insert_Sans_Hint
- (Container.Tree.all,
+ (Container,
New_Item,
Position.Node,
Inserted);
----------------------
procedure Insert_Sans_Hint
- (Container : in out Tree_Types.Tree_Type;
+ (Container : in out Set;
New_Item : Element_Type;
Node : out Count_Type;
Inserted : out Boolean)
----------------------
procedure Insert_With_Hint
- (Dst_Set : in out Tree_Types.Tree_Type;
+ (Dst_Set : in out Set;
Dst_Hint : Count_Type;
Src_Node : Node_Type;
Dst_Node : out Count_Type)
procedure Intersection (Target : in out Set; Source : Set) is
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- if Source.K = Plain then
- Set_Ops.Set_Intersection (Target.Tree.all, Source.Tree.all);
- else
- declare
- Tgt : Count_Type := Target.First;
- Src : Count_Type := Source.First;
-
- S_Last : constant Count_Type :=
- Next (Source.Tree.all, Source.Last);
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Tree.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
-
- if Source.Length = 0 then
- Clear (Target);
- return;
- end if;
-
- while Tgt /= 0
- and then Src /= S_Last
- loop
- if Target.Tree.Nodes (Tgt).Element <
- Source.Tree.Nodes (Src).Element then
- declare
- X : constant Count_Type := Tgt;
- begin
- Tgt := Next (Target.Tree.all, Tgt);
- Delete_Node_Sans_Free (Target.Tree.all, X);
- Formal_Ordered_Sets.Free (Target.Tree.all, X);
- end;
-
- elsif Source.Tree.Nodes (Src).Element <
- Target.Tree.Nodes (Tgt).Element then
- Src := Next (Source.Tree.all, Src);
-
- else
- Tgt := Next (Target.Tree.all, Tgt);
- Src := Next (Source.Tree.all, Src);
- end if;
- end loop;
-
- while Tgt /= 0 loop
- declare
- X : constant Count_Type := Tgt;
- begin
- Tgt := Next (Target.Tree.all, Tgt);
- Delete_Node_Sans_Free (Target.Tree.all, X);
- Formal_Ordered_Sets.Free (Target.Tree.all, X);
- end;
- end loop;
- end;
- end if;
+ Set_Ops.Set_Intersection (Target, Source);
end Intersection;
function Intersection (Left, Right : Set) return Set is
end if;
return S : Set (Count_Type'Min (Length (Left), Length (Right))) do
- if Left.K = Plain and Right.K = Plain then
- Assign (S.Tree.all, Set_Ops.Set_Intersection
- (Left.Tree.all, Right.Tree.all));
- return;
- end if;
-
- if Length (Left) = 0 or Length (Right) = 0 then
- return;
- end if;
-
- declare
-
- L_Node : Count_Type := First (Left).Node;
- R_Node : Count_Type := First (Right).Node;
-
- L_Last : constant Count_Type :=
- Next (Left.Tree.all, Last (Left).Node);
- R_Last : constant Count_Type :=
- Next (Right.Tree.all, Last (Right).Node);
-
- Dst_Node : Count_Type;
-
- begin
- loop
-
- if L_Node = L_Last or R_Node = R_Last then
- return;
- end if;
-
- if Left.Tree.Nodes (L_Node).Element <
- Right.Tree.Nodes (R_Node).Element then
- L_Node := Next (Left.Tree.all, L_Node);
-
- elsif Right.Tree.Nodes (R_Node).Element <
- Left.Tree.Nodes (L_Node).Element then
- R_Node := Next (Right.Tree.all, R_Node);
-
- else
- Insert_With_Hint
- (Dst_Set => S.Tree.all,
- Dst_Hint => 0,
- Src_Node => Left.Tree.Nodes (L_Node),
- Dst_Node => Dst_Node);
-
- L_Node := Next (Left.Tree.all, L_Node);
- R_Node := Next (Right.Tree.all, R_Node);
- end if;
- end loop;
- end;
+ Assign (S, Set_Ops.Set_Intersection
+ (Left, Right));
end return;
end Intersection;
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
begin
- if Subset.K = Plain and Of_Set.K = Plain then
- return Set_Ops.Set_Subset (Subset.Tree.all,
- Of_Set => Of_Set.Tree.all);
- end if;
-
- if Subset'Address = Of_Set'Address then
- return True;
- end if;
-
- if Length (Subset) > Length (Of_Set) then
- return False;
- end if;
-
- declare
- Subset_Node : Count_Type := First (Subset).Node;
- Set_Node : Count_Type := First (Of_Set).Node;
-
- Subset_Last : constant Count_Type :=
- Next (Subset.Tree.all, Last (Subset).Node);
- Set_Last : constant Count_Type :=
- Next (Of_Set.Tree.all, Last (Of_Set).Node);
-
- begin
- loop
- if Set_Node = Set_Last then
- return Subset_Node = 0;
- end if;
-
- if Subset_Node = Subset_Last then
- return True;
- end if;
-
- if Subset.Tree.Nodes (Subset_Node).Element <
- Of_Set.Tree.Nodes (Set_Node).Element then
- return False;
- end if;
-
- if Of_Set.Tree.Nodes (Set_Node).Element <
- Subset.Tree.Nodes (Subset_Node).Element then
- Set_Node := Next (Of_Set.Tree.all, Set_Node);
- else
- Set_Node := Next (Of_Set.Tree.all, Set_Node);
- Subset_Node := Next (Subset.Tree.all, Subset_Node);
- end if;
- end loop;
- end;
+ return Set_Ops.Set_Subset (Subset,
+ Of_Set => Of_Set);
end Is_Subset;
-------------
procedure Local_Iterate is
new Tree_Operations.Generic_Iteration (Process_Node);
- procedure Local_Iterate_Between is
- new Iterate_Between (Process_Node);
-
------------------
-- Process_Node --
------------------
Process (Container, (Node => Node));
end Process_Node;
- T : Tree_Types.Tree_Type renames Container.Tree.all;
- B : Natural renames T.Busy;
+ B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of prccessing for Iterate
B := B + 1;
begin
- if Container.K = Plain then
- Local_Iterate (T);
- return;
- end if;
-
- if Container.Length = 0 then
- return;
- end if;
-
- Local_Iterate_Between (T, Container.First, Container.Last);
-
+ Local_Iterate (Container);
exception
when others =>
B := B - 1;
B := B - 1;
end Iterate;
- ---------------------
- -- Iterate_Between --
- ---------------------
-
- procedure Iterate_Between (Tree : Tree_Types.Tree_Type;
- From : Count_Type;
- To : Count_Type) is
-
- FElt : constant Element_Type := Tree.Nodes (From).Element;
- TElt : constant Element_Type := Tree.Nodes (To).Element;
- procedure Iterate (P : Count_Type);
-
- -------------
- -- Iterate --
- -------------
-
- procedure Iterate (P : Count_Type) is
- X : Count_Type := P;
- begin
- while X /= 0 loop
- if Tree.Nodes (X).Element < FElt then
- X := Tree.Nodes (X).Right;
- elsif TElt < Tree.Nodes (X).Element then
- X := Tree.Nodes (X).Left;
- else
- Iterate (Tree.Nodes (X).Left);
- Process (X);
- X := Tree.Nodes (X).Right;
- end if;
- end loop;
- end Iterate;
-
- begin
- Iterate (Tree.Root);
- end Iterate_Between;
-
----------
-- Last --
----------
return No_Element;
end if;
- if Container.K = Plain then
- return (Node => Container.Tree.Last);
- end if;
-
return (Node => Container.Last);
+
end Last;
------------------
end if;
declare
- N : Tree_Types.Nodes_Type renames Container.Tree.Nodes;
+ N : Tree_Types.Nodes_Type renames Container.Nodes;
begin
return N (Last (Container).Node).Element;
end;
----------
function Left (Container : Set; Position : Cursor) return Set is
- Lst : Count_Type;
- Fst : constant Count_Type := First (Container).Node;
- L : Count_Type := 0;
- C : Count_Type := Fst;
+ Curs : Cursor := Position;
+ C : Set (Container.Capacity) :=
+ Copy (Container, Container.Capacity);
+ Node : Count_Type;
begin
- while C /= Position.Node loop
- if C = Last (Container).Node or C = 0 then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
- Lst := C;
- C := Next (Container.Tree.all, C);
- L := L + 1;
- end loop;
- if L = 0 then
- return (Capacity => Container.Capacity,
- K => Part,
- Tree => Container.Tree,
- Length => 0,
- First => 0,
- Last => 0);
- else
- return (Capacity => Container.Capacity,
- K => Part,
- Tree => Container.Tree,
- Length => L,
- First => Fst,
- Last => Lst);
+ if Curs = No_Element then
+ return C;
+ end if;
+ if not Has_Element (Container, Curs) then
+ raise Constraint_Error;
end if;
+
+ while Curs.Node /= 0 loop
+ Node := Curs.Node;
+ Delete (C, Curs);
+ Curs := Next (Container, (Node => Node));
+ end loop;
+ return C;
end Left;
--------------
function Length (Container : Set) return Count_Type is
begin
- if Container.K = Plain then
- return Container.Tree.Length;
- else
- return Container.Length;
- end if;
+ return Container.Length;
end Length;
----------
----------
procedure Move (Target : in out Set; Source : in out Set) is
- S : Tree_Types.Tree_Type renames Source.Tree.all;
- N : Tree_Types.Nodes_Type renames S.Nodes;
+ N : Tree_Types.Nodes_Type renames Source.Nodes;
X : Count_Type;
begin
- if Target.K /= Plain or Source.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Target'Address = Source'Address then
return;
"Source length exceeds Target capacity";
end if;
- if S.Busy > 0 then
+ if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)";
end if;
Clear (Target);
loop
- X := S.First;
+ X := Source.First;
exit when X = 0;
Insert (Target, N (X).Element); -- optimize???
- Tree_Operations.Delete_Node_Sans_Free (S, X);
- Formal_Ordered_Sets.Free (S, X);
+ Tree_Operations.Delete_Node_Sans_Free (Source, X);
+ Formal_Ordered_Sets.Free (Source, X);
end loop;
end Move;
-- Next --
----------
- function Next_Unchecked
- (Container : Set;
- Position : Count_Type) return Count_Type is
- begin
-
- if Container.K = Part and then
- (Container.Length = 0 or Position = Container.Last) then
- return 0;
- end if;
-
- return Tree_Operations.Next (Container.Tree.all, Position);
- end Next_Unchecked;
-
function Next (Container : Set; Position : Cursor) return Cursor is
begin
if Position = No_Element then
raise Constraint_Error;
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"bad cursor in Next");
- return (Node => Next_Unchecked (Container, Position.Node));
+ return (Node => Tree_Operations.Next (Container, Position.Node));
end Next;
procedure Next (Container : Set; Position : in out Cursor) is
function Overlap (Left, Right : Set) return Boolean is
begin
- if Left.K = Plain and Right.K = Plain then
- return Set_Ops.Set_Overlap (Left.Tree.all, Right.Tree.all);
- end if;
-
- 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;
+ return Set_Ops.Set_Overlap (Left, Right);
- L_Last : constant Count_Type :=
- Next (Left.Tree.all, Last (Left).Node);
- R_Last : constant Count_Type :=
- Next (Right.Tree.all, Last (Right).Node);
-
- begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
- loop
- if L_Node = L_Last
- or else R_Node = R_Last
- then
- return False;
- end if;
-
- if Left.Tree.Nodes (L_Node).Element <
- Right.Tree.Nodes (R_Node).Element then
- L_Node := Next (Left.Tree.all, L_Node);
-
- elsif Right.Tree.Nodes (R_Node).Element <
- Left.Tree.Nodes (L_Node).Element then
- R_Node := Next (Right.Tree.all, R_Node);
-
- else
- return True;
- end if;
- end loop;
- end;
end Overlap;
------------
raise Constraint_Error;
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"bad cursor in Previous");
- if Container.K = Part and then
- (Container.Length = 0 or Position.Node = Container.First) then
- return No_Element;
- end if;
-
declare
- Tree : Tree_Types.Tree_Type renames Container.Tree.all;
Node : constant Count_Type :=
- Tree_Operations.Previous (Tree, Position.Node);
+ Tree_Operations.Previous (Container, Position.Node);
begin
if Node = 0 then
Process : not null access procedure (Element : Element_Type))
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"bad cursor in Query_Element");
declare
- T : Tree_Types.Tree_Type renames Container.Tree.all;
- B : Natural renames T.Busy;
- L : Natural renames T.Lock;
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
begin
- Process (T.Nodes (Position.Node).Element);
+ Process (Container.Nodes (Position.Node).Element);
exception
when others =>
L := L - 1;
end Read_Element;
-- Start of processing for Read
- Result : Tree_Type_Access;
begin
- if Container.K /= Plain then
- raise Constraint_Error;
- end if;
- if Container.Tree = null then
- Result := new Tree_Types.Tree_Type (Container.Capacity);
- else
- Result := Container.Tree;
- end if;
-
- Read_Elements (Stream, Result.all);
- Container.Tree := Result;
+ Read_Elements (Stream, Container);
end Read;
procedure Read
-------------
procedure Replace (Container : in out Set; New_Item : Element_Type) is
- begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
- declare
- Node : constant Count_Type :=
- Element_Keys.Find (Container.Tree.all, 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";
- end if;
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "attempt to replace element not in set";
+ end if;
- if Container.Tree.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is locked)";
- end if;
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
+ end if;
- Container.Tree.Nodes (Node).Element := New_Item;
- end;
+ Container.Nodes (Node).Element := New_Item;
end Replace;
---------------------
---------------------
procedure Replace_Element
- (Tree : in out Tree_Types.Tree_Type;
+ (Tree : in out Set;
Node : Count_Type;
Item : Element_Type)
is
New_Item : Element_Type)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor has no element";
end if;
- pragma Assert (Vet (Container.Tree.all, Position.Node),
+ pragma Assert (Vet (Container, Position.Node),
"bad cursor in Replace_Element");
- Replace_Element (Container.Tree.all, Position.Node, New_Item);
+ Replace_Element (Container, Position.Node, New_Item);
end Replace_Element;
---------------------
Process (Container, (Node => Node));
end Process_Node;
- T : Tree_Types.Tree_Type renames Container.Tree.all;
- B : Natural renames T.Busy;
+ B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Reverse_Iterate
B := B + 1;
begin
- if Container.K = Plain then
- Local_Reverse_Iterate (T);
- return;
- end if;
-
- if Container.Length = 0 then
- return;
- end if;
-
- declare
- Node : Count_Type := Container.Last;
- First : constant Count_Type :=
- Previous (Container.Tree.all, Container.First);
-
- begin
-
- while Node /= First loop
- Process_Node (Node);
- Node := Previous (Container.Tree.all, Node);
- end loop;
-
- end;
-
+ Local_Reverse_Iterate (Container);
exception
when others =>
B := B - 1;
-----------
function Right (Container : Set; Position : Cursor) return Set is
- Lst : Count_Type;
- L : Count_Type := 0;
- C : Count_Type := Position.Node;
- begin
-
- if C = 0 then
- return (Capacity => Container.Capacity,
- K => Part,
- Tree => Container.Tree,
- Length => 0,
- First => 0,
- Last => 0);
- end if;
-
- if Container.K = Plain then
- Lst := 0;
- else
- Lst := Next (Container.Tree.all, Container.Last);
+ Curs : Cursor := First (Container);
+ C : Set (Container.Capacity) :=
+ Copy (Container, Container.Capacity);
+ Node : Count_Type;
+ begin
+ if Curs = No_Element then
+ Clear (C);
+ return C;
end if;
-
- if C = Lst then
- raise Constraint_Error with
- "Position cursor has no element";
+ if Position /= No_Element and not Has_Element (Container, Position) then
+ raise Constraint_Error;
end if;
- while C /= Lst loop
- if C = 0 then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
- C := Next (Container.Tree.all, C);
- L := L + 1;
+ while Curs.Node /= Position.Node loop
+ Node := Curs.Node;
+ Delete (C, Curs);
+ Curs := Next (Container, (Node => Node));
end loop;
-
- return (Capacity => Container.Capacity,
- K => Part,
- Tree => Container.Tree,
- Length => L,
- First => Position.Node,
- Last => Last (Container).Node);
+ return C;
end Right;
---------------
return True;
end if;
- if Left.Tree.Nodes (LNode).Element /=
- Right.Tree.Nodes (RNode).Element then
+ if Left.Nodes (LNode).Element /=
+ Right.Nodes (RNode).Element then
exit;
end if;
- LNode := Next_Unchecked (Left, LNode);
- RNode := Next_Unchecked (Right, RNode);
+ LNode := Next (Left, LNode);
+ RNode := Next (Right, RNode);
end loop;
return False;
procedure Symmetric_Difference (Target : in out Set; Source : Set) is
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- if Source.K = Plain then
- Set_Ops.Set_Symmetric_Difference (Target.Tree.all, Source.Tree.all);
- return;
- end if;
-
- if Source.Length = 0 then
- return;
- end if;
-
- declare
-
- Tgt : Count_Type := Target.First;
- Src : Count_Type := Source.First;
-
- SLast : constant Count_Type := Next (Source.Tree.all, Source.Last);
-
- New_Tgt_Node : Count_Type;
-
- begin
- if Target.Tree.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
-
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
-
- loop
- if Tgt = 0 then
- while Src /= SLast loop
- Insert_With_Hint
- (Dst_Set => Target.Tree.all,
- Dst_Hint => 0,
- Src_Node => Source.Tree.Nodes (Src),
- Dst_Node => New_Tgt_Node);
-
- Src := Next (Source.Tree.all, Src);
- end loop;
-
- return;
- end if;
-
- if Src = SLast then
- return;
- end if;
-
- if Target.Tree.Nodes (Tgt).Element <
- Source.Tree.Nodes (Src).Element then
- Tgt := Next (Target.Tree.all, Tgt);
-
- elsif Source.Tree.Nodes (Src).Element <
- Target.Tree.Nodes (Tgt).Element then
- Insert_With_Hint
- (Dst_Set => Target.Tree.all,
- Dst_Hint => Tgt,
- Src_Node => Source.Tree.Nodes (Src),
- Dst_Node => New_Tgt_Node);
-
- Src := Next (Source.Tree.all, Src);
-
- else
- declare
- X : constant Count_Type := Tgt;
- begin
- Tgt := Next (Target.Tree.all, Tgt);
- Delete_Node_Sans_Free (Target.Tree.all, X);
- Formal_Ordered_Sets.Free (Target.Tree.all, X);
- end;
-
- Src := Next (Source.Tree.all, Src);
- end if;
- end loop;
- end;
+ Set_Ops.Set_Symmetric_Difference (Target, Source);
end Symmetric_Difference;
function Symmetric_Difference (Left, Right : Set) return Set is
end if;
return S : Set (Length (Left) + Length (Right)) do
- if Left.K = Plain and Right.K = Plain then
- Assign (S.Tree.all,
- Set_Ops.Set_Symmetric_Difference (Left.Tree.all,
- Right.Tree.all));
- return;
- end if;
-
- declare
-
- Tree : Tree_Types.Tree_Type renames S.Tree.all;
-
- L_Node : Count_Type := First (Left).Node;
- R_Node : Count_Type := First (Right).Node;
-
- L_Last : constant Count_Type :=
- Next (Left.Tree.all, Last (Left).Node);
- R_Last : constant Count_Type :=
- Next (Right.Tree.all, Last (Right).Node);
-
- Dst_Node : Count_Type;
-
- begin
- loop
- if L_Node = L_Last then
- while R_Node /= R_Last loop
- Insert_With_Hint
- (Dst_Set => Tree,
- Dst_Hint => 0,
- Src_Node => Right.Tree.Nodes (R_Node),
- Dst_Node => Dst_Node);
-
- R_Node := Next (Right.Tree.all, R_Node);
- end loop;
-
- return;
- end if;
-
- if R_Node = R_Last then
- while L_Node /= L_Last loop
- Insert_With_Hint
- (Dst_Set => Tree,
- Dst_Hint => 0,
- Src_Node => Left.Tree.Nodes (L_Node),
- Dst_Node => Dst_Node);
-
- L_Node := Next (Left.Tree.all, L_Node);
- end loop;
-
- return;
- end if;
-
- if Left.Tree.Nodes (L_Node).Element <
- Right.Tree.Nodes (R_Node).Element then
- Insert_With_Hint
- (Dst_Set => Tree,
- Dst_Hint => 0,
- Src_Node => Left.Tree.Nodes (L_Node),
- Dst_Node => Dst_Node);
-
- L_Node := Next (Left.Tree.all, L_Node);
-
- elsif Right.Tree.Nodes (R_Node).Element <
- Left.Tree.Nodes (L_Node).Element then
- Insert_With_Hint
- (Dst_Set => Tree,
- Dst_Hint => 0,
- Src_Node => Right.Tree.Nodes (R_Node),
- Dst_Node => Dst_Node);
-
- R_Node := Next (Right.Tree.all, R_Node);
-
- else
- L_Node := Next (Left.Tree.all, L_Node);
- R_Node := Next (Right.Tree.all, R_Node);
- end if;
- end loop;
- end;
-
+ Assign (S,
+ Set_Ops.Set_Symmetric_Difference (Left,
+ Right));
end return;
end Symmetric_Difference;
begin
return S : Set (Capacity => 1) do
- Insert_Sans_Hint (S.Tree.all, New_Item, Node, Inserted);
+ Insert_Sans_Hint (S, New_Item, Node, Inserted);
pragma Assert (Inserted);
end return;
end To_Set;
procedure Union (Target : in out Set; Source : Set) is
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- if Source.K = Plain then
- Set_Ops.Set_Union (Target.Tree.all, Source.Tree.all);
- return;
- end if;
-
- if Source.Length = 0 then
- return;
- end if;
-
- declare
- Hint : Count_Type := 0;
-
- procedure Process (Node : Count_Type);
- pragma Inline (Process);
-
- procedure Iterate is new Iterate_Between (Process);
-
- -------------
- -- Process --
- -------------
-
- procedure Process (Node : Count_Type) is
- begin
- Insert_With_Hint
- (Dst_Set => Target.Tree.all,
- Dst_Hint => Hint,
- Src_Node => Source.Tree.Nodes (Node),
- Dst_Node => Hint);
- end Process;
-
- -- Start of processing for Union
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Tree.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
-
- Iterate (Source.Tree.all, Source.First, Source.Last);
- end;
+ Set_Ops.Set_Union (Target, Source);
end Union;
function Union (Left, Right : Set) return Set is
-- Start of processing for Write
begin
- Write_Elements (Stream, Container.Tree.all);
+ Write_Elements (Stream, Container);
end Write;
procedure Write
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
type Node_Type is record
Has_Element : Boolean := False;
- Parent : Count_Type;
- Left : Count_Type;
- Right : Count_Type;
+ Parent : Count_Type := 0;
+ Left : Count_Type := 0;
+ Right : Count_Type := 0;
Color : Red_Black_Trees.Color_Type;
Element : Element_Type;
end record;
- type Kind is (Plain, Part);
-
package Tree_Types is
new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
- type Tree_Type_Access is access all Tree_Types.Tree_Type;
-
- type Set (Capacity : Count_Type) is tagged record
- Tree : Tree_Type_Access := new Tree_Types.Tree_Type (Capacity);
- K : Kind := Plain;
- Length : Count_Type := 0;
- First : Count_Type := 0;
- Last : Count_Type := 0;
- end record;
+ type Set (Capacity : Count_Type) is
+ new Tree_Types.Tree_Type (Capacity) with null record;
use Red_Black_Trees;
use Ada.Streams;
-- --
-- B o d y --
-- --
--- Copyright (C) 2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-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- --
function "&" (Left, Right : Vector) return Vector is
LN : constant Count_Type := Length (Left);
RN : constant Count_Type := Length (Right);
-
- RFst : Count_Type;
- RLst : Count_Type;
- LFst : Count_Type;
- LLst : Count_Type;
-
begin
- if Right.K = Plain then
- RFst := 1;
- RLst := RN;
- else
- RFst := Right.First;
- RLst := Right.First + RN - 1;
- end if;
-
- if Left.K = Plain then
- LFst := 1;
- LLst := LN;
- else
- LFst := Left.First;
- LLst := Left.First + LN - 1;
- end if;
-
if LN = 0 then
if RN = 0 then
return Empty_Vector;
declare
E : constant Elements_Array (1 .. Length (Right)) :=
- Right.Plain.Elements (RFst .. RLst);
+ Right.Elements (1 .. RN);
begin
- return (Length (Right),
- new Plain_Vector'(Length (Right), E,
- Last => Right.Plain.Last, others => <>),
- others => <>);
+ return (Length (Right), E,
+ Last => Right.Last, others => <>);
end;
end if;
if RN = 0 then
declare
E : constant Elements_Array (1 .. Length (Left)) :=
- Left.Plain.Elements (LFst .. LLst);
+ Left.Elements (1 .. LN);
begin
- return (Length (Left),
- new Plain_Vector'(Length (Left), E,
- Last => Left.Plain.Last, others => <>),
- others => <>);
+ return (Length (Left), E,
+ Last => Left.Last, others => <>);
end;
end if;
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- LE : constant Elements_Array (1 .. Length (Left)) :=
- Left.Plain.Elements (LFst .. LLst);
+ LE : constant Elements_Array (1 .. LN) :=
+ Left.Elements (1 .. LN);
- RE : Elements_Array renames Right.Plain.Elements (RFst .. RLst);
+ RE : Elements_Array renames Right.Elements (1 .. RN);
Capacity : constant Count_Type := Length (Left) + Length (Right);
begin
- return (Capacity,
- new Plain_Vector'(Capacity, LE & RE,
- Last => Last, others => <>),
- others => <>);
+ return (Capacity, LE & RE,
+ Last => Last, others => <>);
end;
end;
end "&";
function "&" (Left : Vector; Right : Element_Type) return Vector is
LN : constant Count_Type := Length (Left);
Last_As_Int : Int'Base;
- LFst : Count_Type;
- LLst : Count_Type;
begin
if LN = 0 then
- return (1,
- new Plain_Vector'(1, (1 .. 1 => Right),
- Index_Type'First, others => <>),
- others => <>);
+ return (1, (1 .. 1 => Right),
+ Index_Type'First, others => <>);
end if;
if Int (Index_Type'First) > Int'Last - Int (LN) then
raise Constraint_Error with "new length is out of range";
end if;
- if Left.K = Plain then
- LFst := 1;
- LLst := LN;
- else
- LFst := Left.First;
- LLst := Left.First + LN - 1;
- end if;
-
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
LE : constant Elements_Array (1 .. LN) :=
- Left.Plain.Elements (LFst .. LLst);
+ Left.Elements (1 .. LN);
Capacity : constant Count_Type := Length (Left) + 1;
begin
- return (Capacity,
- new Plain_Vector'(Capacity, LE & Right,
- Last => Last, others => <>),
- others => <>);
+ return (Capacity, LE & Right,
+ Last => Last, others => <>);
end;
end "&";
RN : constant Count_Type := Length (Right);
Last_As_Int : Int'Base;
- RFst : Count_Type;
- RLst : Count_Type;
-
begin
if RN = 0 then
- return (1,
- new Plain_Vector'(1, (1 .. 1 => Left),
- Index_Type'First, others => <>),
- others => <>);
+ return (1, (1 .. 1 => Left),
+ Index_Type'First, others => <>);
end if;
if Int (Index_Type'First) > Int'Last - Int (RN) then
raise Constraint_Error with "new length is out of range";
end if;
- if Right.K = Plain then
- RFst := 1;
- RLst := RN;
- else
- RFst := Right.First;
- RLst := Right.First + RN - 1;
- end if;
-
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- RE : Elements_Array renames Right.Plain.Elements (RFst .. RLst);
+ RE : Elements_Array renames Right.Elements (1 .. RN);
Capacity : constant Count_Type := 1 + Length (Right);
begin
- return (Capacity,
- new Plain_Vector'(Capacity, Left & RE,
- Last => Last, others => <>),
- others => <>);
+ return (Capacity, Left & RE,
+ Last => Last, others => <>);
end;
end "&";
Last : constant Index_Type := Index_Type'First + 1;
begin
- return (2,
- new Plain_Vector'(2, (Left, Right),
- Last => Last, others => <>),
- others => <>);
+ return (2, (Left, Right),
+ Last => Last, others => <>);
end;
end "&";
procedure Append (Container : in out Vector; New_Item : Vector) is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Is_Empty (New_Item) then
return;
end if;
- if Container.Plain.Last = Index_Type'Last then
+ if Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
end if;
Insert
(Container,
- Container.Plain.Last + 1,
+ Container.Last + 1,
New_Item);
end Append;
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Count = 0 then
return;
end if;
- if Container.Plain.Last = Index_Type'Last then
+ if Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
end if;
Insert
(Container,
- Container.Plain.Last + 1,
+ Container.Last + 1,
New_Item,
Count);
end Append;
LS : constant Count_Type := Length (Source);
begin
- if Target.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Target'Address = Source'Address then
return;
end if;
Target.Clear;
- if Source.K = Plain then
- Target.Plain.Elements (1 .. LS) :=
- Source.Plain.Elements (1 .. LS);
- Target.Plain.Last := Source.Plain.Last;
- else
- Target.Plain.Elements (1 .. LS) :=
- Source.Plain.Elements (Source.First .. (Source.First + LS - 1));
- Target.Plain.Last := Source.Last;
- end if;
+ Target.Elements (1 .. LS) :=
+ Source.Elements (1 .. LS);
+ Target.Last := Source.Last;
end Assign;
function Capacity (Container : Vector) return Capacity_Subtype is
begin
- return Container.Plain.Elements'Length;
+ return Container.Elements'Length;
end Capacity;
-----------
procedure Clear (Container : in out Vector) is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- if Container.Plain.Busy > 0 then
+ if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
- Container.Plain.Last := No_Index;
+ Container.Last := No_Index;
end Clear;
--------------
end if;
return Target : Vector (C) do
- if Source.K = Plain then
- Target.Plain.Elements (1 .. LS) :=
- Source.Plain.Elements (1 .. LS);
- Target.Plain.Last := Source.Plain.Last;
- else
- Target.Plain.Elements (1 .. LS) :=
- Source.Plain.Elements (Source.First .. (Source.First + LS - 1));
- Target.Plain.Last := Source.Last;
- end if;
+ Target.Elements (1 .. LS) :=
+ Source.Elements (1 .. LS);
+ Target.Last := Source.Last;
end return;
end Copy;
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Index < Index_Type'First then
raise Constraint_Error with "Index is out of range (too small)";
end if;
- if Index > Container.Plain.Last then
- if Index > Container.Plain.Last + 1 then
+ if Index > Container.Last then
+ if Index > Container.Last + 1 then
raise Constraint_Error with "Index is out of range (too large)";
end if;
return;
end if;
- if Container.Plain.Busy > 0 then
+ if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
declare
I_As_Int : constant Int := Int (Index);
Old_Last_As_Int : constant Int :=
- Index_Type'Pos (Container.Plain.Last);
+ Index_Type'Pos (Container.Last);
Count1 : constant Int'Base := Count_Type'Pos (Count);
Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
begin
if J_As_Int > Old_Last_As_Int then
- Container.Plain.Last := Index - 1;
+ Container.Last := Index - 1;
else
declare
- EA : Elements_Array renames Container.Plain.Elements;
+ EA : Elements_Array renames Container.Elements;
II : constant Int'Base := I_As_Int - Int (No_Index);
I : constant Count_Type := Count_Type (II);
begin
EA (I .. K) := EA (J .. Length (Container));
- Container.Plain.Last := New_Last;
+ Container.Last := New_Last;
end;
end if;
end;
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if not Position.Valid then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Index > Container.Plain.Last then
+ if Position.Index > Container.Last then
raise Program_Error with "Position index is out of range";
end if;
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Count = 0 then
return;
end if;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Count = 0 then
return;
end if;
- if Container.Plain.Busy > 0 then
+ if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
- Index := Int'Base (Container.Plain.Last) - Int'Base (Count);
+ Index := Int'Base (Container.Last) - Int'Base (Count);
if Index < Index_Type'Pos (Index_Type'First) then
- Container.Plain.Last := No_Index;
+ Container.Last := No_Index;
else
- Container.Plain.Last := Index_Type (Index);
+ Container.Last := Index_Type (Index);
end if;
end Delete_Last;
Index : Index_Type) return Element_Type
is
begin
- if Index > Container.Plain.Last then
+ if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
begin
- if Container.K = Part and then
- (I > Length (Container)) then
- raise Constraint_Error with "Index is out of range";
- end if;
-
return Get_Element (Container, I);
end;
end Element;
Last : constant Index_Type := Last_Index (Container);
begin
- if Container.Plain.Last <= Last then
+ if Container.Last <= Last then
return True;
end if;
procedure Merge (Target, Source : in out Vector) is
begin
- if Target.K /= Plain or Source.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
declare
- TA : Elements_Array renames Target.Plain.Elements;
- SA : Elements_Array renames Source.Plain.Elements;
+ TA : Elements_Array renames Target.Elements;
+ SA : Elements_Array renames Source.Elements;
I, J : Count_Type;
return;
end if;
- if Source.Plain.Last < Index_Type'First then
+ if Source.Last < Index_Type'First then
return;
end if;
-- I think we're missing this check in a-convec.adb... ???
- if Target.Plain.Busy > 0 then
+ if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
- if Source.Plain.Busy > 0 then
+ if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
if I = 0 then
TA (1 .. J) := SA (1 .. Length (Source));
- Source.Plain.Last := No_Index;
+ Source.Last := No_Index;
return;
end if;
else
TA (J) := SA (Length (Source));
- Source.Plain.Last := Source.Plain.Last - 1;
+ Source.Last := Source.Last - 1;
end if;
J := J - 1;
Element_Type => Element_Type,
Array_Type => Elements_Array,
"<" => "<");
-
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
- if Container.Plain.Last <= Index_Type'First then
+ if Container.Last <= Index_Type'First then
return;
end if;
- if Container.Plain.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is locked)";
end if;
- Sort (Container.Plain.Elements (1 .. Length (Container)));
+ Sort (Container.Elements (1 .. Length (Container)));
end Sort;
end Generic_Sorting;
(Container : Vector;
Position : Count_Type) return Element_Type is
begin
- if Container.K = Plain then
- return Container.Plain.Elements (Position);
- end if;
- return Container.Plain.Elements (Position + Container.First - 1);
+ return Container.Elements (Position);
+
end Get_Element;
-----------------
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
- if Before > Container.Plain.Last
- and then Before > Container.Plain.Last + 1
+ if Before > Container.Last
+ and then Before > Container.Last + 1
then
raise Constraint_Error with
"Before index is out of range (too large)";
end if;
declare
- Old_Last_As_Int : constant Int := Int (Container.Plain.Last);
+ Old_Last_As_Int : constant Int := Int (Container.Last);
begin
if Old_Last_As_Int > Int'Last - N then
-- Resolve issue of capacity vs. max index ???
end;
- if Container.Plain.Busy > 0 then
+ if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
declare
- EA : Elements_Array renames Container.Plain.Elements;
+ EA : Elements_Array renames Container.Elements;
BB : constant Int'Base := Int (Before) - Int (No_Index);
B : constant Count_Type := Count_Type (BB);
L : constant Count_Type := Count_Type (LL);
begin
- if Before <= Container.Plain.Last then
+ if Before <= Container.Last then
declare
II : constant Int'Base := BB + N;
I : constant Count_Type := Count_Type (II);
end if;
end;
- Container.Plain.Last := New_Last;
+ Container.Last := New_Last;
end Insert;
procedure Insert
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
- if Before > Container.Plain.Last
- and then Before > Container.Plain.Last + 1
+ if Before > Container.Last
+ and then Before > Container.Last + 1
then
raise Constraint_Error with
"Before index is out of range (too large)";
Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int);
- Src_Fst : Count_Type;
- Src_Lst : Count_Type;
-
BB : constant Int'Base := Int (Before) - Int (No_Index);
B : constant Count_Type := Count_Type (BB);
begin
- if Container.K = Plain then
- Src_Fst := 1;
- Src_Lst := N;
- else
- Src_Fst := New_Item.First;
- Src_Lst := N + New_Item.First - 1;
- end if;
-
if Container'Address /= New_Item'Address then
- Container.Plain.Elements (B .. Dst_Last) :=
- New_Item.Plain.Elements (Src_Fst .. Src_Lst);
+ Container.Elements (B .. Dst_Last) :=
+ New_Item.Elements (1 .. N);
return;
end if;
declare
- Src : Elements_Array renames Container.Plain.Elements (1 .. B - 1);
+ Src : Elements_Array renames Container.Elements (1 .. B - 1);
Index_As_Int : constant Int'Base := BB + Src'Length - 1;
Index : constant Count_Type := Count_Type (Index_As_Int);
- Dst : Elements_Array renames Container.Plain.Elements (B .. Index);
+ Dst : Elements_Array renames Container.Elements (B .. Index);
begin
Dst := Src;
declare
Src : Elements_Array renames
- Container.Plain.Elements
+ Container.Elements
(Dst_Last + 1 .. Length (Container));
Index_As_Int : constant Int'Base :=
Index : constant Count_Type := Count_Type (Index_As_Int);
Dst : Elements_Array renames
- Container.Plain.Elements (Index .. Dst_Last);
+ Container.Elements (Index .. Dst_Last);
begin
Dst := Src;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Is_Empty (New_Item) then
return;
end if;
if not Before.Valid
- or else Before.Index > Container.Plain.Last
+ or else Before.Index > Container.Last
then
- if Container.Plain.Last = Index_Type'Last then
+ if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
end if;
- Index := Container.Plain.Last + 1;
+ Index := Container.Last + 1;
else
Index := Before.Index;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Is_Empty (New_Item) then
if not Before.Valid
- or else Before.Index > Container.Plain.Last
+ or else Before.Index > Container.Last
then
Position := No_Element;
else
end if;
if not Before.Valid
- or else Before.Index > Container.Plain.Last
+ or else Before.Index > Container.Last
then
- if Container.Plain.Last = Index_Type'Last then
+ if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
end if;
- Index := Container.Plain.Last + 1;
+ Index := Container.Last + 1;
else
Index := Before.Index;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Count = 0 then
return;
end if;
if not Before.Valid
- or else Before.Index > Container.Plain.Last
+ or else Before.Index > Container.Last
then
- if Container.Plain.Last = Index_Type'Last then
+ if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
end if;
- Index := Container.Plain.Last + 1;
+ Index := Container.Last + 1;
else
Index := Before.Index;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Count = 0 then
if not Before.Valid
- or else Before.Index > Container.Plain.Last
+ or else Before.Index > Container.Last
then
Position := No_Element;
else
end if;
if not Before.Valid
- or else Before.Index > Container.Plain.Last
+ or else Before.Index > Container.Last
then
- if Container.Plain.Last = Index_Type'Last then
+ if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
end if;
- Index := Container.Plain.Last + 1;
+ Index := Container.Last + 1;
else
Index := Before.Index;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
- if Before > Container.Plain.Last
- and then Before > Container.Plain.Last + 1
+ if Before > Container.Last
+ and then Before > Container.Last + 1
then
raise Constraint_Error with
"Before index is out of range (too large)";
end if;
declare
- Old_Last_As_Int : constant Int := Int (Container.Plain.Last);
+ Old_Last_As_Int : constant Int := Int (Container.Last);
begin
if Old_Last_As_Int > Int'Last - N then
-- Resolve issue of capacity vs. max index ???
end;
- if Container.Plain.Busy > 0 then
+ if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
declare
- EA : Elements_Array renames Container.Plain.Elements;
+ EA : Elements_Array renames Container.Elements;
BB : constant Int'Base := Int (Before) - Int (No_Index);
B : constant Count_Type := Count_Type (BB);
L : constant Count_Type := Count_Type (LL);
begin
- if Before <= Container.Plain.Last then
+ if Before <= Container.Last then
declare
II : constant Int'Base := BB + N;
I : constant Count_Type := Count_Type (II);
end if;
end;
- Container.Plain.Last := New_Last;
+ Container.Last := New_Last;
end Insert_Space;
procedure Insert_Space
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Count = 0 then
if not Before.Valid
- or else Before.Index > Container.Plain.Last
+ or else Before.Index > Container.Last
then
Position := No_Element;
else
end if;
if not Before.Valid
- or else Before.Index > Container.Plain.Last
+ or else Before.Index > Container.Last
then
- if Container.Plain.Last = Index_Type'Last then
+ if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
end if;
- Index := Container.Plain.Last + 1;
+ Index := Container.Last + 1;
else
Index := Before.Index;
not null access procedure (Container : Vector; Position : Cursor))
is
V : Vector renames Container'Unrestricted_Access.all;
- B : Natural renames V.Plain.Busy;
+ B : Natural renames V.Busy;
begin
B := B + 1;
function Last_Index (Container : Vector) return Extended_Index is
begin
- if Container.K = Plain then
- return Container.Plain.Last;
- else
- return Container.Last;
- end if;
+ return Container.Last;
end Last_Index;
------------
----------
function Left (Container : Vector; Position : Cursor) return Vector is
- Fst : Count_Type;
+ C : Vector (Container.Capacity) :=
+ Copy (Container, Container.Capacity);
begin
- if Container.K = Plain then
- Fst := 1;
- else
- Fst := Container.First;
- end if;
-
- if not Position.Valid then
- return (Container.Capacity, Container.Plain, Part, Fst,
- Last_Index (Container));
+ if Position = No_Element then
+ return C;
end if;
-
- if Position.Index > Last_Index (Container) then
- raise Constraint_Error with
- "Before index is out of range (too large)";
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error;
end if;
- return (Container.Capacity, Container.Plain, Part, Fst,
- (Position.Index - 1));
+ while C.Last /= Position.Index - 1 loop
+ Delete_Last (C);
+ end loop;
+ return C;
end Left;
----------
begin
- if Target.K /= Plain or Source.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
-
if Target'Address = Source'Address then
return;
end if;
- if Target.Plain.Busy > 0 then
+ if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (Target is busy)";
end if;
- if Source.Plain.Busy > 0 then
+ if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (Source is busy)";
end if;
-- We could also write this as a loop, and incrementally
-- copy elements from source to target.
- Target.Plain.Last := No_Index; -- in case array assignment files
- Target.Plain.Elements (1 .. N) := Source.Plain.Elements (1 .. N);
+ Target.Last := No_Index; -- in case array assignment files
+ Target.Elements (1 .. N) := Source.Elements (1 .. N);
- Target.Plain.Last := Source.Plain.Last;
- Source.Plain.Last := No_Index;
+ Target.Last := Source.Last;
+ Source.Last := No_Index;
end Move;
----------
Process : not null access procedure (Element : Element_Type))
is
V : Vector renames Container'Unrestricted_Access.all;
- B : Natural renames V.Plain.Busy;
- L : Natural renames V.Plain.Lock;
+ B : Natural renames V.Busy;
+ L : Natural renames V.Lock;
begin
if Index > Last_Index (Container) then
for J in Count_Type range 1 .. Length loop
Last := Last + 1;
- Element_Type'Read (Stream, Container.Plain.Elements (J));
- Container.Plain.Last := Last;
+ Element_Type'Read (Stream, Container.Elements (J));
+ Container.Last := Last;
end loop;
end Read;
New_Item : Element_Type)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
- if Index > Container.Plain.Last then
+ if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
- if Container.Plain.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is locked)";
end if;
I : constant Count_Type := Count_Type (II);
begin
- Container.Plain.Elements (I) := New_Item;
+ Container.Elements (I) := New_Item;
end;
end Replace_Element;
New_Item : Element_Type)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not Position.Valid then
raise Constraint_Error with "Position cursor has no element";
end if;
- if Position.Index > Container.Plain.Last then
+ if Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
- if Container.Plain.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is locked)";
end if;
I : constant Count_Type := Count_Type (II);
begin
- Container.Plain.Elements (I) := New_Item;
+ Container.Elements (I) := New_Item;
end;
end Replace_Element;
Capacity : Capacity_Subtype)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Capacity > Container.Capacity then
raise Constraint_Error; -- ???
procedure Reverse_Elements (Container : in out Vector) is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Length (Container) <= 1 then
return;
end if;
- if Container.Plain.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is locked)";
end if;
declare
I, J : Count_Type;
- E : Elements_Array renames Container.Plain.Elements;
+ E : Elements_Array renames Container.Elements;
begin
I := 1;
not null access procedure (Container : Vector; Position : Cursor))
is
V : Vector renames Container'Unrestricted_Access.all;
- B : Natural renames V.Plain.Busy;
+ B : Natural renames V.Busy;
begin
B := B + 1;
-----------
function Right (Container : Vector; Position : Cursor) return Vector is
- Fst : Count_Type;
+ C : Vector (Container.Capacity) :=
+ Copy (Container, Container.Capacity);
begin
- if Container.K = Plain then
- Fst := 1;
- else
- Fst := Container.First;
+ if Position = No_Element then
+ Clear (C);
+ return C;
end if;
-
- if not Position.Valid then
- return (Container.Capacity, Container.Plain, Part, Fst, No_Index);
- end if;
-
- if Position.Index > Last_Index (Container) then
- raise Constraint_Error with
- "Position index is out of range (too large)";
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error;
end if;
- Fst := Fst + Count_Type (Int (Position.Index) - Int (No_Index)) - 1;
-
- return (Container.Capacity, Container.Plain, Part, Fst,
- (Last_Index (Container) - Position.Index + 1));
+ while C.Last /= Container.Last - Position.Index + 1 loop
+ Delete_First (C);
+ end loop;
+ return C;
end Right;
----------------
Length : Capacity_Subtype)
is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if Length = Formal_Vectors.Length (Container) then
return;
end if;
- if Container.Plain.Busy > 0 then
+ if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
Last_As_Int : constant Int'Base :=
Int (Index_Type'First) + Int (Length) - 1;
begin
- Container.Plain.Last := Index_Type'Base (Last_As_Int);
+ Container.Last := Index_Type'Base (Last_As_Int);
end;
end Set_Length;
procedure Swap (Container : in out Vector; I, J : Index_Type) is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
- if I > Container.Plain.Last then
+ if I > Container.Last then
raise Constraint_Error with "I index is out of range";
end if;
- if J > Container.Plain.Last then
+ if J > Container.Last then
raise Constraint_Error with "J index is out of range";
end if;
return;
end if;
- if Container.Plain.Lock > 0 then
+ if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is locked)";
end if;
II : constant Int'Base := Int (I) - Int (No_Index);
JJ : constant Int'Base := Int (J) - Int (No_Index);
- EI : Element_Type renames Container.Plain.Elements (Count_Type (II));
- EJ : Element_Type renames Container.Plain.Elements (Count_Type (JJ));
+ EI : Element_Type renames Container.Elements (Count_Type (II));
+ EJ : Element_Type renames Container.Elements (Count_Type (JJ));
EI_Copy : constant Element_Type := EI;
procedure Swap (Container : in out Vector; I, J : Cursor) is
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
if not I.Valid then
raise Constraint_Error with "I cursor has no element";
Last := Index_Type (Last_As_Int);
- return (Length,
- new Plain_Vector'(Length, (others => <>), Last => Last,
- others => <>),
+ return (Length, (others => <>), Last => Last,
others => <>);
end;
end To_Vector;
Last := Index_Type (Last_As_Int);
- return (Length,
- new Plain_Vector'(Length, (others => New_Item), Last => Last,
- others => <>),
+ return (Length, (others => New_Item), Last => Last,
others => <>);
end;
end To_Vector;
Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type))
is
- B : Natural renames Container.Plain.Busy;
- L : Natural renames Container.Plain.Lock;
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
- if Container.K /= Plain then
- raise Constraint_Error
- with "Can't modify part of container";
- end if;
- if Index > Container.Plain.Last then
+ if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
I : constant Count_Type := Count_Type (II);
begin
- Process (Container.Plain.Elements (I));
+ Process (Container.Elements (I));
exception
when others =>
L := L - 1;
Count_Type'Base'Write (Stream, Length (Container));
for J in 1 .. Length (Container) loop
- Element_Type'Write (Stream, Container.Plain.Elements (J));
+ Element_Type'Write (Stream, Container.Elements (J));
end loop;
end Write;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
type Elements_Array is array (Count_Type range <>) of Element_Type;
function "=" (L, R : Elements_Array) return Boolean is abstract;
- type Kind is (Plain, Part);
-
- type Plain_Vector (Capacity : Capacity_Subtype) is record
+ type Vector (Capacity : Capacity_Subtype) is tagged record
Elements : Elements_Array (1 .. Capacity);
Last : Extended_Index := No_Index;
Busy : Natural := 0;
Lock : Natural := 0;
end record;
- type Plain_Access is access all Plain_Vector;
-
- type Vector (Capacity : Capacity_Subtype) is tagged record
- Plain : Plain_Access := new Plain_Vector (Capacity);
- K : Kind := Formal_Vectors.Plain;
- First : Count_Type := 0;
- Last : Index_Type'Base := No_Index;
- end record;
-
use Ada.Streams;
procedure Write
function Find_Numeric_Representation
(Typ : Entity_Id) return Entity_Id;
- -- Given a numeric type Typ, return the smallest integer or floating
- -- point type from Standard, or the smallest unsigned (modular) type
- -- from System.Unsigned_Types, whose range encompasses that of Typ.
+ -- Given a numeric type Typ, return the smallest integer or modular
+ -- type from Interfaces, or the smallest floating point type from
+ -- Standard whose range encompasses that of Typ.
function Make_Helper_Function_Name
(Loc : Source_Ptr;
-- Integer types
- elsif U_Type = Etype (Standard_Short_Short_Integer) then
- Lib_RE := RE_FA_SSI;
+ elsif U_Type = RTE (RE_Integer_8) then
+ Lib_RE := RE_FA_I8;
- elsif U_Type = Etype (Standard_Short_Integer) then
- Lib_RE := RE_FA_SI;
+ elsif U_Type = RTE (RE_Integer_16) then
+ Lib_RE := RE_FA_I16;
- elsif U_Type = Etype (Standard_Integer) then
- Lib_RE := RE_FA_I;
+ elsif U_Type = RTE (RE_Integer_32) then
+ Lib_RE := RE_FA_I32;
- elsif U_Type = Etype (Standard_Long_Integer) then
- Lib_RE := RE_FA_LI;
-
- elsif U_Type = Etype (Standard_Long_Long_Integer) then
- Lib_RE := RE_FA_LLI;
+ elsif U_Type = RTE (RE_Integer_64) then
+ Lib_RE := RE_FA_I64;
-- Unsigned integer types
- elsif U_Type = RTE (RE_Short_Short_Unsigned) then
- Lib_RE := RE_FA_SSU;
-
- elsif U_Type = RTE (RE_Short_Unsigned) then
- Lib_RE := RE_FA_SU;
+ elsif U_Type = RTE (RE_Unsigned_8) then
+ Lib_RE := RE_FA_U8;
- elsif U_Type = RTE (RE_Unsigned) then
- Lib_RE := RE_FA_U;
+ elsif U_Type = RTE (RE_Unsigned_16) then
+ Lib_RE := RE_FA_U16;
- elsif U_Type = RTE (RE_Long_Unsigned) then
- Lib_RE := RE_FA_LU;
+ elsif U_Type = RTE (RE_Unsigned_32) then
+ Lib_RE := RE_FA_U32;
- elsif U_Type = RTE (RE_Long_Long_Unsigned) then
- Lib_RE := RE_FA_LLU;
+ elsif U_Type = RTE (RE_Unsigned_64) then
+ Lib_RE := RE_FA_U64;
elsif Is_RTE (U_Type, RE_Unbounded_String) then
Lib_RE := RE_FA_String;
Make_Object_Declaration (Loc,
Defining_Identifier => Counter,
Object_Definition =>
- New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
+ New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
Expression =>
Make_Integer_Literal (Loc, Initial_Counter_Value)));
-- Integer types
- elsif U_Type = Etype (Standard_Short_Short_Integer) then
- Lib_RE := RE_TA_SSI;
-
- elsif U_Type = Etype (Standard_Short_Integer) then
- Lib_RE := RE_TA_SI;
+ elsif U_Type = RTE (RE_Integer_8) then
+ Lib_RE := RE_TA_I8;
- elsif U_Type = Etype (Standard_Integer) then
- Lib_RE := RE_TA_I;
+ elsif U_Type = RTE (RE_Integer_16) then
+ Lib_RE := RE_TA_I16;
- elsif U_Type = Etype (Standard_Long_Integer) then
- Lib_RE := RE_TA_LI;
+ elsif U_Type = RTE (RE_Integer_32) then
+ Lib_RE := RE_TA_I32;
- elsif U_Type = Etype (Standard_Long_Long_Integer) then
- Lib_RE := RE_TA_LLI;
+ elsif U_Type = RTE (RE_Integer_64) then
+ Lib_RE := RE_TA_I64;
-- Unsigned integer types
- elsif U_Type = RTE (RE_Short_Short_Unsigned) then
- Lib_RE := RE_TA_SSU;
+ elsif U_Type = RTE (RE_Unsigned_8) then
+ Lib_RE := RE_TA_U8;
- elsif U_Type = RTE (RE_Short_Unsigned) then
- Lib_RE := RE_TA_SU;
+ elsif U_Type = RTE (RE_Unsigned_16) then
+ Lib_RE := RE_TA_U16;
- elsif U_Type = RTE (RE_Unsigned) then
- Lib_RE := RE_TA_U;
+ elsif U_Type = RTE (RE_Unsigned_32) then
+ Lib_RE := RE_TA_U32;
- elsif U_Type = RTE (RE_Long_Unsigned) then
- Lib_RE := RE_TA_LU;
-
- elsif U_Type = RTE (RE_Long_Long_Unsigned) then
- Lib_RE := RE_TA_LLU;
+ elsif U_Type = RTE (RE_Unsigned_64) then
+ Lib_RE := RE_TA_U64;
elsif Is_RTE (U_Type, RE_Unbounded_String) then
Lib_RE := RE_TA_String;
-- Integer types (walk back to the base type)
- elsif U_Type = Etype (Standard_Short_Short_Integer) then
- Lib_RE := RE_TC_SSI;
-
- elsif U_Type = Etype (Standard_Short_Integer) then
- Lib_RE := RE_TC_SI;
+ elsif U_Type = RTE (RE_Integer_8) then
+ Lib_RE := RE_TC_I8;
- elsif U_Type = Etype (Standard_Integer) then
- Lib_RE := RE_TC_I;
+ elsif U_Type = RTE (RE_Integer_16) then
+ Lib_RE := RE_TC_I16;
- elsif U_Type = Etype (Standard_Long_Integer) then
- Lib_RE := RE_TC_LI;
+ elsif U_Type = RTE (RE_Integer_32) then
+ Lib_RE := RE_TC_I32;
- elsif U_Type = Etype (Standard_Long_Long_Integer) then
- Lib_RE := RE_TC_LLI;
+ elsif U_Type = RTE (RE_Integer_64) then
+ Lib_RE := RE_TC_I64;
-- Unsigned integer types
- elsif U_Type = RTE (RE_Short_Short_Unsigned) then
- Lib_RE := RE_TC_SSU;
+ elsif U_Type = RTE (RE_Unsigned_8) then
+ Lib_RE := RE_TC_U8;
- elsif U_Type = RTE (RE_Short_Unsigned) then
- Lib_RE := RE_TC_SU;
+ elsif U_Type = RTE (RE_Unsigned_16) then
+ Lib_RE := RE_TC_U16;
- elsif U_Type = RTE (RE_Unsigned) then
- Lib_RE := RE_TC_U;
+ elsif U_Type = RTE (RE_Unsigned_32) then
+ Lib_RE := RE_TC_U32;
- elsif U_Type = RTE (RE_Long_Unsigned) then
- Lib_RE := RE_TC_LU;
-
- elsif U_Type = RTE (RE_Long_Long_Unsigned) then
- Lib_RE := RE_TC_LLU;
+ elsif U_Type = RTE (RE_Unsigned_64) then
+ Lib_RE := RE_TC_U64;
elsif Is_RTE (U_Type, RE_Unbounded_String) then
Lib_RE := RE_TC_String;
begin
Append_To (Parameter_List,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc),
+ Name => New_Occurrence_Of (RTE (RE_TA_I32), Loc),
Parameter_Associations => New_List (Expr_Node)));
end Add_Long_Parameter;
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
- (RTE (RE_TA_LI), Loc),
+ (RTE (RE_TA_I32), Loc),
Parameter_Associations =>
New_List (
Make_Integer_Literal
Inner_TypeCode := Make_Constructed_TypeCode
(RTE (RE_TC_Array), New_List (
Build_To_Any_Call (
- OK_Convert_To (RTE (RE_Long_Unsigned),
+ OK_Convert_To (RTE (RE_Unsigned_32),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Length,
Inner_TypeCode := Make_Constructed_TypeCode
(RTE (RE_TC_Sequence), New_List (
Build_To_Any_Call (
- OK_Convert_To (RTE (RE_Long_Unsigned),
+ OK_Convert_To (RTE (RE_Unsigned_32),
Make_Integer_Literal (Loc, 0)),
Decls),
Build_To_Any_Call (Inner_TypeCode, Decls)));
begin
if Is_Unsigned_Type (Typ) then
- if P_Size <= Standard_Short_Short_Integer_Size then
- return RTE (RE_Short_Short_Unsigned);
+ if P_Size <= 8 then
+ return RTE (RE_Unsigned_8);
- elsif P_Size <= Standard_Short_Integer_Size then
- return RTE (RE_Short_Unsigned);
+ elsif P_Size <= 16 then
+ return RTE (RE_Unsigned_16);
- elsif P_Size <= Standard_Integer_Size then
- return RTE (RE_Unsigned);
-
- elsif P_Size <= Standard_Long_Integer_Size then
- return RTE (RE_Long_Unsigned);
+ elsif P_Size <= 32 then
+ return RTE (RE_Unsigned_32);
else
- return RTE (RE_Long_Long_Unsigned);
+ return RTE (RE_Unsigned_64);
end if;
elsif Is_Integer_Type (Typ) then
- if P_Size <= Standard_Short_Short_Integer_Size then
- return Standard_Short_Short_Integer;
+ if P_Size <= 8 then
+ return RTE (RE_Integer_8);
elsif P_Size <= Standard_Short_Integer_Size then
- return Standard_Short_Integer;
+ return RTE (RE_Integer_16);
elsif P_Size <= Standard_Integer_Size then
- return Standard_Integer;
-
- elsif P_Size <= Standard_Long_Integer_Size then
- return Standard_Long_Integer;
+ return RTE (RE_Integer_32);
else
- return Standard_Long_Long_Integer;
+ return RTE (RE_Integer_64);
end if;
elsif Is_Floating_Point_Type (Typ) then
Make_Object_Declaration (Loc,
Defining_Identifier => Inner_Counter,
Object_Definition =>
- New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
+ New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
Expression =>
Make_Integer_Literal (Loc, 0)));
end if;
Attribute_Name => Name_Length,
Expressions =>
New_List (Make_Integer_Literal (Loc, Depth)));
- Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
+ Set_Etype (Length_Node, RTE (RE_Unsigned_32));
Add_Process_Element (Dimen_Stmts,
Datum => Length_Node,
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
PCS_Version_Number : constant array (PCS_Names) of Int :=
(Name_No_DSA => 1,
Name_GARLIC_DSA => 1,
- Name_PolyORB_DSA => 4);
+ Name_PolyORB_DSA => 5);
-- PCS interface version. This is used to check for consistency between the
-- compiler used to generate distribution stubs and the PCS implementation.
-- It must be incremented whenever a change is made to the generated code
function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is
begin
return VM_Target /= No_VM
- and then Nkind (N) = N_Identifier
- and then Present (Renamed_Object (Entity (N)))
- and then Nkind (Renamed_Object (Entity (N))) = N_Slice;
+ and then (Nkind (N) = N_Slice
+ or else
+ (Nkind (N) = N_Identifier
+ and then Present (Renamed_Object (Entity (N)))
+ and then Nkind (Renamed_Object (Entity (N)))
+ = N_Slice));
end Is_VM_By_Copy_Actual;
--------------------
ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads \
ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \
- ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
- ada/exp_atag.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads \
- ada/exp_dist.adb ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads \
- ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/get_targ.ads \
- ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hlo.ads \
- ada/hostparm.ads ada/inline.ads ada/inline.adb ada/interfac.ads \
- ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \
- ada/lib-sort.adb ada/namet.ads ada/namet.adb ada/nlists.ads \
- ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
- ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem.adb \
- ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \
- ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \
- ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \
- ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \
- ada/sem_dist.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_util.ads \
- ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
- ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \
- ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \
- ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \
- ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
+ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/errout.adb \
+ ada/erroutc.ads ada/erroutc.adb ada/exp_atag.ads ada/exp_ch7.ads \
+ ada/exp_disp.ads ada/exp_dist.ads ada/exp_dist.adb ada/exp_strm.ads \
+ ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \
+ ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \
+ ada/g-htable.ads ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads \
+ ada/inline.ads ada/inline.adb ada/interfac.ads ada/lib.ads ada/lib.adb \
+ ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/namet.ads \
+ ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
+ ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
+ ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \
+ ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch10.ads \
+ ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads \
+ ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \
+ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_dist.ads \
+ ada/sem_eval.ads ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
+ ada/stringt.ads ada/stringt.adb ada/stylesw.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \
+ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \
+ ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
+ ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+ ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/widechar.ads
ada/exp_fixd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \
ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \
ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \
ada/sem_ch9.ads ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \
- ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \
- ada/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \
- ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
- ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
+ ada/stringt.ads ada/stylesw.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
+ ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
ada/instpar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/restrict.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \
- ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \
- ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/errout.adb \
- ada/erroutc.ads ada/erroutc.adb ada/fname.ads ada/fname-uf.ads \
- ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads \
- ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \
- ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \
- ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \
+ ada/atree.adb ada/casing.ads ada/casing.adb ada/csets.ads ada/debug.ads \
+ ada/einfo.ads ada/einfo.adb ada/err_vars.ads ada/errout.ads \
+ ada/errout.adb ada/erroutc.ads ada/erroutc.adb ada/fname.ads \
+ ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \
+ ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \
+ ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \
ada/restrict.ads ada/restrict.adb ada/rident.ads ada/scans.ads \
ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \
s-vxwext.adb<s-vxwext-kernel-smp.adb \
system.ads<system-vxworks-ppc-kernel.ads
+ EH_MECHANISM=-gcc
EXTRA_GNATRTL_TASKING_OBJS=affinity.o
else
LIBGNAT_TARGET_PAIRS += \
s-tpopsp.adb<s-tpopsp-vxworks.adb
ifeq ($(strip $(filter-out kernel,$(THREAD_KIND))),)
+ EH_MECHANISM=-gcc
LIBGNAT_TARGET_PAIRS += \
s-vxwext.ads<s-vxwext-kernel.ads \
s-vxwext.adb<s-vxwext-kernel.adb \
g-bytswa.adb<g-bytswa-x86.adb \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-tpopsp.adb<s-tpopsp-tls.adb \
g-sercom.adb<g-sercom-linux.adb
ifeq ($(strip $(filter-out marte,$(THREAD_KIND))),)
endif
THREADSLIB = -lpthreads
-
+ EH_MECHANISM=-gcc
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-aix.adb \
indepsw.adb<indepsw-aix.adb
s-intman.adb<s-intman-posix.adb \
s-linux.ads<s-linux.ads \
s-osinte.adb<s-osinte-posix.adb \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-tpopsp.adb<s-tpopsp-tls.adb \
g-sercom.adb<g-sercom-linux.adb \
$(ATOMICS_TARGET_PAIRS)
s-tasinf.ads<s-tasinf-linux.ads \
s-tasinf.adb<s-tasinf-linux.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb
+ s-tpopsp.adb<s-tpopsp-tls.adb
LIBGNAT_TARGET_PAIRS_32 = \
g-trasym.ads<g-trasym-unimplemented.ads \
s-taprop.adb<s-taprop-linux.adb \
s-tasinf.ads<s-tasinf-linux.ads \
s-tasinf.adb<s-tasinf-linux.adb \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-tpopsp.adb<s-tpopsp-tls.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
g-sercom.adb<g-sercom-linux.adb \
system.ads<system-linux-ia64.ads \
s-taprop.adb<s-taprop-linux.adb \
s-tasinf.ads<s-tasinf-linux.ads \
s-tasinf.adb<s-tasinf-linux.adb \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-tpopsp.adb<s-tpopsp-tls.adb \
s-taspri.ads<s-taspri-posix.ads \
g-sercom.adb<g-sercom-linux.adb \
system.ads<system-linux-x86_64.ads \
end if;
Main := Project_Tree.Shared.String_Elements.Table
- (Main).Next;
+ (Main).Next;
end loop;
if Proj.Project.Library then
Libraries_Present : in out Boolean)
is
pragma Unreferenced (Tree);
+
Path_Option : constant String_Access :=
MLib.Linker_Library_Path_Option;
Attribute_Or_Array_Name =>
Name_Local_Config_File,
In_Package => Pkg,
- Shared => Project_Tree.Shared);
+ Shared =>
+ Project_Tree.Shared);
end if;
if Variable /= Nil_Variable_Value
package Makeutl is
type Fail_Proc is access procedure (S : String);
+
Do_Fail : Fail_Proc := Osint.Fail'Access;
-- Failing procedure called from procedure Test_If_Relative_Path below. May
-- be redirected.
Project_Tree : constant Project_Tree_Ref :=
- new Project_Tree_Data (Is_Root_Tree => True);
+ new Project_Tree_Data (Is_Root_Tree => True);
-- The project tree
Source_Info_Option : constant String := "--source-info=";
Lib_Dirpath :=
new String'(Get_Name_String (For_Project.Library_Dir.Display_Name));
- Lib_Filename := new String'
- (Get_Name_String (For_Project.Library_Name));
+ Lib_Filename :=
+ new String'(Get_Name_String (For_Project.Library_Name));
case For_Project.Library_Kind is
when Static =>
-- Raises exception Invalid_Config with given message
procedure Apply_Config_File
- (Config_File : Prj.Project_Id;
- Project_Tree : Prj.Project_Tree_Ref);
+ (Config_File : Prj.Project_Id;
+ Project_Tree : Prj.Project_Tree_Ref);
-- Apply the configuration file settings to all the projects in the
-- project tree. The Project_Tree must have been parsed first, and
-- processed through the first phase so that all its projects are known.
String_Element_Table.Increment_Last
(Shared.String_Elements);
- New_List := String_Element_Table.Last
- (Shared.String_Elements);
+ New_List :=
+ String_Element_Table.Last (Shared.String_Elements);
-- Value of attribute is new list
Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr;
loop
-
-- Get each element of configuration list
Conf_Elem := Shared.String_Elements.Table (Conf_List);
- New_Elem := Conf_Elem;
+ New_Elem := Conf_Elem;
Conf_List := Conf_Elem.Next;
if Conf_List = Nil_String then
User_Decl.Arrays := Array_Table.Last (Shared.Arrays);
Shared.Arrays.Table (User_Decl.Arrays) := User_Array;
- else
- -- Otherwise, check each array element
+ -- Otherwise, check each array element
+ else
Conf_Array_Elem_Id := Conf_Array.Value;
while Conf_Array_Elem_Id /= No_Array_Element loop
Conf_Array_Elem :=
User_Array_Elem_Id := User_Array_Elem.Next;
end loop;
- -- If the array element does not exist in the user array,
- -- insert a shallow copy of the conf array element in the
- -- user array.
+ -- If the array element doesn't exist in the user array, insert
+ -- a shallow copy of the conf array element in the user array.
if User_Array_Elem_Id = No_Array_Element then
Array_Element_Table.Increment_Last (Shared.Array_Elements);
User_Array_Elem;
Shared.Arrays.Table (User_Array_Id) := User_Array;
- -- Otherwise, if the value is a string list, prepend the
- -- user array element with the conf array element value.
+ -- Otherwise, if the value is a string list, prepend the conf
+ -- array element value to the array element.
elsif Conf_Array_Elem.Value.Kind = List then
Conf_List := Conf_Array_Elem.Value.Values;
Index : String := "";
Pkg : Project_Node_Id := Empty_Node)
is
- Attr : Project_Node_Id;
+ Attr : Project_Node_Id;
pragma Unreferenced (Attr);
Expr : Name_Id := No_Name;
Val : Name_Id := No_Name;
Parent : Project_Node_Id := Config_File;
+
begin
if Index /= "" then
Name_Len := Index'Length;
-----------------------
procedure Apply_Config_File
- (Config_File : Prj.Project_Id;
- Project_Tree : Prj.Project_Tree_Ref)
+ (Config_File : Prj.Project_Id;
+ Project_Tree : Prj.Project_Tree_Ref)
is
Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
+
Conf_Decl : constant Declarations := Config_File.Decl;
Conf_Pack_Id : Package_Id;
Conf_Pack : Package_Element;
Dummy : in out Boolean)
is
pragma Unreferenced (Dummy, In_Tree);
+
Path : constant Path_Name_Type :=
Get_Object_Directory
(Project,
State : in out Integer)
is
pragma Unreferenced (State, In_Tree);
+
Lang : constant Language_Ptr :=
Get_Language_From_Name (Project, "ada");
Naming : Lang_Naming_Data;
State : in out Integer)
is
pragma Unreferenced (State);
+
Source : Source_Id;
Suffix : File_Name_Type;
Iter : Source_Iterator;
Dummy : in out Integer)
is
pragma Unreferenced (Dummy, Tree);
+
begin
-- ??? Set_Ada_Paths has a different behavior for library project
-- files, should we have the same ?
Dummy : in out Integer)
is
pragma Unreferenced (Dummy);
+
Current : String_List_Id := Prj.Source_Dirs;
The_String : String_Element;
-- information which is only useful while processing the project, and can
-- be discarded as soon as we have finished processing the project
- package Files_Htable is new GNAT.Dynamic_HTables.Simple_HTable
- (Header_Num => Header_Num,
- Element => Source_Id,
- No_Element => No_Source,
- Key => File_Name_Type,
- Hash => Hash,
- Equal => "=");
- -- Mapping from base file names to Source_Id (containing full info about
- -- the source).
-
type Tree_Processing_Data is record
Tree : Project_Tree_Ref;
Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- File_To_Source : Files_Htable.Instance;
Flags : Prj.Processing_Flags;
end record;
-- Temporary data which is needed while parsing a project. It does not need
Source := Prev_Unit.File_Names (Kind);
else
- Source := Files_Htable.Get (Data.File_To_Source, File_Name);
+ Source := Source_Files_Htable.Get
+ (Data.Tree.Source_Files_HT, File_Name);
if Source /= No_Source
and then Source.Index = Index
Data.Tree.Replaced_Source_Number :=
Data.Tree.Replaced_Source_Number - 1;
end if;
-
- Files_Htable.Set (Data.File_To_Source, File_Name, Id);
end Add_Source;
------------------------------
Data : Tree_Processing_Data :=
(Tree => Tree,
Node_Tree => Node_Tree,
- File_To_Source => Files_Htable.Nil,
Flags => Flags);
Project_Files : constant Prj.Variable_Value :=
Source : Source_Id;
Iter : Source_Iterator;
Found : Boolean := False;
- Path : Path_Information;
begin
Iter := For_Each_Source (Data.Tree, Project.Project);
Source := Prj.Element (Iter);
exit when Source = No_Source;
+ -- If the full source path is unknown for this source_id, there
+ -- could be several reasons:
+ -- * we simply did not find the file itself, this is an error
+ -- * we have a multi-unit source file. Another Source_Id from
+ -- the same file has received the full path, so we need to
+ -- propagate it.
+
if Source.Naming_Exception
and then Source.Path = No_Path_Information
then
if Source.Unit /= No_Unit_Index then
Found := False;
- -- For multi-unit source files, source_id gets duplicated
- -- once for every unit. Only the first source_id got its
- -- full path set.
+ if Source.Index /= 0 then -- Only multi-unit files
+ declare
+ S : Source_Id :=
+ Source_Files_Htable.Get
+ (Data.Tree.Source_Files_HT, Source.File);
+ begin
+ while S /= null loop
+ if S.Path /= No_Path_Information then
+ Source.Path := S.Path;
+ Found := True;
- if Source.Index /= 0 then
- Path := Files_Htable.Get
- (Data.File_To_Source, Source.File).Path;
+ if Current_Verbosity = High then
+ Debug_Output
+ ("Setting full path for "
+ & Get_Name_String (Source.File)
+ & " at" & Source.Index'Img
+ & " to "
+ & Get_Name_String (Source.Path.Name));
+ end if;
- if Path /= No_Path_Information then
- Found := True;
- end if;
+ exit;
+ end if;
+
+ S := S.Next_With_File_Name;
+ end loop;
+ end;
end if;
if not Found then
(Data.Flags, Data.Flags.Missing_Source_Files,
"source file %% for unit %% not found",
No_Location, Project.Project);
-
- else
- Source.Path := Path;
-
- if Current_Verbosity = High then
- Debug_Indent;
-
- if Source.Path /= No_Path_Information then
- Write_Line ("Setting full path for "
- & Get_Name_String (Source.File)
- & " at" & Source.Index'Img
- & " to "
- & Get_Name_String (Path.Name));
- end if;
- end if;
end if;
end if;
Flags : Prj.Processing_Flags)
is
begin
- Files_Htable.Reset (Data.File_To_Source);
Data.Tree := Tree;
Data.Node_Tree := Node_Tree;
Data.Flags := Flags;
----------
procedure Free (Data : in out Tree_Processing_Data) is
+ pragma Unreferenced (Data);
begin
- Files_Htable.Reset (Data.File_To_Source);
+ null;
end Free;
----------------
then
Debug_Output ("Override kind for "
& Get_Name_String (Source.File)
+ & " idx=" & Source.Index'Img
& " kind=" & Source.Kind'Img);
end if;
Check_Name := True;
else
+ -- Set the full path for the source_id (which might have been
+ -- created when parsing the naming exceptions, and therefore
+ -- might not have the full path).
+ -- We only set this for this source_id, but not for other
+ -- source_id in the same file (case of multi-unit source files)
+ -- For the latter, they will be set in Find_Sources when we
+ -- check that all source_id have known full paths.
+ -- Doing this later saves one htable lookup per file in the
+ -- common case where the user is not using multi-unit files.
+
Name_Loc.Source.Path := (Path, Display_Path);
Source_Paths_Htable.Set
- (Data.Tree.Source_Paths_HT,
- Path,
- Name_Loc.Source);
+ (Data.Tree.Source_Paths_HT, Path, Name_Loc.Source);
-- Check if this is a subunit
Override_Kind (Name_Loc.Source, Sep);
end if;
end if;
-
- Files_Htable.Set
- (Data.File_To_Source, File_Name, Name_Loc.Source);
end if;
end if;
end if;
procedure Get_Sources_From_Source_Info;
-- Get the source information from the tables that were created when a
- -- source info fie was read.
+ -- source info file was read.
---------------------------
-- Check_Missing_Sources --
Id.Language := Lang_Id;
Id.Kind := Src.Kind;
-
Id.Index := Src.Index;
Id.Path :=
Id.Next_In_Lang := Id.Language.First_Source;
Id.Language.First_Source := Id;
- Files_Htable.Set (Data.File_To_Source, Id.File, Id);
-
Next (Iter);
end loop;
end Get_Sources_From_Source_Info;
-- as processed, call itself recursively for all imported projects and a
-- extended project, if any. Then process the declarative items of the
-- project.
+ --
-- Is_Root_Project should be true only for the project that the user
-- explicitly loaded. In the context of aggregate projects, only that
-- project is allowed to modify the environment that will be used to load
(Next => Decl.Attributes,
Name => Attribute_Name_Of (The_Attribute),
Value => New_Attribute);
- Decl.Attributes := Variable_Element_Table.Last
- (Shared.Variable_Elements);
+ Decl.Attributes :=
+ Variable_Element_Table.Last
+ (Shared.Variable_Elements);
end;
end if;
-- This literal string list is the first term in a
-- string list expression
- Result.Values := String_Element_Table.Last
- (Shared.String_Elements);
+ Result.Values :=
+ String_Element_Table.Last
+ (Shared.String_Elements);
else
Shared.String_Elements.Table (Last).Next :=
String_Element_Table.Last (Shared.String_Elements);
end if;
- Last := String_Element_Table.Last
- (Shared.String_Elements);
+ Last :=
+ String_Element_Table.Last (Shared.String_Elements);
Shared.String_Elements.Table (Last) :=
(Value => Value.Value,
The_Name :=
Name_Of (Term_Package, From_Project_Node_Tree);
- The_Package := The_Project.Decl.Packages;
+ The_Package := The_Project.Decl.Packages;
while The_Package /= No_Package
and then Shared.Packages.Table (The_Package).Name /=
The_Name
while The_Variable_Id /= No_Variable
and then Shared.Variable_Elements.Table
- (The_Variable_Id).Name /= The_Name
+ (The_Variable_Id).Name /= The_Name
loop
- The_Variable_Id := Shared.Variable_Elements.Table
- (The_Variable_Id).Next;
+ The_Variable_Id :=
+ Shared.Variable_Elements.Table
+ (The_Variable_Id).Next;
end loop;
end if;
begin
if The_Package /= No_Package then
- The_Array := Shared.Packages.Table
- (The_Package).Decl.Arrays;
+ The_Array :=
+ Shared.Packages.Table (The_Package).Decl.Arrays;
else
The_Array := The_Project.Decl.Arrays;
end if;
while The_Array /= No_Array
and then Shared.Arrays.Table (The_Array).Name /=
- The_Name
+ The_Name
loop
The_Array := Shared.Arrays.Table (The_Array).Next;
end loop;
(The_Element).Index /= Array_Index
loop
The_Element :=
- Shared.Array_Elements.Table
- (The_Element).Next;
+ Shared.Array_Elements.Table (The_Element).Next;
end loop;
end if;
if The_Element /= No_Array_Element then
- The_Variable := Shared.Array_Elements.Table
- (The_Element).Value;
+ The_Variable :=
+ Shared.Array_Elements.Table (The_Element).Value;
else
if Expression_Kind_Of
- (The_Current_Term, From_Project_Node_Tree) =
+ (The_Current_Term, From_Project_Node_Tree) =
List
then
The_Variable :=
end if;
if not Done then
- -- Count the number of string
+
+ -- Count the number of strings
declare
Saved : constant Positive := First;
- begin
+ begin
Nmb := 1;
loop
Lst :=
Error_Msg
(Env.Flags, "value %% is illegal for typed string %%",
Loc, Project);
+
when Warning =>
Error_Msg
(Env.Flags, "?value %% is illegal for typed string %%",
Loc, Project);
Reset_Value := True;
+
when Silent =>
Reset_Value := True;
end case;
function Value_Of
(Variable_Name : Name_Id;
In_Variables : Variable_Id;
- Shared : Shared_Project_Tree_Data_Access) return Variable_Value
+ Shared : Shared_Project_Tree_Data_Access) return Variable_Value
is
Current : Variable_Id;
The_Variable : Variable;
function Value_Of
(Variable_Name : Name_Id;
In_Variables : Variable_Id;
- Shared : Shared_Project_Tree_Data_Access) return Variable_Value;
+ Shared : Shared_Project_Tree_Data_Access) return Variable_Value;
-- Returns a specified variable in a variable list. Returns null if
-- In_Variables is null or if Variable_Name is not the name of a
-- variable in In_Variables. Caller must ensure that Name is lower case.
Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil;
procedure Recursive_Check
- (Project : Project_Id; Tree : Project_Tree_Ref);
+ (Project : Project_Id;
+ Tree : Project_Tree_Ref);
-- Check if a project has already been seen. If not seen, mark it as
-- Seen, Call Action, and check all its imported projects.
---------------------
procedure Recursive_Check
- (Project : Project_Id; Tree : Project_Tree_Ref)
+ (Project : Project_Id;
+ Tree : Project_Tree_Ref)
is
List : Project_List;
Agg : Aggregated_Project_List;
-- Visible tables
if Tree.Is_Root_Tree then
+
-- We cannot use 'Access here:
-- "illegal attribute for discriminant-dependent component"
-- However, we know this is valid since Shared and Shared_Data have
-- the same lifetime and will always exist concurrently.
+
Tree.Shared := Tree.Shared_Data'Unrestricted_Access;
- Name_List_Table.Init (Tree.Shared.Name_Lists);
- Number_List_Table.Init (Tree.Shared.Number_Lists);
- String_Element_Table.Init (Tree.Shared.String_Elements);
- Variable_Element_Table.Init (Tree.Shared.Variable_Elements);
- Array_Element_Table.Init (Tree.Shared.Array_Elements);
- Array_Table.Init (Tree.Shared.Arrays);
- Package_Table.Init (Tree.Shared.Packages);
+ Name_List_Table.Init (Tree.Shared.Name_Lists);
+ Number_List_Table.Init (Tree.Shared.Number_Lists);
+ String_Element_Table.Init (Tree.Shared.String_Elements);
+ Variable_Element_Table.Init (Tree.Shared.Variable_Elements);
+ Array_Element_Table.Init (Tree.Shared.Array_Elements);
+ Array_Table.Init (Tree.Shared.Arrays);
+ Package_Table.Init (Tree.Shared.Packages);
end if;
- Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
- Source_Files_Htable.Reset (Tree.Source_Files_HT);
- Replaced_Source_HTable.Reset (Tree.Replaced_Sources);
+ Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
+ Source_Files_Htable.Reset (Tree.Source_Files_HT);
+ Replaced_Source_HTable.Reset (Tree.Replaced_Sources);
Tree.Replaced_Source_Number := 0;
-- Private part table
- Temp_Files_Table.Init (Tree.Private_Part.Temp_Files);
+ Temp_Files_Table.Init (Tree.Private_Part.Temp_Files);
Tree.Private_Part.Current_Source_Path_File := No_Path;
Tree.Private_Part.Current_Object_Path_File := No_Path;
Source_Paths_HT : Source_Paths_Htable.Instance;
-- Full path to Source_Id
+ -- ??? What is behavior for multi-unit source files, where there are
+ -- several source_id per file ?
Source_Info_File_Name : String_Access := null;
-- The name of the source info file, if specified by the builder
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
RE_Current_Task, -- Ada.Task_Identification
RO_AT_Task_Id, -- Ada.Task_Identification
+ RE_Integer_8, -- Interfaces
+ RE_Integer_16, -- Interfaces
+ RE_Integer_32, -- Interfaces
RE_Integer_64, -- Interfaces
RE_Unsigned_8, -- Interfaces
RE_Unsigned_16, -- Interfaces
RE_FA_B, -- System.Partition_Interface
RE_FA_C, -- System.Partition_Interface
RE_FA_F, -- System.Partition_Interface
- RE_FA_I, -- System.Partition_Interface
+ RE_FA_I8, -- System.Partition_Interface
+ RE_FA_I16, -- System.Partition_Interface
+ RE_FA_I32, -- System.Partition_Interface
+ RE_FA_I64, -- System.Partition_Interface
RE_FA_LF, -- System.Partition_Interface
- RE_FA_LI, -- System.Partition_Interface
RE_FA_LLF, -- System.Partition_Interface
- RE_FA_LLI, -- System.Partition_Interface
- RE_FA_LLU, -- System.Partition_Interface
- RE_FA_LU, -- System.Partition_Interface
RE_FA_SF, -- System.Partition_Interface
- RE_FA_SI, -- System.Partition_Interface
- RE_FA_SSI, -- System.Partition_Interface
- RE_FA_SSU, -- System.Partition_Interface
- RE_FA_SU, -- System.Partition_Interface
- RE_FA_U, -- System.Partition_Interface
+ RE_FA_U8, -- System.Partition_Interface
+ RE_FA_U16, -- System.Partition_Interface
+ RE_FA_U32, -- System.Partition_Interface
+ RE_FA_U64, -- System.Partition_Interface
RE_FA_WC, -- System.Partition_Interface
RE_FA_WWC, -- System.Partition_Interface
RE_FA_String, -- System.Partition_Interface
RE_TA_B, -- System.Partition_Interface
RE_TA_C, -- System.Partition_Interface
RE_TA_F, -- System.Partition_Interface
- RE_TA_I, -- System.Partition_Interface
+ RE_TA_I8, -- System.Partition_Interface
+ RE_TA_I16, -- System.Partition_Interface
+ RE_TA_I32, -- System.Partition_Interface
+ RE_TA_I64, -- System.Partition_Interface
RE_TA_LF, -- System.Partition_Interface
- RE_TA_LI, -- System.Partition_Interface
RE_TA_LLF, -- System.Partition_Interface
- RE_TA_LLI, -- System.Partition_Interface
- RE_TA_LLU, -- System.Partition_Interface
- RE_TA_LU, -- System.Partition_Interface
RE_TA_SF, -- System.Partition_Interface
- RE_TA_SI, -- System.Partition_Interface
- RE_TA_SSI, -- System.Partition_Interface
- RE_TA_SSU, -- System.Partition_Interface
- RE_TA_SU, -- System.Partition_Interface
- RE_TA_U, -- System.Partition_Interface
+ RE_TA_U8, -- System.Partition_Interface
+ RE_TA_U16, -- System.Partition_Interface
+ RE_TA_U32, -- System.Partition_Interface
+ RE_TA_U64, -- System.Partition_Interface
RE_TA_WC, -- System.Partition_Interface
RE_TA_WWC, -- System.Partition_Interface
RE_TA_String, -- System.Partition_Interface
RE_TC_B, -- System.Partition_Interface
RE_TC_C, -- System.Partition_Interface
RE_TC_F, -- System.Partition_Interface
- RE_TC_I, -- System.Partition_Interface
+ RE_TC_I8, -- System.Partition_Interface
+ RE_TC_I16, -- System.Partition_Interface
+ RE_TC_I32, -- System.Partition_Interface
+ RE_TC_I64, -- System.Partition_Interface
RE_TC_LF, -- System.Partition_Interface
- RE_TC_LI, -- System.Partition_Interface
RE_TC_LLF, -- System.Partition_Interface
- RE_TC_LLI, -- System.Partition_Interface
- RE_TC_LLU, -- System.Partition_Interface
- RE_TC_LU, -- System.Partition_Interface
RE_TC_SF, -- System.Partition_Interface
- RE_TC_SI, -- System.Partition_Interface
- RE_TC_SSI, -- System.Partition_Interface
- RE_TC_SSU, -- System.Partition_Interface
- RE_TC_SU, -- System.Partition_Interface
- RE_TC_U, -- System.Partition_Interface
+ RE_TC_U8, -- System.Partition_Interface
+ RE_TC_U16, -- System.Partition_Interface
+ RE_TC_U32, -- System.Partition_Interface
+ RE_TC_U64, -- System.Partition_Interface
RE_TC_Void, -- System.Partition_Interface
RE_TC_Opaque, -- System.Partition_Interface
RE_TC_WC, -- System.Partition_Interface
RE_Current_Task => Ada_Task_Identification,
RO_AT_Task_Id => Ada_Task_Identification,
+ RE_Integer_8 => Interfaces,
+ RE_Integer_16 => Interfaces,
+ RE_Integer_32 => Interfaces,
RE_Integer_64 => Interfaces,
RE_Unsigned_8 => Interfaces,
RE_Unsigned_16 => Interfaces,
RE_FA_B => System_Partition_Interface,
RE_FA_C => System_Partition_Interface,
RE_FA_F => System_Partition_Interface,
- RE_FA_I => System_Partition_Interface,
+ RE_FA_I8 => System_Partition_Interface,
+ RE_FA_I16 => System_Partition_Interface,
+ RE_FA_I32 => System_Partition_Interface,
+ RE_FA_I64 => System_Partition_Interface,
RE_FA_LF => System_Partition_Interface,
- RE_FA_LI => System_Partition_Interface,
RE_FA_LLF => System_Partition_Interface,
- RE_FA_LLI => System_Partition_Interface,
- RE_FA_LLU => System_Partition_Interface,
- RE_FA_LU => System_Partition_Interface,
RE_FA_SF => System_Partition_Interface,
- RE_FA_SI => System_Partition_Interface,
- RE_FA_SSI => System_Partition_Interface,
- RE_FA_SSU => System_Partition_Interface,
- RE_FA_SU => System_Partition_Interface,
- RE_FA_U => System_Partition_Interface,
+ RE_FA_U8 => System_Partition_Interface,
+ RE_FA_U16 => System_Partition_Interface,
+ RE_FA_U32 => System_Partition_Interface,
+ RE_FA_U64 => System_Partition_Interface,
RE_FA_WC => System_Partition_Interface,
RE_FA_WWC => System_Partition_Interface,
RE_FA_String => System_Partition_Interface,
RE_TA_B => System_Partition_Interface,
RE_TA_C => System_Partition_Interface,
RE_TA_F => System_Partition_Interface,
- RE_TA_I => System_Partition_Interface,
+ RE_TA_I8 => System_Partition_Interface,
+ RE_TA_I16 => System_Partition_Interface,
+ RE_TA_I32 => System_Partition_Interface,
+ RE_TA_I64 => System_Partition_Interface,
RE_TA_LF => System_Partition_Interface,
- RE_TA_LI => System_Partition_Interface,
RE_TA_LLF => System_Partition_Interface,
- RE_TA_LLI => System_Partition_Interface,
- RE_TA_LLU => System_Partition_Interface,
- RE_TA_LU => System_Partition_Interface,
RE_TA_SF => System_Partition_Interface,
- RE_TA_SI => System_Partition_Interface,
- RE_TA_SSI => System_Partition_Interface,
- RE_TA_SSU => System_Partition_Interface,
- RE_TA_SU => System_Partition_Interface,
- RE_TA_U => System_Partition_Interface,
+ RE_TA_U8 => System_Partition_Interface,
+ RE_TA_U16 => System_Partition_Interface,
+ RE_TA_U32 => System_Partition_Interface,
+ RE_TA_U64 => System_Partition_Interface,
RE_TA_WC => System_Partition_Interface,
RE_TA_WWC => System_Partition_Interface,
RE_TA_String => System_Partition_Interface,
RE_TC_B => System_Partition_Interface,
RE_TC_C => System_Partition_Interface,
RE_TC_F => System_Partition_Interface,
- RE_TC_I => System_Partition_Interface,
+ RE_TC_I8 => System_Partition_Interface,
+ RE_TC_I16 => System_Partition_Interface,
+ RE_TC_I32 => System_Partition_Interface,
+ RE_TC_I64 => System_Partition_Interface,
RE_TC_LF => System_Partition_Interface,
- RE_TC_LI => System_Partition_Interface,
RE_TC_LLF => System_Partition_Interface,
- RE_TC_LLI => System_Partition_Interface,
- RE_TC_LLU => System_Partition_Interface,
- RE_TC_LU => System_Partition_Interface,
RE_TC_SF => System_Partition_Interface,
- RE_TC_SI => System_Partition_Interface,
- RE_TC_SSI => System_Partition_Interface,
- RE_TC_SSU => System_Partition_Interface,
- RE_TC_SU => System_Partition_Interface,
- RE_TC_U => System_Partition_Interface,
+ RE_TC_U8 => System_Partition_Interface,
+ RE_TC_U16 => System_Partition_Interface,
+ RE_TC_U32 => System_Partition_Interface,
+ RE_TC_U64 => System_Partition_Interface,
RE_TC_Void => System_Partition_Interface,
RE_TC_Opaque => System_Partition_Interface,
RE_TC_WC => System_Partition_Interface,
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread
-
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread
-
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread
-
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- This is a POSIX version of this package where foreign threads are
-- recognized.
--- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread and
--- GNU/Linux threads use this version.
-
separate (System.Task_Primitives.Operations)
package body Specific is
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_Id associated with a thread
+
----------------
-- Initialize --
----------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
separate (System.Task_Primitives.Operations)
package body Specific is
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_Id associated with a thread
+
----------------
-- Initialize --
----------------
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a version of this package using TLS and where foreign threads are
+-- recognized.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ATCB : aliased Task_Id := null;
+ pragma Thread_Local_Storage (ATCB);
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ begin
+ ATCB := Environment_Task;
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return ATCB /= null;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ begin
+ ATCB := Self_Id;
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ -- To make Ada tasks and C threads interoperate better, we have added some
+ -- functionality to Self. Suppose a C main program (with threads) calls an
+ -- Ada procedure and the Ada procedure calls the tasking runtime system.
+ -- Eventually, a call will be made to self. Since the call is not coming
+ -- from an Ada task, there will be no corresponding ATCB.
+
+ -- What we do in Self is to catch references that do not come from
+ -- recognized Ada tasks, and create an ATCB for the calling thread.
+
+ -- The new ATCB will be "detached" from the normal Ada task master
+ -- hierarchy, much like the existing implicitly created signal-server
+ -- tasks.
+
+ function Self return Task_Id is
+ Result : constant Task_Id := ATCB;
+ begin
+ if Result /= null then
+ return Result;
+ else
+ -- If the value is Null then it is a non-Ada task
+
+ return Register_Foreign_Thread;
+ end if;
+ end Self;
+
+end Specific;
Choice : Node_Id;
Val : Uint;
Err : Boolean := False;
+ -- Set True to avoid cascade errors and crashes on incorrect source code
Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer));
else
Analyze_And_Resolve (Choice, Enumtype);
-
- if Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
- then
- Error_Msg_N ("subtype name not allowed here", Choice);
+ if Error_Posted (Choice) then
Err := True;
- -- ??? should allow static subtype with zero/one entry
+ end if;
- elsif Etype (Choice) = Base_Type (Enumtype) then
- if not Is_Static_Expression (Choice) then
- Flag_Non_Static_Expr
- ("non-static expression used for choice!", Choice);
+ if not Err then
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ Error_Msg_N ("subtype name not allowed here", Choice);
Err := True;
+ -- ??? should allow static subtype with zero/one entry
- else
- Elit := Expr_Value_E (Choice);
-
- if Present (Enumeration_Rep_Expr (Elit)) then
- Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit));
- Error_Msg_NE
- ("representation for& previously given#",
- Choice, Elit);
+ elsif Etype (Choice) = Base_Type (Enumtype) then
+ if not Is_Static_Expression (Choice) then
+ Flag_Non_Static_Expr
+ ("non-static expression used for choice!", Choice);
Err := True;
- end if;
- Set_Enumeration_Rep_Expr (Elit, Expression (Assoc));
+ else
+ Elit := Expr_Value_E (Choice);
+
+ if Present (Enumeration_Rep_Expr (Elit)) then
+ Error_Msg_Sloc :=
+ Sloc (Enumeration_Rep_Expr (Elit));
+ Error_Msg_NE
+ ("representation for& previously given#",
+ Choice, Elit);
+ Err := True;
+ end if;
- Expr := Expression (Assoc);
- Val := Static_Integer (Expr);
+ Set_Enumeration_Rep_Expr (Elit, Expression (Assoc));
- if Val = No_Uint then
- Err := True;
+ Expr := Expression (Assoc);
+ Val := Static_Integer (Expr);
- elsif Val < Lo or else Hi < Val then
- Error_Msg_N ("value outside permitted range", Expr);
- Err := True;
- end if;
+ if Val = No_Uint then
+ Err := True;
+
+ elsif Val < Lo or else Hi < Val then
+ Error_Msg_N ("value outside permitted range", Expr);
+ Err := True;
+ end if;
- Set_Enumeration_Rep (Elit, Val);
+ Set_Enumeration_Rep (Elit, Val);
+ end if;
end if;
end if;
end if;
procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
- -- Check whether an inherited subprogram is an operation of an untagged
- -- derived type.
+ -- Check whether an inherited subprogram S is an operation of an
+ -- untagged derived type T.
---------------------
-- Is_Primitive_Of --
-- S p e c --
-- (AIX/PPC Version) --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
Always_Compatible_Rep : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
- ZCX_By_Default : constant Boolean := False;
- GCC_ZCX_Support : constant Boolean := True; -- Post GCC 4 only
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := True;
end System;
-- S p e c --
-- (PPC/AIX64 Version) --
-- --
--- Copyright (C) 2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
Always_Compatible_Rep : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
- ZCX_By_Default : constant Boolean := False;
- GCC_ZCX_Support : constant Boolean := True; -- Post GCC 4 only
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := True;
end System;
projects / platform / upstream / gcc.git / commitdiff