|
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 - metrics - downloadIndex: B T
Length: 10221 (0x27ed)
Types: TextFile
Names: »B«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─⟦129cab021⟧ »DATA«
└─⟦this⟧
with Counter;
with Boolean_Class;
with Integer_Class;
with String_Utilities;
with Bounded_String;
with Message;
with Text_Io;
with Bug;
package body String_Class is
type String_Unary_Message is (Enmajuscule, Enminuscule,
Talongueur, Entexte, Valeur);
Max_Table_String : constant := 1000;
subtype Table_Index is Positive range 1 .. Max_Table_String;
String_Table : array (Table_Index) of Message.Tiny_String;
Empty_String : Message.Tiny_String;
package Su renames String_Utilities;
package Bs renames Bounded_String;
function The_Table_Index (From_Object : Object.Reference) return Positive is
The_Index : Integer;
use Object;
begin
if not (Object.Get_Class (From_Object) = Object.String_Class) then
Object.In_Text (From_Object);
raise Bug.Search_No_String_Object;
end if;
The_Index := Object.Get_Value (From_Object);
if (The_Index > Max_Table_String) or (The_Index < 1) then
raise Bug.Id_String_Overflow;
else
return The_Index;
end if;
end The_Table_Index;
function Get_String (From_Object : Object.Reference)
return Message.Tiny_String is
begin
return String_Table (The_Table_Index (From_Object));
end Get_String;
procedure In_Text (The_String : Object.Reference) is
begin
Object.In_Text (The_String);
Text_Io.Put_Line ("Contenu:" &
Bs.Image (String_Table
(The_Table_Index (The_String))));
end In_Text;
function Create (Name : Message.Tiny_String) return Object.Reference is
Index : Positive := 1;
New_Object : Object.Reference := Object.Void_Reference;
Found : Boolean := False;
begin
while not Found and (Index <= Max_Table_String) loop
if (Bs.Length (String_Table (Index)) =
Bs.Length (Empty_String)) then
Found := True;
else
Index := Index + 1;
end if;
end loop;
if Found then
String_Table (Index) := Name;
New_Object := Object.Create (Object.String_Class, Index);
else
raise Bug.Too_Many_Strings;
end if;
return New_Object;
end Create;
procedure Reset is
begin
for I in 1 .. Max_Table_String loop
String_Table (I) := Empty_String;
end loop;
end Reset;
procedure Remove (The_Object : Object.Reference) is
begin
Bs.Free (String_Table (The_Table_Index (The_Object)));
end Remove;
function "&" (Left, Right : Object.Reference) return Object.Reference is
New_String : Message.Tiny_String;
use Object;
begin
if (Object.Get_Class (Left) /= Object.String_Class) or
(Object.Get_Class (Right) /= Object.String_Class) then
raise Bug.Mismatch_Type;
end if;
if (Bs.Length (Get_String (Left)) + Bs.Length (Get_String (Right)) >
Bs.Max_Length (New_String)) then
raise Bug.String_Large_Overflow;
else
Bs.Append (New_String, Get_String (Left));
Bs.Append (New_String, Get_String (Right));
end if;
return Create (New_String);
end "&";
function Equal (Left, Right : Object.Reference) return Object.Reference is
Result : Boolean;
use Object;
begin
if (Object.Get_Class (Left) /= Object.String_Class) or
(Object.Get_Class (Right) /= Object.String_Class) then
raise Bug.Mismatch_Type;
end if;
Result := Su.Equal (Bs.Image (Get_String (Left)),
Bs.Image (Get_String (Right)), False);
return Boolean_Class.Create (Result);
end Equal;
function "<" (Left, Right : Object.Reference) return Object.Reference is
Result : Boolean;
use Object;
begin
if (Object.Get_Class (Left) /= Object.String_Class) or
(Object.Get_Class (Right) /= Object.String_Class) then
raise Bug.Mismatch_Type;
end if;
Result := Su.Less_Than (Bs.Image (Get_String (Left)),
Bs.Image (Get_String (Right)), False);
return Boolean_Class.Create (Result);
end "<";
function ">" (Left, Right : Object.Reference) return Object.Reference is
Result : Boolean;
use Object;
begin
if (Object.Get_Class (Left) /= Object.String_Class) or
(Object.Get_Class (Right) /= Object.String_Class) then
raise Bug.Mismatch_Type;
end if;
Result := Su.Greater_Than (Bs.Image (Get_String (Left)),
Bs.Image (Get_String (Right)), False);
return Boolean_Class.Create (Result);
end ">";
function ">=" (Left, Right : Object.Reference) return Object.Reference is
Result : Boolean;
use Object;
begin
if (Object.Get_Class (Left) /= Object.String_Class) or
(Object.Get_Class (Right) /= Object.String_Class) then
raise Bug.Mismatch_Type;
end if;
Result := Su.Greater_Than (Bs.Image (Get_String (Left)),
Bs.Image (Get_String (Right)), False) or
Su.Equal (Bs.Image (Get_String (Left)),
Bs.Image (Get_String (Right)), False);
return Boolean_Class.Create (Result);
end ">=";
function "<=" (Left, Right : Object.Reference) return Object.Reference is
Result : Boolean;
use Object;
begin
if (Object.Get_Class (Left) /= Object.String_Class) or
(Object.Get_Class (Right) /= Object.String_Class) then
raise Bug.Mismatch_Type;
end if;
Result := Su.Less_Than (Bs.Image (Get_String (Left)),
Bs.Image (Get_String (Right)), False) or
Su.Equal (Bs.Image (Get_String (Left)),
Bs.Image (Get_String (Right)), False);
return Boolean_Class.Create (Result);
end "<=";
function To_Upper (The_Object : Object.Reference) return Object.Reference is
The_String : Message.Tiny_String;
Index : Positive := Object.Get_Value (The_Object);
begin
Bs.Free (The_String);
Bs.Copy (The_String,
Bs.Value ((Su.Upper_Case
(Bs.Image (Get_String (The_Object))))));
String_Table (Index) := The_String;
return The_Object;
end To_Upper;
function To_Lower (The_Object : Object.Reference) return Object.Reference is
The_String : Message.Tiny_String;
Index : Positive := Object.Get_Value (The_Object);
begin
Bs.Free (The_String);
Bs.Copy (The_String, Bs.Value
(Su.Lower_Case (Bs.Image
(Get_String (The_Object)))));
String_Table (Index) := The_String;
return The_Object;
end To_Lower;
function Long (The_Object : Object.Reference) return Object.Reference is
The_String : Message.Tiny_String;
begin
The_String := Get_String (The_Object);
return Integer_Class.Create (Bs.Length (The_String));
end Long;
function Value (The_String : Object.Reference) return Object.Reference is
I : Integer;
Success : Boolean := False;
begin
Su.String_To_Number
(Bs.Image (String_Table (The_Table_Index (The_String))), I, Success);
if not Success then
I := 0;
end if;
return Integer_Class.Create (I);
end Value;
function Send (To_Object : Object.Reference;
The_Message : Message.Selector;
With_Arguments : Argument.List) return Object.Reference is
The_Object, Arg1 : Object.Reference := Object.Void_Reference;
Args : Argument.List;
begin
Args := With_Arguments;
Counter.Increase (Object.String_Class);
case The_Message is
when Message.Et =>
Arg1 := Argument.Get (Args);
The_Object := To_Object & Arg1;
when Message.Inferieur =>
Arg1 := Argument.Get (Args);
The_Object := To_Object < Arg1;
when Message.Superieur =>
Arg1 := Argument.Get (Args);
The_Object := To_Object > Arg1;
when Message.Inferieur_Egal =>
Arg1 := Argument.Get (Args);
The_Object := To_Object <= Arg1;
when Message.Superieur_Egal =>
Arg1 := Argument.Get (Args);
The_Object := To_Object >= Arg1;
when Message.Egal =>
Arg1 := Argument.Get (Args);
The_Object := Equal (To_Object, Arg1);
when others =>
raise Bug.Unknown_String_Message;
end case;
Counter.Stop_Time (Object.String_Class);
return The_Object;
end Send;
function Send (To_Object : Object.Reference;
The_Message : Message.Tiny_String) return Object.Reference is
The_Object : Object.Reference := Object.Void_Reference;
Talk : String_Unary_Message;
begin
Talk := String_Unary_Message'Value (Bounded_String.Image (The_Message));
Counter.Increase (Object.String_Class);
case Talk is
when Enmajuscule =>
The_Object := To_Upper (To_Object);
when Enminuscule =>
The_Object := To_Lower (To_Object);
when Talongueur =>
The_Object := Long (To_Object);
when Entexte =>
In_Text (To_Object);
The_Object := To_Object;
when Valeur =>
The_Object := Value (To_Object);
end case;
Counter.Stop_Time (Object.String_Class);
return The_Object;
exception
when Constraint_Error =>
raise Bug.Unknown_String_Message;
end Send;
end String_Class;