DataMuseum.dk

Presents historical artifacts from the history of:

Rational R1000/400 Tapes

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about Rational R1000/400 Tapes

Excavated with: AutoArchaeologist - Free & Open Source Software.


top - download
Index: ┃ B T

⟦3dc7b49a8⟧ TextFile

    Length: 22943 (0x599f)
    Types: TextFile
    Names: »B«

Derivation

└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
    └─ ⟦129cab021⟧ »DATA« 
        └─⟦this⟧ 
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
    └─ ⟦d65440be7⟧ »DATA« 
        └─⟦this⟧ 

TextFile



--  DISCUSSION:
--
--	This package implements the type "variable-length string" (vstring)
--	using generics.  The alternative approaches are to use a discriminant
--	record in which the discriminant controls the length of a STRING inside
--	the record, or a record containing an access type which points to a
--      string, which can be deallocated and reallocated when necessary.
--
--	Advantages of this package:
--	  * 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.
--
--	  * The other approach stores the vstring in a string whose length
--	    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).
--
--	Disadvantages of this package:
--	  * Different instantiations must be used to declare vstrings with
--	    different maximum lengths (this may be desirable, since
--	    CONSTRAINT_ERROR will be raised if the maximum is exceeded).
--
--	  * A second declaration is required to give the type declared by
--	    the instantiation a name other than "VSTRING."
--
--	  * The storage required for a vstring is determined by the generic
--	    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;