⟦a0c1f1b2d⟧

TextFile

--    The use of this system is subject to the software license terms and
--    conditions agreed upon between Rational and the Customer.
--
--                Copyright 1988 by Rational.
--
--                          RESTRICTED RIGHTS LEGEND
--
--    Use, duplication, or disclosure by the Government is subject to
--    restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
--    Technical Data and Computer Software clause at 52.227-7013.
--
--
--                Rational
--                3320 Scott Boulevard
--                Santa Clara, California 95054-3197
--
--   PROPRIETARY AND CONFIDENTIAL INFORMATION OF RATIONAL;
--   USE OR COPYING WITHOUT EXPRESS WRITTEN AUTHORIZATION
--   IS STRICTLY PROHIBITED.  THIS MATERIAL IS PROTECTED AS
--   AN UNPUBLISHED WORK UNDER THE U.S. COPYRIGHT ACT OF
--   1976.  CREATED 1988.  ALL RIGHTS RESERVED.
--
--

with Machine_Primitive_Operations;
with Unchecked_Deallocation;

-- For debugging:
with Primitive_Io;

package body Buffering is

    -- For debugging only:
    --Buffering_Absorb_Output : Boolean renames Primitive_Io.Global_Absorb_Output;

    -- procedure Pput (S             : String;
    --                 Absorb_Output : Boolean := Buffering_Absorb_Output)
    --     renames Primitive_Io.Put_Line;


    procedure Clear (Buffer : in Data_Buffer) is
    begin
        Buffer.Head := 0;
        Buffer.Tail := 1;
    end Clear;


    function Allocate (Max_Length : in Natural) return Data_Buffer is
        -- Nb : constant Data_Buffer := new Buffer (Max_Length => Max_Length);
        Nb : Data_Buffer;
    begin
        Nb := new Buffer (Max_Length);
        Clear (Nb);

        -- If currently debugging, then fill the buffer with a special
        -- character ('.') so that the debugging display will look ok.
        -- If not debugging, then don't bother.
        -- if not Buffering_Absorb_Output then
        --     if Max_Length > 0 then
        --         Machine_Primitive_Operations.Fill_Bytes
        --            (Nb.Buffer, Max_Length, Character'Pos ('.'));
        --     end if;
        --     -- Pput ("Buffering.Allocate allocated a buffer");
        -- end if;

        return Nb;
    exception
        when Storage_Error =>
            -- Pput ("Buffering.Allocate got Storage_Error; size = " &
            --       Integer'Image (Max_Length),
            --       Absorb_Output => False);
            raise Storage_Error;

        when others =>
            -- Pput ("Buffering.Allocate got an exception",
            --       Absorb_Output => False);
            raise;
    end Allocate;


    procedure Free (Buffer : in out Data_Buffer) is
        procedure Free_It is new Unchecked_Deallocation
                                    (Buffering.Buffer, Data_Buffer);
    begin
        Free_It (Buffer);
    end Free;


    function Is_Allocated (Buffer : in Data_Buffer) return Boolean is
    begin
        return Buffer /= null;
    end Is_Allocated;


    function Is_Empty (Buffer : in Data_Buffer) return Boolean is
    begin
        -- return Left (Buffer) = 0;
        return Buffer.Head + 1 = Buffer.Tail;
    end Is_Empty;


    function Is_Full (Buffer : in Data_Buffer) return Boolean is
    begin
        -- return Room (Buffer) = 0;
        return Buffer.Max_Length - Buffer.Head + Buffer.Tail = 1;
    end Is_Full;


    function Left (Buffer : in Data_Buffer) return Natural is
    begin
        return Buffer.Head - Buffer.Tail + 1;
    end Left;


    function Room (Buffer : in Data_Buffer) return Natural is
    begin
        -- return Buffer.Max_Length - Left (Buffer);
        return Buffer.Max_Length - Buffer.Head + Buffer.Tail - 1;
    end Room;


    function Max_Length (Buffer : in Data_Buffer) return Natural is
    begin
        return Buffer.Max_Length;
    end Max_Length;


    function Room_At_End (Buffer : in Data_Buffer) return Natural is
    begin
        return Buffer.Max_Length - Buffer.Head;
    end Room_At_End;


    procedure Slide (Buffer : in Data_Buffer) is
        Left : constant Natural := Buffering.Left (Buffer);
    begin
        if Left > 0 then
            -- Maybe an overlapping slide so do it in Ada!
            Buffer.Buffer (1 .. Left) := Buffer.Buffer
                                            (Buffer.Tail .. Buffer.Head);
            Buffer.Tail               := 1;
            Buffer.Head               := Left;
        else
            Clear (Buffer);
        end if;
    end Slide;


    function Next (Buffer : in Data_Buffer) return Byte is
    begin
        if Left (Buffer) < 1 then
            raise Empty;
        else
            declare
                T : constant Natural := Buffer.Tail;
            begin
                Buffer.Tail := Buffer.Tail + 1;
--                if Buffer.Tail > Buffer.Head then
--                    Clear (Buffer);
--                end if;
                return Buffer.Buffer (T);
            end;
        end if;
    end Next;

    function Next (Buffer : in Data_Buffer) return Character is
    begin
        return To_Character (Next (Buffer));
    end Next;


    procedure Next (Buffer : in Data_Buffer; S : out Byte_String) is
        N : constant Natural := S'Length;
    begin
        if Left (Buffer) < N then
            raise Empty;
        elsif N > 0 then
            declare
                T : constant Natural := Buffer.Tail;
            begin
                Machine_Primitive_Operations.Move_Bytes
                   (Buffer.Buffer (T .. Buffer.Max_Length), S, N);
                Buffer.Tail := T + N;
                --              if Buffer.Tail > Buffer.Head then
                --                  Clear (Buffer);
                --              end if;
            end;
        end if;
    end Next;

    procedure Next (Buffer : in Data_Buffer; S : out String) is
        N : constant Natural := S'Length;
    begin
        if Left (Buffer) < N then
            raise Empty;
        elsif N > 0 then
            declare
                T : constant Natural := Buffer.Tail;
            begin
                Machine_Primitive_Operations.Move_Bytes  
                   (Buffer.Buffer (T .. Buffer.Max_Length), S, N);
                Buffer.Tail := T + N;
--                if Buffer.Tail > Buffer.Head then
--                    Clear (Buffer);
--                end if;
            end;
        end if;
    end Next;

    function Next (Buffer : in Data_Buffer; N : in Natural)
                  return Byte_String is
    begin
        if Left (Buffer) < N then
            raise Empty;
        else
            declare
                T : constant Natural := Buffer.Tail;
            begin
                -- Cleverly, the buffer's pointers are modified before the
                -- data is taken.  But this is fine.
                Buffer.Tail := Buffer.Tail + N;
--              if Buffer.Tail > Buffer.Head then
--                    Clear (Buffer);
--                end if;
                return Buffer.Buffer (T .. T + N - 1);
            end;
        end if;
    end Next;

    function Next (Buffer : in Data_Buffer; N : in Natural) return String is
    begin
        if Left (Buffer) < N then
            raise Empty;
        elsif N = 0 then
            return "";
        else
            -- It is necessary to make an extra copy in order to do the
            -- conversion to String (*).  But why are you using the
            -- functional form instead of the procedural form anyway?
            -- (*) Actually, we could take the address of the first character
            -- of the valid part of the buffer, uncheck-convert the address
            -- to a pointer to an unconstrained string, and then slice off
            -- the right part, but this involves knowing where a pointer to
            -- a string points to.  And since the procedural form exists,
            -- why bother?  (Also the cross-compiler will currently make
            -- an extra copy anyway, instead of passing the slice around.)
            declare
                S : String (1 .. N);
            begin
                Machine_Primitive_Operations.Move_Bytes
                   (Buffer.Buffer (Buffer.Tail .. Buffer.Max_Length), S, N);
                Buffer.Tail := Buffer.Tail + N;
--                if Buffer.Tail > Buffer.Head then
--                    Clear (Buffer);
--                end if;
                return S;
            end;
        end if;
    end Next;

    procedure Rest (Buffer : in  Data_Buffer;
                    S      : out Byte_String;
                    N      : out Natural) is
        T : constant Natural := Buffer.Tail;
        H : constant Natural := Buffer.Head;
        L : constant Natural := H - T + 1;
    begin
        N := L;
        if L /= 0 then
            Machine_Primitive_Operations.Move_Bytes
               (Buffer.Buffer (T .. Buffer.Max_Length), S, L);
        end if;
        Clear (Buffer);
    end Rest;

    procedure Rest (Buffer : in Data_Buffer; S : out String; N : out Natural) is
        T : constant Natural := Buffer.Tail;
        H : constant Natural := Buffer.Head;
        L : constant Natural := H - T + 1;
    begin
        N := L;
        if L /= 0 then
            Machine_Primitive_Operations.Move_Bytes  
               (Buffer.Buffer (T .. Buffer.Max_Length), S, L);
        end if;
        Clear (Buffer);
    end Rest;

    function Rest (Buffer : in Data_Buffer) return Byte_String is
        T : constant Natural := Buffer.Tail;
        H : constant Natural := Buffer.Head;
    begin
        Clear (Buffer);
        return Buffer.Buffer (T .. H);
    end Rest;

    function Rest (Buffer : in Data_Buffer) return String is
        T : constant Natural := Buffer.Tail;
        H : constant Natural := Buffer.Head;
        N : constant Natural := H - T + 1;
    begin
        if N = 0 then
            Clear (Buffer);
            return "";
        else
            declare
                S : String (1 .. N);
            begin
                -- Makes an extra copy, but see comments in the functional
                -- form of Next, above.
                Machine_Primitive_Operations.Move_Bytes
                   (Buffer.Buffer (T .. Buffer.Max_Length), S, N);
                Clear (Buffer);
                return S;
            end;
        end if;
    end Rest;


    procedure Stuff (Buffer : in Data_Buffer; C : in Byte) is
    begin
        if Room (Buffer) < 1 then
            raise Full;
        end if;
        if Room_At_End (Buffer) < 1 then
            Slide (Buffer);
        end if;
        Buffer.Head                 := Buffer.Head + 1;
        Buffer.Buffer (Buffer.Head) := C;
    end Stuff;

    procedure Stuff (Buffer : in Data_Buffer; C : in Character) is
    begin
        if Room (Buffer) < 1 then
            raise Full;
        end if;
        if Room_At_End (Buffer) < 1 then
            Slide (Buffer);
        end if;
        Buffer.Head                 := Buffer.Head + 1;
        Buffer.Buffer (Buffer.Head) := To_Byte (C);
    end Stuff;


    procedure Stuff (Buffer : in Data_Buffer; S : in Byte_String) is
        L : constant Natural := S'Length;
    begin
        if L = 0 then
            return;
        end if;
        if Room (Buffer) < L then
            raise Full;
        end if;
        if Room_At_End (Buffer) < L then
            Slide (Buffer);
        end if;
        Machine_Primitive_Operations.Move_Bytes
           (S, Buffer.Buffer (Buffer.Head + 1 .. Buffer.Max_Length), L);
        Buffer.Head := Buffer.Head + L;
    end Stuff;

    procedure Stuff (Buffer : in Data_Buffer; S : in String) is
        L : constant Natural := S'Length;
    begin
        if L = 0 then
            return;
        end if;
        if Room (Buffer) < L then
            raise Full;
        end if;
        if Room_At_End (Buffer) < L then
            Slide (Buffer);
        end if;
        Machine_Primitive_Operations.Move_Bytes
           (S, Buffer.Buffer (Buffer.Head + 1 .. Buffer.Max_Length), L);
        Buffer.Head := Buffer.Head + L;
    end Stuff;


    function Peek (Buffer : in Data_Buffer) return Byte is
    begin
        if Left (Buffer) < 1 then
            raise Empty;
        else
            return Buffer.Buffer (Buffer.Tail);
        end if;
    end Peek;


    function Peek (Buffer : in Data_Buffer) return Character is
    begin
        return To_Character (Peek (Buffer));
    end Peek;


    function Peek_At_Last (Buffer : in Data_Buffer) return Byte is
    begin
        if Left (Buffer) < 1 then
            raise Empty;
        else
            return Buffer.Buffer (Buffer.Head);
        end if;
    end Peek_At_Last;


    function Peek_At_Last (Buffer : in Data_Buffer) return Character is
    begin
        return To_Character (Peek_At_Last (Buffer));
    end Peek_At_Last;


    procedure Consume (Buffer : in Data_Buffer; N : in Natural := 1) is
    begin
        if Left (Buffer) < N then
            raise Empty;
        else
            Buffer.Tail := Buffer.Tail + N;
        end if;
    end Consume;


    procedure Throwback (Buffer : in Data_Buffer; N : in Natural := 1) is
    begin
        if Room (Buffer) < N then
            raise Full;
        elsif Buffer.Tail - N < 1 then
            -- Buffer has already been slid?  Should never happen
            raise Full;
        else
            Buffer.Tail := Buffer.Tail - N;
        end if;
    end Throwback;


    procedure Ensure_Room_For (Buffer : in Data_Buffer; N : in Natural) is
    begin
        if Room (Buffer) >= N then
            Slide (Buffer);
        else
            raise Full;
        end if;
    end Ensure_Room_For;


    procedure Bump (Buffer : in Data_Buffer; N : in Natural) is
    begin
        if Room (Buffer) >= N then
            Buffer.Head := Buffer.Head + N;
        else
            raise Full;
        end if;
    end Bump;


    procedure Unbump (Buffer : in Data_Buffer; N : in Natural := 1) is
    begin
        if Left (Buffer) >= N then
            Buffer.Head := Buffer.Head - N;
        else
            raise Empty;
        end if;
    end Unbump;



    procedure Display_Buffer (Buffer : in Data_Buffer) is

        function Integer_Image (I : Integer) return String
            renames Primitive_Io.Integer_Image;
        --
        -- procedure Display80 (S : in String) is
        -- begin
        --     if S'Length <= 79 then
        --         Pput (S);
        --     else
        --         Pput (S (S'First .. S'First + 78));
        --         Display80 (S (S'First + 79 .. S'Last));
        --     end if;
        -- end Display80;

    begin
        -- if Buffering_Absorb_Output then
        return;
        -- end if;

        -- if Buffer = null then
        --     Pput ("Buffer is not allocated");
        -- else
        --     Pput ("Buffer:");
        --     declare
        --         S : String (1 .. Buffer.Max_Length);
        --     begin
        --         if Buffer.Max_Length > 0 then
        --             Machine_Primitive_Operations.Move_Bytes
        --                (Buffer.Buffer, S, Buffer.Max_Length);
        --         end if;
        --         Pput ("Buffer [" & Integer_Image (Buffer.Max_Length) &
        --               "] head = " & Integer_Image (Buffer.Head) &
        --               ", tail = " & Integer_Image (Buffer.Tail));
        --         Display80 (S (Buffer.Tail .. Buffer.Head));
        --         Pput ("   ");
        -- Display80 ('<' & S & '>');
        -- declare
        --     Ptrs : String (1 .. Buffer.Max_Length + 2) :=
        --        (1 .. Buffer.Max_Length + 2 => ' ');
        --     procedure Show_Ptrs (Index : Natural) is
        --     begin
        --         Display80 (Ptrs (1 .. Index + 1));
        --     end Show_Ptrs;
        --
        -- begin
        --     if Buffer.Head = Buffer.Tail then
        --         Ptrs (Buffer.Head + 1) := '^';
        --     else
        --         Ptrs (Buffer.Head + 1) := 'h';
        --         Ptrs (Buffer.Tail + 1) := 't';
        --     end if;
        --     if Buffer.Head > Buffer.Tail then
        --         Show_Ptrs (Buffer.Head);
        --         Display80 (Ptrs (1 .. Buffer.Head + 1));
        --     else
        --         Show_Ptrs (Buffer.Tail);
        --         Display80 (Ptrs (1 .. Buffer.Tail + 1));
        --     end if;
        -- end;
        -- end;
        --end if;
    end Display_Buffer;

end Buffering;
DataMuseum.dk

Rational R1000/400 Tapes

⟦a0c1f1b2d⟧ TextFile

Derivation

TextFile
