|
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: 23552 (0x5c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Sorted_List_Generic, seg_0046ad
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
package body Sorted_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 Free_Lis = 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), Insert);
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.Current.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 ut 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;
Duplicate_Reaction : in Duplicate_Reactions) is
procedure Add_Initial_Element is
New_Node : Pointer := null;
begin
Free_List_Manager.Get_Node (New_Node, Contents => This_Element);
To_List.Position := First_Position;
To_List.Current := New_Node;
To_List.First := New_Node;
To_List.Last := New_Node;
To_List.Count := 1;
end Add_Initial_Element;
procedure Add_Subsequent_Element is
Add_Point : Pointer := To_List.First;
Add_Position : Positions := Positions (First_Position);
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) >= Add_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) > Add_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
loop
if Add_Point = null then
--
-- Element is greater than all others in list, so append to
-- end of list.
--
Add_Position := Add_Position - 1;
Add_Point := To_List.Last;
Add_After;
exit;
elsif This_Element < Add_Point.Contents then
--
-- Element is less than current element in list, so add
-- before current element.
--
Add_Before;
exit;
elsif not (Add_Point.Contents < This_Element) then
--
-- Element is not < and not >, so must be equal
-- to current element in list.
--
case Duplicate_Reaction is
when Disallow =>
raise Duplicate_Element;
when Overwrite =>
Add_Point.Contents := This_Element;
exit;
when Insert =>
--
-- Keep walking down list until pass all duplicates
-- of current element. Will either encounter an
-- element larger than the element being added, or
-- will encounter end of list. Both cases are
-- already covered.
--
null;
end case;
end if;
Add_Point := Add_Point.Next;
Add_Position := Add_Position + 1;
end loop;
end Add_Subsequent_Element;
begin
if Is_Empty (To_List) then
Add_Initial_Element;
else
Add_Subsequent_Element;
end if;
end Add;
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 Sorted_List_Generic;
nblk1=16
nid=0
hdr6=2c
[0x00] rec0=20 rec1=00 rec2=01 rec3=046
[0x01] rec0=00 rec1=00 rec2=16 rec3=002
[0x02] rec0=15 rec1=00 rec2=02 rec3=016
[0x03] rec0=01 rec1=00 rec2=15 rec3=020
[0x04] rec0=1f rec1=00 rec2=03 rec3=01e
[0x05] rec0=23 rec1=00 rec2=04 rec3=020
[0x06] rec0=20 rec1=00 rec2=05 rec3=038
[0x07] rec0=00 rec1=00 rec2=14 rec3=002
[0x08] rec0=28 rec1=00 rec2=06 rec3=044
[0x09] rec0=00 rec1=00 rec2=13 rec3=002
[0x0a] rec0=24 rec1=00 rec2=07 rec3=006
[0x0b] rec0=1b rec1=00 rec2=08 rec3=04c
[0x0c] rec0=00 rec1=00 rec2=12 rec3=022
[0x0d] rec0=19 rec1=00 rec2=09 rec3=04e
[0x0e] rec0=00 rec1=00 rec2=11 rec3=00e
[0x0f] rec0=1a rec1=00 rec2=0a rec3=010
[0x10] rec0=00 rec1=00 rec2=10 rec3=006
[0x11] rec0=15 rec1=00 rec2=0b rec3=046
[0x12] rec0=1f rec1=00 rec2=0c rec3=090
[0x13] rec0=00 rec1=00 rec2=0f rec3=006
[0x14] rec0=1a rec1=00 rec2=0d rec3=038
[0x15] rec0=14 rec1=00 rec2=0e rec3=001
tail 0x215004906815c66d0f474 0x42a00088462061e03