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

⟦e9af81dff⟧ Ada Source

    Length: 17408 (0x4400)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, package body String_Class, seg_035e49, seg_0368fd

Derivation

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

with Counter;
with Boolean_Class;  
with Integer_Class;
with String_Utilities;
with Bounded_String;
with Message;
with Text_Io;
with Bug;

package body String_Class is

    type String_Unary_Message is (Enmajuscule, Enminuscule,
                                  Talongueur, Entexte, Valeur);

    Max_Table_String : constant := 1000;  
    subtype Table_Index is Positive range 1 .. Max_Table_String;
    String_Table : array (Table_Index) of Message.Tiny_String;
    Empty_String : Message.Tiny_String;

    package Su renames String_Utilities;
    package Bs renames Bounded_String;

    function The_Table_Index (From_Object : Object.Reference) return Positive is
        The_Index : Integer;  
        use Object;
    begin  
        if not (Object.Get_Class (From_Object) = Object.String_Class) then
            Object.In_Text (From_Object);
            raise Bug.Search_No_String_Object;
        end if;
        The_Index := Object.Get_Value (From_Object);
        if (The_Index > Max_Table_String) or (The_Index < 1) then
            raise Bug.Id_String_Overflow;
        else
            return The_Index;
        end if;
    end The_Table_Index;

    function Get_String (From_Object : Object.Reference)
                        return Message.Tiny_String is
    begin  
        return String_Table (The_Table_Index (From_Object));
    end Get_String;

    procedure In_Text (The_String : Object.Reference) is
    begin
        Object.In_Text (The_String);
        Text_Io.Put_Line ("Contenu:" &
                          Bs.Image (String_Table
                                       (The_Table_Index (The_String))));

    end In_Text;

    function Create (Name : Message.Tiny_String) return Object.Reference is
        Index : Positive := 1;
        New_Object : Object.Reference := Object.Void_Reference;
        Found : Boolean := False;
    begin
        while not Found and (Index <= Max_Table_String) loop
            if (Bs.Length (String_Table (Index)) =
                Bs.Length (Empty_String)) then
                Found := True;
            else
                Index := Index + 1;
            end if;
        end loop;
        if Found then
            String_Table (Index) := Name;
            New_Object := Object.Create (Object.String_Class, Index);
        else  
            raise Bug.Too_Many_Strings;
        end if;  
        return New_Object;  
    end Create;

    procedure Reset is
    begin
        for I in 1 .. Max_Table_String loop
            String_Table (I) := Empty_String;
        end loop;
    end Reset;

    procedure Remove (The_Object : Object.Reference) is
    begin
        Bs.Free (String_Table (The_Table_Index (The_Object)));
    end Remove;

    function "&" (Left, Right : Object.Reference) return Object.Reference is
        New_String : Message.Tiny_String;  
        use Object;
    begin  
        if (Object.Get_Class (Left) /= Object.String_Class) or
           (Object.Get_Class (Right) /= Object.String_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if (Bs.Length (Get_String (Left)) + Bs.Length (Get_String (Right)) >
            Bs.Max_Length (New_String)) then
            raise Bug.String_Large_Overflow;
        else
            Bs.Append (New_String, Get_String (Left));
            Bs.Append (New_String, Get_String (Right));
        end if;
        return Create (New_String);
    end "&";


    function Equal (Left, Right : Object.Reference) return Object.Reference is
        Result : Boolean;
        use Object;
    begin  
        if (Object.Get_Class (Left) /= Object.String_Class) or
           (Object.Get_Class (Right) /= Object.String_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Result := Su.Equal (Bs.Image (Get_String (Left)),
                            Bs.Image (Get_String (Right)), False);
        return Boolean_Class.Create (Result);

    end Equal;

    function "<" (Left, Right : Object.Reference) return Object.Reference is
        Result : Boolean;
        use Object;
    begin  
        if (Object.Get_Class (Left) /= Object.String_Class) or
           (Object.Get_Class (Right) /= Object.String_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Result := Su.Less_Than (Bs.Image (Get_String (Left)),
                                Bs.Image (Get_String (Right)), False);
        return Boolean_Class.Create (Result);
    end "<";

    function ">" (Left, Right : Object.Reference) return Object.Reference is
        Result : Boolean;
        use Object;
    begin  
        if (Object.Get_Class (Left) /= Object.String_Class) or
           (Object.Get_Class (Right) /= Object.String_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Result := Su.Greater_Than (Bs.Image (Get_String (Left)),
                                   Bs.Image (Get_String (Right)), False);
        return Boolean_Class.Create (Result);
    end ">";

    function ">=" (Left, Right : Object.Reference) return Object.Reference is
        Result : Boolean;
        use Object;
    begin  
        if (Object.Get_Class (Left) /= Object.String_Class) or
           (Object.Get_Class (Right) /= Object.String_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Result := Su.Greater_Than (Bs.Image (Get_String (Left)),
                                   Bs.Image (Get_String (Right)), False) or
                  Su.Equal (Bs.Image (Get_String (Left)),
                            Bs.Image (Get_String (Right)), False);

        return Boolean_Class.Create (Result);
    end ">=";

    function "<=" (Left, Right : Object.Reference) return Object.Reference is
        Result : Boolean;
        use Object;
    begin  
        if (Object.Get_Class (Left) /= Object.String_Class) or
           (Object.Get_Class (Right) /= Object.String_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Result := Su.Less_Than (Bs.Image (Get_String (Left)),
                                Bs.Image (Get_String (Right)), False) or
                  Su.Equal (Bs.Image (Get_String (Left)),
                            Bs.Image (Get_String (Right)), False);
        return Boolean_Class.Create (Result);
    end "<=";

    function To_Upper (The_Object : Object.Reference) return Object.Reference is
        The_String : Message.Tiny_String;
        Index : Positive := Object.Get_Value (The_Object);
    begin  
        Bs.Free (The_String);
        Bs.Copy (The_String,
                 Bs.Value ((Su.Upper_Case
                               (Bs.Image (Get_String (The_Object))))));
        String_Table (Index) := The_String;
        return The_Object;
    end To_Upper;

    function To_Lower (The_Object : Object.Reference) return Object.Reference is
        The_String : Message.Tiny_String;
        Index : Positive := Object.Get_Value (The_Object);
    begin  
        Bs.Free (The_String);
        Bs.Copy (The_String, Bs.Value
                                (Su.Lower_Case (Bs.Image
                                                   (Get_String (The_Object)))));
        String_Table (Index) := The_String;
        return The_Object;
    end To_Lower;

    function Long (The_Object : Object.Reference) return Object.Reference is
        The_String : Message.Tiny_String;
    begin
        The_String := Get_String (The_Object);
        return Integer_Class.Create (Bs.Length (The_String));
    end Long;

    function Value (The_String : Object.Reference) return Object.Reference is
        I : Integer;
        Success : Boolean := False;
    begin  
        Su.String_To_Number
           (Bs.Image (String_Table (The_Table_Index (The_String))), I, Success);
        if not Success then
            I := 0;
        end if;
        return Integer_Class.Create (I);
    end Value;

    function Send (To_Object : Object.Reference;
                   The_Message : Message.Selector;
                   With_Arguments : Argument.List) return Object.Reference is

        The_Object, Arg1 : Object.Reference := Object.Void_Reference;
        Args : Argument.List;
    begin
        Args := With_Arguments;
        Counter.Increase (Object.String_Class);
        case The_Message is

            when Message.Et =>
                Arg1 := Argument.Get (Args);
                The_Object := To_Object & Arg1;

            when Message.Inferieur =>
                Arg1 := Argument.Get (Args);
                The_Object := To_Object < Arg1;

            when Message.Superieur =>
                Arg1 := Argument.Get (Args);
                The_Object := To_Object > Arg1;

            when Message.Inferieur_Egal =>
                Arg1 := Argument.Get (Args);
                The_Object := To_Object <= Arg1;

            when Message.Superieur_Egal =>
                Arg1 := Argument.Get (Args);
                The_Object := To_Object >= Arg1;

            when Message.Egal =>
                Arg1 := Argument.Get (Args);
                The_Object := Equal (To_Object, Arg1);

            when others =>
                raise Bug.Unknown_String_Message;

        end case;
        Counter.Stop_Time (Object.String_Class);
        return The_Object;
    end Send;


    function Send (To_Object : Object.Reference;
                   The_Message : Message.Tiny_String) return Object.Reference is
        The_Object : Object.Reference := Object.Void_Reference;
        Talk : String_Unary_Message;
    begin  
        Talk := String_Unary_Message'Value (Bounded_String.Image (The_Message));
        Counter.Increase (Object.String_Class);
        case Talk is

            when Enmajuscule =>
                The_Object := To_Upper (To_Object);

            when Enminuscule =>
                The_Object := To_Lower (To_Object);

            when Talongueur =>
                The_Object := Long (To_Object);

            when Entexte =>
                In_Text (To_Object);
                The_Object := To_Object;

            when Valeur =>
                The_Object := Value (To_Object);

        end case;
        Counter.Stop_Time (Object.String_Class);
        return The_Object;
    exception
        when Constraint_Error =>
            raise Bug.Unknown_String_Message;
    end Send;
end String_Class;

    nblk1=10
    nid=8
    hdr6=1a
        [0x00] rec0=20 rec1=00 rec2=01 rec3=052
        [0x01] rec0=1c rec1=00 rec2=05 rec3=068
        [0x02] rec0=21 rec1=00 rec2=03 rec3=01a
        [0x03] rec0=03 rec1=00 rec2=0d rec3=018
        [0x04] rec0=1b rec1=00 rec2=02 rec3=01e
        [0x05] rec0=19 rec1=00 rec2=04 rec3=042
        [0x06] rec0=18 rec1=00 rec2=0a rec3=04c
        [0x07] rec0=18 rec1=00 rec2=0e rec3=00a
        [0x08] rec0=05 rec1=00 rec2=0c rec3=022
        [0x09] rec0=1d rec1=00 rec2=0b rec3=012
        [0x0a] rec0=1e rec1=00 rec2=06 rec3=018
        [0x0b] rec0=20 rec1=00 rec2=09 rec3=012
        [0x0c] rec0=0b rec1=00 rec2=07 rec3=000
        [0x0d] rec0=1f rec1=00 rec2=09 rec3=03a
        [0x0e] rec0=11 rec1=00 rec2=07 rec3=001
        [0x0f] rec0=00 rec1=00 rec2=00 rec3=000
    tail 0x21732c05684dd5dc9a454 0x42a00088462060003
Free Block Chain:
  0x8: 0000  00 10 00 16 80 01 73 01 00 0f 20 20 20 20 20 20  ┆      s         ┆
  0x10: 0000  00 0f 03 fc 80 20 72 65 74 75 72 6e 20 43 72 65  ┆      return Cre┆
  0xf: 0000  00 00 02 0b 00 13 20 20 20 20 20 20 20 20 75 73  ┆              us┆