DataMuseum.dk Presents historical artifacts from the history of: Rational R1000/400

This is an automatic "excavation" of a thematic subset of artifacts from Datamuseum.dk's BitArchive. See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software.

top - download

⟦66b2dde4e⟧ Ada Source

    Length: 7168 (0x1c00)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Strings, seg_04b97d

Derivation

└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
    └─ ⟦5a81ac88f⟧ »Space Info Vol 1« 
        └─⟦this⟧ 

-- This package defines types and routines for manipulating
-- varying-length Ada strings.  Similar to A_strings.
-- SFZ\x0910/26/91

with A_Strings;
package body Strings is

    pragma Suppress (Length_Check);
    pragma Suppress (Range_Check);
    pragma Suppress (Index_Check);

    function Insert (S : String; Into : String; At_Char : Natural)
                    return String is
    begin
        return Into (Into'First .. At_Char - 1) &
                  S & Into (At_Char .. Into'Last);
    end Insert;

    function Insert (S : Character; Into : String; At_Char : Natural)
                    return String is
    begin
        return Into (Into'First .. At_Char - 1) &
                  S & Into (At_Char .. Into'Last);
    end Insert;

    function Change (S : String; At_Char, To_Char : Natural; Into : String)
                    return String is
    begin
        return S (S'First .. At_Char - 1) & Into & S (To_Char + 1 .. S'Last);
    end Change;

    function Has (Pattern, S : String; Start : Natural := 1) return Integer is
        Len_Less_One : Integer := Pattern'Length - 1;
        Real_Start : Natural := Start;
    begin
        if Start < S'First then
            Real_Start := S'First;
        end if;
        for I in Start .. S'Last - Len_Less_One loop
            if S (I .. I + Len_Less_One) = Pattern then
                return I;
            end if;
        end loop;
        return 0;
    end Has;

    function Has (Pattern : Character; S : String; Start : Natural := 1)
                 return Integer is
        Real_Start : Natural := Start;
    begin
        if Start < S'First then
            Real_Start := S'First;
        end if;
        for I in Start .. S'Last loop
            if S (I) = Pattern then
                return I;
            end if;
        end loop;
        return 0;
    end Has;

    function Next (Pattern, S : 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 : 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 : String; Start : Natural := 1) return Natural is
        I : Integer := Start - 1;
    begin
        if I = 0 then
            I := S'First - 1;
        end if;
        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 : 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 : String) return String is
    begin
        raise Program_Error; -- not yet implemented
        return "";   --WARNING
    end Substitute;

    function Reverse_Order (S : String) return String is
        Result : String (S'Range);
    begin
        for I in S'Range loop
            Result (I) := S (S'Last + S'First - I);
        end loop;
        return Result;
    end Reverse_Order;

    function Trim (S : String) return String is
    begin
        for I in reverse 1 .. S'Length loop
            if S (I) /= ' ' then
                return S (S'First .. I);
            end if;
        end loop;
        return "";
    end Trim;

    procedure Pad_Left
                 (S : String; T : in out String; Pad_Char : Character := ' ') is
    begin
        if S'Length > T'Length then
            raise Constraint_Error;
        end if;
        for I in T'First .. T'Last - S'Length loop
            T (I) := Pad_Char;
        end loop;
        T (T'Last - S'Length + 1 .. T'Last) := S;
    end Pad_Left;

    procedure Pad_Right
                 (S : String; T : in out String; Pad_Char : Character := ' ') is
    begin
        if S'Length > T'Length then
            raise Constraint_Error;
        end if;
        for I in T'First + S'Length .. T'Last loop
            T (I) := Pad_Char;
        end loop;
        T (T'First .. T'First + S'Length - 1) := S;
    end Pad_Right;

    procedure Lower_To_Upper (S : in out String) is
    begin
        for I in S'Range loop
            S (I) := A_Strings.To_Upper (S (I));
        end loop;
    end Lower_To_Upper;

    procedure Upper_To_Lower (S : in out String) is
    begin
        for I in S'Range loop
            S (I) := A_Strings.To_Lower (S (I));
        end loop;
    end Upper_To_Lower;

    procedure Translate (From_Old, To_New : String; S : in out String) is
        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 S'Range loop
            S (I) := Trans (S (I));
        end loop;
    end Translate;

end Strings;

    nblk1=6
    nid=0
    hdr6=c
        [0x00] rec0=1f rec1=00 rec2=01 rec3=012
        [0x01] rec0=20 rec1=00 rec2=02 rec3=082
        [0x02] rec0=24 rec1=00 rec2=03 rec3=064
        [0x03] rec0=21 rec1=00 rec2=04 rec3=092
        [0x04] rec0=21 rec1=00 rec2=05 rec3=032
        [0x05] rec0=17 rec1=00 rec2=06 rec3=000
    tail 0x21548c952868436802259 0x42a00088462060003