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

Text File | 1988-05-03 | 8.4 KB | 230 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, the       --
-- SUBSTRING function has been modified to permit it to return the right    --
-- part of a string if the third parameter is permitted to default, and     --
-- much of the body code has been rewritten.                                --
------------------------------------------------------------------------------
-- R.G. Cleaveland 07 December 1984:                                        --
--  Implementation initially with the Telesoft Ada version                  --
-- This required definition of the DYN_STRING type without use of a         --
-- discriminant; an arbitrary maximum string length was chosen.  This       --
-- should be changed when an improved compiler is available.                --
------------------------------------------------------------------------------
-- Richard Powers 03 January 1985:                                          --
-- changed to be used with a real compiler.                                 --
-- Some of the routines removed by my whim.                                 --
------------------------------------------------------------------------------
-- Richard Powers 26 January 1985:
-- Added UPPER_CASE function
------------------------------------------------------------------------------

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.

-- The following four functions convert from dynamic strings to the
-- desired representation:
function CHAR(DSTR: DYN_STRING) return character;
function STR (DSTR: DYN_STRING) return string;
function INT (DSTR: DYN_STRING) return integer;
function FLT (DSTR: DYN_STRING) return float;

function LENGTH(DSTR: DYN_STRING) return natural;
function "<" (DS1, DS2: DYN_STRING) return boolean;
function "&" (DS1, DS2: DYN_STRING) return DYN_STRING;

function SUBSTRING (DSTR: DYN_STRING;      -- Returns a subpart of this string
                    START  : natural;      -- starting at this position
                    LENGTH : natural := 0) -- and of this length.
                return DYN_STRING;
                -- if LENGTH is zero or not specified, the remainder of the
                -- string is returned (eg the "RIGHT" function).

function INDEX (SOURCE_STRING,              --If this string contains
                PATTERN_STRING: DYN_STRING; --this string starting at or AFTER
                START_POS: integer)         --this position, the position of
                return integer;             --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,             --If this string contains
                PATTERN_STRING: DYN_STRING; --this string starting at or BEFORE
                START_POS: integer)         --this position, the position of
                return integer;             --such start is returned.
                -- If the string lengths prohibit the search -1 is returned.
                -- If no match was found, 0 is returned.

function UPPER_CASE(STRG : in DYN.DYN_STRING) return STRING;
                -- Return the input string in upper case

private

        type STRING_CONTENTS(SIZE : natural := 0) is
           record
               DATA: string(1..SIZE);
           end record;

        type DYN_STRING is access STRING_CONTENTS;

end DYN;

----------------------------------------------------------------------------

package body DYN is

package MY_INTEGER_IO is new INTEGER_IO(INTEGER);

package MY_FLOAT_IO is new FLOAT_IO(FLOAT);

function "&" (DS1, DS2: DYN_STRING) return DYN_STRING is
        DS3 : DYN_STRING;
    begin
        DS3 := new STRING_CONTENTS(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 := new STRING_CONTENTS(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 := new STRING_CONTENTS(SIZE => STR'length);
        DS.DATA(1..DS.SIZE)  := STR;
        return DS;
    end D_STRING;

function CHAR(DSTR: DYN_STRING) return character is
    begin
        return DSTR.DATA(1);
    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;
    begin
        MY_INTEGER_IO.get(STR(DSTR),V,L);
        return V;
    end INT;

function FLT (DSTR: DYN_STRING) return float is
        V: float;
        L: positive;
    begin
        MY_FLOAT_IO.get(STR(DSTR),V,L);
        return V;
    end FLT;

function LENGTH(DSTR: DYN_STRING) return natural is
    begin
        return DSTR.SIZE;
    end LENGTH;

function "<" (DS1, DS2: DYN_STRING) return boolean is
    begin
        if STR(DS1) < STR(DS2)
        then return (TRUE);
        else return (FALSE);
        end if;
    end "<";

function SUBSTRING (DSTR: DYN_STRING;
                    START  : natural;
                    LENGTH : natural := 0)
                                           return DYN_STRING is
        DS: DYN_STRING;
        L : natural := LENGTH;
    begin
        if (START < 1) or (START > DSTR.SIZE)
        then raise CONSTRAINT_ERROR;
        else if L = 0
             then L := DSTR.SIZE-START+1;
             end if;
             if DSTR.SIZE < START + L - 1
             then  raise STRING_TOO_SHORT;
             else
                   DS := new STRING_CONTENTS(L);
                   DS.DATA(1..L) := DSTR.DATA(START..START+L-1);
                   return DS;
             end if;
         end if;
    end SUBSTRING;

function INDEX(SOURCE_STRING, PATTERN_STRING: DYN_STRING;
                        START_POS: integer) return integer is
        NO_MATCH        : integer := 0;
        NO_FIT          : integer := -1;
    begin
        if SOURCE_STRING.SIZE < PATTERN_STRING.SIZE + START_POS - 1
        or START_POS < 1
        then return NO_FIT;
        end if;
        for I in START_POS..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, PATTERN_STRING: DYN_STRING;
                        START_POS: integer) return integer is
        NO_MATCH        : integer := 0;
        NO_FIT          : integer := -1;
    begin
        if SOURCE_STRING.SIZE < PATTERN_STRING.SIZE + START_POS - 1
        or START_POS < 1
        then return NO_FIT;
        end if;
        for I in reverse 1..START_POS 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 UPPER_CASE(STRG : in DYN.DYN_STRING) return STRING is
        ANSWER : STRING(1..LENGTH(STRG));
    begin
        ANSWER := STR(STRG);
        for I in 1..LENGTH(STRG) loop
            if (ANSWER(I) >= 'a') and (ANSWER(I) <= 'z') then
                ANSWER(I) := CHARACTER'VAL(CHARACTER'POS(ANSWER(I)) -
                    CHARACTER'POS('a') + CHARACTER'POS('A'));
            end if;
        end loop;
        return ANSWER;
end UPPER_CASE;

end DYN;