|
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 - metrics - downloadIndex: B T
Length: 16379 (0x3ffb)
Types: TextFile
Names: »B«
└─⟦afbc8121e⟧ Bits:30000532 8mm tape, Rational 1000, MC68020_OS2000 7_2_2
└─⟦77aa8350c⟧ »DATA«
└─⟦f794ecd1d⟧
└─⟦4c85d69e2⟧
└─⟦this⟧
-- 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;