DataMuseum.dk

Presents historical artifacts from the history of:

Rational R1000/400 Tapes

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about Rational R1000/400 Tapes

Excavated with: AutoArchaeologist - Free & Open Source Software.


top - download
Index: ┃ B T

⟦f820abc9c⟧ TextFile

    Length: 16501 (0x4075)
    Types: TextFile
    Names: »B«

Derivation

└─⟦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⟧ 

TextFile

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;