Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/misc/dstr3.src

Text File | 1988-05-03 | 16.3 KB | 488 lines

with TEXT_IO;
use TEXT_IO;
package DYN is


------------------------------------------------------------------------------
--  This is a package of several string manipulation functions based on     --
-- a built-in dynamic STRING type DYN_STRING.  It is an adaptation and      --
-- extension of the package proposed by Sylvan Rubin of Ford Aerospace and  --
-- Communications Corporation in the Nov/Dec 1984 issue of the Journal of   --
-- Pascal, Ada and Modula-2.  Some new functions have been added, and much  --
-- of the body code has been rewritten.                                     --
------------------------------------------------------------------------------
-- R.G. Cleaveland 07 December 1984:                                        --
--  Implementation initially with the Telesoft Ada version 1.3.             --
-- 06 Feb 85: CHAR changed to add the optional parameter POSIT.             --
-- 06 Feb 85: procedure SUBSTITUTE added.                                   --
-- 05 Apr 85: procedures UPPERCASE and CHECKBYTE added.                     --
-- 04 Feb 86: style and formatting changes made, some comments fixed.       --
-- Ported to VERDIX VADS (VAX Ultrix version 5.1).                          --
-- 10 Feb 86: Several bugs fixed - SIZE constrained, exception for '&'      --
-- generating too long a string added, error in integer conversion fixed.   --
-- Functions EQUALS, ">", "<=" and ">=" added.  Subtype DS_POS incorporated.--
------------------------------------------------------------------------------






  MAX_D_STRING_LENGTH : constant POSITIVE := 100;
    -- This is the maximum LENGTH of a dynamic string implemented with this
    -- package.  This value is "arbitrary" in that any reasonable number
    -- equal to or less than the maximum STRING LENGTH permitted by the
    -- compiler is acceptable.  The specific value above was chosen as a
    -- compromise between programmer convenience and memory space requirements.



  subtype DS_POS is INTEGER range 0..MAX_D_STRING_LENGTH;

  type DYN_STRING is private;

  STRING_TOO_SHORT: exception;



  function D_STRING(CHAR: CHARACTER)  return DYN_STRING;
          -- Creates a one-byte dynamic string of contents CHAR.

  function D_STRING(STR : STRING   )  return DYN_STRING;
          -- Creates a dynamic string of contents STR.

  function D_STRING(N: INTEGER;
                    B: NATURAL  := 0;
                    F: CHARACTER:= ' ') return DYN_STRING;

      -- for the preceding function:
      --   B is the number of bytes desired in the returned string.
      --     The  first byte is reserved for the sign; it will be blank
      --     or '-'.  If B is 0 or unspecified the LENGTH of the
      --     string returned is just enough for the sign and the
      --     significant digits.  If the number would overflow B,
      --     the exception STRING_TOO_SHORT is raised.

      --   F is a leading-fill CHARACTER.  If B is not zero, bytes
      --     from 2 up to the first significant byte will be F.

  function D_STRING(FLT : FLOAT; AFT : INTEGER)  return DYN_STRING;
    -- Creates a dynamic string representation of the number FLT
    -- in fixed point notation with AFT decimal places.

  -- The following four functions convert from dynamic strings to the
  -- desired representation:

  function CHAR(DSTR  : DYN_STRING;
                POSIT : POSITIVE := 1) return CHARACTER;

  function STR (DSTR: DYN_STRING) return STRING;

  function INT (DSTR: DYN_STRING) return INTEGER;

  function FLT (DSTR: DYN_STRING) return FLOAT;

  -- (No function for long integer; depends on compiler implementation)

  function LENGTH(DSTR: DYN_STRING)     return NATURAL;
    -- returns the LENGTH of the dynamic string.

  function EQUALS    (DS1, DS2: DYN_STRING) return BOOLEAN;
    -- true if DS1 is equal to DS2 the way Ada compares strings

  function "<"    (DS1, DS2: DYN_STRING) return BOOLEAN;
    -- true if DS1 is less than DS2 the way Ada compares strings

  function "<="   (DS1, DS2: DYN_STRING) return BOOLEAN;
    -- true if DS1 is less than or equal to DS2 the way Ada compares strings

  function ">"    (DS1, DS2: DYN_STRING) return BOOLEAN;
    -- true if DS1 is greater than DS2 the way Ada compares strings

  function ">="   (DS1, DS2: DYN_STRING) return BOOLEAN;
    -- true if DS1 is greater than or equal to DS2 the way Ada compares strings

  function "&"   (DS1, DS2: DYN_STRING) return DYN_STRING;
    -- concatenates DS1 and DS2.  Raises CONSTRAINT_ERROR if LENGTH of
    -- new string would exceed MAX_D_STRING_LENGTH.

  function SUBSTRING (DSTR: DYN_STRING;    -- Returns a subpart of this string
                      START  : NATURAL;    -- starting at this position
                      LENGTH : NATURAL)    -- and of this LENGTH.
                     return DYN_STRING;

  function RIGHT (DSTR: DYN_STRING;        -- Returns the part of this string
                  START  : NATURAL)        -- starting here and to the end.
                 return DYN_STRING;

  procedure SUBSTITUTE(DSTR  : in out DYN_STRING;-- Into this string
                       POSIT : in POSITIVE;      -- at this position,
                       C     : in CHARACTER);    -- this character
                                                 -- is substituted.

  function INDEX (SOURCE_STRING : DYN_STRING; -- If this string contains
                  PATTERN_STRING: DYN_STRING; -- this string starting AT or
                  START_POSIT   : INTEGER)    -- AFTER this position, the
                 return INTEGER;              -- position of such start
                                              -- is returned.
                 -- If the string lengths prohibit the search -1 is returned.
                 -- If no match was found, 0 is returned.
                 -- (This is like the INSTR function of BASIC).

  function RINDEX (SOURCE_STRING : DYN_STRING; -- If this string contains
                   PATTERN_STRING: DYN_STRING; -- this string starting AT or
                   START_POSIT   : INTEGER)    -- BEFORE this position, the
                  return INTEGER;              -- position of such start
                                               -- is returned.
                  -- If the string lengths prohibit the search -1 is returned.
                  -- If no match was found, 0 is returned.
                  -- eg RINDEX(D_STRING("ABC"),D_STRING("C") ,2) =  0
                  --    RINDEX(D_STRING("ABC"),D_STRING("BC"),3) = -1

  function UPPERCASE (DSTR: DYN_STRING) return DYN_STRING;
                  -- Returns with all lower-case characters changed to
                  -- uppercase.
  function CHECKBYTE(DSTR: in DYN_STRING) return CHARACTER;
                  -- Returns a printable check CHARACTER representing a
                  -- logical process on the elements of the string for
                  -- purposes of data validity checks.
  procedure CLEAR(DSTR: in out DYN_STRING);
                  -- makes DSTR a null string.

private
  type DYN_STRING is
    record
      SIZE: INTEGER range 0..MAX_D_STRING_LENGTH;
      DATA: STRING(1..MAX_D_STRING_LENGTH);
    end record;
end DYN;


package body DYN is

  procedure CLEAR(DSTR: in out DYN_STRING) is

    begin
      DSTR.SIZE := 0;
    end CLEAR;

  function MINIMUM(VALUE1, VALUE2: NATURAL) return NATURAL is

    begin
      if VALUE1 < VALUE2 then
        return VALUE1;
      else
        return VALUE2;
      end if;
    end MINIMUM;

  function "&" (DS1, DS2: DYN_STRING) return DYN_STRING is

      DS3 : DYN_STRING;

    begin
      DS3.SIZE              := DS1.SIZE + DS2.SIZE;
      DS3.DATA(1..DS3.SIZE) := DS1.DATA(1..DS1.SIZE) & DS2.DATA(1..DS2.SIZE);
      return DS3;
    end "&";

  function D_STRING(CHAR: CHARACTER)  return DYN_STRING is

      DS : DYN_STRING;

    begin
      DS.SIZE     := 1;
      DS.DATA(1)  := CHAR;
      return DS;
    end D_STRING;

  function D_STRING(STR : STRING   )  return DYN_STRING is

      DS : DYN_STRING;

    begin
      DS.SIZE                   := STR'LENGTH;
      DS.DATA(1..DS.SIZE)       := STR;
      return DS;
    end D_STRING;

  function D_STRING(N: INTEGER;
                    B: NATURAL  := 0;
                    F: CHARACTER:= ' ') return DYN_STRING is

      SIGN, V        : DYN_STRING;

    begin
      if N < 0 then
        SIGN := D_STRING('-');
      else
        SIGN := D_STRING(' ');
      end if;
      if N = 0 then
        V := D_STRING('0');
      else
        V := RIGHT(D_STRING(INTEGER'image(N)),2);
      end if;
      if B /= 0 then
        if B < V.SIZE + 1 then
          raise STRING_TOO_SHORT;
        else
          for I in 1..B-1-V.SIZE loop
            V := D_STRING(F) & V;
          end loop;
        end if;
      end if;
      return SIGN & V;
    end D_STRING;



  function D_STRING(FLT : FLOAT; AFT : INTEGER)  return DYN_STRING is

      DS : DYN_STRING;
      F  : FLOAT;
      L  : INTEGER;            --This should be longest integer form
                               --available for the implementation.

    begin
      F := FLT * (10.0 ** AFT);
      L := INTEGER(F);         --See note above - implementation dependent
      DS := D_STRING(L);
      while DS.SIZE < AFT+1 loop
          DS := SUBSTRING(DS,1,1) & D_STRING('0') & RIGHT(DS,2);
      end loop;
      DS := SUBSTRING(DS,1,LENGTH(DS)-AFT) & D_STRING('.')
            & RIGHT(DS,LENGTH(DS)-AFT+1);
      return DS;
    end D_STRING;

  function CHAR(DSTR  : DYN_STRING;
                POSIT : POSITIVE := 1) return CHARACTER is

    begin
      if POSIT > DSTR.SIZE then
        raise STRING_TOO_SHORT;
      else
        return DSTR.DATA(POSIT);
      end if;
    end CHAR;

  function STR (DSTR: DYN_STRING) return STRING is

    begin
      return DSTR.DATA(1..DSTR.SIZE);
    end STR;

  function INT (DSTR: DYN_STRING) return INTEGER is
      V: INTEGER;
      L: POSITIVE;
      package INT_IO is new INTEGER_IO(INTEGER);

    begin
      INT_IO.GET(STR(DSTR),V,L); -- Package reference may need to be
      return V;                      -- changed for validated compiler
    end INT;

  function FLT (DSTR: DYN_STRING) return FLOAT is
      V: FLOAT;
      L: POSITIVE;
      package F_IO is new FLOAT_IO(FLOAT);

    begin
      F_IO.GET(STR(DSTR),V,L);  -- See comment above.
      return V;
    end FLT;

  function LENGTH(DSTR: DYN_STRING) return NATURAL is

    begin
      return DSTR.SIZE;
    end LENGTH;

  function EQUALS    (DS1, DS2: DYN_STRING) return BOOLEAN is
    -- true if DS1 is equal to DS2 the way Ada compares strings
    begin
      if STR(DS1)=STR(DS2) then
        return (TRUE);
      else
        return (FALSE);
      end if;
    end EQUALS;

  function "<" (DS1, DS2: DYN_STRING) return BOOLEAN is
    -- true if DS1 is less than DS2 the way Ada compares strings

    begin
      if STR(DS1) < STR(DS2) then
        return (TRUE);
      else
        return (FALSE);
      end if;
    end "<";

  function "<="   (DS1, DS2: DYN_STRING) return BOOLEAN is
    -- true if DS1 is less than or equal to DS2 the way Ada compares strings

    begin
      if STR(DS1) <= STR(DS2) then
        return (TRUE);
      else
        return (FALSE);
      end if;
    end "<=";


  function ">"    (DS1, DS2: DYN_STRING) return BOOLEAN is
    -- true if DS1 is greater than DS2 the way Ada compares strings

    begin
      if STR(DS1) > STR(DS2) then
        return (TRUE);
      else
        return (FALSE);
      end if;
    end ">";

  function ">="   (DS1, DS2: DYN_STRING) return BOOLEAN is
    -- true if DS1 is greater than or equal to DS2 the way Ada compares strings

    begin
      if STR(DS1) >= STR(DS2) then
        return (TRUE);
      else
        return (FALSE);
      end if;
    end ">=";

  procedure SUBSTITUTE(DSTR  : in out DYN_STRING;-- Into this string
                       POSIT : in POSITIVE;      -- at this position,
                       C     : in CHARACTER) is  -- this character
                                                 -- is substituted.

    begin
      DSTR.DATA(POSIT) := C;
      if POSIT > DSTR.SIZE then
        DSTR.SIZE := POSIT;
      end if;
    end SUBSTITUTE;

  function SUBSTRING (DSTR: DYN_STRING;
                      START  : NATURAL;
                      LENGTH : NATURAL)
                                             return DYN_STRING is
        DS: DYN_STRING;
        L : NATURAL := LENGTH;

    begin
      if (START < 1) or (START > DSTR.SIZE) then
        raise CONSTRAINT_ERROR;
      else
        if DSTR.SIZE < START + L - 1 then
          raise STRING_TOO_SHORT;
        else
          DS.SIZE := L;
          DS.DATA(1..L) := DSTR.DATA(START..START+L-1);
          return DS;
        end if;
      end if;
    end SUBSTRING;

  function RIGHT (DSTR: DYN_STRING;
                  START  : NATURAL) return DYN_STRING is

    begin
      return SUBSTRING(DSTR, START, LENGTH(DSTR) - START + 1);
    end RIGHT;

  function INDEX(SOURCE_STRING : DYN_STRING;
                 PATTERN_STRING: DYN_STRING;
                 START_POSIT   : INTEGER)    return INTEGER is

          NO_MATCH        : constant INTEGER :=  0;
          NO_FIT          : constant INTEGER := -1;

    begin
      if SOURCE_STRING.SIZE < PATTERN_STRING.SIZE + START_POSIT - 1
      or START_POSIT < 1 then
        return NO_FIT;
      end if;
      for I in START_POSIT..SOURCE_STRING.SIZE-PATTERN_STRING.SIZE+1 loop
        if SOURCE_STRING.DATA(I..I+PATTERN_STRING.SIZE-1)
           = PATTERN_STRING.DATA(1..PATTERN_STRING.SIZE) then
         return I;
        end if;
      end loop;
      return NO_MATCH;
    end INDEX;

  function RINDEX(SOURCE_STRING : DYN_STRING;
                  PATTERN_STRING: DYN_STRING;
                  START_POSIT   : INTEGER)    return INTEGER is

        NO_MATCH        : constant INTEGER := 0;
        NO_FIT          : constant INTEGER := -1;

    begin
      if SOURCE_STRING.SIZE < PATTERN_STRING.SIZE + START_POSIT - 1
      or START_POSIT < 1 then
        return NO_FIT;
      end if;
      for I in reverse 1..START_POSIT loop
        if SOURCE_STRING.DATA(I..I+PATTERN_STRING.SIZE-1)
           = PATTERN_STRING.DATA(1..PATTERN_STRING.SIZE) then
          return I;
        end if;
      end loop;
      return NO_MATCH;
    end RINDEX;

  function UPPERCASE (DSTR: DYN_STRING) return DYN_STRING is

      DS: DYN_STRING  := DSTR;

    begin
      for I in 1..LENGTH(DS) loop
        case DSTR.DATA(I) is
          when 'a'..'z' =>
            DS.DATA(I) := CHARACTER'VAL(CHARACTER'pos(DS.DATA(I))-32);
          when others   => null;
        end case;
      end loop;
      return DS;
    end UPPERCASE;

  function CHECKBYTE(DSTR: in DYN_STRING) return CHARACTER is

     -- Returns a printable check CHARACTER representing a
     -- logical process on the elements of the string for
     -- purposes of data validity checks.
     -- IMPLEMENTATION NOTE:  The MAX_CHECKSUM is defined
     -- so as to permit identical behavior on all systems
     -- which will compile the routine.  This algorithm will
     -- fail to detect a CHARACTER drop or add if that CHARACTER
     -- is the close bracket ']'.

     CHECKSUM    : NATURAL          := DSTR.SIZE;
     MAX_CHECKSUM: constant NATURAL := 16000;
     CALC_MAX    : constant NATURAL := 16000 + CHARACTER'pos(CHARACTER'last);
     MODE        : constant NATURAL := CHARACTER'pos('Z') - CHARACTER'pos('A');

    begin
      for I in 1..DSTR.SIZE loop
        CHECKSUM  := CHECKSUM  +
                 CHARACTER'pos(DSTR.DATA(I));
        if CHECKSUM > MAX_CHECKSUM then
          CHECKSUM := CHECKSUM - 1000;
        end if;
      end loop;
      CHECKSUM  := CHECKSUM  mod MODE;
      return CHARACTER'VAL(CHECKSUM  + CHARACTER'pos('A'));
    end CHECKBYTE;

    begin --(DYN)
      null;
    exception when others => PUT("[DYN EXCEPTION]");
                             raise;
    end DYN;