|
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: 16384 (0x4000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Fact, seg_02ad95
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Condition;
with Constant_String;
with Text_Io;
use Condition;
package body Fact is
Max_Frame_Count : constant := 200;
Last_Frame : Name := 0;
type Frames is array (Name range <>) of Frame;
Working_Memory : Frames (1 .. Max_Frame_Count) := (others => Null_Frame);
-------------------------------------------------------------------------
function Image (Of_Class : Class_Name) return String
renames Constant_String.Image;
function "=" (Left, Right : Class_Name) return Boolean
renames Constant_String."=";
-------------------------------------------------------------------------
function Empty_Collection return Collection is
begin
return (1 .. 0 => Null_Name);
end Empty_Collection;
function Match (The_Fact_Class, The_Filter_Class : Class_Name)
return Boolean is
Result : Boolean;
begin
Result := The_Fact_Class /= Null_Class_Name and then
The_Fact_Class = The_Filter_Class;
return Result;
end Match;
function Match (The_Slots : Slots; Against : Patterns) return Boolean is
begin
for I in The_Slots'Range loop
if not Match (The_Slots (I), Against (I)) then
return False;
end if;
end loop;
return True;
end Match;
-------------------------------------------------------------------------
function Retrieve (Filter : Queries) return Collection is
Result : Collection (Filter'Range);
Wm : Frames renames Working_Memory;
function Recursive_Search (Index : Positive) return Boolean is
Filter_Class : Class_Name;
begin
if Index > Filter'Last then
return True;
else
Filter_Class := Filter (Index).Class;
case Filter (Index).Kind is
when Find =>
for I in Wm'First .. Last_Frame loop
if Match (Wm (I).Class, Filter_Class) and then
Match (Wm (I).Value, Filter (Index).Value) then
if Recursive_Search (Index + 1) then
Result (Index) := I;
return True;
end if;
end if;
end loop;
when Check_No =>
for I in Wm'First .. Last_Frame loop
if Match (Wm (I).Class, Filter_Class) and then
Match (Wm (I).Value, Filter (Index).Value) then
return False;
end if;
end loop;
if Recursive_Search (Index + 1) then
Result (Index) := Null_Name;
return True;
end if;
end case;
return False;
end if;
end Recursive_Search;
begin
if Filter'Length /= 0 and then Recursive_Search (Filter'First) then
return Result;
else
return Empty_Collection;
end if;
end Retrieve;
-------------------------------------------------------------------------
procedure Add (The_Fact : Frame) is
begin
for I in Working_Memory'Range loop
if Working_Memory (I) = Null_Frame then
Working_Memory (I) := The_Fact;
if I > Last_Frame then
Last_Frame := I;
end if;
return;
end if;
end loop;
raise Overflow;
end Add;
procedure Delete (The_Fact : Name) is
begin
Working_Memory (The_Fact) := Null_Frame;
if Last_Frame = The_Fact then
Last_Frame := Last_Frame - 1;
for I in reverse 1 .. Last_Frame loop
exit when Working_Memory (I) /= Null_Frame;
Last_Frame := I;
end loop;
end if;
end Delete;
procedure Change (The_Fact : Name; Value : Frame) is
begin
Working_Memory (The_Fact) := Value;
end Change;
procedure Change (The_Fact : Name;
The_Slot : Slot_Names;
To_Value : Integer) is
begin
Working_Memory (The_Fact).Value (The_Slot) := To_Value;
end Change;
function Get (The_Fact : Name) return Frame is
begin
return Working_Memory (The_Fact);
end Get;
function Get (The_Fact : Name; Slot : Slot_Names) return Integer is
begin
return Working_Memory (The_Fact).Value (Slot);
end Get;
-------------------------------------------------------------------------
procedure Put (The_Patterns : Patterns;
Where : Output_Stream.Object :=
Output_Stream.Standard_Output) is
First : Boolean := True;
use Output_Stream;
begin
for I in The_Patterns'Range loop
if not First then
Put_Line (", ", Where);
else
First := False;
end if;
Put ("Slot" & Slot_Names'Image (I) & " => ", Where);
Put (The_Condition => The_Patterns (I), Where => Where);
end loop;
end Put;
procedure Put (The_Query : Query; Where : Output_Stream.Object) is
use Output_Stream;
begin
case The_Query.Kind is
when Find =>
Put_Line
("Find_" & Image (The_Query.Class) & "_Such_As'(", Where);
when Check_No =>
Put_Line
("Check_No_" & Image (The_Query.Class) & "_Has'(", Where);
end case;
Indent_Right (Where);
Put (The_Patterns => The_Query.Value, Where => Where);
Indent_Left (Where);
Put_Line (")", Where);
end Put;
procedure Put (The_Queries : Queries; Where : Output_Stream.Object) is
use Output_Stream;
begin
Put ("Premiss'(", Where);
Indent_Right (Where);
for I in The_Queries'Range loop
Put (The_Queries (I), Where);
New_Line (Where);
end loop;
Indent_Left (Where);
Put_Line (")", Where);
end Put;
procedure Put (The_Slots : Slots;
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 ("Slot" & Slot_Names'Image (I) & " =>", Where);
Put (Integer'Image (The_Slots (I)), Where);
end loop;
end Put;
procedure Put (The_Fact : Name; Where : Output_Stream.Object) is
The_Object : Frame;
use Output_Stream;
begin
if The_Fact /= Null_Name then
The_Object := Working_Memory (The_Fact);
if The_Object /= Null_Frame then
Put_Line (Image (The_Object.Class) & "'(", Where);
Indent_Right (Where);
Put (The_Slots => The_Object.Value, Where => Where);
Indent_Left (Where);
Put_Line (")", Where);
end if;
else
Put ("No name", Where);
end if;
end Put;
procedure Put (The_Collection : Collection; Where : Output_Stream.Object) is
use Output_Stream;
begin
Put_Line ("Fact_collection'(", Where);
Indent_Right (Where);
if The_Collection'Length /= 0 then
for I in The_Collection'Range loop
Put (The_Collection (I), Where);
end loop;
end if;
Indent_Left (Where);
New_Line (Where);
Put_Line (")", Where);
end Put;
procedure Put (Where : Output_Stream.Object) is
The_Object : Frame;
use Output_Stream;
begin
Put_Line ("Working_Memory'(", Where);
Indent_Right (Where);
for Name in Working_Memory'Range loop
The_Object := Working_Memory (Name);
if The_Object /= Null_Frame then
Put (Name, Where);
end if;
end loop;
Indent_Left (Where);
Put_Line (")", Where);
end Put;
end Fact;
nblk1=f
nid=c
hdr6=18
[0x00] rec0=23 rec1=00 rec2=01 rec3=03c
[0x01] rec0=1e rec1=00 rec2=07 rec3=044
[0x02] rec0=02 rec1=00 rec2=05 rec3=04e
[0x03] rec0=12 rec1=00 rec2=0b rec3=044
[0x04] rec0=23 rec1=00 rec2=08 rec3=036
[0x05] rec0=23 rec1=00 rec2=09 rec3=08c
[0x06] rec0=1c rec1=00 rec2=0f rec3=06e
[0x07] rec0=0b rec1=00 rec2=02 rec3=012
[0x08] rec0=1f rec1=00 rec2=0a rec3=05e
[0x09] rec0=01 rec1=00 rec2=04 rec3=036
[0x0a] rec0=1d rec1=00 rec2=06 rec3=010
[0x0b] rec0=14 rec1=00 rec2=0d rec3=000
[0x0c] rec0=14 rec1=00 rec2=0d rec3=001
[0x0d] rec0=40 rec1=00 rec2=00 rec3=002
[0x0e] rec0=00 rec1=00 rec2=00 rec3=019
tail 0x21723f45683e57bdb42e9 0x42a00088462063c03
Free Block Chain:
0xc: 0000 00 03 00 06 80 03 43 6c 61 03 6e 20 69 73 20 20 ┆ Cla n is ┆
0x3: 0000 00 0e 00 16 80 13 20 20 20 20 20 75 73 65 20 4f ┆ use O┆
0xe: 0000 00 00 00 57 80 0e 61 72 64 5f 4f 75 74 70 75 74 ┆ W ard_Output┆