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