|
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: 30720 (0x7800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Unbounded_Array, seg_011745, seg_0117d0
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦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;
nblk1=1d
nid=8
hdr6=30
[0x00] rec0=1c rec1=00 rec2=01 rec3=028
[0x01] rec0=19 rec1=00 rec2=10 rec3=024
[0x02] rec0=17 rec1=00 rec2=11 rec3=018
[0x03] rec0=01 rec1=00 rec2=0b rec3=022
[0x04] rec0=1e rec1=00 rec2=19 rec3=036
[0x05] rec0=19 rec1=00 rec2=1b rec3=040
[0x06] rec0=00 rec1=00 rec2=03 rec3=008
[0x07] rec0=14 rec1=00 rec2=14 rec3=04a
[0x08] rec0=01 rec1=00 rec2=0a rec3=034
[0x09] rec0=16 rec1=00 rec2=17 rec3=052
[0x0a] rec0=08 rec1=00 rec2=07 rec3=01c
[0x0b] rec0=16 rec1=00 rec2=02 rec3=014
[0x0c] rec0=00 rec1=00 rec2=1c rec3=07c
[0x0d] rec0=17 rec1=00 rec2=13 rec3=010
[0x0e] rec0=00 rec1=00 rec2=0d rec3=012
[0x0f] rec0=19 rec1=00 rec2=15 rec3=01c
[0x10] rec0=18 rec1=00 rec2=1d rec3=01e
[0x11] rec0=1b rec1=00 rec2=09 rec3=032
[0x12] rec0=15 rec1=00 rec2=1a rec3=07c
[0x13] rec0=16 rec1=00 rec2=18 rec3=004
[0x14] rec0=15 rec1=00 rec2=06 rec3=03e
[0x15] rec0=03 rec1=00 rec2=0e rec3=05a
[0x16] rec0=22 rec1=00 rec2=12 rec3=00e
[0x17] rec0=0d rec1=00 rec2=04 rec3=000
[0x18] rec0=0a rec1=00 rec2=08 rec3=000
[0x19] rec0=0a rec1=00 rec2=08 rec3=000
[0x1a] rec0=0d rec1=00 rec2=04 rec3=000
[0x1b] rec0=0a rec1=00 rec2=04 rec3=000
[0x1c] rec0=0a rec1=00 rec2=04 rec3=000
tail 0x2170d9c5c823a4d9308cc 0x42a00088462063c03
Free Block Chain:
0x8: 0000 00 16 01 27 80 03 6f 6f 70 03 00 38 20 20 20 20 ┆ ' oop 8 ┆
0x16: 0000 00 05 00 2f 80 04 3d 20 31 3b 04 00 25 20 20 20 ┆ / = 1; % ┆
0x5: 0000 00 0c 00 c5 80 14 74 20 20 20 20 20 20 3d 3e 20 ┆ t => ┆
0xc: 0000 00 0f 03 fc 00 27 20 20 20 20 20 20 20 20 43 75 ┆ ' Cu┆
0xf: 0000 00 00 00 04 80 01 49 01 66 20 46 72 65 65 5f 4c ┆ I f Free_L┆