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

⟦781d6869e⟧ Ada Source

    Length: 17408 (0x4400)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Boolean_Class, seg_036685, seg_0368fe

Derivation

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

with Object, Argument, Message;
with String_Class;
with Integer_Class;
with Bounded_String;
with Block_Class;
with Counter;
with Bug;
with Symbol;
package body Boolean_Class is

    type Boolean_Unary_Message is (Entexte, Image, Valeur, Non);
    type Boolean_Keyword_Message is (Sivrai, Sifaux);

    package Bs renames Bounded_String;

    function Create (Value : Boolean) return Object.Reference is
        Obj : Object.Reference;  
        Val : Integer;

    begin  
        if Value = Standard.True then
            Val := 1;
        else
            Val := 0;
        end if;
        Obj := Object.Create (Ident_Class => Object.Boolean_Class,
                              Ident_Object => Val);
        return (Obj);
    end Create;

    function True return Object.Reference is
        Obj : Object.Reference;

    begin  
        Obj := Create (Standard.True);
        return (Obj);
    end True;

    function False return Object.Reference is
        Obj : Object.Reference;

    begin
        Obj := Create (Standard.False);
        return (Obj);
    end False;

    procedure Create_Default is
        Default_Boolean_Name : Message.Tiny_String;
    begin
        Bounded_String.Copy (Default_Boolean_Name, "Vrai");
        Symbol.Insert (Default_Boolean_Name, True);
        Bounded_String.Copy (Default_Boolean_Name, "Faux");
        Symbol.Insert (Default_Boolean_Name, False);
    end Create_Default;

    function "+" (Left, Right : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (Left) /= Object.Boolean_Class) or
           (Object.Get_Class (Right) /= Object.Boolean_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if (Object.Get_Value (From_Object => Left) = 1) or
           (Object.Get_Value (From_Object => Right) = 1) then
            Obj := Create (Value => Standard.True);
        else
            Obj := Create (Value => Standard.False);
        end if;
        return Obj;
    end "+";

    function "&" (Left, Right : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (Left) /= Object.Boolean_Class) or
           (Object.Get_Class (Right) /= Object.Boolean_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if (Object.Get_Value (From_Object => Left) = 1) and
           (Object.Get_Value (From_Object => Right) = 1) then  
            Obj := Create (Value => Standard.True);
        else
            Obj := Create (Value => Standard.False);
        end if;
        return Obj;
    end "&";

    function Equal (Left, Right : Object.Reference) return Object.Reference is
        Obj : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (Left) /= Object.Boolean_Class) or
           (Object.Get_Class (Right) /= Object.Boolean_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if Object.Equal (A => Left, B => Right) then
            Obj := Create (Standard.True);
        else
            Obj := Create (Standard.False);
        end if;
        return Obj;
    end Equal;

    function Image (Obj : Object.Reference) return Object.Reference is
        New_String : Message.Tiny_String;

    begin
        Bs.Free (V => New_String);
        if Object.Equal (A => Obj, B => True) then
            Bs.Copy (New_String, "vrai");
        elsif Object.Equal (A => Obj, B => False) then
            Bs.Copy (New_String, "faux");
        else
            null;
        end if;
        return String_Class.Create (Name => New_String);
    end Image;

    function Value (Obj : Object.Reference) return Object.Reference is
    begin
        return Integer_Class.Create (Object.Get_Value (Obj));
    end Value;

    procedure In_Text (The_Object : Object.Reference) is
    begin
        Object.In_Text (The_Object);
    end In_Text;

    function Not_Value (Obj : Object.Reference) return Object.Reference is
        New_Object : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (Obj) /= Object.Boolean_Class) then
            raise Bug.Mismatch_Type;       end if;
        if Object.Equal (A => Obj, B => True) then
            New_Object := Create (Standard.False);
        elsif Object.Equal (A => Obj, B => False) then
            New_Object := Create (Standard.True);
        else
            null;
        end if;
        return New_Object;
    end Not_Value;

    function If_True (Obj, Blk : Object.Reference) return Object.Reference is
        The_Message_Valeur : Message.Tiny_String;
        New_Object : Object.Reference := Object.Void_Reference;
        use Object;
    begin  
        if (Object.Get_Class (Blk) /= Object.Block_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if Object.Equal (A => Obj, B => True) then
            Bs.Copy (The_Message_Valeur, Block_Class.Message_Valeur);
            New_Object := Block_Class.Send (Blk, The_Message_Valeur);
        end if;
        return New_Object;
    end If_True;

    function If_False (Obj, Blk : Object.Reference) return Object.Reference is
        The_Message_Valeur : Message.Tiny_String;
        New_Object : Object.Reference := Object.Void_Reference;
        use Object;
    begin  
        if (Object.Get_Class (Blk) /= Object.Block_Class) then
            raise Bug.Mismatch_Type;
        end if;
        if Object.Equal (A => Obj, B => False) then
            Bs.Copy (The_Message_Valeur, Block_Class.Message_Valeur);
            New_Object := Block_Class.Send (Blk, The_Message_Valeur);
        end if;
        return New_Object;
    end If_False;


    function If_True_If_False (Obj, Blk1, Blk2 : Object.Reference)
                              return Object.Reference is
        The_Message_Valeur : Message.Tiny_String;
        New_Object : Object.Reference := Object.Void_Reference;
        use Object;
    begin
        if (Object.Get_Class (Blk2) /= Object.Block_Class) or
           (Object.Get_Class (Blk2) /= Object.Block_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Bs.Copy (The_Message_Valeur, Block_Class.Message_Valeur);
        if Object.Equal (A => Obj, B => True) then
            New_Object := Block_Class.Send (Blk1, The_Message_Valeur);
        elsif Object.Equal (A => Obj, B => False) then
            New_Object := Block_Class.Send (Blk2, The_Message_Valeur);
        end if;
        return New_Object;
    end If_True_If_False;

    function If_False_If_True (Obj, Blk1, Blk2 : Object.Reference)
                              return Object.Reference is
        The_Message_Valeur : Message.Tiny_String;
        New_Object : Object.Reference := Object.Void_Reference;
        use Object;
    begin  
        if (Object.Get_Class (Blk2) /= Object.Block_Class) or
           (Object.Get_Class (Blk2) /= Object.Block_Class) then
            raise Bug.Mismatch_Type;
        end if;
        Bs.Copy (The_Message_Valeur, Block_Class.Message_Valeur);
        if Object.Equal (A => Obj, B => False) then
            New_Object := Block_Class.Send (Blk1, The_Message_Valeur);
        elsif Object.Equal (A => Obj, B => True) then
            New_Object := Block_Class.Send (Blk2, The_Message_Valeur);
        end if;
        return New_Object;
    end If_False_If_True;


    function Send (To_Object : Object.Reference;
                   The_Message : Message.Selector;
                   With_Arguments : Argument.List) return Object.Reference is
        Obj, Arg1 : Object.Reference;
        Args : Argument.List;
    begin  
        Args := With_Arguments;
        Counter.Increase (Object.Boolean_Class);
        case The_Message is
            when Message.Ou =>
                Arg1 := Argument.Get (L => Args);
                Obj := To_Object + Arg1;
            when Message.Et =>
                Arg1 := Argument.Get (L => Args);
                Obj := To_Object & Arg1;
            when Message.Egal =>
                Arg1 := Argument.Get (L => Args);
                Obj := Equal (To_Object, Arg1);
            when others =>
                raise Bug.Unknown_Boolean_Message;
        end case;
        Counter.Stop_Time (Object.Boolean_Class);
        return (Obj);

    end Send;

    function Send (To_Object : Object.Reference;
                   The_Message : Message.Tiny_String) return Object.Reference is
        Result : Object.Reference := Object.Void_Reference;
        Talk : Boolean_Unary_Message;

    begin
        Talk := Boolean_Unary_Message'Value (Bs.Image (The_Message));
        Counter.Increase (Object.Boolean_Class);
        case Talk is
            when Entexte =>
                In_Text (To_Object);
                Result := To_Object;
            when Non =>
                Result := Not_Value (Obj => To_Object);  
            when Image =>
                Result := Image (Obj => To_Object);
            when Valeur =>
                Result := Value (Obj => To_Object);
        end case;
        Counter.Stop_Time (Object.Boolean_Class);
        return (Result);
    exception
        when Constraint_Error =>
            raise Bug.Unknown_Boolean_Message;

    end Send;


    function Send (To_Object : Object.Reference;
                   The_Message : Message.List;
                   With_Arguments : Argument.List) return Object.Reference is
        Result, Arg1, Arg2 : Object.Reference := Object.Void_Reference;
        Args : Argument.List;  
        Message_List : Message.List;
        Message_Receive : Message.Tiny_String;  
        Talk, Talk2 : Boolean_Keyword_Message;
        Nb_Message : Natural;

    begin
        Args := With_Arguments;  
        Message_List := The_Message;
        Message_Receive := Message.Get (L => Message_List);
        Nb_Message := Message.How_Many (L => Message_List);

        Talk := Boolean_Keyword_Message'Value (Bs.Image (V => Message_Receive));
        Counter.Increase (Object.Boolean_Class);
        case Talk is

            when Sivrai =>
                Arg1 := Argument.Get (L => With_Arguments);
                if Nb_Message = 2 then
                    Message.Next (L => Message_List, Mess => Message_Receive);
                    Talk2 := Boolean_Keyword_Message'Value
                                (Bs.Image (V => Message_Receive));
                    if Talk2 = Sifaux then
                        Argument.Next (L => Args, Obj => Arg2);
                        Result := If_True_If_False (Obj => To_Object,
                                                    Blk1 => Arg1,
                                                    Blk2 => Arg2);
                    end if;
                elsif Nb_Message = 1 then
                    Result := If_True (Obj => To_Object, Blk => Arg1);
                else
                    raise Bug.Unknown_Boolean_Message;
                end if;

            when Sifaux =>
                Arg1 := Argument.Get (L => With_Arguments);
                if Nb_Message = 2 then
                    Message.Next (L => Message_List, Mess => Message_Receive);
                    Talk2 := Boolean_Keyword_Message'Value
                                (Bs.Image (V => Message_Receive));
                    if Talk2 = Sivrai then
                        Argument.Next (L => Args, Obj => Arg2);
                        Result := If_False_If_True (Obj => To_Object,
                                                    Blk1 => Arg1,
                                                    Blk2 => Arg2);
                    end if;
                elsif Nb_Message = 1 then
                    Result := If_False (Obj => To_Object, Blk => Arg1);
                else
                    raise Bug.Unknown_Boolean_Message;
                end if;
        end case;
        Counter.Stop_Time (Object.Boolean_Class);
        return (Result);

    exception
        when Constraint_Error =>
            raise Bug.Unknown_Boolean_Message;

    end Send;


end Boolean_Class;

    nblk1=10
    nid=a
    hdr6=1e
        [0x00] rec0=28 rec1=00 rec2=01 rec3=03c
        [0x01] rec0=00 rec1=00 rec2=0c rec3=01e
        [0x02] rec0=1c rec1=00 rec2=10 rec3=004
        [0x03] rec0=0b rec1=00 rec2=0f rec3=02e
        [0x04] rec0=1c rec1=00 rec2=06 rec3=054
        [0x05] rec0=1f rec1=00 rec2=07 rec3=002
        [0x06] rec0=1a rec1=00 rec2=05 rec3=072
        [0x07] rec0=18 rec1=00 rec2=03 rec3=048
        [0x08] rec0=17 rec1=00 rec2=0e rec3=00c
        [0x09] rec0=19 rec1=00 rec2=08 rec3=018
        [0x0a] rec0=1c rec1=00 rec2=0d rec3=006
        [0x0b] rec0=1b rec1=00 rec2=0b rec3=00c
        [0x0c] rec0=15 rec1=00 rec2=02 rec3=062
        [0x0d] rec0=16 rec1=00 rec2=09 rec3=032
        [0x0e] rec0=06 rec1=00 rec2=04 rec3=000
        [0x0f] rec0=06 rec1=00 rec2=04 rec3=000
    tail 0x21733637484df4afba1b2 0x42a00088462060003
Free Block Chain:
  0xa: 0000  00 00 03 25 80 38 77 5f 4f 62 6a 65 63 74 20 3a  ┆   % 8w_Object :┆