DP Tool Club 19/CD_ASCQ_19_010295.iso/vrac/adaada.zip/ADAADA.ZIP/SRC/CW_ADA/CW_SMAN_.ADA

Text File | 1994-10-12 | 8KB | 273 lines

-- Copyright (c) 1994 ARINC Research Corporation
-- From material copyright (c) 1991, 1992 Premia Corporation
--
-- This material may be reproduced by or for the US Government pursuant
-- to the copyright license under DFAR Clause 252.227-7013 (1988)
--
-- Developed for US Air Force under contract no. F41608-90-D-0544-0005
--
-- MODIFICATIONS
--   94/06 - J. Neuse, SD/OSE/EA  - Initial code
--   94/10 - O. Sluder, SD/OSE/EA - Cleanup

with CW_TYPES;

-- *************
-- *           *
-- *  CW_SMAN  *  BODY
-- *           *
-- *************

package body CW_SMAN is

  -- The following pragmas are required by the Meridian OpenAda for
  -- Windows 2.0 compiler in the package spec and body of code to be
  -- included in a DLL, or an application calling the DLL will
  -- general protection fault
  pragma SUPPRESS (elaboration_check);
  pragma SUPPRESS (storage_check);

  -- ..................
  -- .                        .
  -- .  Addr_Str_Len  .  BODY
  -- .                     .
  -- ..................
  --
  -- NOTES
  --   1. This function returns the length of aa string pointed to by
  --        a system address. It looks for the ASCII.NUL character which
  --        delimits c strings. It is to be used in conjunction with
  --        Addr_To_Str which returns an Ada string indicated by the
  --        system address.
  --   2. This function returns the string length including the nul char
  --   3. This function is not a part of the CodeWright API

  function Addr_Str_Len (Address : in SYSTEM.ADDRESS) return INTEGER is

    Temp_Addr : SYSTEM.ADDRESS := Address;
    Found_Nul : BOOLEAN        := FALSE;
    Length    : INTEGER        := 1;

  begin --  function Addr_Str_Len

    Length := 1;
    while not Found_Nul loop

    Find_Nul:
      declare
        Temp_Ch : character;
        for Temp_Ch use at Temp_Addr;
      begin
        Found_Nul := (Temp_Ch = ASCII.NUL);
        if not Found_Nul then
          Length    := Length + 1;
          Temp_Addr := SYSTEM."+" (Temp_Addr, 1);
        end if;
      end Find_Nul;

    end loop;

    return Length;

  end Addr_Str_Len;

  -- ....................
  -- .                          .
  -- .  Addr_To_String  .  BODY
  -- .                       .
  -- ....................
  --
  -- NOTES
  --   1. This function returns a string pointed to by a system address.
  --        It is to be used in conjunction with Addr_Str_Len which returns
  --        the length of a string pointed to by a system address.
  --        This function returns an Ada string, that is, a string without
  --        the ending nul character.
  --   2. The function bases the length of the returned string on the length
  --        passed.  Therefore, it is the responsibility of the caller to
  --        include the proper length and determine whether to include a nul
  --        character from a c string.
  --   3. This function is not a part of the CodeWright API.

  function Addr_To_String (Address : in SYSTEM.ADDRESS;
                           Length  : in INTEGER) return STRING is

    Return_Str : STRING (1 .. Length);

  begin --  function Addr_To_String

  Assign_Str:
    declare
      Temp_Str : string (1 .. Length);
      for Temp_Str use at Address;
    begin -- Assign_Str
      Return_Str (1 .. Length) := temp_str (1 .. Length);
    end Assign_Str;

    return Return_Str;

  end Addr_To_String;

  -- ..............
  -- .                    .
  -- .  FindChar  .  BODY
  -- .                 .
  -- ..............
  --
  -- NOTES
  --   1. This function is not a part of the CodeWright API.  This is provided
  --        for Ada string manipulation.  The function returns the string
  --        position of a specific character of a string based on a starting
  --        position.

  function FindChar (Start : in INTEGER;
                     Char  : in CHARACTER;
                     Str   : in STRING) return INTEGER is

    i : integer := Start;

  begin --  function FindChar

    while Str (i) /= Char loop
      i := i + 1;
    end loop;

    return i;

  end FindChar;

  -- .............
  -- .           .
  -- .  StrFree  .  BODY
  -- .           .
  -- .............

  procedure StrFree (Str_Address : in SYSTEM.ADDRESS) is


    -- ................
    -- .              .
    -- .  CW_StrFree  .  SPEC
    -- .              .
    -- ................

    procedure CW_StrFree (Str_Address : in SYSTEM.ADDRESS);
    pragma INTERFACE (windows, CW_StrFree, "StrFree");

  begin --  procedure StrFree

    CW_StrFree (Str_Address);

  end StrFree;

  -- ..............
  -- .            .
  -- .  StrMatch  .  BODY
  -- .            .
  -- ..............

  function StrMatch (pattern : in STRING;
                     str     : in STRING;
                     flags   : in INTEGER;
                     len     : in LONG_INTEGER) return LONG_INTEGER is

    Return_Long  : LONG_INTEGER;
    Pass_Pattern : CW_TYPES.LPSTR;
    Pass_Str     : CW_TYPES.LPSTR;

    -- .................
    -- .               .
    -- .  CW_StrMatch  .  SPEC
    -- .               .
    -- .................

    function CW_StrMatch (pattern : in SYSTEM.ADDRESS;
                          str     : in SYSTEM.ADDRESS;
                          flags   : in INTEGER;
                          len     : in SYSTEM.ADDRESS) return LONG_INTEGER;
    pragma INTERFACE (windows, CW_StrMatch, "StrMatch");

  begin --  function StrMatch

    Pass_Pattern := new STRING'(pattern & ASCII.NUL);
    Pass_Str     := new STRING'(str & ASCII.NUL);

    Return_Long :=
      CW_StrMatch (Pass_Pattern.all (Pass_Pattern.all'FIRST)'ADDRESS,
                   Pass_Str.all (Pass_Str.all'FIRST)'ADDRESS, flags,
                   len'ADDRESS);

    return Return_Long;

  end StrMatch;

  -- ............
  -- .          .
  -- .  StrNew  .  BODY
  -- .          .
  -- ............

  function StrNew (str : in STRING) return SYSTEM.ADDRESS is

    Pass_LPSTR     : CW_TYPES.LPSTR;
    Return_Address : SYSTEM.ADDRESS;

    -- ...............
    -- .             .
    -- .  CW_StrNew  .  SPEC
    -- .             .
    -- ...............

    function CW_StrNew (str : in SYSTEM.ADDRESS) return SYSTEM.ADDRESS;
    pragma INTERFACE (windows, CW_StrNew, "StrNew");

  begin

    Pass_LPSTR     := new STRING'(str & ascii.nul);
    Return_Address := CW_StrNew (Pass_LPSTR.all (Pass_LPSTR.all'FIRST)'ADDRESS);
    return (Return_Address);

  end StrNew;

  -- .............
  -- .           .
  -- .  StrTrim  .  BODY
  -- .           .
  -- .............

  function StrTrim (Str  : in STRING;
                    cset : in STRING) return STRING is

    Length     : INTEGER;
    Pass_Str   : CW_TYPES.LPSTR;
    Return_Str : CW_TYPES.LPSTR;
    Pass_Cset  : CW_TYPES.LPSTR;
    Addr       : SYSTEM.ADDRESS;

    -- ................
    -- .              .
    -- .  CW_StrTrim  .  SPEC
    -- .              .
    -- ................

    function CW_StrTrim (string : in SYSTEM.ADDRESS;
                         cset   : in SYSTEM.ADDRESS) return SYSTEM.ADDRESS;
    pragma INTERFACE (windows, CW_StrTrim, "StrTrim");

  begin --  function StrTrim

    Pass_Str  := new STRING'(str & ASCII.NUL);
    Pass_Cset := new STRING'(cset & ASCII.NUL);

    Addr := CW_StrTrim (Pass_Str.all (Pass_Str.all'FIRST)'ADDRESS,
                        Pass_Cset.all (Pass_Cset.all'FIRST)'ADDRESS);

    Length     := Addr_Str_Len (Addr);
    Return_Str := new STRING'(Addr_To_String (Addr, (Length - 1)));

    return Return_Str.all;

  end StrTrim;

end CW_SMAN;