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

⟦c579d8a7a⟧ Ada Source

    Length: 8192 (0x2000)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Type_Table, seg_046a61

Derivation

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

with Tds, Error, Text_Io, Unbounded_String;

package body Type_Table is

    package Unlimited_String is new Unbounded_String (10);

    Master_Table, Current_Table : Tds.Object;  
    Type_Currently_In_Declaration : Unlimited_String.Variable_String;


    procedure Declare_Type_Name (Name : in String; L, C : in Natural) is
    begin
        Tds.Insert_Table_Symbol (Master_Table, Name, Name, L, C);
        Current_Table := Tds.Get_Table (Master_Table, Name);  
        Type_Currently_In_Declaration := Unlimited_String.Value (Name);
    exception
        when Tds.Name_Does_Already_Exist =>
            Error.Set_Type_Error (Error.Duplicate_Identifier_In_Type_Table);
            raise Error.Excep_Semantic_Error;
    end Declare_Type_Name;


    procedure Append_Field_In_Current_Type (Name : in String;
                                            The_Type : in Dynamic_Value.Kinds;
                                            L, C : in Natural) is  
        V : Dynamic_Value.Object;
    begin  
        case The_Type is
            when Dynamic_Value.Unknown =>
                null;
            when Dynamic_Value.Integer_Number =>
                Dynamic_Value.Set_Value (V, 0);  
            when Dynamic_Value.Boolean_Number =>
                Dynamic_Value.Set_Value (V, False);
            when Dynamic_Value.String_Of_Characters =>
                Dynamic_Value.Set_Value (V, "");
            when Dynamic_Value.Vocabulary_Word =>
                Dynamic_Value.Set_Value (V, "", Dynamic_Value.Voca_Value);  
            when Dynamic_Value.Set_Of_Words =>
                Dynamic_Value.Create (V);  
                Dynamic_Value.Append_To_Set (V, "");  
                Dynamic_Value.Print (V);
        end case;
        Tds.Insert_Value_Symbol (Current_Table, Name, L, C, V);
    exception
        when Tds.Name_Does_Already_Exist =>
            Error.Set_Type_Error (Error.Duplicate_Identifier_In_Type_Table);
            raise Error.Excep_Semantic_Error;
    end Append_Field_In_Current_Type;


    procedure Inherite_Type
                 (Name, Parent_Name : in String; L, C : in Natural) is
        Source_Tempo_Table, Target_Tempo_Table : Tds.Object;
    begin  
        if (Parent_Name = Unlimited_String.Image
                             (Type_Currently_In_Declaration)) then
            Error.Set_Type_Error (Error.Recursive_Declaration);
            raise Error.Excep_Semantic_Error;
        end if;  
        Source_Tempo_Table := Tds.Get_Table (Master_Table, Parent_Name);  
        Tds.Insert_Table_Symbol (Current_Table, Name, Parent_Name, L, C);
        Target_Tempo_Table := Tds.Get_Table (Current_Table, Name);
        Tds.Deep_Copy (Source_Tempo_Table, Target_Tempo_Table);  
    exception  
        when Tds.Name_Does_Not_Exist_In_This_Table |
             Tds.Name_Does_Not_Correspond_To_A_Table =>
            Error.Set_Type_Error (Error.Inherited_Type_Does_Not_Exist);
            raise Error.Excep_Semantic_Error;
        when Tds.Name_Does_Already_Exist =>
            Error.Set_Type_Error (Error.Duplicate_Identifier_In_Type_Table);
            raise Error.Excep_Semantic_Error;
    end Inherite_Type;


    procedure Go_To_Master_Type_Table is
    begin
        Current_Table := Master_Table;
    end Go_To_Master_Type_Table;


    procedure Go_In_Type (Name : in String) is
    begin
        Current_Table := Tds.Get_Table (Master_Table, Name);
    exception
        when Tds.Name_Does_Not_Exist_In_This_Table |
             Tds.Name_Does_Not_Correspond_To_A_Table =>
            raise Demanded_Type_Does_Not_Exist;
    end Go_In_Type;


    function Get_Type (Name : in String) return Tds.Object is
        Table : Tds.Object;
    begin
        Table := Tds.Get_Table (Master_Table, Name);
        return Table;
    exception
        when Tds.Name_Does_Not_Correspond_To_A_Table |
             Tds.Name_Does_Not_Exist_In_This_Table =>
            raise Demanded_Type_Does_Not_Exist;
    end Get_Type;


    procedure Print is
    begin
        Text_Io.Put (" TYPES ");
        Tds.Print (Master_Table);
    end Print;

end Type_Table;

    nblk1=7
    nid=7
    hdr6=a
        [0x00] rec0=1b rec1=00 rec2=01 rec3=010
        [0x01] rec0=16 rec1=00 rec2=06 rec3=016
        [0x02] rec0=14 rec1=00 rec2=04 rec3=08e
        [0x03] rec0=1f rec1=00 rec2=03 rec3=04e
        [0x04] rec0=0c rec1=00 rec2=05 rec3=000
        [0x05] rec0=43 rec1=1f rec2=31 rec3=1ec
        [0x06] rec0=bd rec1=34 rec2=00 rec3=026
    tail 0x215436f7c86518c24cece 0x42a00088462060003
Free Block Chain:
  0x7: 0000  00 02 00 05 00 02 20 20 02 00 00 00 00 00 00 01  ┆                ┆
  0x2: 0000  00 00 00 04 80 01 3a 01 02 03 20 20 20 20 20 20  ┆      :         ┆