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

⟦ee53c59b1⟧ Ada Source

    Length: 14336 (0x3800)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Block_Class, seg_03672f, seg_0368f5

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, Block, Boolean_Class,
     Bounded_String, Table, Counter, Bug;
package body Block_Class is


    type Block_Object is
        record
            The_Block : Block.Node;
            Used : Boolean;
        end record;
    Empty_Block : constant Block_Object := (Block.Empty_Node, False);
    subtype Id_Block_Table is Integer range 1 .. 100;
    Block_Table : array (Id_Block_Table) of Block_Object;
    type Block_Keyword_Message is (Prive, Valeur, Tantquevrai, Tantquefaux);
    type Block_Unary_Message is (Unknown, Valeur, Entexte);

    package Bs renames Bounded_String;

    function Search_Empty return Id_Block_Table is
        Id : Id_Block_Table := 1;
    begin
        loop
            exit when Block_Table (Id) = Empty_Block;
            if Id = Id_Block_Table'Last then
                raise Bug.Too_Many_Blocks;
            end if;
            Id := Id + 1;
        end loop;
        return (Id);
    end Search_Empty;
   function Search (A_Block : Object.Reference) return Id_Block_Table is
        Id : Id_Block_Table;
    begin
        Id := Id_Block_Table (Object.Get_Value (A_Block));
        if not Block_Table (Id).Used then
            raise Bug.Block_Not_Found;  
        end if;
        return (Id);
    end Search;

    function Search (A_Block : Object.Reference) return Block.Node is
        Id : Id_Block_Table;
    begin
        Id := Id_Block_Table (Object.Get_Value (A_Block));
        if not Block_Table (Id).Used then
            raise Bug.Block_Not_Found;  
        end if;
        return (Block_Table (Id).The_Block);
    end Search;

    function Create (Value : Block.Node) return Object.Reference is
        Id : Id_Block_Table;  
        Obj : Object.Reference;
    begin
        Id := Search_Empty;  
        Obj := Object.Create (Object.Block_Class, Id);
        Block_Table (Id).The_Block := Value;
        Block_Table (Id).Used := True;
        return (Obj);
    end Create;

    function Valeur (Blk : Object.Reference) return Object.Reference is
        The_Block : Block.Node;
        Result : Object.Reference;  
    begin
        The_Block := Search (Blk);
        Result := Block.Interpret (The_Block);
        return (Result);
    end Valeur;

    procedure In_Text (Blk : Object.Reference) is
        The_Block : Block.Node;  
    begin
        Object.In_Text (Blk);
        The_Block := Search (Blk);
        Block.Unparse (The_Block);
    end In_Text;

    function While_True (Condition_Block, Argument_Block : Object.Reference)
                        return Object.Reference is
        Condition_Block_Result, Argument_Block_Result : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (Argument_Block) /= Object.Block_Class) then
            raise Bug.Mismatch_Type;
        end if;
        loop
            Condition_Block_Result := Valeur (Condition_Block);
           exit when not Object.Equal (A => Condition_Block_Result,
                                        B => Boolean_Class.True);
            Argument_Block_Result := Valeur (Argument_Block);
        end loop;
        return Argument_Block_Result;
    end While_True;

    function While_False (Condition_Block, Argument_Block : Object.Reference)
                         return Object.Reference is
        Condition_Block_Result, Argument_Block_Result : Object.Reference;
        use Object;
    begin
        if (Object.Get_Class (Argument_Block) /= Object.Block_Class) then
            raise Bug.Mismatch_Type;
        end if;
        loop
            Condition_Block_Result := Valeur (Condition_Block);
            exit when not Object.Equal (A => Condition_Block_Result,
                                        B => Boolean_Class.False);
            Argument_Block_Result := Valeur (Argument_Block);
        end loop;  
        return Argument_Block_Result;
    end While_False;

    function Recognize_Keyword (The_Message : Message.Tiny_String)
                               return Block_Keyword_Message is
        Result : Block_Keyword_Message;
    begin
        Result := Block_Keyword_Message'Value (Bs.Image (The_Message));  
        return Result;
    exception
        when Constraint_Error =>
            return Prive;
    end Recognize_Keyword;

    function Recognize_Unary (The_Message : Message.Tiny_String)
                             return Block_Unary_Message is
        Result : Block_Unary_Message;
    begin
        Result := Block_Unary_Message'Value (Bs.Image (The_Message));
        return Result;
    exception
        when Constraint_Error =>
            return Unknown;
    end Recognize_Unary;

    function Send (To_Object : Object.Reference;
                   The_Messages : Message.List;
                   With_Arguments : Argument.List) return Object.Reference is
        Result : Object.Reference := Object.Void_Reference;
        The_Block_Node : Block.Node;
        Keywords, Identifiers : Message.List;
        S_Table : Table.Symbol_Kind;
        A_Message, A_Identifier, A_Keyword : Message.Tiny_String;
        A_Argument : Object.Reference;  
        Mess : Message.List;
        Args : Argument.List;
        Nb_Mess : Natural;
    begin  
        Mess := The_Messages;
        Args := With_Arguments;
        The_Block_Node := Search (To_Object);  
        Keywords := Block.Keyword_List (The_Block_Node);
        Identifiers := Block.Identifier_List (The_Block_Node);
        S_Table := Block.Symbol (The_Block_Node);  
        Nb_Mess := Message.How_Many (The_Messages);
        A_Message := Message.Get (Mess);
        A_Argument := Argument.Get (Args);
        Counter.Increase (Object.Block_Class);
        if Nb_Mess = 1 and (Recognize_Keyword (A_Message) = Tantquevrai or
                            Recognize_Keyword (A_Message) = Tantquefaux) then
            if Recognize_Keyword (A_Message) = Tantquevrai then
                Result := While_True (To_Object, A_Argument);
            elsif Recognize_Keyword (A_Message) = Tantquefaux then
                Result := While_False (To_Object, A_Argument);
            end if;
        else  
            if Nb_Mess > Message.How_Many (Identifiers) then
                raise Bug.Too_Many_Messages;
            end if;
            if Nb_Mess < Message.How_Many (Identifiers) then
                raise Bug.Not_Enough_Messages;
            end if;  
            for I in 1 .. Nb_Mess loop
                A_Message := Message.Get (Mess);
                A_Argument := Argument.Get (Args);
                if Recognize_Keyword (A_Message) = Valeur then
                    A_Identifier := Message.Get (Identifiers);
                    Table.Insert (S_Table, A_Identifier, A_Argument);
                else
                    if Message.How_Many (Keywords) = 0 then
                        raise Bug.Mismatch_Message;
                    end if;
                    A_Keyword := Message.Get (Keywords);
                    if Bounded_String.Image (A_Keyword) =
                       Bounded_String.Image (A_Message) then
                        A_Identifier := Message.Get (Identifiers);
                        Table.Insert (S_Table, A_Identifier, A_Argument);

                    else
                        raise Bug.Unknown_Block_Message;
                    end if;
                end if;  
                Message.Next (Identifiers, A_Identifier);
                Message.Next (Keywords, A_Keyword);
                Argument.Next (Args, A_Argument);
                Message.Next (Mess, A_Message);
            end loop;  
            Result := Valeur (To_Object);
        end if;
        Counter.Stop_Time (Object.Block_Class);
        return (Result);
    end Send;

    function Send (To_Object : Object.Reference;
                   The_Message : Message.Tiny_String) return Object.Reference is
        Result : Object.Reference;
    begin  
        Counter.Increase (Object.Block_Class);
        case Recognize_Unary (The_Message) is
            when Valeur =>
                Result := Valeur (To_Object);
            when Entexte =>
                In_Text (To_Object);
                Result := To_Object;
            when Unknown =>
                raise Bug.Unknown_Block_Message;
        end case;  
        Counter.Stop_Time (Object.Block_Class);
        return (Result);
    end Send;

begin

    for I in Id_Block_Table loop
        Block_Table (I) := Empty_Block;
    end loop;  
end Block_Class;

    nblk1=d
    nid=9
    hdr6=18
        [0x00] rec0=1f rec1=00 rec2=01 rec3=016
        [0x01] rec0=02 rec1=00 rec2=0a rec3=002
        [0x02] rec0=1c rec1=00 rec2=03 rec3=01c
        [0x03] rec0=1e rec1=00 rec2=02 rec3=012
        [0x04] rec0=00 rec1=00 rec2=0b rec3=002
        [0x05] rec0=16 rec1=00 rec2=06 rec3=01e
        [0x06] rec0=1b rec1=00 rec2=0d rec3=04a
        [0x07] rec0=16 rec1=00 rec2=07 rec3=00e
        [0x08] rec0=0e rec1=00 rec2=08 rec3=036
        [0x09] rec0=14 rec1=00 rec2=05 rec3=040
        [0x0a] rec0=1f rec1=00 rec2=0c rec3=012
        [0x0b] rec0=02 rec1=00 rec2=04 rec3=000
        [0x0c] rec0=03 rec1=00 rec2=04 rec3=001
    tail 0x2173370dc84df56afd83b 0x42a00088462060003
Free Block Chain:
  0x9: 0000  00 00 00 06 80 03 20 20 20 03 04 05 06 07 20 20  ┆                ┆