|
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 - download
Length: 13312 (0x3400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Singly_Linked_List_Generic, seg_0046ab
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
package body Singly_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);
else
New_Node := Free_List;
Free_List := Free_List.Next;
New_Node.Next := 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.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
--| fo export.
--|
procedure Set (This_Pointer : in out Pointer;
To_This_Position : in Positions;
In_This_List : in out List;
Permanently : Boolean := False) is
Final_Position : Natural := Natural (To_This_Position) - First_Position;
begin
This_Pointer := In_This_List.First;
for Counter in First_Position .. Final_Position loop
This_Pointer := This_Pointer.Next;
end loop;
if Permanently then
In_This_List.Current := This_Pointer;
In_This_List.Position := Final_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 not (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 (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;
function Done (This_List : in List) return Boolean is
begin
return This_List.Current = null;
end Done;
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 =>
This_List.Position := Done_Position; -- Reset position.
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_Position : 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;
To_List.Last := New_Node;
To_List.Count := To_List.Count + 1;
end if;
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 Dispose (Of_This_List : in out List) is
Current : Pointer := Of_This_List.First;
Delete_Point : Pointer := null;
begin
while Current /= null loop
Delete_Point := Current;
Current := Delete_Point.Next;
Free_List_Manager.Free_Node (Delete_Point);
end loop;
Of_This_List := Create;
end Dispose;
end Singly_Linked_List_Generic;
nblk1=c
nid=0
hdr6=18
[0x00] rec0=20 rec1=00 rec2=01 rec3=038
[0x01] rec0=00 rec1=00 rec2=0c rec3=002
[0x02] rec0=18 rec1=00 rec2=02 rec3=01a
[0x03] rec0=02 rec1=00 rec2=0b rec3=01a
[0x04] rec0=1f rec1=00 rec2=03 rec3=036
[0x05] rec0=00 rec1=00 rec2=0a rec3=002
[0x06] rec0=23 rec1=00 rec2=04 rec3=062
[0x07] rec0=26 rec1=00 rec2=05 rec3=014
[0x08] rec0=00 rec1=00 rec2=09 rec3=002
[0x09] rec0=25 rec1=00 rec2=06 rec3=024
[0x0a] rec0=1f rec1=00 rec2=07 rec3=06a
[0x0b] rec0=06 rec1=00 rec2=08 rec3=000
tail 0x2150048dc815c66cab78a 0x42a00088462061e03