|
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: 12629 (0x3155)
Types: TextFile
Names: »B«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─ ⟦129cab021⟧ »DATA«
└─⟦this⟧
with Object, Argument, Message, Bounded_String, Random,
Block_Class, Boolean_Class, String_Class, Counter, Bug;
package body Integer_Class is
package Bs renames Bounded_String;
type Integer_Keyword_Message is (Fois, Repeter, A);
type Integer_Unary_Message is
(Entexte, Image, Aucube, Moins, Aleatoire, Attend);
function Create (Value : Integer) return Object.Reference is
Obj : Object.Reference;
begin
Obj := Object.Create (Object.Integer_Class, Value);
return (Obj);
end Create;
function Fois (Indice, Blk : Object.Reference) return Object.Reference is
Obj : Object.Reference;
The_Message_Valeur : Message.Tiny_String;
use Object;
begin
if (Object.Get_Class (Blk) /= Object.Block_Class) then
raise Bug.Mismatch_Type;
end if;
Bs.Copy (The_Message_Valeur, Block_Class.Message_Valeur);
for I in 1 .. Object.Get_Value (Indice) loop
Obj := Block_Class.Send (Blk, The_Message_Valeur);
end loop;
return (Obj);
end Fois;
function Repeter (Min, Max, Blk : Object.Reference)
return Object.Reference is
Obj : Object.Reference;
Arg : Argument.List;
Mess : Message.List;
The_Value_Message : Message.Tiny_String;
use Object;
begin
if (Object.Get_Class (Blk) /= Object.Block_Class) or
(Object.Get_Class (Min) /= Object.Integer_Class) or
(Object.Get_Class (Max) /= Object.Integer_Class) then
raise Bug.Mismatch_Type;
end if;
Bs.Copy (The_Value_Message, Block_Class.Message_Valeur);
if (Object.Get_Value (Min) > Object.Get_Value (Max)) then
for I in reverse Object.Get_Value (Max) ..
Object.Get_Value (Min) loop
Message.Init (Mess);
Mess := Message.Put (Mess, The_Value_Message);
Obj := Create (I);
Argument.Init (Arg);
Arg := Argument.Put (Arg, Obj);
Obj := Block_Class.Send (Blk, Mess, Arg);
end loop;
else
for I in Object.Get_Value (Min) .. Object.Get_Value (Max) loop
Message.Init (Mess);
Mess := Message.Put (Mess, The_Value_Message);
Obj := Create (I);
Argument.Init (Arg);
Arg := Argument.Put (Arg, Obj);
Obj := Block_Class.Send (Blk, Mess, Arg);
end loop;
end if;
return (Obj);
end Repeter;
function "+" (A, B : Object.Reference) return Object.Reference is
Obj : Object.Reference;
use Object;
begin
if (Object.Get_Class (A) /= Object.Integer_Class) or
(Object.Get_Class (B) /= Object.Integer_Class) then
raise Bug.Mismatch_Type;
end if;
Obj := Create (Object.Get_Value (A) + Object.Get_Value (B));
return (Obj);
end "+";
function "-" (A, B : Object.Reference) return Object.Reference is
Obj : Object.Reference;
use Object;
begin
if (Object.Get_Class (A) /= Object.Integer_Class) or
(Object.Get_Class (B) /= Object.Integer_Class) then
raise Bug.Mismatch_Type;
end if;
Obj := Create (Object.Get_Value (A) - Object.Get_Value (B));
return (Obj);
end "-";
function "*" (A, B : Object.Reference) return Object.Reference is
Obj : Object.Reference;
use Object;
begin
if (Object.Get_Class (A) /= Object.Integer_Class) or
(Object.Get_Class (B) /= Object.Integer_Class) then
raise Bug.Mismatch_Type;
end if;
Obj := Create (Object.Get_Value (A) * Object.Get_Value (B));
return (Obj);
end "*";
function "/" (A, B : Object.Reference) return Object.Reference is
Obj : Object.Reference;
use Object;
begin
if (Object.Get_Class (A) /= Object.Integer_Class) or
(Object.Get_Class (B) /= Object.Integer_Class) then
raise Bug.Mismatch_Type;
end if;
Obj := Create (Object.Get_Value (A) / Object.Get_Value (B));
return (Obj);
end "/";
function Randomize (A : Object.Reference) return Object.Reference is
Obj : Object.Reference;
A_Handle : Random.Handle;
Value : Integer;
begin
Random.Initialize (A_Handle);
Value := Object.Get_Value (A);
if (Value > 0) then
Obj := Create (Random.Natural_Value (A_Handle, Natural (Value)));
else
Obj := Create (Random.Natural_Value
(A_Handle, Natural (-1 * Value)));
end if;
return (Obj);
end Randomize;
function Wait (A : Object.Reference) return Object.Reference is
begin
if Object.Get_Value (A) > 0 then
delay (Duration (Object.Get_Value (A)));
end if;
return (A);
end Wait;
function Au_Cube (A : Object.Reference) return Object.Reference is
Obj : Object.Reference;
Value : Integer;
begin
Value := Object.Get_Value (A);
Obj := Create (Value * Value * Value);
return (Obj);
end Au_Cube;
function Greater_Than (A, B : Object.Reference) return Object.Reference is
Obj : Object.Reference;
use Object;
begin
if (Object.Get_Class (A) /= Object.Integer_Class) or
(Object.Get_Class (B) /= Object.Integer_Class) then
raise Bug.Mismatch_Type;
end if;
if Object.Get_Value (A) > Object.Get_Value (B) then
Obj := Boolean_Class.True;
else
Obj := Boolean_Class.False;
end if;
return (Obj);
end Greater_Than;
function Lower_Than (A, B : Object.Reference) return Object.Reference is
Obj : Object.Reference;
use Object;
begin
if (Object.Get_Class (A) /= Object.Integer_Class) or
(Object.Get_Class (B) /= Object.Integer_Class) then
raise Bug.Mismatch_Type;
end if;
if Object.Get_Value (A) < Object.Get_Value (B) then
Obj := Boolean_Class.True;
else
Obj := Boolean_Class.False;
end if;
return (Obj);
end Lower_Than;
function Greater_Or_Equal (A, B : Object.Reference)
return Object.Reference is
Obj : Object.Reference;
use Object;
begin
if (Object.Get_Class (A) /= Object.Integer_Class) or
(Object.Get_Class (B) /= Object.Integer_Class) then
raise Bug.Mismatch_Type;
end if;
if Object.Get_Value (A) >= Object.Get_Value (B) then
Obj := Boolean_Class.True;
else
Obj := Boolean_Class.False;
end if;
return (Obj);
end Greater_Or_Equal;
function Lower_Or_Equal (A, B : Object.Reference) return Object.Reference is
Obj : Object.Reference;
use Object;
begin
if (Object.Get_Class (A) /= Object.Integer_Class) or
(Object.Get_Class (B) /= Object.Integer_Class) then
raise Bug.Mismatch_Type;
end if;
if Object.Get_Value (A) <= Object.Get_Value (B) then
Obj := Boolean_Class.True;
else
Obj := Boolean_Class.False;
end if;
return (Obj);
end Lower_Or_Equal;
function Equal (A, B : Object.Reference) return Object.Reference is
Obj : Object.Reference;
use Object;
begin
if (Object.Get_Class (A) /= Object.Integer_Class) or
(Object.Get_Class (B) /= Object.Integer_Class) then
raise Bug.Mismatch_Type;
end if;
if Object.Get_Value (A) = Object.Get_Value (B) then
Obj := Boolean_Class.True;
else
Obj := Boolean_Class.False;
end if;
return (Obj);
end Equal;
function Minus (I : Object.Reference) return Object.Reference is
begin
return Create (-Object.Get_Value (I));
end Minus;
function Image (I : Object.Reference) return Object.Reference is
Valeur : Message.Tiny_String;
Result : Object.Reference;
begin
Bs.Copy (Valeur, Bs.Value (Integer'Image (Object.Get_Value (I))));
Result := String_Class.Create (Valeur);
return (Result);
end Image;
procedure In_Text (I : Object.Reference) is
begin
Object.In_Text (I);
end In_Text;
function Send (To_Object : Object.Reference;
The_Message : Message.Selector;
With_Arguments : Argument.List) return Object.Reference is
Obj, Arg1 : Object.Reference;
Args : Argument.List;
begin
Args := With_Arguments;
Arg1 := Argument.Get (Args);
Counter.Increase (Object.Integer_Class);
case The_Message is
when Message.Plus =>
Obj := To_Object + Arg1;
when Message.Moins =>
Obj := To_Object - Arg1;
when Message.Multiplier =>
Obj := To_Object * Arg1;
when Message.Diviser =>
Obj := To_Object / Arg1;
when Message.Inferieur =>
Obj := Lower_Than (To_Object, Arg1);
when Message.Superieur =>
Obj := Greater_Than (To_Object, Arg1);
when Message.Inferieur_Egal =>
Obj := Lower_Or_Equal (To_Object, Arg1);
when Message.Superieur_Egal =>
Obj := Greater_Or_Equal (To_Object, Arg1);
when Message.Egal =>
Obj := Equal (To_Object, Arg1);
when others =>
raise Bug.Unknown_Integer_Message;
end case;
Counter.Stop_Time (Object.Integer_Class);
return (Obj);
end Send;
function Send (To_Object : Object.Reference;
The_Messages : Message.List;
With_Arguments : Argument.List) return Object.Reference is
Result, Arg1, Arg2 : Object.Reference := Object.Void_Reference;
Args : Argument.List;
Mess : Message.List;
A_Message : Message.Tiny_String;
Talk : Integer_Keyword_Message;
begin
Args := With_Arguments;
Mess := The_Messages;
A_Message := Message.Get (Mess);
Talk := Integer_Keyword_Message'Value (Bs.Image (V => A_Message));
Counter.Increase (Object.Integer_Class);
case Talk is
when Fois =>
if Message.How_Many (Mess) > 1 then
raise Bug.Too_Many_Keywords;
end if;
Arg1 := Argument.Get (With_Arguments);
Result := Fois (To_Object, Arg1);
when Repeter =>
Message.Next (Mess, A_Message);
if Integer_Keyword_Message'Value (Bs.Image (V => A_Message)) /=
A then
raise Bug.Unknown_Integer_Message;
end if;
Arg1 := Argument.Get (With_Arguments);
Argument.Next (L => Args, Obj => Arg2);
Result := Repeter (To_Object, Arg2, Arg1);
when others =>
raise Bug.Unknown_Integer_Message;
end case;
Counter.Stop_Time (Object.Integer_Class);
return (Result);
exception
when Constraint_Error =>
raise Bug.Unknown_Integer_Message;
end Send;
function Send (To_Object : Object.Reference;
The_Message : Message.Tiny_String) return Object.Reference is
Result : Object.Reference := Object.Void_Reference;
Talk : Integer_Unary_Message;
begin
Talk := Integer_Unary_Message'Value (Bs.Image (V => The_Message));
Counter.Increase (Object.Integer_Class);
case Talk is
when Entexte =>
In_Text (To_Object);
Result := To_Object;
when Image =>
Result := Image (To_Object);
when Aucube =>
Result := Au_Cube (To_Object);
when Moins =>
Result := Minus (To_Object);
when Aleatoire =>
Result := Randomize (To_Object);
when Attend =>
Result := Wait (To_Object);
end case;
Counter.Stop_Time (Object.Integer_Class);
return (Result);
exception
when Constraint_Error =>
raise Bug.Unknown_Integer_Message;
end Send;
end Integer_Class;