|
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 - downloadIndex: ┃ B T ┃
Length: 16501 (0x4075)
Types: TextFile
Names: »B«
└─⟦149519bd4⟧ Bits:30000546 8mm tape, Rational 1000, !projects 93-07-13
└─ ⟦124ff5788⟧ »DATA«
└─⟦this⟧
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
└─ ⟦6f12a12be⟧ »DATA«
└─⟦this⟧
package body Unbounded_Array is
Default_Allocation : constant := 10; --[a modifier]
type Liste is
record
First : Array_Pointer;
Last : Array_Pointer;
end record;
Free_List : Liste;
------------------------------------------------------------------------------
procedure Find (In_Object : Object;
The_Item : Natural;
Giving_Array : out Array_Pointer;
Giving_Element : in out Positive) is
Array_Number : Natural := 0;
Current_Array : Array_Pointer;
begin
if The_Item > 0 and The_Item <= In_Object.Element_Count then
if The_Item <= Max_Size then
Giving_Array := In_Object.First_Array;
else
Array_Number := The_Item / Max_Size;
Giving_Element := The_Item rem Max_Size;
Current_Array := In_Object.First_Array;
if Giving_Element = 0 then
Giving_Element := Max_Size;
for I in 1 .. Array_Number - 1 loop
Current_Array := Current_Array.Next_Array;
end loop;
else
for I in 1 .. Array_Number loop
Current_Array := Current_Array.Next_Array;
end loop;
end if;
Giving_Array := Current_Array;
end if;
else
Giving_Array := null;
-- raise Illegal_Access;
end if;
end Find;
------------------------------------------------------------------------------
procedure Locate (In_Object : Object;
The_Element : Element;
At_Position : in out Natural) is
Element_Number, Array_Number : Natural;
Current_Array : Array_Pointer;
Found : Boolean := False;
begin
if In_Object.First_Array /= null then
Current_Array := In_Object.First_Array;
Array_Number := 0;
Element_Number := 0;
for I in 1 .. In_Object.Element_Count loop
Element_Number := Element_Number + 1;
if Element_Number = Max_Size + 1 then
if Current_Array.Next_Array /= null then
Current_Array := Current_Array.Next_Array;
Element_Number := 1;
Array_Number := Array_Number + 1;
else
exit;
end if;
end if;
if Current_Array.The_Values (Element_Number) = The_Element then
Found := True;
exit;
end if;
end loop;
end if;
if Found then
At_Position := (Array_Number * Max_Size) + Element_Number;
else
At_Position := 0;
end if;
end Locate;
------------------------------------------------------------------------------
function Allocate return Array_Pointer is
New_Array : Array_Pointer;
begin
if Free_List.First = null then
New_Array := new Array_Range;
else
New_Array := Free_List.First;
Free_List.First := Free_List.First.Next_Array;
end if;
New_Array.Next_Array := null;
return New_Array;
end Allocate;
------------------------------------------------------------------------------
procedure Allocate (For_Object : in out Object) is
New_Array : Array_Pointer;
begin
New_Array := Allocate;
if For_Object.Array_Count = 0 then
For_Object.First_Array := New_Array;
For_Object.Last_Array := New_Array;
else
For_Object.Last_Array.Next_Array := New_Array;
For_Object.Last_Array := New_Array;
end if;
For_Object.Array_Count := For_Object.Array_Count + 1;
end Allocate;
------------------------------------------------------------------------------
procedure Dispose_Last_Array (In_Object : in out Object;
After_Array : Array_Pointer) is
begin
In_Object.Last_Array := After_Array;
In_Object.Last_Array.Next_Array := null;
end Dispose_Last_Array;
------------------------------------------------------------------------------
function Create (The_Content : Content) return Object is
New_Array : Array_Pointer;
An_Object : Object;
Count : Natural := 0;
Array_Number : Natural := 0;
First_Pos : Natural := 0;
Last_Pos : Natural := 0;
begin
if The_Content'Last >= The_Content'First then
An_Object.Array_Count := 1;
An_Object.Element_Count := The_Content'Last;
Count := The_Content'Last;
New_Array := Allocate;
An_Object.First_Array := New_Array;
An_Object.Last_Array := New_Array;
if Count <= Max_Size then
An_Object.First_Array.The_Values (1 .. Count) :=
The_Content (The_Content'First ..
The_Content'First + Count - 1);
else
First_Pos := The_Content'First;
Last_Pos := The_Content'First + Max_Size - 1;
An_Object.First_Array.The_Values (1 .. Max_Size) :=
The_Content (First_Pos .. Last_Pos);
Count := Count - Max_Size;
Array_Number := Count / Max_Size;
for I in 1 .. Array_Number loop
Allocate (For_Object => An_Object);
First_Pos := First_Pos + Max_Size;
Last_Pos := Last_Pos + Max_Size;
An_Object.Last_Array.The_Values (1 .. Max_Size) :=
The_Content (First_Pos .. Last_Pos);
Count := Count - Max_Size;
end loop;
if Count > 0 then
Allocate (For_Object => An_Object);
First_Pos := First_Pos + Max_Size;
Last_Pos := Last_Pos + Count;
An_Object.Last_Array.The_Values (1 .. Count) :=
The_Content (First_Pos .. Last_Pos);
end if;
end if;
end if;
return An_Object;
end Create;
------------------------------------------------------------------------------
function "&" (The_Object : Object; With_Element : Element) return Object is
An_Object : Object := The_Object;
New_Array : Array_Pointer;
begin
if The_Object.Element_Count rem Max_Size = 0 then
Allocate (For_Object => An_Object);
An_Object.Last_Array.The_Values (1) := With_Element;
An_Object.Element_Count := An_Object.Element_Count + 1;
else
An_Object.Last_Array.The_Values
(The_Object.Element_Count rem Max_Size + 1) := With_Element;
An_Object.Element_Count := An_Object.Element_Count + 1;
end if;
return An_Object;
end "&";
------------------------------------------------------------------------------
function "&" (The_Object, With_Object : Object) return Object is
An_Object : Object := The_Object;
New_Array : Array_Pointer;
Free_Elements : Natural;
Current_Array : Array_Pointer;
Position_1, Position_2 : Natural;
begin
Free_Elements := An_Object.Element_Count rem Max_Size;
if Free_Elements = 0 then
Current_Array := With_Object.First_Array;
for I in 1 .. With_Object.Array_Count loop
Allocate (For_Object => An_Object);
An_Object.Last_Array.The_Values := Current_Array.The_Values;
Current_Array := Current_Array.Next_Array;
end loop;
elsif With_Object.Element_Count <= Free_Elements then
Position_1 := (An_Object.Element_Count rem Max_Size + 1);
for I in Position_1 .. Position_1 + With_Object.Element_Count loop
An_Object.Last_Array.The_Values (I) :=
With_Object.Last_Array.The_Values (I - Position_1 + 1);
end loop;
else
Position_1 := An_Object.Element_Count rem Max_Size;
Position_2 := 0;
Current_Array := With_Object.First_Array;
for I in 1 .. With_Object.Element_Count loop
if Position_2 = Max_Size then
Position_2 := 1;
Current_Array := Current_Array.Next_Array;
else
Position_2 := Position_2 + 1;
end if;
if Position_1 = Max_Size then
Allocate (For_Object => An_Object);
Position_1 := 1;
else
Position_1 := Position_1 + 1;
end if;
An_Object.Last_Array.The_Values (Position_1) :=
Current_Array.The_Values (Position_2);
end loop;
end if;
An_Object.Element_Count :=
An_Object.Element_Count + With_Object.Element_Count;
return An_Object;
end "&";
------------------------------------------------------------------------------
procedure Free (The_Object : in out Object) is
begin
if The_Object.First_Array /= null then
if Free_List.First = null then
Free_List.First := The_Object.First_Array;
Free_List.Last := The_Object.Last_Array;
else
Free_List.Last.Next_Array := The_Object.First_Array;
Free_List.Last := The_Object.Last_Array;
end if;
end if;
The_Object.Element_Count := 0;
The_Object.Array_Count := 0;
The_Object.First_Array := null;
The_Object.Last_Array := null;
end Free;
------------------------------------------------------------------------------
procedure Remove (In_Object : in out Object; The_Item : Positive) is
A_Content : Content (1 .. In_Object.Element_Count);
Element_Number : Natural;
Current_Array : Array_Pointer;
An_Object : Object;
begin
if The_Item <= In_Object.Element_Count then
A_Content := Get (In_Object);
for I in A_Content'First + The_Item - 1 .. A_Content'Last - 1 loop
A_Content (I) := A_Content (I + 1);
end loop;
An_Object := Create (A_Content
(A_Content'First .. A_Content'Last - 1));
Free (In_Object);
In_Object := An_Object;
-- else
-- raise Illegal_Access;
end if;
end Remove;
------------------------------------------------------------------------------
procedure Remove (In_Object : in out Object; The_Element : Element) is
The_Position : Natural;
begin
Locate (In_Object, The_Element, At_Position => The_Position);
if The_Position /= 0 then
Remove (In_Object, The_Position);
-- else
-- raise Illegal_Access;
end if;
end Remove;
------------------------------------------------------------------------------
function Get (In_Object : Object; The_Item : Positive) return Element is
Element_Number : Natural := The_Item;
Current_Array : Array_Pointer;
begin
Find (In_Object => In_Object,
The_Item => The_Item,
Giving_Array => Current_Array,
Giving_Element => Element_Number);
if Current_Array /= null then
return Current_Array.The_Values (Element_Number);
end if;
end Get;
------------------------------------------------------------------------------
function Get (The_Object : Object) return Content is
The_Content : Content (1 .. The_Object.Element_Count);
Count : Natural := 0;
Current_Array : Array_Pointer;
begin
if The_Object.Element_Count /= 0 then
if The_Object.Array_Count = 0 then
Count := 0;
elsif The_Object.Array_Count = 1 then
Current_Array := The_Object.First_Array;
Count := The_Object.Element_Count;
The_Content (1 .. Count) :=
Current_Array.The_Values (1 .. Count);
elsif The_Object.Array_Count > 1 then
Count := Max_Size;
Current_Array := The_Object.First_Array;
The_Content (1 .. Max_Size) :=
Current_Array.The_Values (1 .. Max_Size);
for J in 2 .. The_Object.Array_Count - 1 loop
Current_Array := Current_Array.Next_Array;
The_Content (1 + Count .. Max_Size + Count) :=
Current_Array.The_Values (1 .. Max_Size);
Count := Count + Max_Size;
end loop;
Current_Array := Current_Array.Next_Array;
The_Content (1 + Count .. The_Object.Element_Count) :=
Current_Array.The_Values
(1 .. The_Object.Element_Count - Count);
Count := The_Object.Element_Count;
end if;
end if;
return The_Content (1 .. Count);
end Get;
------------------------------------------------------------------------------
function Dupplicate (The_Object : Object) return Object is
An_Object : Object;
Current_Array_Dest, Current_Array_Source : Array_Pointer;
begin
if The_Object.Array_Count /= 0 then
for I in 1 .. The_Object.Array_Count loop
Allocate (For_Object => An_Object);
end loop;
Current_Array_Dest := An_Object.First_Array;
Current_Array_Source := The_Object.First_Array;
Current_Array_Dest.The_Values := Current_Array_Source.The_Values;
for I in 2 .. The_Object.Array_Count loop
Current_Array_Dest := Current_Array_Dest.Next_Array;
Current_Array_Source := Current_Array_Source.Next_Array;
Current_Array_Dest.The_Values :=
Current_Array_Source.The_Values;
end loop;
An_Object.Element_Count := The_Object.Element_Count;
end if;
return An_Object;
end Dupplicate;
------------------------------------------------------------------------------
procedure Set (In_Object : Object;
The_Item : Positive;
With_Element : Element) is
Element_Number : Natural := The_Item;
Current_Array : Array_Pointer;
begin
Find (In_Object => In_Object,
The_Item => The_Item,
Giving_Array => Current_Array,
Giving_Element => Element_Number);
if Current_Array /= null then
Current_Array.The_Values (Element_Number) := With_Element;
end if;
end Set;
------------------------------------------------------------------------------
function Length (Of_Object : Object) return Natural is
begin
return Of_Object.Element_Count;
end Length;
------------------------------------------------------------------------------
begin
--[A verifier : premiere allocation de free_list]
declare
Current_Array : Array_Pointer;
begin
Free_List.First := null;
Free_List.Last := null;
Free_List.First := new Array_Range;
Free_List.Last := Free_List.First;
Current_Array := Free_List.First;
for I in 1 .. Default_Allocation loop
Current_Array.Next_Array := new Array_Range;
Current_Array := Current_Array.Next_Array;
end loop;
Free_List.Last := Current_Array;
Free_List.Last.Next_Array := null;
end;
end Unbounded_Array;