|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 13312 (0x3400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body A_Strings, seg_050967
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
-- This package defines types and routines for manipulating
-- varying-length character strings, as a_string (access string_rec).
-- SFZ\x091/21/86
package body A_Strings is
pragma Suppress (Length_Check);
pragma Suppress (Range_Check);
pragma Suppress (Index_Check);
procedure Check_Len (Try, Bound : Integer) is
begin
if Try < 1 or else Try > Bound then
raise Constraint_Error;
end if;
end Check_Len;
pragma Inline_Only (Check_Len);
function Allocate (Size : Integer) return A_String is
begin
return new String_Rec (Size);
end Allocate;
function To_C (S : A_String) return System.Address is
With_Nul : A_String;
begin
if S.Len /= 0 then
if S.S (S.Len) = Ascii.Nul then
return S.S (1)'Address;
end if;
end if;
With_Nul := S & Ascii.Nul;
return With_Nul.S (1)'Address;
end To_C;
function To_A (S : String) return A_String is
Result : A_String;
begin
Result := Allocate (S'Length);
Result.S := S;
return Result;
end To_A;
function To_A (C : Character) return A_String is
Result : A_String;
begin
Result := Allocate (1);
Result.S (1) := C;
return Result;
end To_A;
function "&" (S : A_String; T : A_String) return A_String is
Result : A_String;
begin
Result := Allocate (S.Len + T.Len);
Result.S := S.S & T.S;
return Result;
end "&";
function "&" (S : String; T : A_String) return A_String is
Result : A_String;
begin
Result := Allocate (S'Length + T.Len);
Result.S := S & T.S;
return Result;
end "&";
function "&" (S : A_String; T : String) return A_String is
Result : A_String;
begin
Result := Allocate (S.Len + T'Length);
Result.S := S.S & T;
return Result;
end "&";
function "&" (S : Character; T : A_String) return A_String is
Result : A_String;
begin
Result := Allocate (1 + T.Len);
Result.S := S & T.S;
return Result;
end "&";
function "&" (S : A_String; T : Character) return A_String is
Result : A_String;
begin
Result := Allocate (1 + S.Len);
Result.S := S.S & T;
return Result;
end "&";
function Insert (S : A_String; Into : A_String; At_Char : Natural)
return A_String is
Result : A_String;
begin
Check_Len (At_Char, Into.Len);
Result := Allocate (S.Len + Into.Len);
Result.S := Into.S (1 .. At_Char - 1) & S.S &
Into.S (At_Char .. Into.Len);
return Result;
end Insert;
function Insert (S : String; Into : A_String; At_Char : Natural)
return A_String is
Result : A_String;
begin
Check_Len (At_Char, Into.Len);
Result := Allocate (S'Length + Into.Len);
Result.S := Into.S (1 .. At_Char - 1) & S &
Into.S (At_Char .. Into.Len);
return Result;
end Insert;
function Insert (S : Character; Into : A_String; At_Char : Natural)
return A_String is
Result : A_String;
begin
Check_Len (At_Char, Into.Len);
Result := Allocate (Into.Len + 1);
Result.S := Into.S (1 .. At_Char - 1) & S &
Into.S (At_Char .. Into.Len);
return Result;
end Insert;
function Change (S : A_String; At_Char, To_Char : Natural; Into : A_String)
return A_String is
Result : A_String;
Deleted : Integer := To_Char - At_Char + 1;
begin
Check_Len (At_Char, S.Len);
Check_Len (To_Char, S.Len);
Result := Allocate (S.Len + Into.Len - Deleted);
Result.S := S.S (1 .. At_Char - 1) & Into.S &
S.S (To_Char + 1 .. S.Len);
return Result;
end Change;
function Change (S : A_String; At_Char, To_Char : Natural; Into : String)
return A_String is
Result : A_String;
Deleted : Integer := To_Char - At_Char + 1;
begin
Check_Len (At_Char, S.Len);
Check_Len (To_Char, S.Len);
Result := Allocate (S.Len + Into'Length - Deleted);
Result.S := S.S (1 .. At_Char - 1) & Into & S.S (To_Char + 1 .. S.Len);
return Result;
end Change;
function Has (Pattern, S : A_String; Start : Natural := 1) return Integer is
Len_Less_One : Integer := Pattern.Len - 1;
begin
for I in Start .. S.Len - Len_Less_One loop
if S.S (I .. I + Len_Less_One) = Pattern.S then
return I;
end if;
end loop;
return 0;
end Has;
function Has (Pattern : String; S : A_String; Start : Natural := 1)
return Integer is
Len_Less_One : Integer := Pattern'Length - 1;
begin
for I in Start .. S.Len - Len_Less_One loop
if S.S (I .. I + Len_Less_One) = Pattern then
return I;
end if;
end loop;
return 0;
end Has;
function Has (Pattern : Character; S : A_String; Start : Natural := 1)
return Integer is
begin
for I in Start .. S.Len loop
if S.S (I) = Pattern then
return I;
end if;
end loop;
return 0;
end Has;
function Next (Pattern, S : A_String; Start : Natural := 1)
return Natural is
Index : Integer := Has (Pattern, S, Start);
begin
if Index = 0 then
raise Not_Found;
end if;
return Index;
end Next;
function Next (Pattern : String; S : A_String; Start : Natural := 1)
return Natural is
Index : Integer := Has (Pattern, S, Start);
begin
if Index = 0 then
raise Not_Found;
end if;
return Index;
end Next;
function Next (Pattern : Character; S : A_String; Start : Natural := 1)
return Natural is
Index : Integer := Has (Pattern, S, Start);
begin
if Index = 0 then
raise Not_Found;
end if;
return Index;
end Next;
function Last (Pattern, S : A_String; Start : Natural := 1)
return Natural is
begin
return Last (Pattern.S, S, Start);
end Last;
function Last (Pattern : String; S : A_String; Start : Natural := 1)
return Natural is
I : Integer := Start - 1;
begin
loop
I := Next (Pattern, S, I + 1);
end loop;
exception
when Not_Found =>
if I = Start - 1 then
raise Not_Found;
end if;
return I;
end Last;
function Last (Pattern : Character; S : A_String; Start : Natural := 1)
return Natural is
begin
return Last (String'(1 => Pattern), S, Start);
end Last;
function Substitute (For_Pattern, To_Pattern : String; S : A_String)
return A_String is
begin
raise Program_Error; -- not yet implemented
return Empty; --WARNING
end Substitute;
function Reverse_Order (S : A_String) return A_String is
Result : A_String := Allocate (S.Len);
begin
for I in 1 .. S.Len loop
Result.S (I) := S.S (S.Len - I + 1);
end loop;
return Result;
end Reverse_Order;
function Truncate (S : A_String; At_Char : Natural) return A_String is
Result : A_String;
begin
if At_Char > S.Len then
return S;
end if;
Check_Len (At_Char, S.Len);
Result := new String_Rec'(At_Char - 1, S.S (1 .. At_Char - 1));
return Result;
end Truncate;
function Trim (S : A_String) return A_String is
Result : A_String;
begin
for I in reverse 1 .. S.Len loop
if S.S (I) /= ' ' then
Result := Allocate (I);
Result.S := S.S (1 .. I);
return Result;
end if;
end loop;
return Empty;
end Trim;
function Pad_Left (S : A_String;
To_Length : Natural;
Pad_Char : Character := ' ') return A_String is
Result : A_String;
begin
if S.Len > To_Length then
raise Constraint_Error;
end if;
Result := Allocate (To_Length);
for I in 1 .. To_Length - S.Len loop
Result.S (I) := Pad_Char;
end loop;
Result.S (To_Length - S.Len + 1 .. To_Length) := S.S;
return Result;
end Pad_Left;
function Pad_Right (S : A_String;
To_Length : Natural;
Pad_Char : Character := ' ') return A_String is
Result : A_String;
begin
if S.Len > To_Length then
raise Constraint_Error;
end if;
Result := Allocate (To_Length);
for I in S.Len + 1 .. To_Length loop
Result.S (I) := Pad_Char;
end loop;
Result.S (1 .. S.Len) := S.S;
return Result;
end Pad_Right;
function Copy (S : A_String) return A_String is
Result : A_String := Allocate (S.Len);
begin
Result.S := S.S;
return Result;
end Copy;
function Lower_To_Upper (S : A_String) return A_String is
Result : A_String := Allocate (S.Len);
begin
for I in 1 .. S.Len loop
Result.S (I) := To_Upper (S.S (I));
end loop;
return Result;
end Lower_To_Upper;
function Upper_To_Lower (S : A_String) return A_String is
Result : A_String := Allocate (S.Len);
begin
for I in 1 .. S.Len loop
Result.S (I) := To_Lower (S.S (I));
end loop;
return Result;
end Upper_To_Lower;
function Translate
(From_Old, To_New : String; S : A_String) return A_String is
Result : A_String := Allocate (S.Len);
Trans : array (Character) of Character;
begin
if From_Old'First /= To_New'First or else
From_Old'Last /= To_New'Last then
raise Constraint_Error;
end if;
for C in Character loop
Trans (C) := C;
end loop;
for I in From_Old'Range loop
Trans (From_Old (I)) := To_New (I);
end loop;
for I in 1 .. S.Len loop
Result.S (I) := Trans (S.S (I));
end loop;
return Result;
end Translate;
function Is_Null (S : A_String) return Boolean is
begin
return S = null;
end Is_Null;
function Is_Empty (S : A_String) return Boolean is
begin
return S.Len = 0;
end Is_Empty;
procedure Free (S : A_String) is
begin
null;
end Free;
end A_Strings;
nblk1=c
nid=0
hdr6=18
[0x00] rec0=23 rec1=00 rec2=01 rec3=01a
[0x01] rec0=25 rec1=00 rec2=02 rec3=056
[0x02] rec0=21 rec1=00 rec2=03 rec3=01c
[0x03] rec0=1c rec1=00 rec2=04 rec3=014
[0x04] rec0=1a rec1=00 rec2=05 rec3=01c
[0x05] rec0=22 rec1=00 rec2=06 rec3=018
[0x06] rec0=22 rec1=00 rec2=07 rec3=03a
[0x07] rec0=20 rec1=00 rec2=08 rec3=086
[0x08] rec0=21 rec1=00 rec2=09 rec3=024
[0x09] rec0=1f rec1=00 rec2=0a rec3=044
[0x0a] rec0=1f rec1=00 rec2=0b rec3=008
[0x0b] rec0=17 rec1=00 rec2=0c rec3=000
tail 0x21757fe28878e78c99c3a 0x42a00088462060003