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