Solo Programadores 22/SOLO_22.iso/packages/win32ada/data.z/win32-winnt.adb

Text File | 1995-11-17 | 5.3 KB | 162 lines

-- $Source: /home/harp/1/proto/monoBANK/winnt/win32-winnt.adb,v $
-- $Revision: 1.4 $ $Date: 95/02/12 14:39:05 $ $Author: mg $
-------------------------------------------------------------------------------
--
-- THIS FILE AND ANY ASSOCIATED DOCUMENTATION IS FURNISHED "AS IS" WITHOUT
-- WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED
-- TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR
-- PURPOSE.  The user assumes the entire risk as to the accuracy and the
-- use of this file.
--
-- Copyright (c) Intermetrics, Inc. 1995
-- Royalty-free, unlimited, worldwide, non-exclusive use, modification,
-- reproduction and further distribution of this file is permitted.
--
-------------------------------------------------------------------------------


with Ada.Unchecked_Conversion;
with Interfaces;

package body Win32.Winnt is

    function MAKELANGID (P, S: WORD) return WORD is
      use Interfaces;
    begin
      return WORD(Unsigned_16(P) or Interfaces.Shift_Left(Unsigned_16(S), 10));
    end MAKELANGID;

    function PRIMARYLANGID (LGID: WORD) return WORD is
      use Interfaces;
    begin
      return WORD(Unsigned_16(LGID) and 16#3ff#);
    end PRIMARYLANGID;

    function SUBLANGID (LGID: WORD) return WORD is
      use Interfaces;
    begin
      return WORD(Interfaces.Shift_Right(Unsigned_16(LGID), 10));
    end SUBLANGID;

    function MAKELCID (Lgid, Srtid: WORD) return DWORD is
      use Interfaces;
    begin
      return DWORD(Shift_Left(Unsigned_32(Srtid), 16) or Unsigned_32(Lgid));
    end MAKELCID;

    function LANGIDFROMLCID (Lcid: DWORD) return WORD is
      use Interfaces;
    begin
      return WORD(Unsigned_32(Lcid) and 16#ffff#);
    end LANGIDFROMLCID;

    function SORTIDFROMLCID (Lcid: DWORD) return WORD is
      use Interfaces;
    begin
      return WORD(Shift_Right((Unsigned_32(Lcid) and NLS_VALID_LOCALE_MASK),
                                16));
    end SORTIDFROMLCID;

    function IMAGE_FIRST_SECTION(NTHeader: PIMAGE_NT_HEADERS) return
        PIMAGE_DATA_DIRECTORY is

        Dummy: IMAGE_NT_HEADERS;
        subtype Long is Interfaces.C.Long;
        use type Interfaces.C.Long;
        function To_Long is new Ada.Unchecked_Conversion(
            PIMAGE_NT_HEADERS, Long);
        function To_PIMAGE is new Ada.Unchecked_Conversion(
            Long, PIMAGE_DATA_DIRECTORY);
    begin
        return To_PIMAGE(To_Long(NTHeader) +
             Dummy.OptionalHeader'Position +
             Long(NTHeader.FileHeader.SizeOfOptionalHeader));
    end IMAGE_FIRST_SECTION;

    function BTYPE(X: BYTE) return BYTE is
      use Interfaces;
    begin
      return BYTE(Unsigned_8(X) and N_BTMASK);
    end BTYPE;

    function ISPTR(X: BYTE) return Standard.Boolean is
      use Interfaces;
    begin
      return (Unsigned_8(X) and N_TMASK) =
             Shift_Left(Unsigned_8(IMAGE_SYM_DTYPE_POINTER), N_BTSHFT);
    end ISPTR;

    function ISFCN(X: BYTE) return Standard.Boolean is
      use Interfaces;
    begin
      return (Unsigned_8(X) and N_TMASK) =
             Shift_Left(Unsigned_8(IMAGE_SYM_DTYPE_FUNCTION), N_BTSHFT);
    end ISFCN;

    function ISARY(X: BYTE) return Standard.Boolean is
      use Interfaces;
    begin
      return (Unsigned_8(X) and N_TMASK) =
             Shift_Left(Unsigned_8(IMAGE_SYM_DTYPE_ARRAY), N_BTSHFT);
    end ISARY;

    function ISTAG(X: BYTE) return Standard.Boolean is
      use Interfaces;
    begin
      return X = IMAGE_SYM_CLASS_STRUCT_TAG or
             X = IMAGE_SYM_CLASS_UNION_TAG or
             X = IMAGE_SYM_CLASS_ENUM_TAG;
    end ISTAG;

    function INCREF(X: BYTE) return BYTE is
        use Interfaces;
        U8X: Unsigned_8 := Unsigned_8(X);
    begin
        return BYTE((Shift_Left(U8X and not N_BTMASK, N_TSHIFT)) or
                    (Shift_Left(Unsigned_8(IMAGE_SYM_DTYPE_POINTER),N_BTSHFT))
            or (U8X and N_BTMASK));
    end INCREF;

    function DECREF(X: BYTE) return BYTE is
        use Interfaces;
    begin
      return BYTE((Shift_Right(Unsigned_8(X), N_TSHIFT) and not N_BTMASK) or
                 (Unsigned_8(X) and N_BTMASK));
    end DECREF;

    function IMAGE_SNAP_BY_ORDINAL(Ordinal: DWORD) return Standard.Boolean is
        use Interfaces;
    begin
        return Interfaces.Integer_32(Ordinal) < 0;
    end IMAGE_SNAP_BY_ORDINAL;

    function IMAGE_ORDINAL(Ordinal: DWORD) return WORD is
        use Interfaces;
    begin
        return WORD(Interfaces.Unsigned_32(Ordinal) and 16#FFFF#);
    end IMAGE_ORDINAL;

    function RtlFillMemory
        (Destination : in Win32.PVOID;
         Length      : in Win32.Strings.size_t;
         Fill        : in Win32.BYTE)
        return Win32.PVOID is
    begin
        return Win32.Strings.memset(Destination, Win32.INT(Fill), Length);
    end RtlFillMemory;

    function RtlZeroMemory
        (Destination : in Win32.PVOID;
         Length      : in Win32.Strings.size_t) return Win32.PVOID is
    begin
        return Win32.Strings.memset(Destination, 0, Length);
    end RtlZeroMemory;

begin

    -- In GNAT 2.02 aggregate assignment not supported for unions
    SYSTEM_LUID.Luid.QuadPart := 16#3E7#;
    SYSTEM_LUID.Attributes    := 0;                          -- winnt.h:2206

end Win32.Winnt;