⟦f423e915a⟧

TextFile

package body Unbounded_String is

    function Max (X : Integer; Y : Integer) return Integer is
    begin
        if X > Y then
            return X;
        else
            return Y;
        end if;
    end Max;
    pragma Inline (Max);

    procedure Free (V : in out Variable_String) is
    begin
        if V /= null then
            if V.Length /= Free_List_Item then
                V.Next_Free := Free_List.Next_Free;
                V.Length := Free_List_Item;
                Free_List.Next_Free := V;
            end if;
            V := null;
        end if;
    end Free;


    function Length (Source : Variable_String) return String_Length is
    begin
        if Source /= null then
            return Source.Length;
        else
            return 0;
        end if;
    exception
        when others =>
            return 0;
    end Length;

    function Allocated_Length (Source : Variable_String) return String_Length is
    begin
        if Source /= null and then Source.Length /= Free_List_Item then
            return Source.Contents'Length;
        else
            return 0;
        end if;
    end Allocated_Length;

    procedure Real_Allocate (Target : in out Variable_String;
                             Length : String_Length;
                             Room_For_Growth : Boolean := True) is

        function Allocation (Length : String_Length) return String_Length is
        begin
            if Room_For_Growth then
                return Max (2 * Length, Default_Maximum_Length);
            else
                return Max (Length, Default_Maximum_Length);
            end if;
        end Allocation;

        procedure Find (Free : in out Real_String;
                        This : in out Variable_String) is
        begin
            This := Free.Next_Free;
            if This /= null then
                if This.Contents'Length > Length then
                    Free.Next_Free := This.Next_Free;
                    This.Next_Free := null;
                else
                    Find (This.all, This);
                end if;
            end if;
        end Find;

    begin
        Find (Free_List, Target);
        if Target = null then
            Target := new Real_String'
                             (Length => Length,
                              Contents => new String (1 .. Allocation (Length)),
                              Next_Free => null);
        else
            Target.Length := Length;
            Target.Next_Free := null;
        end if;
    end Real_Allocate;

    procedure Move (Target : in out Variable_String;
                    Source : in out Variable_String) is
    begin
        Free (Target);
        Target := Source;
        Source := null;
    end Move;

    procedure Allocate (Target : in out Variable_String;
                        Length : String_Length;
                        Preserve_Contents : Boolean := True) is
        Max_Length : String_Length := Allocated_Length (Target);
    begin
        -- check for alias of freed string and remove pointer to free list
        if Max_Length = 0 then
            Real_Allocate (Target, Length, Room_For_Growth => False);
        elsif Max_Length >= Length then
            Target.Length := Length;
        else
            declare
                Temp : Variable_String;
            begin
                Real_Allocate (Temp, Length, Preserve_Contents);
                if Preserve_Contents then
                    Temp.Contents (1 .. Target.Length) :=
                       Target.Contents (1 .. Target.Length);
                end if;
                Move (Target, Temp);
            end;
        end if;
    end Allocate;

    function Value (S : String) return Variable_String is
        Result : Variable_String;
    begin
        Real_Allocate (Result, S'Length, Room_For_Growth => False);
        Copy (Result, S);
        return Result;
    end Value;

    procedure Copy (Target : in out Variable_String;
                    Source : Variable_String) is
    begin
        Copy (Target, Image (Source));
    end Copy;

    procedure Copy (Target : in out Variable_String; Source : String) is
    begin
        Allocate (Target, Source'Length, Preserve_Contents => False);
        declare
            T : Real_String renames Target.all;
        begin
            T.Contents (1 .. Source'Length) := Source;
            T.Length := Source'Length;
        end;
    end Copy;

    procedure Copy (Target : in out Variable_String; Source : Character) is
    begin
        Allocate (Target, 1, Preserve_Contents => False);
        Target.Contents (1) := Source;
    end Copy;


    function Image (V : Variable_String) return String is
    begin
        return V.all.Contents (1 .. V.all.Length);
    exception
        when others =>
            return String'(1 .. 0 => ' ');
    end Image;


    procedure Append (Target : in out Variable_String; Source : String) is
        Len : String_Length := Length (Target);
    begin
        Allocate (Target, Len + Source'Length, Preserve_Contents => True);
        declare
            T : Real_String renames Target.all;
        begin
            T.Contents (Len + 1 .. T.Length) := Source;
        end;
    end Append;


    procedure Append (Target : in out Variable_String;
                      Source : Variable_String) is
    begin
        Append (Target, Image (Source));
    end Append;


    procedure Append (Target : in out Variable_String; Source : Character) is
        Len : String_Length := Length (Target) + 1;
    begin
        Allocate (Target, Len, Preserve_Contents => True);
        Target.Contents (Len) := Source;
    end Append;


    procedure Append (Target : in out Variable_String;
                      Source : Character;
                      Count : String_Length) is
        Value_String : String (1 .. Count) := String'(1 .. Count => Source);
    begin
        Append (Target, Value_String);
    end Append;


    procedure Insert (Target : in out Variable_String;
                      At_Pos : Positive;
                      Source : String) is
        Len : String_Length := Length (Target);
    begin
        if At_Pos = Len + 1 then
            Append (Target, Source);
        elsif At_Pos <= Len then
            Allocate (Target, Len + Source'Length);
            declare
                T : Real_String renames Target.all;
            begin
                T.Contents (At_Pos .. T.Length) :=
                   Source & T.Contents (At_Pos .. Len);
            end;
        else
            raise Constraint_Error;
        end if;
    end Insert;


    procedure Insert (Target : in out Variable_String;
                      At_Pos : Positive;
                      Source : Variable_String) is
    begin
        Insert (Target, At_Pos, Image (Source));
    end Insert;


    procedure Insert (Target : in out Variable_String;
                      At_Pos : Positive;
                      Source : Character) is
        Len : String_Length := Length (Target) + 1;
    begin
        if At_Pos = Len then
            Append (Target, Source);
        elsif At_Pos > Len then
            raise Constraint_Error;
        else
            Allocate (Target, Len, Preserve_Contents => True);
            declare
                T : Real_String renames Target.all;
            begin
                T.Contents (At_Pos + 1 .. Len) :=
                   T.Contents (At_Pos .. Len - 1);
                T.Contents (At_Pos) := Source;
            end;
        end if;
    end Insert;


    procedure Insert (Target : in out Variable_String;
                      At_Pos : Positive;
                      Source : Character;
                      Count : String_Length) is
        Value_String : String (1 .. Count) := String'(1 .. Count => Source);
    begin
        Insert (Target, At_Pos, Value_String);
    end Insert;


    procedure Delete (Target : in out Variable_String;
                      At_Pos : Positive;
                      Count : String_Length := 1) is
        T : Real_String renames Target.all;
        Len : String_Length := T.Length - Count;
    begin
        if At_Pos - 1 > Len then
            raise Constraint_Error;
        end if;
        if At_Pos <= Len then
            T.Contents (At_Pos .. Len) :=
               T.Contents (At_Pos + Count .. T.Length);
        end if;
        T.Length := Len;
    end Delete;


    procedure Replace (Target : in out Variable_String;
                       At_Pos : Positive;
                       Source : Character) is
        T : Real_String renames Target.all;
    begin
        if At_Pos > T.Length then
            raise Constraint_Error;
        else
            T.Contents (At_Pos) := Source;
        end if;
    end Replace;


    procedure Replace (Target : in out Variable_String;
                       At_Pos : Positive;
                       Source : String) is
        T : Real_String renames Target.all;
        End_Pos : constant Natural -- not positive JMK 28 Sep 84
            := At_Pos + Source'Length - 1;
    begin
        if End_Pos > T.Length then
            raise Constraint_Error;
        else
            T.Contents (At_Pos .. End_Pos) := Source;
        end if;
    end Replace;

    procedure Replace (Target : in out Variable_String;
                       At_Pos : Positive;
                       Source : Character;
                       Count : String_Length) is
        Value_String : String (1 .. Count) := String'(1 .. Count => Source);
    begin
        Replace (Target, At_Pos, Value_String);
    end Replace;

    procedure Replace (Target : in out Variable_String;
                       At_Pos : Positive;
                       Source : Variable_String) is
    begin
        Replace (Target, At_Pos, Image (Source));
    end Replace;


    procedure Set_Length (Target : in out Variable_String;
                          New_Length : String_Length;
                          Fill_With : Character := ' ') is
        Current_Length : String_Length := Length (Target);
    begin
        if New_Length > Current_Length then
            Allocate (Target, New_Length, Preserve_Contents => True);
            declare
                C : String renames Target.Contents.all;
            begin
                for I in Current_Length + 1 .. New_Length loop
                    C (I) := Fill_With;
                end loop;
            end;
        elsif Target /= null then
            Target.Length := New_Length;
        end if;
    end Set_Length;

    function Char_At (Source : Variable_String; At_Pos : Positive)
                     return Character is
        S : Real_String renames Source.all;
    begin
        if At_Pos > S.Length then
            raise Constraint_Error;
        else
            return S.Contents (At_Pos);
        end if;
    end Char_At;

    function Extract (Source : Variable_String;
                      Start_Pos : Positive;
                      End_Pos : Natural) return String is
    begin
        if End_Pos > Source.Length then
            raise Constraint_Error;
        else
            return Source.Contents (Start_Pos .. End_Pos);
        end if;
    end Extract;


    function Is_Nil (V : Variable_String) return Boolean is
    begin
        return V = null;
    end Is_Nil;


    function Nil return Variable_String is
    begin
        return null;
    end Nil;
end Unbounded_String;
DataMuseum.dk

Rational R1000/400 Tapes

⟦f423e915a⟧ TextFile

Derivation

TextFile
