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

⟦52d1692b4⟧ Ada Source

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

Derivation

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

with Fields, Text_Io, Bounded_String, Binary_Trees_Pkg;

package body Models is

    use Models_Tree;

    Inf : constant Integer := -1;
    Equ : constant Integer := 0;
    Sup : constant Integer := 1;

    Current_Model : Model;
    Lookahead : Boolean;

    function Create_Model
                (N : String; T : String; F : Fields.Object) return Model is
        A : Model;
    begin
        Bounded_String.Free (A.Model_Name);
        Bounded_String.Copy (A.Model_Name, N);
        Bounded_String.Free (A.Model_Type);
        Bounded_String.Copy (A.Model_Type, T);
        Fields.Surface_Copy (A.Model_Fields, F);
        return A;
    end Create_Model;


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

    procedure Dispose_Model (The_Model : in out Model) is
    begin
        Fields.Dispose_Object (The_Model.Model_Fields);
        Bounded_String.Free (The_Model.Model_Name);
        Bounded_String.Free (The_Model.Model_Type);
    end Dispose_Model;
    procedure Destroy_Object is new Destroy_Deep (Free_Value => Dispose_Model);




    procedure Dump_An_Model (A : Model) is
    begin
        Text_Io.Put_Line ("........................................");
        Text_Io.Put_Line (Bounded_String.Image (A.Model_Name) & " " &
                          Bounded_String.Image (A.Model_Type) & "With Fields:");
        Fields.Dump_Fields (A.Model_Fields);
    end Dump_An_Model;
    procedure Dump is new Visit (Process => Dump_An_Model);




--Creation
    procedure Create (D : in out Object) is
    begin
        D.Node := Models_Tree.Create;
    end Create;



--Access
    procedure Dump_Number_Of_Model (D : in Object) is
    begin
        Text_Io.Put_Line ("Number of Model:" &
                          Natural'Image (Models_Tree.Size (D.Node)));
    end Dump_Number_Of_Model;


    function Has_Model (D : in Object; Name : in String) return Boolean is
        A : Model;
        F : Fields.Object;
    begin
        Fields.Create (F);
        A := Create_Model (Name, Name,
                           F);  -- Only the first param. is important
        return Models_Tree.Is_Found (A, D.Node);
    end Has_Model;

    function Get_Model_Type_By_Name (D : Object; Name : String) return String is
        Found : Boolean := False;
        A : Model;
        B : Fields.Object;
    begin
        Fields.Create (B);
        A := Create_Model (Name, Name,
                           B);  -- Only the first param. is important
        Models_Tree.Find (A, D.Node, Found, A);
        if Found then
            return Bounded_String.Image (A.Model_Type);
        else
            return "";
        end if;
    exception
        when others =>
            raise Error_Model_Search;
    end Get_Model_Type_By_Name;

    procedure Get_Model_Fields_By_Name
                 (D : Object; Name : String; F : in out Fields.Object) is
        Found : Boolean := False;
        A : Model;
        B : Fields.Object;
    begin
        Fields.Create (B);
        A := Create_Model (Name, Name,
                           B);  -- Only the first param. is important
        Models_Tree.Find (A, D.Node, Found, A);
        if Found then
            Fields.Deep_Copy (F, A.Model_Fields);
        end if;
    exception
        when others =>
            raise Error_Model_Search;
    end Get_Model_Fields_By_Name;



    procedure Dump_Models (D : in Object) is
    begin
        Dump (D.Node, Models_Tree.Inorder);
    end Dump_Models;



--Modification
    procedure Store_Model (D : in out Object;
                           Aname : String;
                           Atype : String;
                           F : Fields.Object) is
        Found : Boolean := False;
        A : Model;
        B : Fields.Object;
    begin
        Fields.Create (B);
        Fields.Deep_Copy (B, F);
        Models_Tree.Replace_If_Found
           (Create_Model (Aname, Atype, B), D.Node, Found, A);
        if Found then
            Dispose_Model (A);
        end if;
    exception
        when others =>
            raise Error_Model_Store;
    end Store_Model;



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


--Iteration
    procedure Open_Model_Indexation (D : Object; I : in out Model_Index) is
    begin
        I.Node := Models_Tree.Make_Iter (D.Node);
        Lookahead := False;
        Next_Model_Index (I);
    end Open_Model_Indexation;

    procedure Next_Model_Index (I : in out Model_Index) is
    begin
        if not Lookahead then
            if Models_Tree.More (I.Node) then
                Models_Tree.Next (I.Node, Current_Model);
            else
                raise Error_Model_Index;
            end if;
        end if;
    end Next_Model_Index;




    function Get_Indexed_Model_Name (I : Model_Index) return String is
    begin
        return Bounded_String.Image (Current_Model.Model_Name);
    exception
        when others =>
            raise Error_Model_Index;
    end Get_Indexed_Model_Name;

    function Get_Indexed_Model_Type (I : Model_Index) return String is
    begin
        return Bounded_String.Image (Current_Model.Model_Type);
    exception
        when others =>
            raise Error_Model_Index;
    end Get_Indexed_Model_Type;

    procedure Get_Indexed_Model_Fields
                 (I : Model_Index; F : in out Fields.Object) is
    begin
        Fields.Deep_Copy (F, Current_Model.Model_Fields);
    exception
        when others =>
            raise Error_Model_Index;
            raise Error_Model_Index;
    end Get_Indexed_Model_Fields;

    function No_More_Models (I : Model_Index) return Boolean is
        More : Boolean := True;
    begin
        More := Models_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_Models;



end Models;

    nblk1=7
    nid=0
    hdr6=e
        [0x00] rec0=23 rec1=00 rec2=01 rec3=084
        [0x01] rec0=22 rec1=00 rec2=02 rec3=028
        [0x02] rec0=20 rec1=00 rec2=03 rec3=006
        [0x03] rec0=24 rec1=00 rec2=04 rec3=000
        [0x04] rec0=24 rec1=00 rec2=05 rec3=030
        [0x05] rec0=22 rec1=00 rec2=06 rec3=052
        [0x06] rec0=1c rec1=00 rec2=07 rec3=001
    tail 0x2153c782c862656b319cd 0x42a00088462060003