|
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: 20480 (0x5000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Class, seg_02cfe1, seg_02d133, 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_User_Object
(The_Instance : Instance_Name; For_Class : Class.Object)
return User_Object is
begin
return User_Object'(Isa => For_Class, Name => The_Instance);
end As_User_Object;
function Class_Of (The_Object : User_Object) return Class.Object is
begin
return The_Object.Isa;
end Class_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 Class_Name_Of (The_Object.Isa);
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 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 renames The_Object.Isa;
The_Instance : Instance_Name renames The_Object.Name;
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 renames The_Object.Isa;
The_Instance : Instance_Name renames The_Object.Name;
begin
return The_Class.Instances (The_Instance).Value (The_Slot);
end Get;
procedure Add (To_Class : Class.Object; The_Instance : Slots) is
Content : Instance_Collection renames To_Class.Instances;
Last_Instance : Instance_Name renames To_Class.Last_Instance;
begin
for I in Content'Range loop
if Content (I) = Null_Instance then
Content (I) := Instance'(Size => The_Instance'Length,
Value => The_Instance);
if I > Last_Instance then
Last_Instance := I;
end if;
return;
end if;
end loop;
raise Overflow;
end Add;
procedure Delete (The_Object : User_Object) is
The_Instance : Instance_Name renames The_Object.Name;
Content : Instance_Collection renames The_Object.Isa.Instances;
Last_Instance : Instance_Name renames The_Object.Isa.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 renames The_Object.Isa;
The_Instance : Instance_Name renames The_Object.Name;
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 renames The_Object.Isa;
The_Instance : Instance_Name renames The_Object.Name;
begin
The_Class.Instances (The_Instance).Value (The_Slot) := To_Value;
end Change;
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 not First then
Put (", ", Where);
if I mod 2 /= 0 then
New_Line (Where);
end if;
else
First := False;
end if;
Put (Constant_String.Image (The_Images (I)) & " =>", Where);
Slot.Put (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 renames The_Object.Name;
The_Class : Class.Object renames The_Object.Isa;
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 (User_Object'(Isa => The_Class, Name => I), 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=13
nid=2
hdr6=20
[0x00] rec0=1f rec1=00 rec2=01 rec3=008
[0x01] rec0=00 rec1=00 rec2=13 rec3=01c
[0x02] rec0=23 rec1=00 rec2=10 rec3=030
[0x03] rec0=1a rec1=00 rec2=0e rec3=030
[0x04] rec0=1c rec1=00 rec2=04 rec3=066
[0x05] rec0=1a rec1=00 rec2=0d rec3=02e
[0x06] rec0=05 rec1=00 rec2=05 rec3=00e
[0x07] rec0=1c rec1=00 rec2=12 rec3=004
[0x08] rec0=00 rec1=00 rec2=0c rec3=00e
[0x09] rec0=17 rec1=00 rec2=11 rec3=028
[0x0a] rec0=01 rec1=00 rec2=07 rec3=012
[0x0b] rec0=1a rec1=00 rec2=08 rec3=058
[0x0c] rec0=1b rec1=00 rec2=03 rec3=06c
[0x0d] rec0=00 rec1=00 rec2=0b rec3=006
[0x0e] rec0=1c rec1=00 rec2=0a rec3=09c
[0x0f] rec0=19 rec1=00 rec2=0f rec3=000
[0x10] rec0=19 rec1=00 rec2=0f rec3=000
[0x11] rec0=1c rec1=00 rec2=11 rec3=000
[0x12] rec0=00 rec1=00 rec2=00 rec3=000
tail 0x21525ebe884144817857f 0x42a00088462063c03
Free Block Chain:
0x2: 0000 00 06 03 fc 80 06 67 65 72 20 69 73 06 00 09 20 ┆ ger is ┆
0x6: 0000 00 09 01 74 80 12 62 6a 65 63 74 2c 20 54 68 65 ┆ t bject, The┆
0x9: 0000 00 00 00 16 a4 0b 5b 73 74 61 74 65 6d 65 6e 74 ┆ [statement┆