|
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: 13039 (0x32ef)
Types: TextFile
Names: »B«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─ ⟦129cab021⟧ »DATA«
└─⟦this⟧
with Class_Block;
with Class_String;
with Class_Printer;
with Bounded_String;
with String_Utilities;
with Text_Io;
with Random;
with Bug_Report;
package body Class_Integer is
function Send (This_Message : Message.Unary; To : Object.Reference)
return Object.Reference is
type E_Message is (Moins, Entexte, Image, Attend, Auhasard);
Token : E_Message;
A_Handle : Random.Handle;
package Bs renames Bounded_String;
package Su renames String_Utilities;
use Object;
begin
Token := E_Message'Value (Bs.Image (Message.Get (This_Message)));
case Token is
when Entexte =>
Put (To);
return To;
when Image =>
return Class_String.Create
(Bs.Value
(Su.Number_To_String
(Value =>
Integer (Object.Get (Index_From => To))),
80));
when Moins =>
return Create (-Object.Index'(Object.Get (Index_From => To)));
when Attend =>
delay (Duration (Object.Index'(Object.Get (Index_From => To))));
return To;
when Auhasard =>
Random.Initialize (The_Handle => A_Handle);
return Create
(Object.Index
(Random.Natural_Value
(The_Handle => A_Handle,
Max => Natural
(Object.Get (Index_From => To)))));
end case;
exception
when Constraint_Error =>
raise Bug_Report.Unknown_Unary_Message;
end Send;
function Send (This_Message : Message.Binary; To : Object.Reference)
return Object.Reference is
type E_Message is (Plus, Moins, Mul, Div, Egal, Diff,
Sup, Sup_Egal, Inf, Inf_Egal);
Token : E_Message;
package Bs renames Bounded_String;
use Object;
begin
if Object.Get (Class_From =>
Message.Get (Argument_From => This_Message)) =
Object.Integer_Class then
begin
Token := E_Message'Value (Bs.Image
(Message.Get (This_Message)));
case Token is
when Plus =>
return Create (Object.Get (Index_From => To) +
Object.Get (Index_From =>
Message.Get
(Argument_From =>
This_Message)));
when Moins =>
return Create (Object.Get (Index_From => To) -
Object.Get (Index_From =>
Message.Get
(Argument_From =>
This_Message)));
when Mul =>
return Create (Object.Get (Index_From => To) *
Object.Get (Index_From =>
Message.Get
(Argument_From =>
This_Message)));
when Div =>
if Object.Get
(Index_From =>
Message.Get (Argument_From => This_Message)) =
0 then
raise Bug_Report.Divide_By_Zero;
end if;
return Create (Object.Get (Index_From => To) /
Object.Get (Index_From =>
Message.Get
(Argument_From =>
This_Message)));
when Egal =>
if Object.Index'(Object.Get (Index_From => To)) =
Object.Get (Index_From =>
Message.Get (Argument_From =>
This_Message)) then
return Object.Create (Object.Boolean_Class, 1);
else
return Object.Create (Object.Boolean_Class, 0);
end if;
when Diff =>
if Object.Index'(Object.Get (Index_From => To)) /=
Object.Get (Index_From =>
Message.Get (Argument_From =>
This_Message)) then
return Object.Create (Object.Boolean_Class, 1);
else
return Object.Create (Object.Boolean_Class, 0);
end if;
when Sup =>
if Object.Index'(Object.Get (Index_From => To)) >
Object.Get (Index_From =>
Message.Get (Argument_From =>
This_Message)) then
return Object.Create (Object.Boolean_Class, 1);
else
return Object.Create (Object.Boolean_Class, 0);
end if;
when Sup_Egal =>
if Object.Index'(Object.Get (Index_From => To)) >=
Object.Get (Index_From =>
Message.Get (Argument_From =>
This_Message)) then
return Object.Create (Object.Boolean_Class, 1);
else
return Object.Create (Object.Boolean_Class, 0);
end if;
when Inf =>
if Object.Index'(Object.Get (Index_From => To)) <
Object.Get (Index_From =>
Message.Get (Argument_From =>
This_Message)) then
return Object.Create (Object.Boolean_Class, 1);
else
return Object.Create (Object.Boolean_Class, 0);
end if;
when Inf_Egal =>
if Object.Index'(Object.Get (Index_From => To)) <=
Object.Get (Index_From =>
Message.Get (Argument_From =>
This_Message)) then
return Object.Create (Object.Boolean_Class, 1);
else
return Object.Create (Object.Boolean_Class, 0);
end if;
end case;
exception
when Constraint_Error =>
raise Bug_Report.Unknown_Binary_Message;
end;
else
raise Bug_Report.Integer_Bad_Type;
end if;
end Send;
function Send (This_Message : Message.Keyword; To : Object.Reference)
return Object.Reference is
type E_Message is (Fois, Repeter, Puissance);
Token : E_Message;
Mess : Message.Keyword := This_Message;
Unar : Message.Unary;
Kwd : Message.Keyword;
Val : Object.Tiny_String;
package Bs renames Bounded_String;
package Su renames String_Utilities;
begin
Bs.Copy (Val, Bs.Value ("Valeur"));
Message.Init (Mess);
declare
Result : Object.Reference;
Block : Object.Reference;
A, B : Object.Index;
use Object;
begin
Token := E_Message'Value (Bs.Image (Message.Get (Mess)));
case Token is
when Fois =>
if Object.Get (Class_From =>
Message.Get (Argument_From => Mess)) =
Object.Block_Class then
Message.Put (This_Name => Val, Into => Unar);
for I in 1 .. Object.Get (Index_From => To) loop
Result := Class_Block.Send
(Unar, Message.Get
(Argument_From => Mess));
end loop;
if Object.Get (Index_From => To) < 1 then
return To;
else
return Result;
end if;
else
raise Bug_Report.Integer_Bad_Type;
end if;
when Repeter =>
if Object.Get (Class_From =>
Message.Get (Argument_From => Mess)) =
Object.Block_Class then
Block := Message.Get (Argument_From => Mess);
Message.Next (Mess);
if Su.Equal (Bs.Image (Message.Get (Name_From => Mess)),
"a", True) then
A := Object.Get (Index_From => To);
B := Object.Get
(Index_From => Message.Get
(Argument_From => Mess));
if A < B then
for I in A .. B loop
Message.Free (This => Kwd);
Message.Put (This_Name => Val, Into => Kwd);
Message.Put (This_Argument =>
Create (Value => I),
Into => Kwd);
Result := Class_Block.Send (Kwd, Block);
end loop;
else
for I in reverse B .. A loop
Message.Free (This => Kwd);
Message.Put (This_Name => Val, Into => Kwd);
Message.Put (This_Argument =>
Create (Value => I),
Into => Kwd);
Result := Class_Block.Send (Kwd, Block);
end loop;
end if;
else
raise Bug_Report.Unknown_Keyword_Message;
end if;
return Result;
else
raise Bug_Report.Integer_Bad_Type;
end if;
when Puissance =>
if Object.Get (Class_From =>
Message.Get (Argument_From => Mess)) =
Object.Integer_Class then
return Create (Object.Index
(Integer (Object.Get
(Index_From => To)) **
Integer (Object.Get
(Index_From =>
Message.Get
(Argument_From =>
Mess)))));
else
raise Bug_Report.Integer_Bad_Type;
end if;
end case;
exception
when Constraint_Error =>
raise Bug_Report.Unknown_Keyword_Message;
end;
end Send;
function Create (Value : Object.Index := 0) return Object.Reference is
begin
return Object.Create (Object.Integer_Class, Value);
end Create;
procedure Put (An_Object : Object.Reference) is
begin
Class_Printer.Put ("Objet Entier { Valeur =>" &
Object.Index'Image (Object.Get (An_Object)) & " }");
Class_Printer.New_Line (2);
end Put;
end Class_Integer;