|
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: 14336 (0x3800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Class_Boolean, seg_037062
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Class_Block;
with Class_String;
with Class_Printer;
with Block;
with Bounded_String;
with String_Utilities;
with Text_Io;
with Bug_Report;
package body Class_Boolean is
function Send (This_Message : Message.Unary; To : Object.Reference)
return Object.Reference is
type E_Message is (Entexte, Image, Non);
Token : E_Message;
Mess : Message.Unary := This_Message;
package Bs renames Bounded_String;
begin
Message.Init (Mess);
if not Message.Is_Done (Mess) then
declare
use Object;
begin
Token := E_Message'Value (Bs.Image (V => Message.Get (Mess)));
case Token is
when Non =>
if Object.Get (Index_From => To) = 1 then
return False;
else
return True;
end if;
when Entexte =>
Put (To);
return To;
when Image =>
if Object.Get (Index_From => To) = 1 then
return Class_String.Create (Bs.Value ("VRAI"));
else
return Class_String.Create (Bs.Value ("FAUX"));
end if;
end case;
exception
when Constraint_Error =>
raise Bug_Report.Unknown_Unary_Message;
end;
end if;
end Send;
function Send (This_Message : Message.Binary; To : Object.Reference)
return Object.Reference is
type E_Message is (Et, Ou, Eou);
Token : E_Message;
Mess : Message.Binary := This_Message;
package Bs renames Bounded_String;
use Object;
begin
if Object.Get (Class_From => Message.Get (Argument_From => Mess)) =
Object.Boolean_Class then
begin
Token := E_Message'Value
(Bs.Image (V => Message.Get (Name_From => Mess)));
case Token is
when Et =>
if Object.Get (To) = 1 and
Object.Get (Message.Get (Mess)) = 1 then
return True;
else
return False;
end if;
when Ou =>
if Object.Get (To) = 1 or
Object.Get (Message.Get (This_Message)) = 1 then
return True;
else
return False;
end if;
when Eou =>
if Object.Get (To) = 1 xor
Object.Get (Message.Get (This_Message)) = 1 then
return True;
else
return False;
end if;
end case;
exception
when Constraint_Error =>
raise Bug_Report.Unknown_Binary_Message;
end;
else
raise Bug_Report.Boolean_Bad_Type;
end if;
end Send;
function Send (This_Message : Message.Keyword; To : Object.Reference)
return Object.Reference is
type E_Message is (Sivrai, Sifaux);
Token : E_Message;
Mess : Message.Keyword := This_Message;
Run : Message.Unary;
Result : Object.Reference;
package Bs renames Bounded_String;
Val : Object.Tiny_String;
use Object;
begin
Bs.Copy (Val, Bs.Value ("Valeur"));
Message.Init (Mess);
Message.Put (This_Name => Val, Into => Run);
Message.Init (This => Run);
while not Message.Is_Done (Mess) loop
if Object.Get (Class_From => Message.Get (Argument_From => Mess)) =
Object.Block_Class then
Token := E_Message'Value
(Bs.Image (V => Message.Get (Name_From => Mess)));
case Token is
when Sivrai =>
if Object.Get (Index_From => To) = 1 then
return Class_Block.Send
(Run, Message.Get
(Argument_From => Mess));
end if;
when Sifaux =>
if Object.Get (Index_From => To) = 0 then
return Class_Block.Send
(Run, Message.Get
(Argument_From => Mess));
end if;
end case;
else
raise Bug_Report.Boolean_Bad_Type;
end if;
Message.Next (Mess);
end loop;
return To;
exception
when Constraint_Error =>
raise Bug_Report.Unknown_Keyword_Message;
end Send;
function Create (Value : Object.Index := 0) return Object.Reference is
begin
return Object.Create (Class => Object.Boolean_Class, Object => Value);
end Create;
procedure Create is
Node : Block.Node := Block.Get_Current_Node;
begin
Block.Put_Into_Table (This_Object => Class_Boolean.True,
Named => Bounded_String.Value ("Vrai", 80),
Into_Block => Node);
Block.Put_Into_Table (This_Object => Class_Boolean.False,
Named => Bounded_String.Value ("Faux", 80),
Into_Block => Node);
end Create;
function True return Object.Reference is
begin
return Object.Create (Class => Object.Boolean_Class, Object => 1);
end True;
function False return Object.Reference is
begin
return Object.Create (Class => Object.Boolean_Class, Object => 0);
end False;
procedure Put (An_Object : Object.Reference) is
use Object;
begin
Class_Printer.Put ("Objet Booleen { Valeur => ");
if Object.Get (Index_From => An_Object) = 1 then
Class_Printer.Put ("Vrai }");
else
Class_Printer.Put ("Faux }");
end if;
Class_Printer.New_Line (2);
end Put;
end Class_Boolean;
nblk1=d
nid=a
hdr6=14
[0x00] rec0=25 rec1=00 rec2=01 rec3=018
[0x01] rec0=00 rec1=00 rec2=04 rec3=01c
[0x02] rec0=20 rec1=00 rec2=07 rec3=024
[0x03] rec0=04 rec1=00 rec2=02 rec3=09c
[0x04] rec0=18 rec1=00 rec2=03 rec3=01e
[0x05] rec0=22 rec1=00 rec2=06 rec3=032
[0x06] rec0=17 rec1=00 rec2=05 rec3=016
[0x07] rec0=10 rec1=00 rec2=0c rec3=016
[0x08] rec0=1c rec1=00 rec2=08 rec3=046
[0x09] rec0=04 rec1=00 rec2=09 rec3=000
[0x0a] rec0=04 rec1=00 rec2=09 rec3=000
[0x0b] rec0=15 rec1=00 rec2=06 rec3=000
[0x0c] rec0=24 rec1=00 rec2=0c rec3=54a
tail 0x21530765684e181dfcea1 0x42a00088462060003
Free Block Chain:
0xa: 0000 00 0b 00 14 80 03 75 65 2c 03 00 0b 20 20 20 20 ┆ ue, ┆
0xb: 0000 00 0d 00 ab 80 18 62 6a 65 63 74 2e 42 6f 6f 6c ┆ bject.Bool┆
0xd: 0000 00 00 00 04 80 01 5f 01 02 03 04 05 06 07 00 00 ┆ _ ┆