|
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: 39936 (0x9c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Class, seg_04b2f1, seg_04b44f, separate Generic_Fact_Base
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
separate (Generic_Fact_Base)
package body Class is
type Instance (Size : Instance_Size := 0) is
record
Value : Slots (1 .. Size);
Date : Recency.Object;
end record;
Null_Instance : constant Instance := (Size => 0,
Value => (others => Slot.Null_Object),
Date => Recency.Null_Object);
type Instance_Collection is array (Instance_Name range <>) of Instance;
type Slot_Images (Size : Instance_Size := 0) is
record
Value : Slot_Names_Images (1 .. Size);
end record;
type Object_Structure (Class_Size : Instance_Name) is
record
Class_Name : Class_Names;
Last_Instance : Instance_Name := Null_Instance_Name;
Instances : Instance_Collection (1 .. Class_Size) :=
(others => Null_Instance);
Images : Slot_Images;
end record;
function As_Anonymous (The_Class : Object) return Natural is
begin
return Class_Names'Pos (Class_Name_Of (The_Class));
end As_Anonymous;
function As_Class_Name (Anonymous_Class : Natural) return Class_Names is
begin
return Class_Names'Val (Anonymous_Class);
end As_Class_Name;
function As_User_Object
(The_Instance : Instance_Name; For_Class : Class.Object)
return User_Object is
begin
return Fact_Reference.Value (C => As_Anonymous (For_Class),
I => Natural (The_Instance));
end As_User_Object;
function As_User_Object (The_Slot : Slot.Object) return User_Object is
begin
return Slot.Get_Reference (The_Slot);
end As_User_Object;
function Class_Of (The_Object : User_Object) return Class.Object is
use Fact_Reference;
begin
return Working_Memory.Get (As_Class_Name (Get_Class (The_Object)));
end Class_Of;
function Instance_Of (The_Object : User_Object) return Instance_Name is
begin
return Instance_Name (Fact_Reference.Get_Instance (The_Object));
end Instance_Of;
function Class_Name_Of (The_Object : Object) return Class_Names is
begin
if The_Object /= Null_Class then
return The_Object.Class_Name;
else
return Null_Class_Name;
end if;
end Class_Name_Of;
function Class_Name_Of (The_Object : User_Object) return Class_Names is
begin
return As_Class_Name (Fact_Reference.Get_Class (The_Object));
end Class_Name_Of;
function Last_Instance (Of_Class : Object) return Instance_Name is
begin
return Of_Class.Last_Instance;
end Last_Instance;
function Is_Valid_Instance
(The_Instance : Instance_Name; Of_Class : Class.Object)
return Boolean is
begin
return Of_Class /= Null_Class and then
The_Instance /= Null_Instance_Name and then
The_Instance <= Of_Class.Last_Instance;
end Is_Valid_Instance;
function No_User_Objects return User_Objects is
begin
return (1 .. 0 => Null_User_Object);
end No_User_Objects;
function Make (Name : Class_Names;
Class_Size : Natural;
Names : Slot_Names_Images) return Object is
begin
return new Object_Structure'
(Class_Size => Instance_Name (Class_Size),
Class_Name => Name,
Last_Instance => 0,
Instances => (others => Null_Instance),
Images => (Size => Names'Length, Value => Names));
end Make;
procedure Make_Empty (The_Class : in out Class.Object) is
begin
The_Class.Last_Instance := Null_Instance_Name;
The_Class.Instances := (others => Null_Instance);
end Make_Empty;
function Is_Equal (Left, Right : Slot.Object) return Boolean is
L : constant Slots := Get (As_User_Object (Left));
R : constant Slots := Get (As_User_Object (Right));
use Slot.Operators;
begin
if L'Length = R'Length then
for I in L'Range loop
if Slot.Is_A_Reference (L (I)) then
if not Is_Equal (L (I), R (I)) then
return False;
end if;
else
if L (I) /= R (I) then
return False;
end if;
end if;
end loop;
return True;
else
return False;
end if;
end Is_Equal;
function Match (The_Slots : Slots; Against : Query.Patterns)
return Boolean is
begin
for I in The_Slots'Range loop
if not Predicate.Match (The_Slots (I), Against (I)) then
return False;
end if;
end loop;
return True;
end Match;
function Match (The_Instance : Instance_Name;
Against_Patterns : Query.Patterns;
Using_Class : Class.Object) return Boolean is
Instances : Instance_Collection renames Using_Class.Instances;
begin
return Instances (The_Instance).Size /= 0 and then
Match (The_Slots => Instances (The_Instance).Value,
Against => Against_Patterns);
end Match;
function Slot_Name_Image (From_Class : Class.Object; For_Slot : Slot_Names)
return String is
The_String_Object : Constant_String.Object;
begin
The_String_Object := From_Class.Images.Value (For_Slot);
return Constant_String.Image (The_String_Object);
end Slot_Name_Image;
function Get (The_Object : User_Object) return Slots is
The_Class : Object := Class_Of (The_Object);
The_Instance : Instance_Name := Instance_Of (The_Object);
begin
return The_Class.Instances (The_Instance).Value;
end Get;
function Get (The_Object : User_Object; The_Slot : Slot_Names)
return Slot.Object is
The_Class : Object := Class_Of (The_Object);
The_Instance : Instance_Name := Instance_Of (The_Object);
begin
return The_Class.Instances (The_Instance).Value (The_Slot);
end Get;
function Get (The_Object : User_Object) return Recency.Object is
The_Class : Object := Class_Of (The_Object);
The_Instance : Instance_Name := Instance_Of (The_Object);
begin
if The_Object = Null_User_Object then
return Recency.Null_Object;
else
return The_Class.Instances (The_Instance).Date;
end if;
end Get;
procedure Add (To_Class : Class.Object;
The_Instance : Slots;
Its_Reference : out Slot.Object) is
Content : Instance_Collection renames To_Class.Instances;
Last_Instance : Instance_Name renames To_Class.Last_Instance;
Class : Natural := Class_Names'Pos (Class_Name_Of (To_Class));
Id : Natural;
The_Reference : Fact_Reference.Object;
The_Date : Recency.Object;
begin
Recency.Get (The_Date);
for I in Content'Range loop
if Content (I) = Null_Instance then
Content (I) := Instance'(Size => The_Instance'Length,
Value => The_Instance,
Date => The_Date);
Id := Natural (I);
if I > Last_Instance then
Last_Instance := I;
end if;
The_Reference := Fact_Reference.Value (Class, Id);
Its_Reference := Slot.Reference_Value (The_Reference);
return;
end if;
end loop;
raise Overflow;
end Add;
procedure Delete (The_Object : User_Object) is
The_Class : Object := Class_Of (The_Object);
The_Instance : Instance_Name := Instance_Of (The_Object);
Content : Instance_Collection renames The_Class.Instances;
Last_Instance : Instance_Name renames The_Class.Last_Instance;
begin
Content (The_Instance) := Null_Instance;
if Last_Instance = The_Instance then
loop
if Last_Instance = 1 then
Last_Instance := Null_Instance_Name;
else
Last_Instance := Last_Instance - 1;
end if;
exit when (Last_Instance = Null_Instance_Name) or else
(Content (Last_Instance) /= Null_Instance);
end loop;
end if;
end Delete;
procedure Change (The_Object : User_Object; To_Value : Slots) is
The_Class : Object := Class_Of (The_Object);
The_Instance : Instance_Name := Instance_Of (The_Object);
The_Date : Recency.Object;
begin
Recency.Get (The_Date);
The_Class.Instances (The_Instance) := Instance'(Size => To_Value'Length,
Value => To_Value,
Date => The_Date);
end Change;
procedure Change (The_Object : User_Object;
The_Slot : Slot_Names;
To_Value : Slot.Object) is
The_Class : Object := Class_Of (The_Object);
The_Instance : Instance_Name := Instance_Of (The_Object);
The_Date : Recency.Object;
begin
Recency.Get (The_Date);
The_Class.Instances (The_Instance).Value (The_Slot) := To_Value;
The_Class.Instances (The_Instance).Date := The_Date;
end Change;
procedure Put_Slot (The_Slot : Slot.Object; Where : Output_Stream.Object) is
The_Instance : User_Object;
begin
if Slot.Is_A_Reference (The_Slot) then
The_Instance := As_User_Object (The_Slot);
Default_Put (The_Instance, Where);
else
Slot.Put (The_Slot, Where);
end if;
end Put_Slot;
procedure Put_Slots (The_Slots : Slots;
The_Images : Slot_Names_Images;
Where : Output_Stream.Object :=
Output_Stream.Standard_Output) is
First : Boolean := True;
use Output_Stream;
begin
for I in The_Slots'Range loop
if First then
First := False;
else
Put_Line (",", Where);
end if;
Put (Constant_String.Image (The_Images (I)) & " => ", Where);
Put_Slot (The_Slots (I), Where);
end loop;
end Put_Slots;
procedure Put_Instance (The_Class : Class.Object;
The_Instance : Instance;
Where : Output_Stream.Object) is
use Output_Stream;
begin
if The_Instance /= Null_Instance then
Put_Line (Class_Names'Image (The_Class.Class_Name) & "'(", Where);
Indent_Right (Where);
Put ("DATE =>", Where);
Recency.Put (The_Instance.Date, Where);
Put_Line (",", Where);
Put_Slots (The_Slots => The_Instance.Value,
The_Images => The_Class.Images.Value,
Where => Where);
Indent_Left (Where);
Put_Line (")", Where);
else
Put_Line ("FREE", Where);
end if;
end Put_Instance;
procedure Default_Put (The_Object : User_Object;
Where : Output_Stream.Object) is
The_Instance : Instance_Name := Instance_Of (The_Object);
The_Class : Class.Object := Class_Of (The_Object);
use Output_Stream;
begin
if Is_Valid_Instance (The_Instance, The_Class) then
Put_Instance (The_Class, The_Class.Instances (The_Instance), Where);
else
Put_Line ("null_object", Where);
end if;
end Default_Put;
procedure Default_Put (The_Collection : User_Objects;
Where : Output_Stream.Object) is
use Output_Stream;
begin
Put_Line ("Collection'(", Where);
Indent_Right (Where);
if The_Collection'Length /= 0 then
for I in The_Collection'Range loop
Default_Put (The_Collection (I), Where);
end loop;
end if;
Indent_Left (Where);
New_Line (Where);
Put_Line (")", Where);
end Default_Put;
procedure Generic_Put (The_Class : Class.Object;
Where : Output_Stream.Object) is
use Output_Stream;
The_Instance : Instance;
begin
if The_Class /= Null_Class then
Put_Line ("Class'(", Where);
Indent_Right (Where);
Put_Line
("Kind => " & Class_Names'Image (The_Class.Class_Name),
Where);
Put_Line
("Size => " & Instance_Name'Image (The_Class.Last_Instance),
Where);
Put_Line ("Instances => Collection'(", Where);
Indent_Right (Where);
for I in 1 .. Last_Instance (The_Class) loop
Put (Integer (I), Where);
Put (" => ", Where);
The_Instance := The_Class.Instances (I);
if The_Instance /= Null_Instance then
Put (As_User_Object (I, The_Class), Where);
else
Put_Line ("FREE", Where);
end if;
end loop;
Indent_Left (Where);
Put_Line (")", Where);
Indent_Left (Where);
Put_Line (")", Where);
end if;
end Generic_Put;
procedure Default_Put (The_Class : Class.Object;
Where : Output_Stream.Object) is
procedure Default_Class_Put is new Generic_Put;
begin
Default_Class_Put (The_Class, Where);
end Default_Put;
end Class;
nblk1=26
nid=1e
hdr6=2c
[0x00] rec0=1c rec1=00 rec2=01 rec3=03a
[0x01] rec0=01 rec1=00 rec2=17 rec3=002
[0x02] rec0=21 rec1=00 rec2=02 rec3=040
[0x03] rec0=22 rec1=00 rec2=12 rec3=01c
[0x04] rec0=1d rec1=00 rec2=09 rec3=00a
[0x05] rec0=20 rec1=00 rec2=21 rec3=006
[0x06] rec0=00 rec1=00 rec2=23 rec3=008
[0x07] rec0=1a rec1=00 rec2=06 rec3=078
[0x08] rec0=1b rec1=00 rec2=03 rec3=020
[0x09] rec0=01 rec1=00 rec2=16 rec3=008
[0x0a] rec0=17 rec1=00 rec2=1f rec3=056
[0x0b] rec0=01 rec1=00 rec2=1c rec3=052
[0x0c] rec0=1a rec1=00 rec2=08 rec3=00e
[0x0d] rec0=00 rec1=00 rec2=1a rec3=030
[0x0e] rec0=17 rec1=00 rec2=0c rec3=07e
[0x0f] rec0=01 rec1=00 rec2=0b rec3=02e
[0x10] rec0=1d rec1=00 rec2=10 rec3=014
[0x11] rec0=00 rec1=00 rec2=1d rec3=018
[0x12] rec0=19 rec1=00 rec2=0f rec3=03c
[0x13] rec0=1d rec1=00 rec2=18 rec3=012
[0x14] rec0=1c rec1=00 rec2=22 rec3=028
[0x15] rec0=17 rec1=00 rec2=19 rec3=000
[0x16] rec0=11 rec1=00 rec2=1e rec3=000
[0x17] rec0=12 rec1=00 rec2=06 rec3=08a
[0x18] rec0=18 rec1=00 rec2=03 rec3=07a
[0x19] rec0=17 rec1=00 rec2=1f rec3=080
[0x1a] rec0=20 rec1=00 rec2=08 rec3=046
[0x1b] rec0=05 rec1=00 rec2=0c rec3=02c
[0x1c] rec0=19 rec1=00 rec2=10 rec3=058
[0x1d] rec0=1d rec1=00 rec2=0f rec3=04c
[0x1e] rec0=00 rec1=00 rec2=18 rec3=008
[0x1f] rec0=1d rec1=00 rec2=19 rec3=028
[0x20] rec0=1c rec1=00 rec2=1e rec3=000
[0x21] rec0=1c rec1=00 rec2=1e rec3=000
[0x22] rec0=1c rec1=00 rec2=1e rec3=000
[0x23] rec0=19 rec1=00 rec2=05 rec3=06e
[0x24] rec0=06 rec1=00 rec2=11 rec3=000
[0x25] rec0=06 rec1=00 rec2=11 rec3=000
tail 0x21750026a867d5f3b00ab 0x42a00088462063c03
Free Block Chain:
0x1e: 0000 00 15 02 13 80 23 55 73 65 72 5f 4f 62 6a 65 63 ┆ #User_Objec┆
0x15: 0000 00 13 03 fc 80 0b 6c 6f 74 5f 49 6d 61 67 65 73 ┆ lot_Images┆
0x13: 0000 00 0d 00 91 80 37 20 20 20 43 6c 61 73 73 5f 4f ┆ 7 Class_O┆
0xd: 0000 00 04 03 fc 80 14 6e 64 20 6e 6f 74 20 28 46 69 ┆ nd not (Fi┆
0x4: 0000 00 14 00 18 80 15 61 73 73 2e 49 6e 73 74 61 6e ┆ ass.Instan┆
0x14: 0000 00 05 03 fc 80 08 28 49 6e 64 65 78 29 2e 08 00 ┆ (Index). ┆
0x5: 0000 00 11 03 fc 80 28 65 5f 52 65 66 65 72 65 6e 63 ┆ (e_Referenc┆
0x11: 0000 00 20 03 fc 80 06 62 6a 65 63 74 3b 06 00 21 20 ┆ bject; ! ┆
0x20: 0000 00 26 00 0f 80 0c 20 20 20 3a 20 43 6c 61 73 73 ┆ & : Class┆
0x26: 0000 00 25 03 fc 80 0b 6c 6f 74 5f 49 6d 61 67 65 73 ┆ % lot_Images┆
0x25: 0000 00 0a 00 2a 80 0b 6e 73 20 28 49 6e 64 65 78 29 ┆ * ns (Index)┆
0xa: 0000 00 0e 00 0f 80 0c 72 20 49 20 69 6e 20 54 68 65 ┆ r I in The┆
0xe: 0000 00 07 00 18 80 04 20 20 6f 72 04 00 00 00 00 0b ┆ or ┆
0x7: 0000 00 1b 03 fc 80 2a 20 20 20 20 20 20 20 20 20 20 ┆ * ┆
0x1b: 0000 00 24 00 22 80 02 3a 3d 02 00 1a 20 20 20 20 20 ┆ $ " := ┆
0x24: 0000 00 00 00 5e 80 05 65 6c 65 63 74 05 00 36 20 20 ┆ ^ elect 6 ┆