|
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: 10812 (0x2a3c)
Types: TextFile
Names: »B«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─⟦129cab021⟧ »DATA«
└─⟦this⟧
with Class_Boolean;
with Class_Integer;
with Class_Printer;
with Bounded_String;
with String_Utilities;
with Text_Io;
with Bug_Report;
package body Class_String is
function Send (This_Message : Message.Unary; To : Object.Reference)
return Object.Reference is
type E_Message is (Entexte, Valeur, Enmajuscules,
Enminuscules, Aveccapitales, Talongueur);
Token : E_Message;
package Bs renames Bounded_String;
package Su renames String_Utilities;
Success : Boolean;
Result : Integer;
begin
Token := E_Message'Value (Bs.Image (Message.Get (This_Message)));
case Token is
when Entexte =>
Put (To);
return To;
when Enmajuscules =>
Bs.Copy (Table (Object.Get (To)),
Bs.Value (Su.Upper_Case
(Bs.Image (Table (Object.Get (To))))));
return To;
when Enminuscules =>
Bs.Copy (Table (Object.Get (To)),
Bs.Value (Su.Lower_Case
(Bs.Image (Table (Object.Get (To))))));
return To;
when Aveccapitales =>
Bs.Copy (Table (Object.Get (To)),
Bs.Value (Su.Capitalize
(Bs.Image (Table (Object.Get (To))))));
return To;
when Talongueur =>
return Object.Create
(Class => Object.Integer_Class,
Object => Object.Index
(Bs.Length (Table (Object.Get (To)))));
when Valeur =>
if Su.Equal (Bs.Image (Table (Object.Get (To))),
"vrai", True) then
return Class_Boolean.True;
elsif Su.Equal (Bs.Image (Table (Object.Get (To))),
"faux", True) then
return Class_Boolean.False;
else
String_Utilities.String_To_Number
(Source => Bs.Image (Table (Object.Get (To))),
Worked => Success,
Target => Result);
if Success then
return Class_Integer.Create (Object.Index (Result));
else
return To;
end if;
end if;
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, Sup, Inf, Sup_Egal, Inf_Egal, Egal);
Token : E_Message;
package Bs renames Bounded_String;
package Su renames String_Utilities;
use Object;
begin
if Object.Get (Class_From =>
Message.Get (Argument_From => This_Message)) =
Object.String_Class then
declare
Chaine : Object.Tiny_String;
Result : Boolean;
begin
Token := E_Message'Value
(Bs.Image (Message.Get
(Name_From => This_Message)));
case Token is
when Plus =>
Bs.Copy (Chaine, Bs.Image
(Table (Object.Get
(Index_From => To))));
Bs.Append
(Chaine, Bs.Image
(Table (Object.Get
(Index_From =>
Message.Get
(Argument_From =>
This_Message)))));
return Class_String.Create (Chaine);
when Sup =>
if Bs.Image (Table (Object.Get (Index_From => To))) >
Bs.Image (Table (Object.Get
(Index_From =>
Message.Get
(Argument_From =>
This_Message)))) then
return Class_Boolean.True;
else
return Class_Boolean.False;
end if;
when Inf =>
if Su.Less_Than
(Bs.Image (Table (Object.Get (Index_From => To))),
Bs.Image
(Table (Object.Get
(Index_From =>
Message.Get
(Argument_From =>
This_Message))))) then
return Class_Boolean.True;
else
return Class_Boolean.False;
end if;
when Sup_Egal =>
if Su.Greater_Than
(Bs.Image (Table (Object.Get (Index_From => To))),
Bs.Image
(Table
(Object.Get
(Index_From =>
Message.Get
(Argument_From =>
This_Message))))) or else
Su.Equal
(Bs.Image (Table (Object.Get (Index_From => To))),
Bs.Image
(Table (Object.Get
(Index_From =>
Message.Get
(Argument_From =>
This_Message))))) then
return Class_Boolean.True;
else
return Class_Boolean.False;
end if;
when Inf_Egal =>
if Su.Less_Than
(Bs.Image (Table (Object.Get (Index_From => To))),
Bs.Image
(Table
(Object.Get
(Index_From =>
Message.Get
(Argument_From =>
This_Message))))) or else
Su.Equal
(Bs.Image (Table (Object.Get (Index_From => To))),
Bs.Image
(Table (Object.Get
(Index_From =>
Message.Get
(Argument_From =>
This_Message))))) then
return Class_Boolean.True;
else
return Class_Boolean.False;
end if;
when Egal =>
if Su.Equal
(Bs.Image (Table (Object.Get (Index_From => To))),
Bs.Image
(Table (Object.Get
(Index_From =>
Message.Get
(Argument_From =>
This_Message))))) then
return Class_Boolean.True;
else
return Class_Boolean.False;
end if;
end case;
exception
when Constraint_Error =>
raise Bug_Report.Unknown_Binary_Message;
end;
else
raise Bug_Report.String_Bad_Type;
end if;
end Send;
function Send (This_Message : Message.Keyword; To : Object.Reference)
return Object.Reference is
begin
raise Bug_Report.Unknown_Keyword_Message;
return Object.Void_Reference;
end Send;
function Create return Object.Reference is
use Object;
begin
Last := Last + 1;
return Object.Create (Class => Object.String_Class, Object => Last);
exception
when Constraint_Error =>
raise Bug_Report.Full_String_Table;
end Create;
function Create (Str : Object.Tiny_String) return Object.Reference is
use Object;
begin
Last := Last + 1;
Table (Last) := Str;
return Object.Create (Class => Object.String_Class, Object => Last);
exception
when Constraint_Error =>
raise Bug_Report.Full_String_Table;
end Create;
function Create (Str : String) return Object.Reference is
use Object;
begin
Last := Last + 1;
Bounded_String.Copy (Table (Last), Str);
return Object.Create (Class => Object.String_Class, Object => Last);
exception
when Constraint_Error =>
raise Bug_Report.Full_String_Table;
end Create;
function Get (Index : Object.Index) return Object.Tiny_String is
begin
return Table (Index);
end Get;
function How_Many return Object.Index is
begin
return Last;
end How_Many;
procedure Put (An_Object : Object.Reference) is
package Bs renames Bounded_String;
begin
Class_Printer.Put ("Objet Chaine {");
Class_Printer.New_Line;
Class_Printer.Forward (4);
Class_Printer.Put ("Contenu => " & '"' &
Bs.Image (Table (Object.Get (An_Object))) & '"');
Class_Printer.Backward (4);
Class_Printer.New_Line;
Class_Printer.Put ("}");
Class_Printer.New_Line (2);
end Put;
end Class_String;