|
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: 26624 (0x6800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Class, seg_03b94b, separate Generic_Fact_Base
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
separate (Generic_Fact_Base)
package body Class is
type Instance (Size : Instance_Size := 0) is
record
Value : Slots (1 .. Size);
end record;
Null_Instance : constant Instance :=
(Size => 0, Value => (others => Slot.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_Reference_Slot : Slot.Object;
Against : Predicate_Object) return Boolean is
The_User_Object : User_Object := As_User_Object (The_Reference_Slot);
The_Class : Object := Class_Of (The_User_Object);
begin
if Isa_Collection_Predicate (Against) then
declare
The_Patterns : constant Query.Patterns :=
Predicate_Get_Collection (Against);
begin
return Match (The_Instance => Instance_Of (The_User_Object),
Against_Patterns => The_Patterns,
Using_Class => The_Class);
end;
elsif Isa_And_Predicate (Against) then
declare
Left, Right : Predicate_Object;
begin
Predicate_Get_Conjunction
(From_Object => Against, Left => Left, Right => Right);
if not Match (The_Reference_Slot, Left) then
return False;
end if;
if not Match (The_Reference_Slot, Right) then
return False;
end if;
return True;
end;
elsif Isa_Is_Equal_Predicate (Against) then
return Is_Equal (The_Reference_Slot,
Expression_Evaluate
(Predicate_Get_Expression (Against)));
elsif Isa_Is_Different_Predicate (Against) then
return not Is_Equal (The_Reference_Slot,
Expression_Evaluate
(Predicate_Get_Expression (Against)));
elsif Isa_Is_Any_Predicate (Against) then
return Predicate_Match (The_Reference_Slot, Against);
elsif Isa_Define_As_Predicate (Against) then
return Predicate_Match (The_Reference_Slot, Against);
end if;
end Match;
function Match (The_Slots : Slots; Against : Query.Patterns)
return Boolean is
begin
for I in The_Slots'Range loop
if Slot.Is_A_Reference (The_Slots (I)) then
if not Match (The_Reference_Slot => The_Slots (I),
Against => Against (I)) then
return False;
end if;
else
if not Predicate_Match (The_Slots (I), Against (I)) then
return False;
end if;
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;
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;
begin
for I in Content'Range loop
if Content (I) = Null_Instance then
Content (I) := Instance'(Size => The_Instance'Length,
Value => The_Instance);
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
Last_Instance := Last_Instance - 1;
for I in reverse 1 .. Last_Instance loop
exit when Content (I) /= Null_Instance;
Last_Instance := I;
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);
begin
The_Class.Instances (The_Instance) :=
Instance'(Size => To_Value'Length, Value => To_Value);
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);
begin
The_Class.Instances (The_Instance).Value (The_Slot) := To_Value;
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_Slots (The_Slots => The_Instance.Value,
The_Images => The_Class.Images.Value,
Where => Where);
Indent_Left (Where);
Put_Line (")", 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_Line (Class_Names'Image (The_Class.Class_Name) & "'(", Where);
Indent_Right (Where);
Put_Slots (The_Slots => The_Class.Instances (The_Instance).Value,
The_Images => The_Class.Images.Value,
Where => Where);
Indent_Left (Where);
Put_Line (")", 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;
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);
Put (As_User_Object (I, The_Class), Where);
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=19
nid=5
hdr6=2e
[0x00] rec0=20 rec1=00 rec2=01 rec3=036
[0x01] rec0=00 rec1=00 rec2=17 rec3=01c
[0x02] rec0=20 rec1=00 rec2=12 rec3=096
[0x03] rec0=22 rec1=00 rec2=08 rec3=006
[0x04] rec0=1e rec1=00 rec2=09 rec3=008
[0x05] rec0=1c rec1=00 rec2=0d rec3=010
[0x06] rec0=16 rec1=00 rec2=19 rec3=012
[0x07] rec0=17 rec1=00 rec2=16 rec3=044
[0x08] rec0=11 rec1=00 rec2=18 rec3=08c
[0x09] rec0=1b rec1=00 rec2=11 rec3=00a
[0x0a] rec0=00 rec1=00 rec2=06 rec3=014
[0x0b] rec0=15 rec1=00 rec2=03 rec3=048
[0x0c] rec0=01 rec1=00 rec2=04 rec3=050
[0x0d] rec0=19 rec1=00 rec2=0b rec3=012
[0x0e] rec0=01 rec1=00 rec2=0c rec3=01e
[0x0f] rec0=1b rec1=00 rec2=07 rec3=028
[0x10] rec0=00 rec1=00 rec2=15 rec3=028
[0x11] rec0=1f rec1=00 rec2=14 rec3=024
[0x12] rec0=16 rec1=00 rec2=0e rec3=02e
[0x13] rec0=00 rec1=00 rec2=02 rec3=008
[0x14] rec0=1f rec1=00 rec2=10 rec3=032
[0x15] rec0=1a rec1=00 rec2=0a rec3=032
[0x16] rec0=06 rec1=00 rec2=0f rec3=000
[0x17] rec0=06 rec1=00 rec2=0f rec3=000
[0x18] rec0=00 rec1=00 rec2=00 rec3=000
tail 0x21738ded485267a6b3d54 0x42a00088462063c03
Free Block Chain:
0x5: 0000 00 13 02 66 80 2c 20 69 66 20 53 6c 6f 74 2e 49 ┆ f , if Slot.I┆
0x13: 0000 00 00 02 41 80 09 75 72 6e 20 54 72 75 65 3b 09 ┆ A urn True; ┆