|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 21504 (0x5400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Doubly_Linked_List_Generic, seg_0046a7
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
package body Doubly_Linked_List_Generic is
First_Position : constant Natural := Natural (Positions'First);
Done_Position : constant Natural := Natural'Pred (First_Position);
--| @SUMMARY Task that manages the internal free-list.
--| @SPECIAL_NOTES Use of a task ensures concurrency safety.
--|
task Free_List_Manager is
entry Get_Node (The_Node : out Pointer; Contents : in Element);
entry Free_Node (This_Node : in out Pointer);
end Free_List_Manager;
task body Free_List_Manager is
--| @SPECIAL_NOTES Package/task state: the internal free list.
--|
Free_List : Pointer := null;
begin
loop
select
accept Get_Node (The_Node : out Pointer;
Contents : in Element) do
declare
New_Node : Pointer := null;
begin
if Fee_List = null then
New_Node := new Node'(Contents => Contents,
Next => null,
Previous => null);
else
New_Node := Free_List;
Free_List := Free_List.Next;
New_Node.Next := null;
New_Node.Previous := null;
New_Node.Contents := Contents;
end if;
The_Node := New_Node;
end;
end Get_Node;
or
accept Free_Node (This_Node : in out Pointer) do
This_Node.Previous := null;
This_Node.Next := Free_List;
Free_List := This_Node;
end Free_Node;
or
terminate;
end select;
end loop;
end Free_List_Manager;
--| @DESCRIPTION Walks a pointer to an arbitrary position in the
--| list.
--|
--| @SPECIAL_NOTES Blows up if position is out of range. Unsafe
--| for export.
--|
procedure Set (This_Pointer : in out Pointer;
To_This_Position : in Positions;
In_This_List : in out List;
Permanently : Boolean := False) is
begin
This_Pointer := In_This_List.First;
for Counter in First_Position .. Natural (To_This_Position) - 1 loop
This_Pointer := This_Pointer.Next;
end loop;
if Permanently then
In_This_List.Current := This_Pointer;
In_This_List.Position := Natural (To_This_Position);
end if;
end Set;
function Create return List is
The_List : List;
begin
return The_List;
end Create;
function Is_Empty (This_List : in List) return Boolean is
begin
return Elements_In (This_List) = 0;
end Is_Empty;
function Elements_In (This_List : in List) return Natural is
begin
return This_List.Count;
end Elements_In;
function Copy (Of_List : in List) return List is
Current : Pointer := Of_List.First;
New_List : List := Create;
begin
while Current /= null loop
Add (New_List, Copy (Current.Contents));
Current := Current.Next;
end loop;
if not Done (Of_List) then
Set (New_List, Position (Of_List));
end if;
return New_List;
end Copy;
procedure Reset_To_First (This_List : in out List) is
begin
This_List.Current := This_List.First;
if This_List.First = null then
This_List.Position := Done_Position;
else
This_List.Position := First_Position;
end if;
end Reset_To_First;
procedure Reset_To_Last (This_List : in out List) is
begin
This_List.Current := This_List.Last;
if This_List.Last = null then
This_List.Position := Done_Position;
else
This_List.Position := This_List.Count;
end if;
end Reset_To_Last;
function Done (This_List : in List) return Boolean is
begin
return This_List.Current = null;
end Done;
function At_First (This_List : in List) return Boolean is
begin
return not Done (This_List) and then
This_List.Current = This_List.First;
end At_First;
function At_Last (This_List : in List) return Boolean is
begin
return not Done (This_List) and then This_List.Current = This_List.Last;
end At_Last;
procedure Previous (This_List : in out List) is
begin
This_List.Current := This_List.Currnt.Previous;
This_List.Position := This_List.Position - 1;
exception
when Constraint_Error =>
raise No_Previous_Element;
end Previous;
procedure Next (This_List : in out List) is
begin
This_List.Current := This_List.Current.Next;
This_List.Position := This_List.Position + 1;
exception
when Constraint_Error =>
raise No_Next_Element;
end Next;
function Current (This_List : in List) return Element is
begin
return This_List.Current.Contents;
exception
when Constraint_Error =>
raise No_Current_Element;
end Current;
function Position (In_List : in List) return Positions is
begin
return Positions (In_List.Position);
exception
when Constraint_Error =>
raise No_Current_Element;
end Position;
procedure Set (This_List : in out List; To_Positon : in Positions) is
begin
Set (This_List.Current, To_Position, This_List, Permanently => True);
exception
when Constraint_Error =>
raise Out_Of_Range;
end Set;
--| @ALGORITHM Walks a "probe" pointer along list, leaving internal
--| list pointers undisturbed.
--|
function Element_At (This_Position : in Positions; In_List : in List)
return Element is
The_List : List := In_List;
Probe : Pointer := null;
begin
Set (Probe, This_Position, The_List);
return Probe.Contents;
exception
when Constraint_Error =>
raise Out_Of_Range;
end Element_At;
procedure Add (To_List : in out List;
This_Element : in Element) is
New_Node : Pointer := null;
begin
Free_List_Manager.Get_Node (New_Node, Contents => This_Element);
if Is_Empty (To_List) then
To_List.Position := First_Position;
To_List.Current := New_Node;
To_List.First := New_Node;
To_List.Last := New_Node;
To_List.Count := 1;
else
To_List.Last.Next := New_Node;
New_Node.Previous := To_List.Last;
To_List.Last := New_Node;
To_List.Count := To_List.Count + 1;
end if;
end Add;
procedure Add (To_List : in out List;
This_Element : in Element;
With_Orientation : in Orientations) is
begin
Add (To_List => To_List,
This_Element => This_Element,
At_Position => Position (To_List),
With_Orientation => With_Orientation);
exception
when Storage_Error =>
raise;
when others =>
raise No_Current_Element;
end Add;
procedure Add (To_List : in out List;
This_Element : in Element;
At_Position : in Positions;
With_Orientation : in Orientations) is
Add_Point : Pointer := null;
procedure Add_Before is
New_Node : Pointer := null;
begin
Free_List_Manager.Get_Node (New_Node, Contents => This_Element);
New_Node.Previous := Add_Point.Previous;
Add_Point.Previous := New_Node;
New_Node.Next := Add_Point;
if New_Node.Previous /= null then
New_Node.Previous.Next := New_Node;
end if;
if To_List.First = Add_Point then
To_List.First := New_Node;
end if;
To_List.Count := To_List.Count + 1;
if Position (To_List) >= At_Position then
--
-- Insertion was before the original position, so the
-- position needs to be shifted over by one.
--
To_List.Position := To_List.Position + 1;
end if;
end Add_Before;
procedure Add_After is
New_Node : Pointer := null;
begin
Free_List_Manager.Get_Node (New_Node, Contents => This_Element);
New_Node.Next := Add_Point.Next;
Add_Point.Next := New_Node;
New_Node.Previous := Add_Point;
if New_Node.Next /= null then
New_Node.Next.Previous := New_Node;
end if;
if To_List.Last = Add_Point then
To_List.Last := New_Node;
end if;
To_List.Count := To_List.Count + 1;
if Position (To_List) > At_Position then
--
-- Insertion was before the original position, so the
-- position needs to be shifted over by one.
--
To_List.Position := To_List.Position + 1;
end if;
end Add_After;
begin
Set (Add_Point, At_Position, To_List);
case With_Orientation is
when Preceeding =>
Add_Before;
when Following =>
Add_After;
end case;
exception
when Storage_Error =>
raise;
when others =>
raise Out_Of_Range;
end Add;
procedure Modify (This_List : in out List; New_Element : in Element) is
begin
This_List.Current.Contents := New_Element;
exception
when Constraint_Error =>
raise No_Current_Element;
end Modify;
procedure Delete (From_List : in out List) is
begin
Delete (From_List, Position (From_List));
exception
when others =>
raise No_Current_Element;
end Delete;
procedure Delete (From_List : in out List; At_Position : in Positions) is
Delete_Point : Pointer := null;
begin
Set (Delete_Point, At_Position, From_List);
if From_List.Current = Delete_Point then
From_List.Current := Delete_Point.Next;
end if;
if From_List.First = Delete_Point then
From_List.First := Delete_Point.Next;
end if;
if From_List.Last = Delete_Point then
From_List.Last := Delete_Point.Previous;
end if;
if Delete_Point.Previous /= null then
Delete_Point.Previous.Next := Delete_Point.Next;
end if;
if Delete_Point.Next /= null then
Delete_Point.Next.Previous := Delete_Point.Previous;
end if;
Free_List_Manager.Free_Node (Delete_Point);
From_List.Count := From_List.Count - 1;
if Position (From_List) > At_Position then
--
-- Deletion was before the original position, so the
-- position needs to be shifted over by one.
--
From_List.Position := From_List.Position - 1;
end if;
exception
when others =>
raise Out_Of_Range;
end Delete;
procedure Dispose (Of_This_List : in out List) is
begin
Reset_To_First (Of_This_List);
while not Done (Of_This_List) loop
Delete (Of_This_List);
end loop;
end Dispose;
end Doubly_Linked_List_Generic;
nblk1=14
nid=0
hdr6=28
[0x00] rec0=20 rec1=00 rec2=01 rec3=038
[0x01] rec0=00 rec1=00 rec2=14 rec3=002
[0x02] rec0=15 rec1=00 rec2=02 rec3=010
[0x03] rec0=01 rec1=00 rec2=13 rec3=01a
[0x04] rec0=1f rec1=00 rec2=03 rec3=01e
[0x05] rec0=23 rec1=00 rec2=04 rec3=040
[0x06] rec0=20 rec1=00 rec2=05 rec3=058
[0x07] rec0=00 rec1=00 rec2=12 rec3=002
[0x08] rec0=28 rec1=00 rec2=06 rec3=068
[0x09] rec0=00 rec1=00 rec2=11 rec3=002
[0x0a] rec0=25 rec1=00 rec2=07 rec3=02e
[0x0b] rec0=1d rec1=00 rec2=08 rec3=016
[0x0c] rec0=02 rec1=00 rec2=10 rec3=01a
[0x0d] rec0=19 rec1=00 rec2=09 rec3=07c
[0x0e] rec0=00 rec1=00 rec2=0f rec3=00c
[0x0f] rec0=1b rec1=00 rec2=0a rec3=00c
[0x10] rec0=00 rec1=00 rec2=0e rec3=00e
[0x11] rec0=2a rec1=00 rec2=0b rec3=02c
[0x12] rec0=19 rec1=00 rec2=0c rec3=064
[0x13] rec0=15 rec1=00 rec2=0d rec3=000
tail 0x215004888815c66c37782 0x42a00088462061e03