|
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 - download
Length: 15360 (0x3c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Class_String, seg_038198
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦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;
nblk1=e
nid=e
hdr6=1a
[0x00] rec0=21 rec1=00 rec2=01 rec3=05e
[0x01] rec0=15 rec1=00 rec2=0b rec3=05a
[0x02] rec0=19 rec1=00 rec2=07 rec3=026
[0x03] rec0=1b rec1=00 rec2=06 rec3=01c
[0x04] rec0=00 rec1=00 rec2=0c rec3=032
[0x05] rec0=11 rec1=00 rec2=0a rec3=03a
[0x06] rec0=13 rec1=00 rec2=08 rec3=006
[0x07] rec0=12 rec1=00 rec2=09 rec3=064
[0x08] rec0=11 rec1=00 rec2=03 rec3=032
[0x09] rec0=16 rec1=00 rec2=0d rec3=020
[0x0a] rec0=25 rec1=00 rec2=05 rec3=000
[0x0b] rec0=21 rec1=00 rec2=04 rec3=03c
[0x0c] rec0=07 rec1=00 rec2=02 rec3=000
[0x0d] rec0=80 rec1=00 rec2=00 rec3=002
tail 0x21735bab684e67cd05f8c 0x42a00088462060003
Free Block Chain:
0xe: 0000 00 00 00 06 80 03 61 67 65 03 02 02 02 02 02 02 ┆ age ┆