|
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 - download
Length: 28672 (0x7000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body String_Utilities, seg_0522ea
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Bounded_String;
package body String_Utilities is
type Translate_Table is array (Character) of Character;
type Equality_Table is array (Character, Character) of Boolean;
pragma Pack (Equality_Table);
Upper_Ascii : Translate_Table;
Lower_Ascii : Translate_Table;
Equal_Mod_Case : Equality_Table := (others => (others => False));
subtype Translation is Integer range 0 .. 2 ** 8 - 1;
-- Next_Cap is 0..1 * 2**7
-- Lower_Char is 0..127
type Caps_Array is array (Translation) of Translation;
Caps : Caps_Array;
Char : constant Translation := 2 ** 7;
Base_Characters : array (0 .. 15) of Character :=
('0', '1', '2', '3', '4', '5', '6', '7',
'8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
procedure Capitalize (S : in out String) is
Upper : Translation := 0;
begin
for I in S'Range loop
declare
C : Character renames S (I);
T : Translation renames Caps (Character'Pos (C) + Upper);
begin
C := Character'Val (T mod Char);
Upper := T - Character'Pos (C);
end;
end loop;
end Capitalize;
function Capitalize (S : String) return String is
Upper : Translation := 0;
New_S : String (S'Range) := S;
begin
for I in New_S'Range loop
declare
C : Character renames New_S (I);
T : Translation renames Caps (Character'Pos (C) + Upper);
begin
C := Character'Val (T mod Char);
Upper := T - Character'Pos (C);
end;
end loop;
return New_S;
end Capitalize;
function Upper_Case (C : Character) return Character is
begin
return Upper_Ascii (C);
end Upper_Case;
function Lower_Case (C : Character) return Character is
begin
return Lower_Ascii (C);
end Lower_Case;
procedure Upper_Case (C : in out Character) is
begin
C := Upper_Ascii (C);
end Upper_Case;
procedure Lower_Case (C : in out Character) is
begin
C := Lower_Ascii (C);
end Lower_Case;
procedure Upper_Case (S : in out String) is
begin
for I in S'Range loop
S (I) := Upper_Ascii (S (I));
end loop;
end Upper_Case;
procedure Lower_Case (S : in out String) is
begin
for I in S'Range loop
S (I) := Lower_Ascii (S (I));
end loop;
end Lower_Case;
function Upper_Case (S : String) return String is
New_S : String (S'First .. S'Last);
begin
for I in S'Range loop
New_S (I) := Upper_Ascii (S (I));
end loop;
return New_S;
end Upper_Case;
function Lower_Case (S : String) return String is
New_S : String (S'First .. S'Last);
begin
for I in S'Range loop
New_S (I) := Lower_Ascii (S (I));
end loop;
return New_S;
end Lower_Case;
-- It is expected that specific targets will be able to get better hashes
-- using code insertions.
function Hash_String (S : String) return Integer is
L : constant Integer := S'Length;
Result : Integer := L;
begin
if L > 0 then
Result := Result +
2 ** 5 * Character'Pos (Upper_Ascii (S (S'First))) +
Character'Pos
(Upper_Ascii
(S (S'First + (1 + S'Last - S'First) / 2))) +
2 ** 3 * Character'Pos (Upper_Ascii (S (S'Last)));
end if;
return Result;
end Hash_String;
function Number_To_String (Value : Integer;
Base : Natural := 10;
Width : Natural := 0;
Leading : Character := ' ') return String is
Sign : Boolean := False;
Result : Bounded_String.Variable_String (80);
Ch : Integer;
procedure N2s (Num : Integer; Width : Integer) is
begin
if Num = 0 then
-- Handle leading stuff
for I in 1 .. Width loop
Bounded_String.Append (Result, Leading);
end loop;
if Sign then
Bounded_String.Append (Result, '-');
end if;
if Value = 0 then
if Width > 0 then
Bounded_String.Replace
(Result, Bounded_String.Length (Result), '0');
else
Bounded_String.Append (Result, '0');
end if;
end if;
else
N2s (Num / Base, Width - 1);
if not Sign then
Ch := Num mod Base;
else
Ch := Base - Num mod Base;
if Ch = Base then
Ch := 0;
end if;
end if;
Bounded_String.Append (Result, Base_Characters (Ch));
end if;
end N2s;
begin
Bounded_String.Set_Length (Result, 0);
if Value < 0 then
Sign := True;
N2s (Value, Width - 1);
else
N2s (Value, Width);
end if;
return Bounded_String.Image (Result);
end Number_To_String;
-- the above used to be the long_integer version
-- function Number_To_String (Value : Integer;
-- Base : Natural := 10;
-- Width : Natural := 0;
-- Leading : Character := ' ') return String is
-- begin
-- return Number_To_String (Long_Integer (Value), Base, Width, Leading);
-- end Number_To_String;
-- the following used to be the long_integer version
procedure String_To_Number (Source : String;
Target : out Integer;
Worked : out Boolean;
Base : Natural := 10) is
Sign : Integer;
Result : Integer;
Ch : Character;
Char_Val : Integer;
Prefix : Boolean := True;
begin
Worked := False;
Target := 0;
Result := 0;
Sign := +1;
for I in Source'Range loop
Ch := Source (I);
if Ch = ' ' then
if not Prefix then
return;
end if;
else
if Prefix and Ch = '-' then
Sign := -1;
else
if Ch in '0' .. '9' then
Char_Val := (Character'Pos (Ch) - 48);
else
Upper_Case (Ch);
if Ch in 'A' .. 'F' then
Char_Val := Character'Pos (Ch) -
Character'Pos ('A') + 10;
else
-- set Char_Val > any legal base
Char_Val := 500;
end if;
end if;
if Char_Val >= Base then
return;
end if;
Result := Result * Base + Char_Val;
end if;
Prefix := False;
end if;
end loop;
if Source'Length /= 0 and then
(Source'Length > 1 or else Sign = +1) then
Target := Result * Sign;
Worked := True;
end if;
exception
when others =>
Worked := False;
end String_To_Number;
-- procedure String_To_Number (Source : String;
-- Target : out Integer;
-- Worked : out Boolean;
-- Base : Natural := 10) is
-- Result : Long_Integer;
-- begin
-- String_To_Number (Source, Result, Worked, Base);
-- Target := Integer (Result);
-- end String_To_Number;
function Locate (Fragment : Character;
Within : String;
Ignore_Case : Boolean := False) return Natural is
begin
if Ignore_Case then
for I in Within'Range loop
if Equal_Mod_Case (Fragment, Within (I)) then
return I;
end if;
end loop;
else
for I in Within'Range loop
if Fragment = Within (I) then
return I;
end if;
end loop;
end if;
return 0;
end Locate;
function Locate (Fragment : String;
Within : String;
Ignore_Case : Boolean := False) return Natural is
Dec_Length : Integer := Fragment'Length - 1;
First : Positive := Fragment'First;
First_Char : Character;
begin
if Dec_Length >= 1 then
First_Char := Fragment (First);
if Ignore_Case then
for I in Within'First .. Within'Last - Dec_Length loop
if Equal_Mod_Case (Within (I), First_Char) then
for J in reverse 1 .. Dec_Length loop
if not Equal_Mod_Case (Fragment (First + J),
Within (I + J)) then
exit;
elsif J = 1 then
return I;
end if;
end loop;
end if;
end loop;
else
for I in Within'First .. Within'Last - Dec_Length loop
if Within (I) = First_Char then
for J in reverse 1 .. Dec_Length loop
if Fragment (First + J) /= Within (I + J) then
exit;
elsif J = 1 then
return I;
end if;
end loop;
end if;
end loop;
end if;
return 0;
elsif Dec_Length = 0 then
return Locate (Fragment (First), Within, Ignore_Case);
else
return Within'First;
end if;
end Locate;
function Reverse_Locate (Fragment : Character;
Within : String;
Ignore_Case : Boolean := False) return Natural is
begin
if Ignore_Case then
for I in reverse Within'Range loop
if Equal_Mod_Case (Fragment, Within (I)) then
return I;
end if;
end loop;
else
for I in reverse Within'Range loop
if Fragment = Within (I) then
return I;
end if;
end loop;
end if;
return 0;
end Reverse_Locate;
function Reverse_Locate (Fragment : String;
Within : String;
Ignore_Case : Boolean := False) return Natural is
Dec_Length : Integer := Fragment'Length - 1;
First : Positive := Fragment'First;
First_Char : Character;
begin
if Dec_Length >= 1 then
First_Char := Fragment (First);
if Ignore_Case then
for I in reverse Within'First .. Within'Last - Dec_Length loop
if Equal_Mod_Case (Within (I), First_Char) then
for J in reverse 1 .. Dec_Length loop
if not Equal_Mod_Case (Fragment (First + J),
Within (I + J)) then
exit;
elsif J = 1 then
return I + Dec_Length;
end if;
end loop;
end if;
end loop;
else
for I in reverse Within'First .. Within'Last - Dec_Length loop
if Within (I) = First_Char then
for J in reverse 1 .. Dec_Length loop
if Fragment (First + J) /= Within (I + J) then
exit;
elsif J = 1 then
return I + Dec_Length;
end if;
end loop;
end if;
end loop;
end if;
return 0;
elsif Dec_Length = 0 then
return Reverse_Locate (Fragment (First), Within, Ignore_Case);
else
return Within'Last;
end if;
end Reverse_Locate;
function Equal
(Str1 : String; Str2 : String; Ignore_Case : Boolean := False)
return Boolean is
Length : Integer := Str1'Length;
First1 : Positive := Str1'First;
First2 : Positive := Str2'First;
begin
if Length = Str2'Length then
if Ignore_Case then
for I in 0 .. Length - 1 loop
if not Equal_Mod_Case(Str1 (First1 + I),
Str2 (First2 + I)) then
return False;
end if;
end loop;
return True;
else
return Str1 = Str2;
end if;
else
return False;
end if;
end Equal;
function Less_Than
(Str1 : String; Str2 : String; Ignore_Case : Boolean := False)
return Boolean is
begin
if Ignore_Case then
return Lower_Case (Str1) < Lower_Case (Str2);
else
return Str1 < Str2;
end if;
end Less_Than;
function Greater_Than
(Str1 : String; Str2 : String; Ignore_Case : Boolean := False)
return Boolean is
begin
if Ignore_Case then
return Lower_Case (Str1) > Lower_Case (Str2);
else
return Str1 > Str2;
end if;
end Greater_Than;
function Strip_Leading
(From : String; Filler : Character := ' ') return String is
begin
for I in From'First .. From'Last loop
if From (I) /= Filler then
return From (I .. From'Last);
end if;
end loop;
return "";
end Strip_Leading;
function Strip_Trailing
(From : String; Filler : Character := ' ') return String is
begin
for I in reverse From'First .. From'Last loop
if From (I) /= Filler then
return From (From'First .. I);
end if;
end loop;
return "";
end Strip_Trailing;
function Strip (From : String; Filler : Character := ' ') return String is
begin
return Strip_Leading (Strip_Trailing (From, Filler), Filler);
end Strip;
begin
for C in Character loop
Upper_Ascii (C) := C;
Equal_Mod_Case (C, C) := True;
end loop;
Lower_Ascii := Upper_Ascii;
for C in 'A' .. 'Z' loop
Lower_Ascii (C) := Character'Val (Character'Pos (C) + 32);
Equal_Mod_Case (C, Lower_Ascii (C)) := True;
end loop;
for C in 'a' .. 'z' loop
Upper_Ascii (C) := Character'Val (Character'Pos (C) - 32);
Equal_Mod_Case (C, Upper_Ascii (C)) := True;
end loop;
declare
Alphanumeric : Integer;
Upper : Character;
Lower : Character;
begin
for C in Character loop
Upper := Upper_Ascii (C);
Lower := Lower_Ascii (C);
Alphanumeric := Boolean'Pos
(Upper /= Lower or else C in '0' .. '9') * Char;
Caps (Character'Pos (C)) := Alphanumeric + Character'Pos (Upper);
Caps (Character'Pos (C) + Char) :=
Alphanumeric + Character'Pos (Lower);
end loop;
end;
end String_Utilities;
nblk1=1b
nid=0
hdr6=36
[0x00] rec0=21 rec1=00 rec2=01 rec3=052
[0x01] rec0=00 rec1=00 rec2=1b rec3=006
[0x02] rec0=20 rec1=00 rec2=02 rec3=070
[0x03] rec0=01 rec1=00 rec2=1a rec3=012
[0x04] rec0=2c rec1=00 rec2=03 rec3=016
[0x05] rec0=1b rec1=00 rec2=04 rec3=05a
[0x06] rec0=00 rec1=00 rec2=19 rec3=018
[0x07] rec0=18 rec1=00 rec2=05 rec3=01c
[0x08] rec0=01 rec1=00 rec2=18 rec3=002
[0x09] rec0=1c rec1=00 rec2=06 rec3=064
[0x0a] rec0=1e rec1=00 rec2=07 rec3=03c
[0x0b] rec0=01 rec1=00 rec2=17 rec3=018
[0x0c] rec0=19 rec1=00 rec2=08 rec3=02e
[0x0d] rec0=1f rec1=00 rec2=09 rec3=014
[0x0e] rec0=1a rec1=00 rec2=0a rec3=00c
[0x0f] rec0=00 rec1=00 rec2=16 rec3=00c
[0x10] rec0=1e rec1=00 rec2=0b rec3=00e
[0x11] rec0=1b rec1=00 rec2=0c rec3=00a
[0x12] rec0=00 rec1=00 rec2=15 rec3=008
[0x13] rec0=15 rec1=00 rec2=0d rec3=054
[0x14] rec0=1e rec1=00 rec2=0e rec3=052
[0x15] rec0=00 rec1=00 rec2=14 rec3=002
[0x16] rec0=24 rec1=00 rec2=0f rec3=038
[0x17] rec0=24 rec1=00 rec2=10 rec3=03a
[0x18] rec0=00 rec1=00 rec2=13 rec3=00c
[0x19] rec0=1d rec1=00 rec2=11 rec3=022
[0x1a] rec0=04 rec1=00 rec2=12 rec3=000
tail 0x21759a9fc87a067d2bb0d 0x42a00088462063203