|
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: 25600 (0x6400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Vstrings, seg_030ab6
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
-- DISCUSSION:
--
--\x09This package implements the type "variable-length string" (vstring)
--\x09using generics. The alternative approaches are to use a discriminant
--\x09record in which the discriminant controls the length of a STRING inside
--\x09the record, or a record containing an access type which points to a
-- string, which can be deallocated and reallocated when necessary.
--
--\x09Advantages of this package:
--\x09 * The other approaches force the vstring to be a limited private
-- type. Thus, their vstrings cannot appear on the left side of
-- the assignment operator; ie., their vstrings cannot be given
-- initial values or values by direct assignment. This package
-- uses a private type; therefore, these things can be done.
--
--\x09 * The other approach stores the vstring in a string whose length
--\x09 is determined dynamically. This package uses a fixed length
-- string. This difference might be reflected in faster and more
-- consistent execution times (this has NOT been verified).
--
--\x09Disadvantages of this package:
--\x09 * Different instantiations must be used to declare vstrings with
--\x09 different maximum lengths (this may be desirable, since
--\x09 CONSTRAINT_ERROR will be raised if the maximum is exceeded).
--
--\x09 * A second declaration is required to give the type declared by
--\x09 the instantiation a name other than "VSTRING."
--
--\x09 * The storage required for a vstring is determined by the generic
--\x09 parameter LAST and not the actual length of its contents. Thus,
-- each object is allocated the maximum amount of storage, regardless
-- of its actual size.
--
-- MISCELLANEOUS:
-- Constraint checking is done explicitly in the code; thus, it cannot
-- be suppressed. On the other hand, constraint checking is not lost
-- if pragma suppress is supplied to the compilation (-S option)
-- (The robustness of the explicit constraint checking has NOT been
-- determined).
--
-- Compiling with the optimizer (-O option) may significantly reduce
-- the size (and possibly execution time) of the resulting executable.
--
-- Compiling an instantiation of VSTRINGS is roughly equivelent to
-- recompiling VSTRINGS. Since this takes a significant amount of time,
-- and the instantiation does not depend on any other library units,
-- it is STRONGLY recommended that the instantiation be compiled
-- separately, and thus done only ONCE.
--
-- USAGE: with VSTRINGS;
-- package package_name is new VSTRINGS(maximum_length);
-- .......................................................................... --
pragma Page;
package body Vstrings is
-- local declarations
Fill_Char : constant Character := Ascii.Nul;
procedure Format (The_String : in out Vstring;
Oldlen : in Strindex := Last) is
-- fill the string with FILL_CHAR to null out old values
begin -- FORMAT (Local Procedure)
The_String.Value (The_String.Len + 1 .. Oldlen) :=
(others => Fill_Char);
end Format;
-- bodies of visible operations
function Len (From : Vstring) return Strindex is
begin -- LEN
return (From.Len);
end Len;
function Max (From : Vstring) return Strindex is
begin -- MAX
return (Last);
end Max;
function Str (From : Vstring) return String is
begin -- STR
return (From.Value (First .. From.Len));
end Str;
function Char (From : Vstring; Position : Strindex := First)
return Character is
begin -- CHAR
if Position not in First .. From.Len then
raise Constraint_Error;
end if;
return (From.Value (Position));
end Char;
function "<" (Left : Vstring; Right : Vstring) return Boolean is
begin -- "<"
return (Left.Value < Right.Value);
end "<";
function ">" (Left : Vstring; Right : Vstring) return Boolean is
begin -- ">"
return (Left.Value > Right.Value);
end ">";
function "<=" (Left : Vstring; Right : Vstring) return Boolean is
begin -- "<="
return (Left.Value <= Right.Value);
end "<=";
function ">=" (Left : Vstring; Right : Vstring) return Boolean is
begin -- ">="
return (Left.Value >= Right.Value);
end ">=";
procedure Put (File : in File_Type; Item : in Vstring) is
begin -- PUT
Put (File, Item.Value (First .. Item.Len));
end Put;
procedure Put (Item : in Vstring) is
begin -- PUT
Put (Item.Value (First .. Item.Len));
end Put;
procedure Put_Line (File : in File_Type; Item : in Vstring) is
begin -- PUT_LINE
Put_Line (File, Item.Value (First .. Item.Len));
end Put_Line;
procedure Put_Line (Item : in Vstring) is
begin -- PUT_LINE
Put_Line (Item.Value (First .. Item.Len));
end Put_Line;
procedure Get (File : in File_Type;
Item : out Vstring;
Length : in Strindex := Last) is
begin -- GET
if Length not in First .. Last then
raise Constraint_Error;
end if;
Item := Nul;
for Index in First .. Length loop
Get (File, Item.Value (Index));
Item.Len := Index;
end loop;
end Get;
procedure Get (Item : out Vstring; Length : in Strindex := Last) is
begin -- GET
if Length not in First .. Last then
raise Constraint_Error;
end if;
Item := Nul;
for Index in First .. Length loop
Get (Item.Value (Index));
Item.Len := Index;
end loop;
end Get;
procedure Get_Line (File : in File_Type; Item : in out Vstring) is
Oldlen : constant Strindex := Item.Len;
begin -- GET_LINE
Get_Line (File, Item.Value, Item.Len);
Format (Item, Oldlen);
end Get_Line;
procedure Get_Line (Item : in out Vstring) is
Oldlen : constant Strindex := Item.Len;
begin -- GET_LINE
Get_Line (Item.Value, Item.Len);
Format (Item, Oldlen);
end Get_Line;
function Slice (From : Vstring; Front, Back : Strindex) return Vstring is
begin -- SLICE
if ((Front not in First .. From.Len) or else
(Back not in First .. From.Len)) and then Front <= Back then
raise Constraint_Error;
end if;
return (Vstr (From.Value (Front .. Back)));
end Slice;
function Substr (From : Vstring; Start, Length : Strindex) return Vstring is
begin -- SUBSTR
if (Start not in First .. From.Len) or else
((Start + Length - 1 not in First .. From.Len) and then
(Length > 0)) then
raise Constraint_Error;
end if;
return (Vstr (From.Value (Start .. Start + Length - 1)));
end Substr;
function Delete (From : Vstring; Front, Back : Strindex) return Vstring is
Temp : Vstring := From;
begin -- DELETE
if ((Front not in First .. From.Len) or else
(Back not in First .. From.Len)) and then Front <= Back then
raise Constraint_Error;
end if;
if Front > Back then
return (From);
end if;
Temp.Len := From.Len - (Back - Front) - 1;
Temp.Value (Front .. Temp.Len) := From.Value (Back + 1 .. From.Len);
Format (Temp, From.Len);
return (Temp);
end Delete;
function Insert
(Target : Vstring; Item : Vstring; Position : Strindex := First)
return Vstring is
Temp : Vstring;
begin -- INSERT
if Position not in First .. Target.Len then
raise Constraint_Error;
end if;
if Target.Len + Item.Len > Last then
raise Constraint_Error;
else
Temp.Len := Target.Len + Item.Len;
end if;
Temp.Value (First .. Position - 1) :=
Target.Value (First .. Position - 1);
Temp.Value (Position .. (Position + Item.Len - 1)) :=
Item.Value (First .. Item.Len);
Temp.Value ((Position + Item.Len) .. Temp.Len) :=
Target.Value (Position .. Target.Len);
return (Temp);
end Insert;
function Insert
(Target : Vstring; Item : String; Position : Strindex := First)
return Vstring is
begin -- INSERT
return Insert (Target, Vstr (Item), Position);
end Insert;
function Insert (Target : Vstring;
Item : Character;
Position : Strindex := First) return Vstring is
begin -- INSERT
return Insert (Target, Vstr (Item), Position);
end Insert;
function Append (Target : Vstring; Item : Vstring; Position : Strindex)
return Vstring is
Temp : Vstring;
Pos : Strindex := Position;
begin -- APPEND
if Position not in First .. Target.Len then
raise Constraint_Error;
end if;
if Target.Len + Item.Len > Last then
raise Constraint_Error;
else
Temp.Len := Target.Len + Item.Len;
end if;
Temp.Value (First .. Pos) := Target.Value (First .. Pos);
Temp.Value (Pos + 1 .. (Pos + Item.Len)) :=
Item.Value (First .. Item.Len);
Temp.Value ((Pos + Item.Len + 1) .. Temp.Len) :=
Target.Value (Pos + 1 .. Target.Len);
return (Temp);
end Append;
function Append (Target : Vstring; Item : String; Position : Strindex)
return Vstring is
begin -- APPEND
return Append (Target, Vstr (Item), Position);
end Append;
function Append (Target : Vstring; Item : Character; Position : Strindex)
return Vstring is
begin -- APPEND
return Append (Target, Vstr (Item), Position);
end Append;
function Append (Target : Vstring; Item : Vstring) return Vstring is
begin -- APPEND
return (Append (Target, Item, Target.Len));
end Append;
function Append (Target : Vstring; Item : String) return Vstring is
begin -- APPEND
return (Append (Target, Vstr (Item), Target.Len));
end Append;
function Append (Target : Vstring; Item : Character) return Vstring is
begin -- APPEND
return (Append (Target, Vstr (Item), Target.Len));
end Append;
function Replace
(Target : Vstring; Item : Vstring; Position : Strindex := First)
return Vstring is
Temp : Vstring;
begin -- REPLACE
if Position not in First .. Target.Len then
raise Constraint_Error;
end if;
if Position + Item.Len - 1 <= Target.Len then
Temp.Len := Target.Len;
elsif Position + Item.Len - 1 > Last then
raise Constraint_Error;
else
Temp.Len := Position + Item.Len - 1;
end if;
Temp.Value (First .. Position - 1) :=
Target.Value (First .. Position - 1);
Temp.Value (Position .. (Position + Item.Len - 1)) :=
Item.Value (First .. Item.Len);
Temp.Value ((Position + Item.Len) .. Temp.Len) :=
Target.Value ((Position + Item.Len) .. Target.Len);
return (Temp);
end Replace;
function Replace
(Target : Vstring; Item : String; Position : Strindex := First)
return Vstring is
begin -- REPLACE
return Replace (Target, Vstr (Item), Position);
end Replace;
function Replace (Target : Vstring;
Item : Character;
Position : Strindex := First) return Vstring is
begin -- REPLACE
return Replace (Target, Vstr (Item), Position);
end Replace;
function "&" (Left : Vstring; Right : Vstring) return Vstring is
Temp : Vstring;
begin -- "&"
if Left.Len + Right.Len > Last then
raise Constraint_Error;
else
Temp.Len := Left.Len + Right.Len;
end if;
Temp.Value (First .. Temp.Len) :=
Left.Value (First .. Left.Len) & Right.Value (First .. Right.Len);
return (Temp);
end "&";
function "&" (Left : Vstring; Right : String) return Vstring is
begin -- "&"
return Left & Vstr (Right);
end "&";
function "&" (Left : Vstring; Right : Character) return Vstring is
begin -- "&"
return Left & Vstr (Right);
end "&";
function "&" (Left : String; Right : Vstring) return Vstring is
begin -- "&"
return Vstr (Left) & Right;
end "&";
function "&" (Left : Character; Right : Vstring) return Vstring is
begin -- "&"
return Vstr (Left) & Right;
end "&";
function Index (Whole : Vstring; Part : Vstring; Occurrence : Natural := 1)
return Strindex is
Not_Found : constant Natural := 0;
Index : Natural := First;
Count : Natural := 0;
begin -- INDEX
if Part = Nul then
return (Not_Found); -- by definition
end if;
while Index + Part.Len - 1 <= Whole.Len and then Count < Occurrence loop
if Whole.Value (Index .. Part.Len + Index - 1) =
Part.Value (1 .. Part.Len) then
Count := Count + 1;
end if;
Index := Index + 1;
end loop;
if Count = Occurrence then
return (Index - 1);
else
return (Not_Found);
end if;
end Index;
function Index (Whole : Vstring; Part : String; Occurrence : Natural := 1)
return Strindex is
begin -- Index
return (Index (Whole, Vstr (Part), Occurrence));
end Index;
function Index (Whole : Vstring;
Part : Character;
Occurrence : Natural := 1) return Strindex is
begin -- Index
return (Index (Whole, Vstr (Part), Occurrence));
end Index;
function Rindex (Whole : Vstring; Part : Vstring; Occurrence : Natural := 1)
return Strindex is
Not_Found : constant Natural := 0;
Index : Integer := Whole.Len - (Part.Len - 1);
Count : Natural := 0;
begin -- RINDEX
if Part = Nul then
return (Not_Found); -- by definition
end if;
while Index >= First and then Count < Occurrence loop
if Whole.Value (Index .. Part.Len + Index - 1) =
Part.Value (1 .. Part.Len) then
Count := Count + 1;
end if;
Index := Index - 1;
end loop;
if Count = Occurrence then
if Count > 0 then
return (Index + 1);
else
return (Not_Found);
end if;
else
return (Not_Found);
end if;
end Rindex;
function Rindex (Whole : Vstring; Part : String; Occurrence : Natural := 1)
return Strindex is
begin -- Rindex
return (Rindex (Whole, Vstr (Part), Occurrence));
end Rindex;
function Rindex (Whole : Vstring;
Part : Character;
Occurrence : Natural := 1) return Strindex is
begin -- Rindex
return (Rindex (Whole, Vstr (Part), Occurrence));
end Rindex;
function Vstr (From : Character) return Vstring is
Temp : Vstring;
begin -- VSTR
if Last < 1 then
raise Constraint_Error;
else
Temp.Len := 1;
end if;
Temp.Value (First) := From;
return (Temp);
end Vstr;
function Vstr (From : String) return Vstring is
Temp : Vstring;
begin -- VSTR
if From'Length > Last then
raise Constraint_Error;
else
Temp.Len := From'Length;
end if;
Temp.Value (First .. From'Length) := From;
return (Temp);
end Vstr;
function "+" (From : String) return Vstring is
begin -- "+"
return (Vstr (From));
end "+";
function "+" (From : Character) return Vstring is
begin
return (Vstr (From));
end "+";
function Convert (X : From) return To is
begin -- CONVERT
return (Vstr (Str (X)));
end Convert;
end Vstrings;
-- .......................................................................... --
--
-- DISTRIBUTION AND COPYRIGHT:
--
-- This software is released to the Public Domain (note:
-- software released to the Public Domain is not subject
-- to copyright protection).
-- Restrictions on use or distribution: NONE
--
-- DISCLAIMER:
--
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered. The user is advised to
-- test the software thoroughly before relying on it. The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
-- UNIT: generic package spec of VSTRINGS
--
-- FILES: vstring_spec.a in publiclib
-- related file is vstring_body.a in publiclib
--
-- PURPOSE: An implementation of the abstract data type "variable-length
-- string."
--
-- DESCRIPTION: This package provides a private type VSTRING. VSTRING objects
-- are "strings" that have a length between zero and LAST, where
-- LAST is the generic parameter supplied in the package
-- instantiation.
--
-- In addition to the type VSTRING, a subtype and two constants
-- are declared. The subtype STRINDEX is an index to a VSTRING,
-- The STRINDEX constant FIRST is an index to the first character
-- of the string, and the VSTRING constant NUL is a VSTRING of
-- length zero. NUL is the default initial value of a VSTRING.
--
-- The following sets of functions, procedures, and operators
-- are provided as operations on the type VSTRING:
--
-- ATTRIBUTE FUNCTIONS: LEN, MAX, STR, CHAR
-- The attribute functions return the characteristics of
-- a VSTRING.
--
-- COMPARISON OPERATORS: "=", "/=", "<", ">", "<=", ">="
-- The comparison operators are the same as for the predefined
-- type STRING.
--
-- INPUT/OUTPUT PROCEDURES: GET, GET_LINE, PUT, PUT_LINE
--
-- The input/output procedures are similar to those for the
-- predefined type STRING, with the following exceptions:
--
-- - GET has an optional parameter LENGTH, which indicates
-- the number of characters to get (default is LAST).
--
-- - GET_LINE does not have a parameter to return the length
-- of the string (the LEN function should be used instead).
--
-- EXTRACTION FUNCTIONS: SLICE, SUBSTR, DELETE
-- The SLICE function returns the slice of a VSTRING between
-- two indices (equivalent to STR(X)(A .. B)).
--
-- SUBSTR returns a substring of a VSTRING taken from a given
-- index and extending a given length.
--
-- The DELETE function returns the VSTRING which results from
-- removing the slice between two indices.
--
-- EDITING FUNCTIONS: INSERT, APPEND, REPLACE
-- The editing functions return the VSTRING which results from
-- inserting, appending, or replacing at a given index with a
-- VSTRING, STRING, or CHARACTER. The index must be in the
-- current range of the VSTRING; i.e., zero cannot be used.
--
-- CONCATENATION OPERATOR: "&"
-- The concatenation operator is the same as for the type
-- STRING. It should be used instead of APPEND when the
-- APPEND would always be after the last character.
--
-- POSITION FUNCTIONS: INDEX, RINDEX
-- The position functions return an index to the Nth occurrence
-- of a VSTRING, STRING, or CHARACTER from the front or back
-- of a VSTRING. Zero is returned if the search is not
-- successful.
--
-- CONVERSION FUNCTIONS AND OPERATOR: VSTR, CONVERT, "+"
-- VSTR converts a STRING or a CHARACTER to a VSTRING.
--
-- CONVERT is a generic function which can be instantiated to
-- convert from any given variable-length string to another,
-- provided the FROM type has a function equivelent to STR
-- defined for it, and that the TO type has a function equiv-
-- elent to VSTR defined for it. This provides a means for
-- converting between VSTRINGs declared in separate instant-
-- iations of VSTRINGS. When instantiating CONVERT for
-- VSTRINGs, the STR and VSTR functions are implicitly defined,
-- provided that they have been made visible (by a use clause).
--
-- Note: CONVERT is NOT implicitly associated with the type
-- VSTRING declared in this package (since it would not be a
-- derivable function (see RM 3.4(11))).
--
-- Caution: CONVERT cannot be instantiated directly with the
-- names VSTR and STR, since the name of the subprogram being
-- declared would hide the generic parameters with the same
-- names (see RM 8.3(16)). CONVERT can be instantiated with
-- the operator "+", and any instantiation of CONVERT can
-- subsequently be renamed VSTR or STR.
--
-- Example: Given two VSTRINGS instantiations X and Y:
-- function "+" is new X.CONVERT(X.VSTRING, Y.VSTRING);
-- function "+" is new X.CONVERT(Y.VSTRING, X.VSTRING);
--
-- (Y.CONVERT could have been used in place of X.CONVERT)
--
-- function VSTR(A : X.VSTRING) return Y.VSTRING renames "+";
-- function VSTR(A : Y.VSTRING) return X.VSTRING renames "+";
--
-- "+" is equivelent to VSTR. It is supplied as a short-hand
-- notation for the function. The "+" operator cannot immed-
-- iately follow the "&" operator; use ... & (+ ...) instead.
pragma Page;
nblk1=18
nid=0
hdr6=30
[0x00] rec0=15 rec1=00 rec2=01 rec3=072
[0x01] rec0=14 rec1=00 rec2=02 rec3=03a
[0x02] rec0=1a rec1=00 rec2=03 rec3=01e
[0x03] rec0=28 rec1=00 rec2=04 rec3=086
[0x04] rec0=26 rec1=00 rec2=05 rec3=01c
[0x05] rec0=25 rec1=00 rec2=06 rec3=042
[0x06] rec0=23 rec1=00 rec2=07 rec3=034
[0x07] rec0=22 rec1=00 rec2=08 rec3=022
[0x08] rec0=20 rec1=00 rec2=09 rec3=012
[0x09] rec0=20 rec1=00 rec2=0a rec3=042
[0x0a] rec0=1e rec1=00 rec2=0b rec3=06a
[0x0b] rec0=1e rec1=00 rec2=0c rec3=030
[0x0c] rec0=22 rec1=00 rec2=0d rec3=04c
[0x0d] rec0=20 rec1=00 rec2=0e rec3=01e
[0x0e] rec0=24 rec1=00 rec2=0f rec3=034
[0x0f] rec0=21 rec1=00 rec2=10 rec3=082
[0x10] rec0=2e rec1=00 rec2=11 rec3=00a
[0x11] rec0=1d rec1=00 rec2=12 rec3=016
[0x12] rec0=15 rec1=00 rec2=13 rec3=09e
[0x13] rec0=15 rec1=00 rec2=14 rec3=02a
[0x14] rec0=12 rec1=00 rec2=15 rec3=084
[0x15] rec0=13 rec1=00 rec2=16 rec3=018
[0x16] rec0=0f rec1=00 rec2=17 rec3=018
[0x17] rec0=11 rec1=00 rec2=18 rec3=000
tail 0x2152980da84a64eb8b2c9 0x42a00088462060003