mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-21 23:41:13 +08:00
Code Issues Packages Projects Releases Wiki Activity

g-sercom.ads, [...] (Data_Rate): Add B115200.

Browse Source 
2008-04-08  Pascal Obry  <obry@adacore.com>

	* g-sercom.ads, g-sercom.adb (Data_Rate): Add B115200.
	(Stop_Bits_Number): New type.
	(Parity_Check): Likewise.
	(Set): Add parameter to set the number of stop bits and
	the parity. Parameter timeout is now a duration instead
	of a plain integer.

	* g-sercom-linux.adb:
	Implement the stop bits and parity support for GNU/Linux.
	Fix handling of timeout, it must be given in tenth of seconds.
	
	* g-sercom-mingw.adb:
	Implement the stop bits and parity support for Windows.
	Use new s-win32.ads unit instead of declaring Win32 services
	directly into this body.
	Update handling of timeout as now a duration.

	* s-win32.ads, s-winext.ads: New files.

From-SVN: r134003
This commit is contained in:
Pascal Obry 2008-04-08 08:42:41 +02:00 committed by Arnaud Charlet
parent e68c63e380
commit 42c3898c1d
6 changed files with 563 additions and 233 deletions

48
gcc/ada/g-sercom-linux.adb

@ -43,6 +43,8 @@ with GNAT.OS_Lib; use GNAT.OS_Lib;
package body GNAT.Serial_Communications is
use type Interfaces.C.unsigned;
type Port_Data is new int;
subtype unsigned is Interfaces.C.unsigned;
@ -63,6 +65,8 @@ package body GNAT.Serial_Communications is
CREAD : constant := 8#0200#;
CSTOPB : constant := 8#0100#;
CRTSCTS : constant := 8#020000000000#;
PARENB : constant := 8#00400#;
PARODD : constant := 8#01000#;
-- c_cc indexes
@ -70,16 +74,23 @@ package body GNAT.Serial_Communications is
VMIN : constant := 6;
C_Data_Rate : constant array (Data_Rate) of unsigned :=
(B1200 => 8#000011#,
B2400 => 8#000013#,
B4800 => 8#000014#,
B9600 => 8#000015#,
B19200 => 8#000016#,
B38400 => 8#000017#,
B57600 => 8#010001#);
(B1200 => 8#000011#,
B2400 => 8#000013#,
B4800 => 8#000014#,
B9600 => 8#000015#,
B19200 => 8#000016#,
B38400 => 8#000017#,
B57600 => 8#010001#,
B115200 => 8#010002#);
C_Bits : constant array (Data_Bits) of unsigned :=
(B7 => 8#040#, B8 => 8#060#);
C_Bits : constant array (Data_Bits) of unsigned :=
(B7 => 8#040#, B8 => 8#060#);
C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned :=
(One => 0, Two => CSTOPB);
C_Parity : constant array (Parity_Check) of unsigned :=
(None => 0, Odd => PARENB or PARODD, Even => PARENB);
procedure Raise_Error (Message : String; Error : Integer := Errno);
pragma No_Return (Raise_Error);
@ -168,14 +179,14 @@ package body GNAT.Serial_Communications is
---------
procedure Set
(Port : Serial_Port;
Rate : Data_Rate := B9600;
Bits : Data_Bits := B8;
Block : Boolean := True;
Timeout : Integer := 10)
(Port : Serial_Port;
Rate : Data_Rate := B9600;
Bits : Data_Bits := B8;
Stop_Bits : Stop_Bits_Number := One;
Parity : Parity_Check := None;
Block : Boolean := True;
Timeout : Duration := 10.0)
is
use type unsigned;
type termios is record
c_iflag : unsigned;
c_oflag : unsigned;
@ -214,9 +225,10 @@ package body GNAT.Serial_Communications is
Current.c_cflag := C_Data_Rate (Rate)
or C_Bits (Bits)
or C_Stop_Bits (Stop_Bits)
or C_Parity (Parity)
or CLOCAL
or CREAD
or CSTOPB
or CRTSCTS;
Current.c_lflag := 0;
Current.c_iflag := 0;
@ -224,7 +236,7 @@ package body GNAT.Serial_Communications is
Current.c_ispeed := Data_Rate_Value (Rate);
Current.c_ospeed := Data_Rate_Value (Rate);
Current.c_cc (VMIN) := char'Val (0);
Current.c_cc (VTIME) := char'Val (Timeout);
Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10));
-- Set port settings

235
gcc/ada/g-sercom-mingw.adb

@ -35,176 +35,24 @@
with Ada.Unchecked_Deallocation; use Ada;
with Ada.Streams; use Ada.Streams;
with System; use System;
with System.Win32.Ext; use System, System.Win32, System.Win32.Ext;
package body GNAT.Serial_Communications is
-- Common types
type HANDLE is new Interfaces.C.long;
type DWORD is new Interfaces.C.unsigned_long;
type WORD is new Interfaces.C.unsigned_short;
subtype PVOID is System.Address;
type BOOL is new Boolean;
for BOOL'Size use Interfaces.C.unsigned_long'Size;
type BYTE is new Interfaces.C.unsigned_char;
subtype CHAR is Interfaces.C.char;
type Port_Data is new HANDLE;
type Bits1 is range 0 .. 2 ** 1 - 1;
type Bits2 is range 0 .. 2 ** 2 - 1;
type Bits17 is range 0 .. 2 ** 17 - 1;
for Bits1'Size use 1;
for Bits2'Size use 2;
for Bits17'Size use 17;
C_Bits : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7);
C_Parity : constant array (Parity_Check) of Interfaces.C.unsigned :=
(None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY);
C_Stop_Bits : constant array (Stop_Bits_Number) of Interfaces.C.unsigned :=
(One => ONESTOPBIT, Two => TWOSTOPBITS);
-----------
-- Files --
-----------
function GetLastError return DWORD;
pragma Import (Stdcall, GetLastError, "GetLastError");
GENERIC_READ : constant := 16#80000000#;
GENERIC_WRITE : constant := 16#40000000#;
OPEN_EXISTING : constant := 3;
type OVERLAPPED is record
Internal : DWORD;
InternalHigh : DWORD;
Offset : DWORD;
OffsetHigh : DWORD;
hEvent : HANDLE;
end record;
type SECURITY_ATTRIBUTES is record
nLength : DWORD;
pSecurityDescriptor : PVOID;
bInheritHandle : BOOL;
end record;
function CreateFile
(lpFileName : Address;
dwDesiredAccess : DWORD;
dwShareMode : DWORD;
lpSecurityAttributes : access SECURITY_ATTRIBUTES;
dwCreationDisposition : DWORD;
dwFlagsAndAttributes : DWORD;
hTemplateFile : HANDLE) return HANDLE;
pragma Import (Stdcall, CreateFile, "CreateFileA");
function WriteFile
(hFile : HANDLE;
lpBuffer : Address;
nNumberOfBytesToWrite : DWORD;
lpNumberOfBytesWritten : access DWORD;
lpOverlapped : access OVERLAPPED) return BOOL;
pragma Import (Stdcall, WriteFile, "WriteFile");
function ReadFile
(hFile : HANDLE;
lpBuffer : Address;
nNumberOfBytesToRead : DWORD;
lpNumberOfBytesRead : access DWORD;
lpOverlapped : access OVERLAPPED) return BOOL;
pragma Import (Stdcall, ReadFile, "ReadFile");
function CloseHandle (hObject : HANDLE) return BOOL;
pragma Import (Stdcall, CloseHandle, "CloseHandle");
DTR_CONTROL_DISABLE : constant := 16#0#;
RTS_CONTROL_DISABLE : constant := 16#0#;
ODDPARITY : constant := 1;
ONESTOPBIT : constant := 0;
type DCB is record
DCBLENGTH : DWORD;
BaudRate : DWORD;
fBinary : Bits1;
fParity : Bits1;
fOutxCtsFlow : Bits1;
fOutxDsrFlow : Bits1;
fDtrControl : Bits2;
fDsrSensitivity : Bits1;
fTXContinueOnXoff : Bits1;
fOutX : Bits1;
fInX : Bits1;
fErrorChar : Bits1;
fNull : Bits1;
fRtsControl : Bits2;
fAbortOnError : Bits1;
fDummy2 : Bits17;
wReserved : WORD;
XonLim : WORD;
XoffLim : WORD;
ByteSize : BYTE;
Parity : BYTE;
StopBits : BYTE;
XonChar : CHAR;
XoffChar : CHAR;
ErrorChar : CHAR;
EofChar : CHAR;
EvtChar : CHAR;
wReserved1 : WORD;
end record;
pragma Convention (C, DCB);
for DCB use record
DCBLENGTH at 0 range 0 .. 31;
BaudRate at 4 range 0 .. 31;
fBinary at 8 range 0 .. 0;
fParity at 8 range 1 .. 1;
fOutxCtsFlow at 8 range 2 .. 2;
fOutxDsrFlow at 8 range 3 .. 3;
fDtrControl at 8 range 4 .. 5;
fDsrSensitivity at 8 range 6 .. 6;
fTXContinueOnXoff at 8 range 7 .. 7;
fOutX at 9 range 0 .. 0;
fInX at 9 range 1 .. 1;
fErrorChar at 9 range 2 .. 2;
fNull at 9 range 3 .. 3;
fRtsControl at 9 range 4 .. 5;
fAbortOnError at 9 range 6 .. 6;
fDummy2 at 9 range 7 .. 23;
wReserved at 12 range 0 .. 15;
XonLim at 14 range 0 .. 15;
XoffLim at 16 range 0 .. 15;
ByteSize at 18 range 0 .. 7;
Parity at 19 range 0 .. 7;
StopBits at 20 range 0 .. 7;
XonChar at 21 range 0 .. 7;
XoffChar at 22 range 0 .. 7;
ErrorChar at 23 range 0 .. 7;
EofChar at 24 range 0 .. 7;
EvtChar at 25 range 0 .. 7;
wReserved1 at 26 range 0 .. 15;
end record;
type COMMTIMEOUTS is record
ReadIntervalTimeout : DWORD;
ReadTotalTimeoutMultiplier : DWORD;
ReadTotalTimeoutConstant : DWORD;
WriteTotalTimeoutMultiplier : DWORD;
WriteTotalTimeoutConstant : DWORD;
end record;
pragma Convention (C, COMMTIMEOUTS);
function GetCommState
(hFile : HANDLE;
lpDCB : access DCB) return BOOL;
pragma Import (Stdcall, GetCommState, "GetCommState");
function SetCommState
(hFile : HANDLE;
lpDCB : access DCB) return BOOL;
pragma Import (Stdcall, SetCommState, "SetCommState");
function SetCommTimeouts
(hFile : HANDLE;
lpCommTimeouts : access COMMTIMEOUTS) return BOOL;
pragma Import (Stdcall, SetCommTimeouts, "SetCommTimeouts");
procedure Raise_Error (Message : String; Error : DWORD := GetLastError);
pragma No_Return (Raise_Error);
@ -222,7 +70,8 @@ package body GNAT.Serial_Communications is
if Port.H /= null then
Success := CloseHandle (HANDLE (Port.H.all));
Unchecked_Free (Port.H);
if not Success then
if Success = Win32.FALSE then
Raise_Error ("error closing the port");
end if;
end if;
@ -257,14 +106,14 @@ package body GNAT.Serial_Communications is
Success := CloseHandle (HANDLE (Port.H.all));
end if;
Port.H.all := Port_Data (CreateFile
Port.H.all := CreateFile
(lpFileName => C_Name (C_Name'First)'Address,
dwDesiredAccess => GENERIC_READ or GENERIC_WRITE,
dwShareMode => 0,
lpSecurityAttributes => null,
DwCreationDisposition => OPEN_EXISTING,
dwCreationDisposition => OPEN_EXISTING,
dwFlagsAndAttributes => 0,
HTemplateFile => 0));
hTemplateFile => 0);
if Port.H.all = 0 then
Raise_Error ("cannot open com port");
@ -297,14 +146,15 @@ package body GNAT.Serial_Communications is
Raise_Error ("read: port not opened", 0);
end if;
Success := ReadFile
(hFile => HANDLE (Port.H.all),
lpBuffer => Buffer (Buffer'First)'Address,
nNumberOfBytesToRead => DWORD (Buffer'Length),
lpNumberOfBytesRead => Read_Last'Access,
lpOverlapped => null);
Success :=
ReadFile
(hFile => HANDLE (Port.H.all),
lpBuffer => Buffer (Buffer'First)'Address,
nNumberOfBytesToRead => DWORD (Buffer'Length),
lpNumberOfBytesRead => Read_Last'Access,
lpOverlapped => null);
if not Success then
if Success = Win32.FALSE then
Raise_Error ("read error");
end if;
@ -316,11 +166,13 @@ package body GNAT.Serial_Communications is
---------
procedure Set
(Port : Serial_Port;
Rate : Data_Rate := B9600;
Bits : Data_Bits := B8;
Block : Boolean := True;
Timeout : Integer := 10)
(Port : Serial_Port;
Rate : Data_Rate := B9600;
Bits : Data_Bits := B8;
Stop_Bits : Stop_Bits_Number := One;
Parity : Parity_Check := None;
Block : Boolean := True;
Timeout : Duration := 10.0)
is
Success : BOOL;
Com_Time_Out : aliased COMMTIMEOUTS;
@ -333,7 +185,7 @@ package body GNAT.Serial_Communications is
Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access);
if not Success then
if Success = Win32.FALSE then
Success := CloseHandle (HANDLE (Port.H.all));
Port.H.all := 0;
Raise_Error ("set: cannot get comm state");
@ -341,6 +193,7 @@ package body GNAT.Serial_Communications is
Com_Settings.BaudRate := DWORD (Data_Rate_Value (Rate));
Com_Settings.fParity := 1;
Com_Settings.fBinary := Bits1 (System.Win32.TRUE);
Com_Settings.fOutxCtsFlow := 0;
Com_Settings.fOutxDsrFlow := 0;
Com_Settings.fDsrSensitivity := 0;
@ -349,13 +202,13 @@ package body GNAT.Serial_Communications is
Com_Settings.fInX := 0;
Com_Settings.fRtsControl := RTS_CONTROL_DISABLE;
Com_Settings.fAbortOnError := 0;
Com_Settings.ByteSize := BYTE (Bit_Value (Bits));
Com_Settings.Parity := ODDPARITY;
Com_Settings.StopBits := ONESTOPBIT;
Com_Settings.ByteSize := BYTE (C_Bits (Bits));
Com_Settings.Parity := BYTE (C_Parity (Parity));
Com_Settings.StopBits := BYTE (C_Stop_Bits (Stop_Bits));
Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access);
if not Success then
if Success = Win32.FALSE then
Success := CloseHandle (HANDLE (Port.H.all));
Port.H.all := 0;
Raise_Error ("cannot set comm state");
@ -371,11 +224,12 @@ package body GNAT.Serial_Communications is
others => 0);
end if;
Success := SetCommTimeouts
(hFile => HANDLE (Port.H.all),
lpCommTimeouts => Com_Time_Out'Access);
Success :=
SetCommTimeouts
(hFile => HANDLE (Port.H.all),
lpCommTimeouts => Com_Time_Out'Access);
if not Success then
if Success = Win32.FALSE then
Raise_Error ("cannot set the timeout");
end if;
end Set;
@ -396,14 +250,15 @@ package body GNAT.Serial_Communications is
Raise_Error ("write: port not opened", 0);
end if;
Success := WriteFile
(hFile => HANDLE (Port.H.all),
lpBuffer => Buffer'Address,
nNumberOfBytesToWrite => DWORD (Buffer'Length),
lpNumberOfBytesWritten => Temp_Last'Access,
lpOverlapped => null);
Success :=
WriteFile
(hFile => HANDLE (Port.H.all),
lpBuffer => Buffer'Address,
nNumberOfBytesToWrite => DWORD (Buffer'Length),
lpNumberOfBytesWritten => Temp_Last'Access,
lpOverlapped => null);
if not Boolean (Success)
if Success = Win32.FALSE
or else Stream_Element_Offset (Temp_Last) /= Buffer'Length
then
Raise_Error ("failed to write data");

17
gcc/ada/g-sercom.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2007, AdaCore --
-- Copyright (C) 2007-2008, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -77,11 +77,13 @@ package body GNAT.Serial_Communications is
---------
procedure Set
(Port : Serial_Port;
Rate : Data_Rate := B9600;
Bits : Data_Bits := B8;
Block : Boolean := True;
Timeout : Integer := 10) is
(Port : Serial_Port;
Rate : Data_Rate := B9600;
Bits : Data_Bits := B8;
Stop_Bits : Stop_Bits_Number := One;
Parity : Parity_Check := None;
Block : Boolean := True;
Timeout : Duration := 10.0) is
begin
Unimplemented;
end Set;
@ -124,8 +126,7 @@ package body GNAT.Serial_Communications is
procedure Unimplemented is
begin
raise Program_Error
with "Serial_Communications not implemented";
raise Program_Error with "Serial_Communications not implemented";
end Unimplemented;
end GNAT.Serial_Communications;

44
gcc/ada/g-sercom.ads

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2007, AdaCore --
-- Copyright (C) 2007-2008, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -47,12 +47,19 @@ package GNAT.Serial_Communications is
function Name (Number : Positive) return Port_Name;
-- Returns the port name for the given port number
type Data_Rate is (B1200, B2400, B4800, B9600, B19200, B38400, B57600);
type Data_Rate is
(B1200, B2400, B4800, B9600, B19200, B38400, B57600, B115200);
-- Speed of the communication
type Data_Bits is (B8, B7);
-- Communication bits
type Stop_Bits_Number is (One, Two);
-- One or two stop bits
type Parity_Check is (None, Even, Odd);
-- Either no parity check or an even or odd parity
type Serial_Port is new Ada.Streams.Root_Stream_Type with private;
procedure Open
@ -62,14 +69,18 @@ package GNAT.Serial_Communications is
-- opened.
procedure Set
(Port : Serial_Port;
Rate : Data_Rate := B9600;
Bits : Data_Bits := B8;
Block : Boolean := True;
Timeout : Integer := 10);
(Port : Serial_Port;
Rate : Data_Rate := B9600;
Bits : Data_Bits := B8;
Stop_Bits : Stop_Bits_Number := One;
Parity : Parity_Check := None;
Block : Boolean := True;
Timeout : Duration := 10.0);
-- The communication port settings. If Block is set then a read call
-- will wait for the whole buffer to be filed. If Block is not set then
-- the given Timeout (in seconds) is used.
-- the given Timeout (in seconds) is used. Note that the timeout precision
-- may be limited on some implementation (e.g. on GNU/Linux the maximum
-- precision is a tenth of seconds).
overriding procedure Read
(Port : in out Serial_Port;
@ -96,14 +107,13 @@ private
end record;
Data_Rate_Value : constant array (Data_Rate) of Interfaces.C.unsigned :=
(B1200 => 1_200,
B2400 => 2_400,
B4800 => 4_800,
B9600 => 9_600,
B19200 => 19_200,
B38400 => 38_400,
B57600 => 57_600);
Bit_Value : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7);
(B1200 => 1_200,
B2400 => 2_400,
B4800 => 4_800,
B9600 => 9_600,
B19200 => 19_200,
B38400 => 38_400,
B57600 => 57_600,
B115200 => 115_200);
end GNAT.Serial_Communications;

295
gcc/ada/s-win32.ads Normal file

@ -0,0 +1,295 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I N 3 2 --
-- --
-- S p e c --
-- --
-- Copyright (C) 2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package plus its child provide the low level interface to the Win32
-- API. The core part of the Win32 API (commont to RTX and Win32) is in this
-- package, and an additional part of the Win32 API which is not supported by
-- RTX is in package System.Win33.Ext.
with Interfaces.C;
package System.Win32 is
pragma Pure;
-------------------
-- General Types --
-------------------
-- The LARGE_INTEGER type is actually a fixed point type
-- that only can represent integers. The reason for this is
-- easier conversion to Duration or other fixed point types.
-- (See Operations.Clock)
type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0;
subtype PVOID is Address;
type HANDLE is new Interfaces.C.long;
INVALID_HANDLE_VALUE : constant HANDLE := -1;
type DWORD is new Interfaces.C.unsigned_long;
type WORD is new Interfaces.C.unsigned_short;
type BYTE is new Interfaces.C.unsigned_char;
type LONG is new Interfaces.C.long;
type CHAR is new Interfaces.C.char;
type BOOL is new Interfaces.C.int;
for BOOL'Size use Interfaces.C.int'Size;
type Bits1 is range 0 .. 2 ** 1 - 1;
type Bits2 is range 0 .. 2 ** 2 - 1;
type Bits17 is range 0 .. 2 ** 17 - 1;
for Bits1'Size use 1;
for Bits2'Size use 2;
for Bits17'Size use 17;
FALSE : constant := 0;
TRUE : constant := 1;
function GetLastError return DWORD;
pragma Import (Stdcall, GetLastError, "GetLastError");
-----------
-- Files --
-----------
GENERIC_READ : constant := 16#80000000#;
GENERIC_WRITE : constant := 16#40000000#;
CREATE_NEW : constant := 1;
CREATE_ALWAYS : constant := 2;
OPEN_EXISTING : constant := 3;
OPEN_ALWAYS : constant := 4;
TRUNCATE_EXISTING : constant := 5;
FILE_SHARE_DELETE : constant := 16#00000004#;
FILE_SHARE_READ : constant := 16#00000001#;
FILE_SHARE_WRITE : constant := 16#00000002#;
FILE_BEGIN : constant := 0;
FILE_CURRENT : constant := 1;
FILE_END : constant := 2;
PAGE_NOACCESS : constant := 16#0001#;
PAGE_READONLY : constant := 16#0002#;
PAGE_READWRITE : constant := 16#0004#;
PAGE_WRITECOPY : constant := 16#0008#;
PAGE_EXECUTE : constant := 16#0010#;
FILE_MAP_ALL_ACCESS : constant := 16#F001f#;
FILE_MAP_READ : constant := 4;
FILE_MAP_WRITE : constant := 2;
FILE_MAP_COPY : constant := 1;
FILE_ADD_FILE : constant := 16#0002#;
FILE_ADD_SUBDIRECTORY : constant := 16#0004#;
FILE_APPEND_DATA : constant := 16#0004#;
FILE_CREATE_PIPE_INSTANCE : constant := 16#0004#;
FILE_DELETE_CHILD : constant := 16#0040#;
FILE_EXECUTE : constant := 16#0020#;
FILE_LIST_DIRECTORY : constant := 16#0001#;
FILE_READ_ATTRIBUTES : constant := 16#0080#;
FILE_READ_DATA : constant := 16#0001#;
FILE_READ_EA : constant := 16#0008#;
FILE_TRAVERSE : constant := 16#0020#;
FILE_WRITE_ATTRIBUTES : constant := 16#0100#;
FILE_WRITE_DATA : constant := 16#0002#;
FILE_WRITE_EA : constant := 16#0010#;
STANDARD_RIGHTS_READ : constant := 16#20000#;
STANDARD_RIGHTS_WRITE : constant := 16#20000#;
SYNCHRONIZE : constant := 16#100000#;
FILE_ATTRIBUTE_READONLY : constant := 16#00000001#;
FILE_ATTRIBUTE_HIDDEN : constant := 16#00000002#;
FILE_ATTRIBUTE_SYSTEM : constant := 16#00000004#;
FILE_ATTRIBUTE_DIRECTORY : constant := 16#00000010#;
FILE_ATTRIBUTE_ARCHIVE : constant := 16#00000020#;
FILE_ATTRIBUTE_DEVICE : constant := 16#00000040#;
FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#;
FILE_ATTRIBUTE_TEMPORARY : constant := 16#00000100#;
FILE_ATTRIBUTE_SPARSE_FILE : constant := 16#00000200#;
FILE_ATTRIBUTE_REPARSE_POINT : constant := 16#00000400#;
FILE_ATTRIBUTE_COMPRESSED : constant := 16#00000800#;
FILE_ATTRIBUTE_OFFLINE : constant := 16#00001000#;
FILE_ATTRIBUTE_NOT_CONTENT_INDEXED : constant := 16#00002000#;
FILE_ATTRIBUTE_ENCRYPTED : constant := 16#00004000#;
FILE_ATTRIBUTE_VALID_FLAGS : constant := 16#00007fb7#;
FILE_ATTRIBUTE_VALID_SET_FLAGS : constant := 16#000031a7#;
type OVERLAPPED is record
Internal : DWORD;
InternalHigh : DWORD;
Offset : DWORD;
OffsetHigh : DWORD;
hEvent : HANDLE;
end record;
type SECURITY_ATTRIBUTES is record
nLength : DWORD;
pSecurityDescriptor : PVOID;
bInheritHandle : BOOL;
end record;
function CreateFile
(lpFileName : Address;
dwDesiredAccess : DWORD;
dwShareMode : DWORD;
lpSecurityAttributes : access SECURITY_ATTRIBUTES;
dwCreationDisposition : DWORD;
dwFlagsAndAttributes : DWORD;
hTemplateFile : HANDLE) return HANDLE;
pragma Import (Stdcall, CreateFile, "CreateFileA");
function GetFileSize
(hFile : HANDLE;
lpFileSizeHigh : access DWORD) return BOOL;
pragma Import (Stdcall, GetFileSize, "GetFileSize");
function SetFilePointer
(hFile : HANDLE;
lDistanceToMove : LONG;
lpDistanceToMoveHigh : access LONG;
dwMoveMethod : DWORD) return DWORD;
pragma Import (Stdcall, SetFilePointer, "SetFilePointer");
function WriteFile
(hFile : HANDLE;
lpBuffer : Address;
nNumberOfBytesToWrite : DWORD;
lpNumberOfBytesWritten : access DWORD;
lpOverlapped : access OVERLAPPED) return BOOL;
pragma Import (Stdcall, WriteFile, "WriteFile");
function ReadFile
(hFile : HANDLE;
lpBuffer : Address;
nNumberOfBytesToRead : DWORD;
lpNumberOfBytesRead : access DWORD;
lpOverlapped : access OVERLAPPED) return BOOL;
pragma Import (Stdcall, ReadFile, "ReadFile");
function CloseHandle (hObject : HANDLE) return BOOL;
pragma Import (Stdcall, CloseHandle, "CloseHandle");
function CreateFileMapping
(hFile : HANDLE;
lpSecurityAttributes : access SECURITY_ATTRIBUTES;
flProtect : DWORD;
dwMaximumSizeHigh : DWORD;
dwMaximumSizeLow : DWORD;
lpName : Address) return HANDLE;
pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingA");
function MapViewOfFile
(hFileMappingObject : HANDLE;
dwDesiredAccess : DWORD;
dwFileOffsetHigh : DWORD;
dwFileOffsetLow : DWORD;
dwNumberOfBytesToMap : DWORD) return System.Address;
pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile");
function UnmapViewOfFile (lpBaseAddress : System.Address) return BOOL;
pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile");
------------------------
-- System Information --
------------------------
subtype ProcessorId is DWORD;
type SYSTEM_INFO is record
dwOemId : DWORD;
dwPageSize : DWORD;
lpMinimumApplicationAddress : PVOID;
lpMaximumApplicationAddress : PVOID;
dwActiveProcessorMask : DWORD;
dwNumberOfProcessors : DWORD;
dwProcessorType : DWORD;
dwAllocationGranularity : DWORD;
dwReserved : DWORD;
end record;
procedure GetSystemInfo (SI : access SYSTEM_INFO);
pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo");
---------------------
-- Time Management --
---------------------
type SYSTEMTIME is record
wYear : WORD;
wMonth : WORD;
wDayOfWeek : WORD;
wDay : WORD;
wHour : WORD;
wMinute : WORD;
wSecond : WORD;
wMilliseconds : WORD;
end record;
procedure GetSystemTime (pSystemTime : access SYSTEMTIME);
pragma Import (Stdcall, GetSystemTime, "GetSystemTime");
procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer);
pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime");
function FileTimeToSystemTime
(lpFileTime : access Long_Long_Integer;
lpSystemTime : access SYSTEMTIME) return BOOL;
pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime");
function SystemTimeToFileTime
(lpSystemTime : access SYSTEMTIME;
lpFileTime : access Long_Long_Integer) return BOOL;
pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime");
function FileTimeToLocalFileTime
(lpFileTime : access Long_Long_Integer;
lpLocalFileTime : access Long_Long_Integer) return BOOL;
pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime");
function LocalFileTimeToFileTime
(lpFileTime : access Long_Long_Integer;
lpLocalFileTime : access Long_Long_Integer) return BOOL;
pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime");
procedure Sleep (dwMilliseconds : DWORD);
pragma Import (Stdcall, Sleep, External_Name => "Sleep");
function QueryPerformanceCounter
(lpPerformanceCount : access LARGE_INTEGER) return BOOL;
pragma Import
(Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter");
end System.Win32;

157
gcc/ada/s-winext.ads Normal file

@ -0,0 +1,157 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I N 3 2 . E X T --
-- --
-- S p e c --
-- --
-- Copyright (C) 2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides the part of the low level Win32 interface which is
-- not supported by RTX (but supported by regular Windows platforms).
package System.Win32.Ext is
pragma Pure;
---------------------
-- Time Management --
---------------------
function QueryPerformanceFrequency
(lpFrequency : access LARGE_INTEGER) return Win32.BOOL;
pragma Import
(Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");
---------------
-- Processor --
---------------
function SetThreadIdealProcessor
(hThread : HANDLE;
dwIdealProcessor : ProcessorId) return DWORD;
pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor");
--------------
-- Com Port --
--------------
DTR_CONTROL_DISABLE : constant := 16#0#;
RTS_CONTROL_DISABLE : constant := 16#0#;
NOPARITY : constant := 0;
ODDPARITY : constant := 1;
EVENPARITY : constant := 2;
ONESTOPBIT : constant := 0;
TWOSTOPBITS : constant := 2;
type DCB is record
DCBLENGTH : DWORD;
BaudRate : DWORD;
fBinary : Bits1;
fParity : Bits1;
fOutxCtsFlow : Bits1;
fOutxDsrFlow : Bits1;
fDtrControl : Bits2;
fDsrSensitivity : Bits1;
fTXContinueOnXoff : Bits1;
fOutX : Bits1;
fInX : Bits1;
fErrorChar : Bits1;
fNull : Bits1;
fRtsControl : Bits2;
fAbortOnError : Bits1;
fDummy2 : Bits17;
wReserved : WORD;
XonLim : WORD;
XoffLim : WORD;
ByteSize : BYTE;
Parity : BYTE;
StopBits : BYTE;
XonChar : CHAR;
XoffChar : CHAR;
ErrorChar : CHAR;
EofChar : CHAR;
EvtChar : CHAR;
wReserved1 : WORD;
end record;
pragma Convention (C, DCB);
for DCB use record
DCBLENGTH at 0 range 0 .. 31;
BaudRate at 4 range 0 .. 31;
fBinary at 8 range 0 .. 0;
fParity at 8 range 1 .. 1;
fOutxCtsFlow at 8 range 2 .. 2;
fOutxDsrFlow at 8 range 3 .. 3;
fDtrControl at 8 range 4 .. 5;
fDsrSensitivity at 8 range 6 .. 6;
fTXContinueOnXoff at 8 range 7 .. 7;
fOutX at 9 range 0 .. 0;
fInX at 9 range 1 .. 1;
fErrorChar at 9 range 2 .. 2;
fNull at 9 range 3 .. 3;
fRtsControl at 9 range 4 .. 5;
fAbortOnError at 9 range 6 .. 6;
fDummy2 at 9 range 7 .. 23;
wReserved at 12 range 0 .. 15;
XonLim at 14 range 0 .. 15;
XoffLim at 16 range 0 .. 15;
ByteSize at 18 range 0 .. 7;
Parity at 19 range 0 .. 7;
StopBits at 20 range 0 .. 7;
XonChar at 21 range 0 .. 7;
XoffChar at 22 range 0 .. 7;
ErrorChar at 23 range 0 .. 7;
EofChar at 24 range 0 .. 7;
EvtChar at 25 range 0 .. 7;
wReserved1 at 26 range 0 .. 15;
end record;
type COMMTIMEOUTS is record
ReadIntervalTimeout : DWORD;
ReadTotalTimeoutMultiplier : DWORD;
ReadTotalTimeoutConstant : DWORD;
WriteTotalTimeoutMultiplier : DWORD;
WriteTotalTimeoutConstant : DWORD;
end record;
pragma Convention (C, COMMTIMEOUTS);
function GetCommState
(hFile : HANDLE;
lpDCB : access DCB) return BOOL;
pragma Import (Stdcall, GetCommState, "GetCommState");
function SetCommState
(hFile : HANDLE;
lpDCB : access DCB) return BOOL;
pragma Import (Stdcall, SetCommState, "SetCommState");
function SetCommTimeouts
(hFile : HANDLE;
lpCommTimeouts : access COMMTIMEOUTS) return BOOL;
pragma Import (Stdcall, SetCommTimeouts, "SetCommTimeouts");
end System.Win32.Ext;