|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 8853 (0x2295)
Types: TextFile
Names: »B«
└─⟦180fe333a⟧ Bits:30000405 8mm tape, Rational 1000, SW CATALOG, 10_20_0
└─⟦180fe333a⟧ Bits:30000537 8mm tape, Rational 1000, SW Catalog 10_20_0
└─⟦5cb1d1d7f⟧ »DATA«
└─⟦3b1ee7bd8⟧
└─⟦this⟧
--------------------------------- COPYRIGHT ------------------------------------
-- (C) 1986 Swiss Federal Institute of Technology (EPFL). --
-- Represented by A. Strohmeier DMA-EPFL 1015 Lausanne Switzerland. --
-- All Rights Reserved. --
--------------------------------------------------------------------------------
--+ TITLE: GENERIC PACKAGE FOR QUEUES.
--+ SUPPORT: S.R.Y. Louboutin DMA-EPFL CH-1015 Lausanne
--+ APPROVAL: 03-DEC-1987 C. Genillard.
--+ CREATION: 10-JUL-1987 A. Strohmeier.
with Unchecked_Deallocation;
package body Queue_Of_Static_Items_G is
--/ LOCAL SUBPROGRAM:
procedure Assign_Item (Destination : out Item_Type; Source : in Item_Type);
procedure Assign (Destination : out Item_Type; Source : in Item_Type)
renames Assign_Item;
--/ LOCAL SUBPROGRAM:
procedure Destroy_Item (Item : in Item_Type);
procedure Destroy (Item : in Item_Type) renames Destroy_Item;
Max_Free_List_Size : Natural := 0;
type Free_List_Type is
record
Ptr : Link_Type;
Count : Natural := 0;
end record;
--/ STATE VARIABLE:
Free_List : Free_List_Type;
--/ LOCAL SUBPROGRAM:
procedure Create_And_Assign_Cell
(Link : in out Link_Type; Data_Value : in Item_Type) is
-- LINK has in (out) mode for allowing access to LINK.VALUE.
begin
if Free_List.Count = 0 then
Link := new Cell_Type;
else
Link := Free_List.Ptr;
Free_List.Ptr := Free_List.Ptr.Next;
Free_List.Count := Free_List.Count - 1;
Link.Next := null;
end if;
Assign (Link.Value, Data_Value);
end Create_And_Assign_Cell;
pragma Inline (Create_And_Assign_Cell);
--/ LOCAL SUBPROGRAM:
procedure Dispose is new Unchecked_Deallocation
(Object => Cell_Type, Name => Link_Type);
pragma Inline (Dispose);
--/ LOCAL SUBPROGRAM:
procedure Release (Link : in out Link_Type) is
begin
Destroy (Link.Value);
if Free_List.Count < Max_Free_List_Size then
Link.Next := Free_List.Ptr;
Free_List.Ptr := Link;
Free_List.Count := Free_List.Count + 1;
else
Dispose (Link);
end if;
end Release;
pragma Inline (Release);
--/ CONSTRUCTORS:
procedure Assign (Destination : in out Queue_Type;
Source : in Queue_Type) is
Current_Source_Ptr : Link_Type;
Current_Dest_Ptr : Link_Type;
begin
if Destination.First = Source.First then
return;
end if;
-- Actual parameters are identical queues.
Destroy (Destination);
if Source.Count = 0 then
return;
end if;
-- SOURCE is a null queue.
Create_And_Assign_Cell (Destination.First, Source.First.Value);
Current_Dest_Ptr := Destination.First;
Current_Source_Ptr := Source.First.Next;
while Current_Source_Ptr /= null loop
Create_And_Assign_Cell (Current_Dest_Ptr.Next,
Current_Source_Ptr.Value);
Current_Dest_Ptr := Current_Dest_Ptr.Next;
Current_Source_Ptr := Current_Source_Ptr.Next;
end loop;
Destination.Last := Current_Dest_Ptr;
Destination.Count := Source.Count;
end Assign;
procedure Insert (Queue : in out Queue_Type; Item : in Item_Type) is
Temp : Link_Type;
begin
Create_And_Assign_Cell (Temp, Item);
if Queue.Count = 0 then
Queue.First := Temp;
else
Queue.Last.Next := Temp;
end if;
Queue.Last := Temp;
Queue.Count := Queue.Count + 1;
end Insert;
--/ LOCAL SUBPROGRAM:
procedure Remove_First_Cell (Queue : in out Queue_Type) is
-- Removes and releases the first cell from the queue.
Temp : Link_Type := Queue.First;
begin
Queue.First := Queue.First.Next;
Queue.Count := Queue.Count - 1;
Release (Temp);
end Remove_First_Cell;
pragma Inline (Remove_First_Cell);
procedure Remove (Queue : in out Queue_Type) is
begin
if Queue.Count = 0 then
raise Empty_Structure_Error;
end if;
Remove_First_Cell (Queue);
end Remove;
procedure Remove (Queue : in out Queue_Type; Item : out Item_Type) is
begin
if Queue.Count = 0 then
raise Empty_Structure_Error;
end if;
Assign (Item, Queue.First.Value);
-- no call to DESTROY before ASSIGN.
Remove_First_Cell (Queue);
end Remove;
--/ QUERIES:
function "=" (Left, Right : in Queue_Type) return Boolean is
Pointer_To_L_Item : Link_Type := Left.First;
Pointer_To_R_Item : Link_Type := Right.First;
begin
if Left.Count /= Right.Count then
return False;
end if;
while Pointer_To_L_Item /= null loop
if not Equals (Pointer_To_L_Item.Value,
Pointer_To_R_Item.Value) then
return False;
end if;
Pointer_To_L_Item := Pointer_To_L_Item.Next;
Pointer_To_R_Item := Pointer_To_R_Item.Next;
end loop;
return True;
end "=";
function First_Value (Queue : in Queue_Type) return Item_Type is
begin
if Queue.Count = 0 then
raise Empty_Structure_Error;
end if;
return Queue.First.Value;
end First_Value;
procedure Get_First_Value (Queue : in Queue_Type; Item : out Item_Type) is
begin
if Queue.Count = 0 then
raise Empty_Structure_Error;
end if;
Assign (Item, Queue.First.Value);
-- No call to DESTROY before ASSIGN !
end Get_First_Value;
function Last_Value (Queue : in Queue_Type) return Item_Type is
begin
if Queue.Count = 0 then
raise Empty_Structure_Error;
end if;
return Queue.Last.Value;
end Last_Value;
procedure Get_Last_Value (Queue : in Queue_Type; Item : out Item_Type) is
begin
if Queue.Count = 0 then
raise Empty_Structure_Error;
end if;
Assign (Item, Queue.Last.Value);
-- No call to DESTROY before ASSIGN !
end Get_Last_Value;
function Is_Empty (Queue : in Queue_Type) return Boolean is
begin
return Queue.Count = 0;
end Is_Empty;
function Size (Queue : in Queue_Type) return Natural is
begin
return Queue.Count;
end Size;
--/ ITERATORS:
procedure Traverse_G (Queue : in Queue_Type) is
Temp : Link_Type := Queue.First;
Continue : Boolean := True;
begin
for Counter in 1 .. Queue.Count loop
Action (Temp.Value, Counter, Continue);
exit when not Continue;
Temp := Temp.Next;
end loop;
end Traverse_G;
--/ HEAP MANAGEMENT:
procedure Destroy (Queue : in out Queue_Type) is
Temp : Link_Type := Queue.First;
Next : Link_Type;
begin
while Temp /= null loop
Next := Temp.Next;
Release (Temp);
Temp := Next;
end loop;
Queue := (null, null, 0);
end Destroy;
procedure Release_Free_List is
Temp : Link_Type;
begin
while Free_List.Ptr /= null loop
Temp := Free_List.Ptr;
Free_List.Ptr := Free_List.Ptr.Next;
Dispose (Temp);
end loop;
Free_List.Count := 0;
end Release_Free_List;
procedure Set_Max_Free_List_Size (Max_Free_List_Size : in Natural) is
Nb_Of_Cells_For_System : Integer :=
Free_List.Count - Max_Free_List_Size;
Temp : Link_Type;
begin
if Nb_Of_Cells_For_System > 0 then
for I in 1 .. Nb_Of_Cells_For_System loop
Temp := Free_List.Ptr;
Free_List.Ptr := Free_List.Ptr.Next;
Dispose (Temp);
end loop;
Free_List.Count := Free_List.Count - Nb_Of_Cells_For_System;
end if;
Queue_Of_Static_Items_G.Max_Free_List_Size := Max_Free_List_Size;
end Set_Max_Free_List_Size;
function Free_List_Size return Natural is
begin
return Free_List.Count;
end Free_List_Size;
procedure Assign_Item (Destination : out Item_Type;
Source : in Item_Type) is
begin
Destination := Source;
end Assign_Item;
procedure Destroy_Item (Item : in Item_Type) is
-- Mode of the parameter is artificial, but mode 'out' could raise
-- CONSTRAINT_ERROR !
begin
null;
end Destroy_Item;
pragma Inline (Assign_Item);
pragma Inline (Destroy_Item);
end Queue_Of_Static_Items_G;