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

Text File | 1994-10-12 | 9KB | 366 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;
with SYSTEM;
with CW_SMAN;

-- *************
-- *           *
-- *  CW_BFEX  *  BODY
-- *           *
-- *************

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

  -- ....................
  -- .                  .
  -- .  PosCurrentChar  .  BODY
  -- .                  .
  -- ....................

  function PosCurrentChar return CHARACTER is

    Return_Word : CW_TYPES.WORD := 0;
    Return_Char : CHARACTER;

    -- .......................
    -- .                     .
    -- .  CW_PosCurrentChar  .  SPEC
    -- .                     .
    -- .......................

    function CW_PosCurrentChar return CW_TYPES.WORD;
    pragma INTERFACE (windows, CW_PosCurrentChar, "_PosCurrentChar");

  begin
    Return_Word := CW_PosCurrentChar;

    if CW_TYPES."<" (Return_Word, CW_TYPES.EOF_CHAR) then
      Return_Char := CHARACTER'VAL (Return_Word);
    else
      Return_Char := ASCII.SUB;
    end if;

    return Return_Char;

  end PosCurrentChar;

  -- .............
  -- .           .
  -- .  PosInit  .  BODY
  -- .           .
  -- .............

  function PosInit (offset : in long_integer) return BOOLEAN is

    Return_Bool : CW_TYPES.BOOL;

    -- ................
    -- .              .
    -- .  CW_PosInit  .  SPEC
    -- .              .
    -- ................

    function CW_PosInit (offset : in CW_TYPES.LONG) return CW_TYPES.BOOL;
    pragma INTERFACE (windows, CW_PosInit, "_PosInit");

  begin

    Return_Bool := CW_PosInit (CW_TYPES.LONG (offset));

    return BOOLEAN'VAL (Return_Bool);
  end PosInit;

  -- .................
  -- .               .
  -- .  PosNextChar  .  BODY
  -- .               .
  -- .................

  function PosNextChar return CHARACTER is

    Return_Word : CW_TYPES.WORD := 0;
    Return_Char : CHARACTER;

    -- ....................
    -- .                  .
    -- .  CW_PosNextChar  .  SPEC
    -- .                  .
    -- ....................

    function CW_PosNextChar return CW_TYPES.WORD;
    pragma INTERFACE (windows, CW_PosNextChar, "_PosNextChar");

  begin
    Return_Word := CW_PosNextChar;

    if CW_TYPES."<" (Return_Word, CW_TYPES.EOF_CHAR) then
      Return_Char := CHARACTER'VAL (Return_Word);
    else
      Return_Char := ASCII.SUB;
    end if;

    return Return_Char;

  end PosNextChar;

  -- .................
  -- .               .
  -- .  PosNextLine  .  BODY
  -- .               .
  -- .................

  function PosNextLine (Lines : in Long_Integer) return Long_Integer is

    Return_Long : CW_TYPES.LONG := 0;

    -- ....................
    -- .                  .
    -- .  CW_PosNextLine  .  SPEC
    -- .                  .
    -- ....................

    function CW_PosNextLine (Lines : in Long_Integer) return CW_TYPES.LONG;
    pragma INTERFACE (windows, CW_PosNextLine, "_PosNextLine");

  begin
    Return_Long := CW_PosNextLine (Lines);
    return Long_Integer (Return_Long);
  end PosNextLine;

  -- .................
  -- .               .
  -- .  PosPrevChar  .  BODY
  -- .               .
  -- .................

  function PosPrevChar return CHARACTER is

    Return_Word : CW_TYPES.WORD := 0;
    Return_Char : CHARACTER;

    -- ....................
    -- .                  .
    -- .  CW_PosPrevChar  .  SPEC
    -- .                  .
    -- ....................

    function CW_PosPrevChar return CW_TYPES.WORD;
    pragma INTERFACE (windows, CW_PosPrevChar, "_PosPrevChar");

  begin
    Return_Word := CW_PosPrevChar;

    if CW_TYPES."<" (Return_Word, CW_TYPES.EOF_CHAR) then
      Return_Char := CHARACTER'VAL (Return_Word);
    else
      Return_Char := ASCII.SUB;
    end if;

    return Return_Char;

  end PosPrevChar;

  -- .................
  -- .               .
  -- .  PosPrevLine  .  BODY
  -- .               .
  -- .................

  function PosPrevLine (Lines : in Long_Integer) return Long_Integer is

    Return_Long : CW_TYPES.LONG := 0;

    -- ....................
    -- .                  .
    -- .  CW_PosPrevLine  .  SPEC
    -- .                  .
    -- ....................

    function CW_PosPrevLine (Lines : in Long_Integer) return CW_TYPES.LONG;
    pragma INTERFACE (windows, CW_PosPrevLine, "_PosPrevLine");

  begin
    Return_Long := CW_PosPrevLine (Lines);
    return Long_Integer (Return_Long);
  end PosPrevLine;

  -- ..............
  -- .            .
  -- .  PosQLine  .  BODY
  -- .            .
  -- ..............

  function PosQLine return Long_Integer is

    Return_Long : CW_TYPES.LONG := 0;

    -- .................
    -- .               .
    -- .  CW_PosQLine  .  SPEC
    -- .               .
    -- .................

    function CW_PosQLine return CW_TYPES.LONG;
    pragma INTERFACE (windows, CW_PosQLine, "_PosQLine");

  begin
    Return_Long := CW_PosQLine;
    return Long_Integer (Return_Long);
  end PosQLine;

  -- ................
  -- .              .
  -- .  PosQOffset  .  BODY
  -- .              .
  -- ................

  function PosQOffset return Long_Integer is

    Return_Long : CW_TYPES.LONG := 0;

    -- ...................
    -- .                 .
    -- .  CW_PosQOffset  .  SPEC
    -- .                 .
    -- ...................

    function CW_PosQOffset return CW_TYPES.LONG;
    pragma INTERFACE (windows, CW_PosQOffset, "_PosQOffset");

  begin
    Return_Long := CW_PosQOffset;
    return Long_Integer (Return_Long);
  end PosQOffset;

  -- .................
  -- .               .
  -- .  PosSetColor  .  BODY
  -- .               .
  -- .................
  --
    -- NOTES
    --   Data type integer was chosen for the color parameter based on
    --   Codewright's documentation. Page 78 of the Programmer's Reference
    --   indicates that the color is passed as specified in Appendix A of
    --   the User's Manual. Appendix A specifies that a byte is used to
    --   encode foreground and background colors. Each nibble of the byte
    --   holds one color. Other color functions listed in Appendix A use
    --   an integer to pass color, so the integer type was chosen for this
    --   implementation.

  procedure PosSetColor (color : in integer;
                         count : in long_integer) is

    Passed_Word  : CW_TYPES.WORD := 0;
    Passed_Count : CW_TYPES.LONG := 0;

    -- ....................
    -- .                  .
    -- .  CW_PosSetColor  .  SPEC
    -- .                  .
    -- ....................

    procedure CW_PosSetColor (color : in CW_TYPES.WORD;
                              count : in CW_TYPES.LONG);
    pragma INTERFACE (windows, CW_PosSetColor, "_PosSetColor");

  begin

    Passed_Word  := CW_TYPES.WORD (color);
    Passed_Count := CW_TYPES.LONG (count);

    CW_PosSetColor (Passed_Word, Passed_Count);

  end PosSetColor;

  -- .................
  -- .               .
  -- .  BufReadChar  .  BODY
  -- .               .
  -- .................

  function BufReadChar return CHARACTER is

    Return_Int : INTEGER;

    -- ....................
    -- .                  .
    -- .  CW_BufReadChar  .  SPEC
    -- .                  .
    -- ....................

    function CW_BufReadChar return INTEGER;
    pragma INTERFACE (windows, CW_BufReadChar, "BufReadChar");

  begin -- procedure BufReadChar

    Return_Int := CW_BufReadChar;
    return CHARACTER'VAL (Return_Int);

  end BufReadChar;

  -- ................
  -- .              .
  -- .  BufReadStr  .  BODY
  -- .              .
  -- ................

  procedure BufReadStr (str : in out string) is

    Addr : SYSTEM.ADDRESS;

    -- ...................
    -- .                 .
    -- .  CW_BufReadStr  .  SPEC
    -- .                 .
    -- ...................

    function CW_BufReadStr (count : in LONG_INTEGER) return SYSTEM.ADDRESS;
    pragma INTERFACE (windows, CW_BufReadStr, "BufReadStr");

  begin -- procedure BufReadStr

    Addr := CW_BufReadStr (LONG_INTEGER (str'LAST));

  Assign_Str:
    declare
      Temp_Str : string (1 .. str'LAST);
      for Temp_Str use at Addr;
      i : integer := 1;
    begin -- Assign_Str

      while Temp_Str (i) /= ASCII.NUL loop
        i := i + 1;
      end loop;

      str (1 .. (i - 1)) := temp_str (1 .. (i - 1));
      str (i)            := ASCII.CR;

    end Assign_Str;

    --  Must deallocate the memory allocated by CW_BufReadStr since
    --  that string is no longer used after this function.
    CW_SMAN.StrFree (Addr);

  end BufReadStr;

end CW_BFEX;