|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 8407 (0x20d7)
Types: TextFile
Names: »B«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─ ⟦129cab021⟧ »DATA«
└─⟦this⟧
with Object, Argument, Message, Block, Boolean_Class,
Bounded_String, Table, Counter, Bug;
package body Block_Class is
type Block_Object is
record
The_Block : Block.Node;
Used : Boolean;
end record;
Empty_Block : constant Block_Object := (Block.Empty_Node, False);
subtype Id_Block_Table is Integer range 1 .. 100;
Block_Table : array (Id_Block_Table) of Block_Object;
type Block_Keyword_Message is (Prive, Valeur, Tantquevrai, Tantquefaux);
type Block_Unary_Message is (Unknown, Valeur, Entexte);
package Bs renames Bounded_String;
function Search_Empty return Id_Block_Table is
Id : Id_Block_Table := 1;
begin
loop
exit when Block_Table (Id) = Empty_Block;
if Id = Id_Block_Table'Last then
raise Bug.Too_Many_Blocks;
end if;
Id := Id + 1;
end loop;
return (Id);
end Search_Empty;
function Search (A_Block : Object.Reference) return Id_Block_Table is
Id : Id_Block_Table;
begin
Id := Id_Block_Table (Object.Get_Value (A_Block));
if not Block_Table (Id).Used then
raise Bug.Block_Not_Found;
end if;
return (Id);
end Search;
function Search (A_Block : Object.Reference) return Block.Node is
Id : Id_Block_Table;
begin
Id := Id_Block_Table (Object.Get_Value (A_Block));
if not Block_Table (Id).Used then
raise Bug.Block_Not_Found;
end if;
return (Block_Table (Id).The_Block);
end Search;
function Create (Value : Block.Node) return Object.Reference is
Id : Id_Block_Table;
Obj : Object.Reference;
begin
Id := Search_Empty;
Obj := Object.Create (Object.Block_Class, Id);
Block_Table (Id).The_Block := Value;
Block_Table (Id).Used := True;
return (Obj);
end Create;
function Valeur (Blk : Object.Reference) return Object.Reference is
The_Block : Block.Node;
Result : Object.Reference;
begin
The_Block := Search (Blk);
Result := Block.Interpret (The_Block);
return (Result);
end Valeur;
procedure In_Text (Blk : Object.Reference) is
The_Block : Block.Node;
begin
Object.In_Text (Blk);
The_Block := Search (Blk);
Block.Unparse (The_Block);
end In_Text;
function While_True (Condition_Block, Argument_Block : Object.Reference)
return Object.Reference is
Condition_Block_Result, Argument_Block_Result : Object.Reference;
use Object;
begin
if (Object.Get_Class (Argument_Block) /= Object.Block_Class) then
raise Bug.Mismatch_Type;
end if;
loop
Condition_Block_Result := Valeur (Condition_Block);
exit when not Object.Equal (A => Condition_Block_Result,
B => Boolean_Class.True);
Argument_Block_Result := Valeur (Argument_Block);
end loop;
return Argument_Block_Result;
end While_True;
function While_False (Condition_Block, Argument_Block : Object.Reference)
return Object.Reference is
Condition_Block_Result, Argument_Block_Result : Object.Reference;
use Object;
begin
if (Object.Get_Class (Argument_Block) /= Object.Block_Class) then
raise Bug.Mismatch_Type;
end if;
loop
Condition_Block_Result := Valeur (Condition_Block);
exit when not Object.Equal (A => Condition_Block_Result,
B => Boolean_Class.False);
Argument_Block_Result := Valeur (Argument_Block);
end loop;
return Argument_Block_Result;
end While_False;
function Recognize_Keyword (The_Message : Message.Tiny_String)
return Block_Keyword_Message is
Result : Block_Keyword_Message;
begin
Result := Block_Keyword_Message'Value (Bs.Image (The_Message));
return Result;
exception
when Constraint_Error =>
return Prive;
end Recognize_Keyword;
function Recognize_Unary (The_Message : Message.Tiny_String)
return Block_Unary_Message is
Result : Block_Unary_Message;
begin
Result := Block_Unary_Message'Value (Bs.Image (The_Message));
return Result;
exception
when Constraint_Error =>
return Unknown;
end Recognize_Unary;
function Send (To_Object : Object.Reference;
The_Messages : Message.List;
With_Arguments : Argument.List) return Object.Reference is
Result : Object.Reference := Object.Void_Reference;
The_Block_Node : Block.Node;
Keywords, Identifiers : Message.List;
S_Table : Table.Symbol_Kind;
A_Message, A_Identifier, A_Keyword : Message.Tiny_String;
A_Argument : Object.Reference;
Mess : Message.List;
Args : Argument.List;
Nb_Mess : Natural;
begin
Mess := The_Messages;
Args := With_Arguments;
The_Block_Node := Search (To_Object);
Keywords := Block.Keyword_List (The_Block_Node);
Identifiers := Block.Identifier_List (The_Block_Node);
S_Table := Block.Symbol (The_Block_Node);
Nb_Mess := Message.How_Many (The_Messages);
A_Message := Message.Get (Mess);
A_Argument := Argument.Get (Args);
Counter.Increase (Object.Block_Class);
if Nb_Mess = 1 and (Recognize_Keyword (A_Message) = Tantquevrai or
Recognize_Keyword (A_Message) = Tantquefaux) then
if Recognize_Keyword (A_Message) = Tantquevrai then
Result := While_True (To_Object, A_Argument);
elsif Recognize_Keyword (A_Message) = Tantquefaux then
Result := While_False (To_Object, A_Argument);
end if;
else
if Nb_Mess > Message.How_Many (Identifiers) then
raise Bug.Too_Many_Messages;
end if;
if Nb_Mess < Message.How_Many (Identifiers) then
raise Bug.Not_Enough_Messages;
end if;
for I in 1 .. Nb_Mess loop
A_Message := Message.Get (Mess);
A_Argument := Argument.Get (Args);
if Recognize_Keyword (A_Message) = Valeur then
A_Identifier := Message.Get (Identifiers);
Table.Insert (S_Table, A_Identifier, A_Argument);
else
if Message.How_Many (Keywords) = 0 then
raise Bug.Mismatch_Message;
end if;
A_Keyword := Message.Get (Keywords);
if Bounded_String.Image (A_Keyword) =
Bounded_String.Image (A_Message) then
A_Identifier := Message.Get (Identifiers);
Table.Insert (S_Table, A_Identifier, A_Argument);
else
raise Bug.Unknown_Block_Message;
end if;
end if;
Message.Next (Identifiers, A_Identifier);
Message.Next (Keywords, A_Keyword);
Argument.Next (Args, A_Argument);
Message.Next (Mess, A_Message);
end loop;
Result := Valeur (To_Object);
end if;
Counter.Stop_Time (Object.Block_Class);
return (Result);
end Send;
function Send (To_Object : Object.Reference;
The_Message : Message.Tiny_String) return Object.Reference is
Result : Object.Reference;
begin
Counter.Increase (Object.Block_Class);
case Recognize_Unary (The_Message) is
when Valeur =>
Result := Valeur (To_Object);
when Entexte =>
In_Text (To_Object);
Result := To_Object;
when Unknown =>
raise Bug.Unknown_Block_Message;
end case;
Counter.Stop_Time (Object.Block_Class);
return (Result);
end Send;
begin
for I in Id_Block_Table loop
Block_Table (I) := Empty_Block;
end loop;
end Block_Class;