|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 7271 (0x1c67) Types: TextFile Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000 └─ ⟦5a81ac88f⟧ »Space Info Vol 1« └─⟦e81a05e65⟧ └─⟦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; -----***************************************************************** -----***************************************************************** 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 (B); Get_Model_field_by_Name(D,Name,Strawberry_Fields); Bounded_String.Copy(s, Fields.Get_Field_Type_By_Name (Strawberry_fields,Attribute_Name)); Fields.Dispose_Object(B); return Bounded_String.Image(S); end; -----***************************************************************** -----***************************************************************** 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