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

Text File | 1994-10-12 | 12KB | 364 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_EDSY  *  BODY
-- *           *
-- *************

package body CW_EDSY 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);

  -- .....................
  -- .                   .
  -- .  ColorAlternate1  .  BODY
  -- .                   .
  -- .....................
  --
    -- NOTES
    --   Again, ColorAlternate1 uses the color IDs as specified in the
    --   User's Guide, Appendix A. The original Codewright function
    --   specifies an unsigned 16 bit return value. The Meridian INTEGER
    --   type was chosen since this type will represent the possible
    --   values returned for Codewright's color scheme.

  function ColorAlternate1 (color : in integer) return integer is

    Return_Word : CW_TYPES.WORD;

    -- ........................
    -- .                      .
    -- .  CW_ColorAlternate1  .  SPEC
    -- .                      .
    -- ........................

    function CW_ColorAlternate1 (color : in integer) return CW_TYPES.WORD;
    pragma INTERFACE (windows, CW_ColorAlternate1, "ColorAlternate1");

  begin

    Return_Word := CW_ColorAlternate1 (color);
    return INTEGER (Return_Word);

  end ColorAlternate1;

  -- .....................
  -- .                   .
  -- .  ColorAlternate2  .  BODY
  -- .                   .
  -- .....................
  --
    -- NOTES
    --   Again, ColorAlternate2 uses the color IDs as specified in the
    --   User's Guide, Appendix A. The original Codewright function
    --   specifies an unsigned 16 bit return value. The Meridian INTEGER
    --   type was chosen since this type will represent the possible
    --   values returned for Codewright's color scheme.

  function ColorAlternate2 (color : in integer) return integer is

    Return_Word : CW_TYPES.WORD;

    -- ........................
    -- .                      .
    -- .  CW_ColorAlternate2  .  SPEC
    -- .                      .
    -- ........................

    function CW_ColorAlternate2 (color : in integer) return CW_TYPES.WORD;
    pragma INTERFACE (windows, CW_ColorAlternate2, "ColorAlternate2");

  begin

    Return_Word := CW_ColorAlternate2 (color);
    return INTEGER (Return_Word);

  end ColorAlternate2;

  -- .....................
  -- .                   .
  -- .  ColorAlternate3  .  BODY
  -- .                   .
  -- .....................
  --
    -- NOTES
    --   Again, ColorAlternate3 uses the color IDs as specified in the
    --   User's Guide, Appendix A. The original Codewright function
    --   specifies an unsigned 16 bit return value. The Meridian INTEGER
    --   type was chosen since this type will represent the possible
    --   values returned for Codewright's color scheme.

  function ColorAlternate3 (color : in integer) return integer is

    Return_Word : CW_TYPES.WORD;

    -- ........................
    -- .                      .
    -- .  CW_ColorAlternate3  .  SPEC
    -- .                      .
    -- ........................

    function CW_ColorAlternate3 (color : in integer) return CW_TYPES.WORD;
    pragma INTERFACE (windows, CW_ColorAlternate3, "ColorAlternate3");

  begin

    Return_Word := CW_ColorAlternate3 (color);
    return INTEGER (Return_Word);

  end ColorAlternate3;

  -- .....................
  -- .                   .
  -- .  ColorAlternate4  .  BODY
  -- .                   .
  -- .....................
  --
    -- NOTES
    --   Again, ColorAlternate4 uses the color IDs as specified in the
    --   User's Guide, Appendix A. The original Codewright function
    --   specifies an unsigned 16 bit return value. The Meridian INTEGER
    --   type was chosen since this type will represent the possible
    --   values returned for Codewright's color scheme.

  function ColorAlternate4 (color : in integer) return integer is

    Return_Word : CW_TYPES.WORD;

    -- ........................
    -- .                      .
    -- .  CW_ColorAlternate4  .  SPEC
    -- .                      .
    -- ........................

    function CW_ColorAlternate4 (color : in integer) return CW_TYPES.WORD;
    pragma INTERFACE (windows, CW_ColorAlternate4, "ColorAlternate4");

  begin

    Return_Word := CW_ColorAlternate4 (color);
    return INTEGER (Return_Word);

  end ColorAlternate4;

  -- ...................
  -- .                 .
  -- .  ColorComments  .  BODY
  -- .                 .
  -- ...................
  --
    -- NOTES
    --   Again, ColorComments uses the color IDs as specified in the
    --   User's Guide, Appendix A. The original Codewright function
    --   specifies an unsigned 16 bit return value. The Meridian INTEGER
    --   type was chosen since this type will represent the possible
    --   values returned for Codewright's color scheme. This function
    --   operates similarly to the ColorAlternate functions.  It returns
    --   the color codes as specified in the Window, Colors Dialogue for
    --   Comments.

  function ColorComments (color : in integer) return integer is

    Return_Word : CW_TYPES.WORD;

    -- ......................
    -- .                    .
    -- .  CW_ColorComments  .  SPEC
    -- .                    .
    -- ......................

    function CW_ColorComments (color : in integer) return CW_TYPES.WORD;
    pragma INTERFACE (windows, CW_ColorComments, "ColorComments");

  begin

    Return_Word := CW_ColorComments (color);
    return INTEGER (Return_Word);

  end ColorComments;

  -- ...................
  -- .                 .
  -- .  ColorKeywords  .  BODY
  -- .                 .
  -- ...................
  --
    -- NOTES
    --   Again, ColorKeywords uses the color IDs as specified in the
    --   User's Guide, Appendix A. The original Codewright function
    --   specifies an unsigned 16 bit return value. The Meridian INTEGER
    --   type was chosen since this type will represent the possible
    --   values returned for Codewright's color scheme. This function
    --   operates similarly to the ColorAlternate functions.  It returns
    --   the color codes as specified in the Window, Colors Dialogue for
    --   Keywords.

  function ColorKeywords (color : in integer) return integer is

    Return_Word : CW_TYPES.WORD;

    -- ......................
    -- .                    .
    -- .  CW_ColorKeywords  .  SPEC
    -- .                    .
    -- ......................

    function CW_ColorKeywords (color : in integer) return CW_TYPES.WORD;
    pragma INTERFACE (windows, CW_ColorKeywords, "ColorKeywords");

  begin

    Return_Word := CW_ColorKeywords (color);
    return INTEGER (Return_Word);

  end ColorKeywords;

  -- .....................
  -- .                   .
  -- .  HashCreateTable  .  BODY
  -- .                   .
  -- .....................

  function HashCreateTable (entries  : in integer;
                            datasize : in integer;
                            mode     : in integer) return SYSTEM.ADDRESS is

    Return_LPVOID : CW_TYPES.LPVOID;

    -- ........................
    -- .                      .
    -- .  CW_HashCreateTable  .  SPEC
    -- .                      .
    -- ........................

    function CW_HashCreateTable (entries  : in integer;
                                 datasize : in integer;
                                 mode     : in integer) return CW_TYPES.LPVOID;
    pragma INTERFACE (windows, CW_HashCreateTable, "HashCreateTable");

  begin

    Return_LPVOID := CW_HashCreateTable (entries, datasize, mode);
    return SYSTEM.ADDRESS (Return_LPVOID);

  end HashCreateTable;

  -- ...................
  -- .                 .
  -- .  HashFindEntry  .  BODY
  -- .                 .
  -- ...................

  function HashFindEntry (hashTab : in SYSTEM.ADDRESS;
                          key     : in STRING;
                          keyLen  : in integer) return SYSTEM.ADDRESS is

    Pass_LPSTR    : CW_TYPES.LPSTR;
    Pass_LPVOID   : CW_TYPES.LPVOID;
    Return_LPVOID : CW_TYPES.LPVOID;
    Temp_Address  : SYSTEM.ADDRESS;

    -- ......................
    -- .                    .
    -- .  CW_HashFindEntry  .  SPEC
    -- .                    .
    -- ......................

    function CW_HashFindEntry (hashTab : in CW_TYPES.LPVOID;
                               key     : in SYSTEM.ADDRESS;
                               keyLen  : in integer) return CW_TYPES.LPVOID;
    pragma INTERFACE (windows, CW_HashFindEntry, "HashFindEntry");

  begin

    Pass_LPVOID  := CW_TYPES.LPVOID (hashTab);
    Pass_LPSTR   := new STRING'(key & ASCII.NUL);
    Temp_Address := Pass_LPSTR.all (Pass_LPSTR.all'FIRST)'ADDRESS;

    Return_LPVOID := CW_HashFindEntry (Pass_LPVOID, Temp_Address, keyLen);
    return SYSTEM.ADDRESS (Return_LPVOID);

  end HashFindEntry;

  -- ..................
  -- .                .
  -- .  HashGetEntry  .  BODY
  -- .                .
  -- ..................

  function HashGetEntry (hashTab : in SYSTEM.ADDRESS;
                         key     : in STRING;
                         keyLen  : in integer) return SYSTEM.ADDRESS is

    Pass_LPSTR    : CW_TYPES.LPSTR;
    Pass_LPVOID   : CW_TYPES.LPVOID;
    Return_LPVOID : CW_TYPES.LPVOID;
    Temp_Address  : SYSTEM.ADDRESS;

    -- .....................
    -- .                   .
    -- .  CW_HashGetEntry  .  SPEC
    -- .                   .
    -- .....................

    function CW_HashGetEntry (hashTab : in CW_TYPES.LPVOID;
                              key     : in SYSTEM.ADDRESS;
                              keyLen  : in integer) return CW_TYPES.LPVOID;
    pragma INTERFACE (windows, CW_HashGetEntry, "HashGetEntry");

  begin

    Pass_LPVOID  := CW_TYPES.LPVOID (hashTab);
    Pass_LPSTR   := new STRING'(key & ASCII.NUL);
    Temp_Address := Pass_LPSTR.all (Pass_LPSTR.all'FIRST)'ADDRESS;

    Return_LPVOID := CW_HashGetEntry (Pass_LPVOID, Temp_Address, keyLen);
    return SYSTEM.ADDRESS (Return_LPVOID);

  end HashGetEntry;

  -- ...............
  -- .             .
  -- .  LibExport  .  BODY
  -- .             .
  -- ...............

  procedure LibExport (execStr : in STRING) is

    Pass_LPSTR : CW_TYPES.LPSTR;

    -- ..................
    -- .                .
    -- .  CW_LibExport  .  SPEC
    -- .                .
    -- ..................

    procedure CW_LibExport (execStr : in SYSTEM.ADDRESS);
    pragma INTERFACE (windows, CW_LibExport, "LibExport");

  begin

    Pass_LPSTR := new STRING'(execStr & ASCII.NUL);
    CW_LibExport (Pass_LPSTR.all (Pass_LPSTR.all'FIRST)'ADDRESS);
  end LibExport;

end CW_EDSY;