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 - metrics - download

⟦7e657c884⟧ Ada Source

    Length: 11264 (0x2c00)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Dynamic_Object, seg_0491af

Derivation

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

with T_Value, Text_Io, Bounded_String, Binary_Trees_Pkg;


package body Dynamic_Object is

    use Object_Tree;

    Inf : constant Integer := -1;
    Equ : constant Integer := 0;
    Sup : constant Integer := 1;
    Current_Attribute : Attribute;
    Lookahead : Boolean;

    function Create_Attribute
                (N : String; V : T_Value.Object) return Attribute is
        A : Attribute;
    begin
        Bounded_String.Free (A.Name);
        Bounded_String.Copy (A.Name, N);
        T_Value.New_Value (A.Value);
        T_Value.Copy (A.Value, V);
        return A;
    end Create_Attribute;


    function Compare (A, B : Attribute) return Integer is
    begin
        declare
            use Bounded_String;
        begin
            if Image (A.Name) < Image (B.Name) then
                return Inf;
            elsif Image (A.Name) = Image (B.Name) then
                return Equ;
            else
                return Sup;           end if;
        end;
    end Compare;

    procedure Dispose_Attribute (The_Attribute : in out Attribute) is
    begin
        T_Value.Dispose (The_Attribute.Value);
        Bounded_String.Free (The_Attribute.Name);
    end Dispose_Attribute;
    procedure Destroy_Object is new Destroy_Deep
                                       (Free_Value => Dispose_Attribute);


    function Copy_Attribute (A : Attribute) return Attribute is
    begin
        return Create_Attribute (Bounded_String.Image (A.Name), A.Value);
    end Copy_Attribute;

    function Copy_Object_Tree is new Copy_Tree (Copy_Value => Copy_Attribute);

    procedure Dump_An_Attribute (A : Attribute) is
    begin
        Text_Io.Put_Line (Bounded_String.Image (A.Name) &
                          " : " & T_Value.Image (A.Value));
    end Dump_An_Attribute;
    procedure Dump is new Visit (Process => Dump_An_Attribute);






--Creation
    procedure New_Object (D : in out Dynamic_Object) is
    begin
        D.Node := Object_Tree.Create;
    end New_Object;



--Access
    procedure Dump_Number_Of_Attribute (D : in Dynamic_Object) is
    begin
        Text_Io.Put_Line ("Number of Attribute:" &
                          Natural'Image (Object_Tree.Size (D.Node)));
    end Dump_Number_Of_Attribute;


    function Has_Attribute
                (D : in Dynamic_Object; Name : in String) return Boolean is
        A : Attribute;
    begin
        A := Create_Attribute (Name, T_Value.Null_Value);
        return Object_Tree.Is_Found (A, D.Node);
        Dispose_Attribute (A);
    end Has_Attribute;


    procedure Get_Attribute_By_Name (D : Dynamic_Object;
                                     Name : String;
                                     V : in out T_Value.Object) is
        Found : Boolean := False;
        A : Attribute;
    begin
        A := Create_Attribute (Name, V);
        Object_Tree.Find (A, D.Node, Found, A);

        T_Value.New_Value (V);
        T_Value.Copy (V, A.Value);

        if not Found then
            T_Value.Undefine (V);
        end if;

        Dispose_Attribute (A);
    end Get_Attribute_By_Name;

    function Equal (Left, Right : Dynamic_Object) return Boolean is
        Index : Attribute_Index;
        Val_R : T_Value.Object;
        Val_L : T_Value.Object;
        Memo : Boolean :=
           Lookahead; -- memorize to avoid modification on Lookahead
    begin
        if Object_Tree.Size (Left.Node) /= Object_Tree.Size (Right.Node) then
            return False;
        end if;

        Open_Attribute_Indexation (Left, Index);
        Test_Equal:
            while not No_More_Attributes (Index) loop
                if Has_Attribute (Right,
                                  Get_Indexed_Attribute_Name (Index)) then
                    Get_Attribute_By_Name
                       (Right, Get_Indexed_Attribute_Name (Index), Val_R);
                    Get_Indexed_Attribute_Value (Index, Val_L);
                    if not T_Value.Equal (Val_L, Val_R) then
                        Lookahead := Memo;
                        return False;
                    end if;

                else
                    Lookahead := Memo;
                    return False;
                end if;
                Next_Attribute_Index (Index);
            end loop Test_Equal;

        Lookahead := Memo;
        return True;
    end Equal;


    procedure Dump_Object_Attributes (D : in Dynamic_Object) is
    begin
        Dump (D.Node, Object_Tree.Preorder);

    end Dump_Object_Attributes;


    function Object_Image (D : in Dynamic_Object) return String is
    begin
        return ("Function not yet implemented");
    end Object_Image;

    procedure Object_To_File (D : Dynamic_Object; F : D_File) is
    begin
        Text_Io.Put_Line ("function not yet implemented");
    end Object_To_File;

--Modification
    procedure Store_Attribute (D : in out Dynamic_Object;
                               Name : String;
                               V : T_Value.Object) is
        Found : Boolean := False;
        A : Attribute;
    begin
        Object_Tree.Replace_If_Found
           (Create_Attribute (Name, V), D.Node, Found, A);
        if Found then
            Dispose_Attribute (A);
        end if;
    exception
        when others =>
            raise Error_Attribute_Store;
    end Store_Attribute;

    procedure Store_Attribute
                 (D : in out Dynamic_Object; Name : String; I : Integer) is
        V : T_Value.Object;
    begin
        T_Value.New_Value (V);
        T_Value.Set (V, I);
        Store_Attribute (D, Name, V);
        T_Value.Dispose (V);
    end Store_Attribute;

    procedure Store_Attribute
                 (D : in out Dynamic_Object; Name : String; S : String) is
        V : T_Value.Object;
    begin
        T_Value.New_Value (V);
        T_Value.Set (V, S);
        Store_Attribute (D, Name, V);
        T_Value.Dispose (V);
    end Store_Attribute;

    procedure Store_Attribute
                 (D : in out Dynamic_Object; Name : String; B : Boolean) is
        V : T_Value.Object;
    begin
        T_Value.New_Value (V);
        T_Value.Set (V, B);
        Store_Attribute (D, Name, V);
        T_Value.Dispose (V);
    end Store_Attribute;

    procedure Delete_Attribute (D : in out Dynamic_Object; Name : String) is
    begin
        Text_Io.Put_Line ("function not yet implemented");
    end Delete_Attribute;


    procedure Object_From_File (D : in out Dynamic_Object; F : D_File) is
    begin
        Text_Io.Put_Line ("function not yet implemented");
    end Object_From_File;

    procedure Copy_Object (To_Object : in out Dynamic_Object;
                           The_Object : Dynamic_Object) is
    begin
        To_Object.Node := Copy_Object_Tree (T => The_Object.Node);
    end Copy_Object;


    procedure Surface_Copy (To_Object : in out Dynamic_Object;
                            The_Object : Dynamic_Object) is
    begin
        To_Object.Node := The_Object.Node;
    end Surface_Copy;

--Liberation
    procedure Dispose_Object (D : in out Dynamic_Object) is
    begin
        Destroy_Object (D.Node);
    end Dispose_Object;


--Iteration
    procedure Open_Attribute_Indexation
                 (D : Dynamic_Object; I : in out Attribute_Index) is
    begin
        I.Node := Object_Tree.Make_Iter (D.Node);
        Lookahead := False;
        Next_Attribute_Index (I);
    end Open_Attribute_Indexation;

    procedure Next_Attribute_Index (I : in out Attribute_Index) is
    begin
        if not Lookahead then
            if Object_Tree.More (I.Node) then
                Object_Tree.Next (I.Node, Current_Attribute);
            else
                raise Error_Attribute_Index;
            end if;
        end if;
    end Next_Attribute_Index;

    function Get_Indexed_Attribute_Name (I : Attribute_Index) return String is
    begin
        return Bounded_String.Image (Current_Attribute.Name);
    exception
        when others =>
            raise Error_Attribute_Index;
    end Get_Indexed_Attribute_Name;

    procedure Get_Indexed_Attribute_Value
                 (I : Attribute_Index; V : in out T_Value.Object) is
    begin
        T_Value.Copy (V, Current_Attribute.Value);
    exception
        when others =>
            raise Error_Attribute_Index;
            raise Error_Attribute_Index;
    end Get_Indexed_Attribute_Value;

    function No_More_Attributes (I : Attribute_Index) return Boolean is
        More : Boolean := True;
    begin
        More := Object_Tree.More (I.Node);
        if More then
            return (False);
        end if;

        if (not More and not Lookahead) then
            Lookahead := True;
            return (False);
        elsif (not More and Lookahead) then
            return (True);
        end if;
    end No_More_Attributes;



end Dynamic_Object;

    nblk1=a
    nid=0
    hdr6=14
        [0x00] rec0=26 rec1=00 rec2=01 rec3=002
        [0x01] rec0=21 rec1=00 rec2=02 rec3=040
        [0x02] rec0=20 rec1=00 rec2=03 rec3=042
        [0x03] rec0=1d rec1=00 rec2=04 rec3=080
        [0x04] rec0=22 rec1=00 rec2=05 rec3=006
        [0x05] rec0=1f rec1=00 rec2=06 rec3=026
        [0x06] rec0=20 rec1=00 rec2=07 rec3=016
        [0x07] rec0=20 rec1=00 rec2=08 rec3=02c
        [0x08] rec0=1f rec1=00 rec2=09 rec3=058
        [0x09] rec0=0b rec1=00 rec2=0a rec3=000
    tail 0x2174d6904865b46515e31 0x42a00088462060003