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

⟦4af4fa51f⟧ Ada Source

    Length: 13312 (0x3400)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Models, seg_047c71

Derivation

└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
    └─ ⟦cfc2e13cd⟧ »Space Info Vol 2« 
        └─⟦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 Has_Field_In_Model
                (D : in Object; Model_Name : String; Field_Name : String)
                return Boolean is






        F : Fields.Object;
        Exist : Boolean;
    begin
        Fields.Create (F);
        Get_Model_Fields_By_Name (D, Model_Name, F);
        Exist := Fields.Has_Field (F, Field_Name);
        Fields.Dispose_Object (F);
        return Exist;
    end Has_Field_In_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;

-----*****************************************************************
-----*****************************************************************

    function Get_Field_Type_By_Name
                (D : Object; Model_Name : String; Attribute_Name : String)
                return String is
        Strawberry_Fields : Fields.Object;
        S : Bounded_String.Variable_String (Max_Model_String);
    begin
        Bounded_String.Free (S);
        Fields.Create (Strawberry_Fields);
        Get_Model_Fields_By_Name (D, Model_Name, Strawberry_Fields);
        Bounded_String.Copy (S, Fields.Get_Field_Type_By_Name
                                   (Strawberry_Fields, Attribute_Name));
        Fields.Dispose_Object (Strawberry_Fields);
        return Bounded_String.Image (S);
    end Get_Field_Type_By_Name;

-----*****************************************************************

    function Enum_Image (D : Object; Enum_Type : String; Enum_Value : Integer)
                        return String is  
        Index : Fields.Field_Index;
        Count : Integer := 0;
        F : Fields.Object;
    begin


        Fields.Create (F);
        Get_Model_Fields_By_Name (D, Enum_Type, F);

        Fields.Open_Field_Indexation (F, Index);
        while not Fields.No_More_Fields (Index) loop


            if (Count = Enum_Value) then
                return Fields.Get_Indexed_Field_Name (Index);
            end if;

            Count := Count + 1;
            Fields.Next_Field_Index (Index);

        end loop;

        Fields.Dispose_Object (F);  
        return "Erreur sur affichage de variables enumeres";
    end Enum_Image;


-----*****************************************************************

    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=c
    nid=c
    hdr6=14
        [0x00] rec0=23 rec1=00 rec2=01 rec3=084
        [0x01] rec0=22 rec1=00 rec2=07 rec3=004
        [0x02] rec0=27 rec1=00 rec2=06 rec3=036
        [0x03] rec0=21 rec1=00 rec2=0a rec3=020
        [0x04] rec0=18 rec1=00 rec2=02 rec3=028
        [0x05] rec0=20 rec1=00 rec2=08 rec3=044
        [0x06] rec0=20 rec1=00 rec2=0b rec3=00c
        [0x07] rec0=28 rec1=00 rec2=03 rec3=048
        [0x08] rec0=20 rec1=00 rec2=05 rec3=044
        [0x09] rec0=08 rec1=00 rec2=04 rec3=000
        [0x0a] rec0=08 rec1=00 rec2=04 rec3=000
        [0x0b] rec0=40 rec1=40 rec2=40 rec3=202
    tail 0x2174b73da86574948eaac 0x42a00088462060003
Free Block Chain:
  0xc: 0000  00 09 00 09 00 06 20 20 20 20 65 6e 06 64 65 78  ┆          en dex┆
  0x9: 0000  00 00 00 09 00 06 20 20 20 20 65 6e 06 44 69 73  ┆          en Dis┆