diff options
author | Pascal Obry <obry@adacore.com> | 2008-03-26 08:40:18 +0100 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2008-03-26 08:40:18 +0100 |
commit | f88ecba0bc8dca1af95ba6ff29de6c2c263c5b76 (patch) | |
tree | 28343910375ab6a065b5ea0288fb08858441c855 /gcc | |
parent | 4e9f48a126a0812b87a7dba7dfcd11d441c48e80 (diff) | |
download | gcc-f88ecba0bc8dca1af95ba6ff29de6c2c263c5b76.zip gcc-f88ecba0bc8dca1af95ba6ff29de6c2c263c5b76.tar.gz gcc-f88ecba0bc8dca1af95ba6ff29de6c2c263c5b76.tar.bz2 |
Makefile.in: Add proper GNAT.Serial_Communications implementation on supported platforms.
2008-03-26 Pascal Obry <obry@adacore.com>
* Makefile.in: Add proper GNAT.Serial_Communications implementation on
supported platforms.
* Makefile.rtl: Add g-sercom.o.
* impunit.adb: Add g-sercom.adb.
* s-crtl.ads (open): New routine.
(close): Likewise.
(write): Likewise.
* s-osinte-mingw.ads (BYTE): New type.
(CHAR): Likewise.
(OVERLAPPED): Likewise.
(GENERIC_READ): New constant.
(GENERIC_WRITE): Likewise.
(OPEN_EXISTING): Likewise.
(PSECURITY_ATTRIBUTES): Removed this type, use anonymous access
type instead.
(CreateFile): New routine.
(WriteFile): Likewise.
(ReadFile): Likewise.
(CloseHandle): Move next to the other file oriented routines.
* g-sercom.ads: New unit.
* g-sercom.adb: Default implementation, calls to this unit will raise
a program error exception.
* g-sercom-mingw.adb, g-sercom-linux.adb: Windows and
GNU/Linux implementations.
From-SVN: r133569
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/Makefile.in | 8 | ||||
-rw-r--r-- | gcc/ada/Makefile.rtl | 1 | ||||
-rw-r--r-- | gcc/ada/g-sercom-linux.adb | 289 | ||||
-rw-r--r-- | gcc/ada/g-sercom-mingw.adb | 413 | ||||
-rw-r--r-- | gcc/ada/g-sercom.adb | 131 | ||||
-rw-r--r-- | gcc/ada/g-sercom.ads | 109 | ||||
-rw-r--r-- | gcc/ada/impunit.adb | 26 | ||||
-rw-r--r-- | gcc/ada/s-crtl.ads | 14 |
8 files changed, 971 insertions, 20 deletions
diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 2869926..c27e7e2 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -837,6 +837,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) s-osprim.adb<s-osprim-posix.adb \ s-taspri.ads<s-taspri-posix.ads \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ + g-sercom.adb<g-sercom-linux.adb \ system.ads<system-linux-x86.ads ifeq ($(strip $(filter-out marte,$(THREAD_KIND))),) @@ -1247,7 +1248,6 @@ endif i-cpoint.ads<i-cpoint-vms_64.ads \ i-cpoint.adb<i-cpoint-vms_64.adb \ i-cstrea.adb<i-cstrea-vms.adb \ - i-forbla.ads<i-forbla-unimplemented.ads \ s-inmaop.adb<s-inmaop-vms.adb \ s-interr.adb<s-interr-vms.adb \ s-intman.adb<s-intman-vms.adb \ @@ -1315,7 +1315,8 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) g-socthi.adb<g-socthi-mingw.adb \ g-stsifd.adb<g-stsifd-sockets.adb \ g-soccon.ads<g-soccon-mingw.ads \ - g-soliop.ads<g-soliop-mingw.ads + g-soliop.ads<g-soliop-mingw.ads \ + g-sercom.adb<g-sercom-mingw.adb ifeq ($(strip $(filter-out rtx_w32 rtx_rtss,$(THREAD_KIND))),) LIBGNAT_TARGET_PAIRS += \ @@ -1376,6 +1377,7 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(arch) $(osys))),) s-tasinf.adb<s-tasinf-linux.adb \ s-taspri.ads<s-taspri-posix.ads \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ + g-sercom.adb<g-sercom-linux.adb \ system.ads<system-linux-ppc.ads TOOLS_TARGET_PAIRS = \ @@ -1487,6 +1489,7 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),) s-tasinf.adb<s-tasinf-linux.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ s-taspri.ads<s-taspri-posix.ads \ + g-sercom.adb<g-sercom-linux.adb \ system.ads<system-linux-ia64.ads TOOLS_TARGET_PAIRS = \ @@ -1545,6 +1548,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) s-tasinf.adb<s-tasinf-linux.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ s-taspri.ads<s-taspri-posix.ads \ + g-sercom.adb<g-sercom-linux.adb \ system.ads<system-linux-x86_64.ads TOOLS_TARGET_PAIRS = \ diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 7ae4388..9eaa707 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -360,6 +360,7 @@ GNATRTL_NONTASKING_OBJS= \ g-rannum$(objext) \ g-regexp$(objext) \ g-regpat$(objext) \ + g-sercom$(objext) \ g-sestin$(objext) \ g-sha1$(objext) \ g-soccon$(objext) \ diff --git a/gcc/ada/g-sercom-linux.adb b/gcc/ada/g-sercom-linux.adb new file mode 100644 index 0000000..bcb5952 --- /dev/null +++ b/gcc/ada/g-sercom-linux.adb @@ -0,0 +1,289 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- 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- -- +-- 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 is the GNU/Linux implementation of this package + +with Ada.Streams; use Ada.Streams; +with Ada; use Ada; +with Ada.Unchecked_Deallocation; + +with System.CRTL; use System, System.CRTL; + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package body GNAT.Serial_Communications is + + type Port_Data is new int; + + subtype unsigned is Interfaces.C.unsigned; + subtype char is Interfaces.C.char; + subtype unsigned_char is Interfaces.C.unsigned_char; + + function fcntl (fd : int; cmd : int; value : int) return int; + pragma Import (C, fcntl, "fcntl"); + + O_RDWR : constant := 8#02#; + O_NOCTTY : constant := 8#0400#; + O_NDELAY : constant := 8#04000#; + FNDELAY : constant := O_NDELAY; + F_SETFL : constant := 4; + TCSANOW : constant := 0; + TCIFLUSH : constant := 0; + CLOCAL : constant := 8#04000#; + CREAD : constant := 8#0200#; + CSTOPB : constant := 8#0100#; + CRTSCTS : constant := 8#020000000000#; + + -- c_cc indexes + + VTIME : constant := 5; + 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#); + + C_Bits : constant array (Data_Bits) of unsigned := + (B7 => 8#040#, B8 => 8#060#); + + procedure Raise_Error (Message : String; Error : Integer := Errno); + pragma No_Return (Raise_Error); + + ---------- + -- Name -- + ---------- + + function Name (Number : Positive) return Port_Name is + N : constant Natural := Number - 1; + N_Img : constant String := Natural'Image (N); + begin + return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last)); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (Port : out Serial_Port; + Name : Port_Name) + is + C_Name : constant String := String (Name) & ASCII.NUL; + Res : int; + + begin + if Port.H = null then + Port.H := new Port_Data; + end if; + + Port.H.all := Port_Data (open + (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY))); + + if Port.H.all = -1 then + Raise_Error ("open: open failed"); + end if; + + -- By default we are in blocking mode + + Res := fcntl (int (Port.H.all), F_SETFL, 0); + + if Res = -1 then + Raise_Error ("open: fcntl failed"); + end if; + end Open; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error (Message : String; Error : Integer := Errno) is + begin + raise Serial_Error with Message & " (" & Integer'Image (Error) & ')'; + end Raise_Error; + + ---------- + -- Read -- + ---------- + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Len : constant int := Buffer'Length; + Res : int; + + begin + if Port.H = null then + Raise_Error ("read: port not opened", 0); + end if; + + Res := read (Integer (Port.H.all), Buffer'Address, Len); + + if Res = -1 then + Last := 0; + Raise_Error ("read failed"); + else + Last := Buffer'First + Stream_Element_Offset (Res) - 1; + end if; + end Read; + + --------- + -- Set -- + --------- + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := B8; + Block : Boolean := True; + Timeout : Integer := 10) + is + use type unsigned; + + type termios is record + c_iflag : unsigned; + c_oflag : unsigned; + c_cflag : unsigned; + c_lflag : unsigned; + c_line : unsigned_char; + c_cc : Interfaces.C.char_array (0 .. 31); + c_ispeed : unsigned; + c_ospeed : unsigned; + end record; + pragma Convention (C, termios); + + function tcgetattr (fd : int; termios_p : Address) return int; + pragma Import (C, tcgetattr, "tcgetattr"); + + function tcsetattr + (fd : int; action : int; termios_p : Address) return int; + pragma Import (C, tcsetattr, "tcsetattr"); + + function tcflush (fd : int; queue_selector : int) return int; + pragma Import (C, tcflush, "tcflush"); + + Current : termios; + Res : int; + + begin + if Port.H = null then + Raise_Error ("set: port not opened", 0); + end if; + + -- Get current port settings + + Res := tcgetattr (int (Port.H.all), Current'Address); + + -- Change settings now + + Current.c_cflag := C_Data_Rate (Rate) + or C_Bits (Bits) + or CLOCAL + or CREAD + or CSTOPB + or CRTSCTS; + Current.c_lflag := 0; + Current.c_iflag := 0; + Current.c_oflag := 0; + 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); + + -- Set port settings + + Res := tcflush (int (Port.H.all), TCIFLUSH); + Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address); + + -- Block + + if Block then + Res := fcntl (int (Port.H.all), F_SETFL, 0); + else + Res := fcntl (int (Port.H.all), F_SETFL, FNDELAY); + end if; + + if Res = -1 then + Raise_Error ("set: fcntl failed"); + end if; + end Set; + + ----------- + -- Write -- + ----------- + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Stream_Element_Array) + is + Len : constant int := Buffer'Length; + Res : int; + + begin + if Port.H = null then + Raise_Error ("write: port not opened", 0); + end if; + + Res := write (int (Port.H.all), Buffer'Address, Len); + pragma Assert (Res = Len); + + if Res = -1 then + Raise_Error ("write failed"); + end if; + end Write; + + ----------- + -- Close -- + ----------- + + procedure Close (Port : in out Serial_Port) is + procedure Unchecked_Free is + new Unchecked_Deallocation (Port_Data, Port_Data_Access); + + Res : int; + pragma Unreferenced (Res); + + begin + if Port.H /= null then + Res := close (int (Port.H.all)); + Unchecked_Free (Port.H); + end if; + end Close; + +end GNAT.Serial_Communications; diff --git a/gcc/ada/g-sercom-mingw.adb b/gcc/ada/g-sercom-mingw.adb new file mode 100644 index 0000000..5cb6e45 --- /dev/null +++ b/gcc/ada/g-sercom-mingw.adb @@ -0,0 +1,413 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- 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- -- +-- 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 is the Windows implementation of this package + +with Ada.Unchecked_Deallocation; use Ada; +with Ada.Streams; use Ada.Streams; +with System; use System; + +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; + + ----------- + -- 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); + + ----------- + -- Close -- + ----------- + + procedure Close (Port : in out Serial_Port) is + procedure Unchecked_Free is + new Unchecked_Deallocation (Port_Data, Port_Data_Access); + + Success : BOOL; + + begin + if Port.H /= null then + Success := CloseHandle (HANDLE (Port.H.all)); + Unchecked_Free (Port.H); + if not Success then + Raise_Error ("error closing the port"); + end if; + end if; + end Close; + + ---------- + -- Name -- + ---------- + + function Name (Number : Positive) return Port_Name is + N_Img : constant String := Positive'Image (Number); + begin + return Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':'); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (Port : out Serial_Port; + Name : Port_Name) + is + C_Name : constant String := String (Name) & ASCII.NUL; + Success : BOOL; + pragma Unreferenced (Success); + + begin + if Port.H = null then + Port.H := new Port_Data; + else + Success := CloseHandle (HANDLE (Port.H.all)); + end if; + + Port.H.all := Port_Data (CreateFile + (lpFileName => C_Name (C_Name'First)'Address, + dwDesiredAccess => GENERIC_READ or GENERIC_WRITE, + dwShareMode => 0, + lpSecurityAttributes => null, + DwCreationDisposition => OPEN_EXISTING, + dwFlagsAndAttributes => 0, + HTemplateFile => 0)); + + if Port.H.all = 0 then + Raise_Error ("cannot open com port"); + end if; + end Open; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is + begin + raise Serial_Error with Message & " (" & DWORD'Image (Error) & ')'; + end Raise_Error; + + ---------- + -- Read -- + ---------- + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Success : BOOL; + Read_Last : aliased DWORD; + + begin + if Port.H = null then + 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); + + if not Success then + Raise_Error ("read error"); + end if; + + Last := Buffer'First - 1 + Stream_Element_Offset (Read_Last); + end Read; + + --------- + -- Set -- + --------- + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := B8; + Block : Boolean := True; + Timeout : Integer := 10) + is + Success : BOOL; + Com_Time_Out : aliased COMMTIMEOUTS; + Com_Settings : aliased DCB; + + begin + if Port.H = null then + Raise_Error ("set: port not opened", 0); + end if; + + Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access); + + if not Success then + Success := CloseHandle (HANDLE (Port.H.all)); + Port.H.all := 0; + Raise_Error ("set: cannot get comm state"); + end if; + + Com_Settings.BaudRate := DWORD (Data_Rate_Value (Rate)); + Com_Settings.fParity := 1; + Com_Settings.fOutxCtsFlow := 0; + Com_Settings.fOutxDsrFlow := 0; + Com_Settings.fDsrSensitivity := 0; + Com_Settings.fDtrControl := DTR_CONTROL_DISABLE; + Com_Settings.fOutX := 0; + 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; + + Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access); + + if not Success then + Success := CloseHandle (HANDLE (Port.H.all)); + Port.H.all := 0; + Raise_Error ("cannot set comm state"); + end if; + + -- Set the timeout status + + if Block then + Com_Time_Out := (others => 0); + else + Com_Time_Out := + (ReadTotalTimeoutConstant => DWORD (1000 * Timeout), + others => 0); + end if; + + Success := SetCommTimeouts + (hFile => HANDLE (Port.H.all), + lpCommTimeouts => Com_Time_Out'Access); + + if not Success then + Raise_Error ("cannot set the timeout"); + end if; + end Set; + + ----------- + -- Write -- + ----------- + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Stream_Element_Array) + is + Success : BOOL; + Temp_Last : aliased DWORD; + + begin + if Port.H = null then + 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); + + if not Boolean (Success) + or else Stream_Element_Offset (Temp_Last) /= Buffer'Length + then + Raise_Error ("failed to write data"); + end if; + end Write; + +end GNAT.Serial_Communications; diff --git a/gcc/ada/g-sercom.adb b/gcc/ada/g-sercom.adb new file mode 100644 index 0000000..920557b --- /dev/null +++ b/gcc/ada/g-sercom.adb @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007, 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- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Default version of this package + +with Ada.Streams; use Ada.Streams; + +package body GNAT.Serial_Communications is + + pragma Warnings (Off); + -- Kill warnings on unreferenced formals + + type Port_Data is new Integer; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Unimplemented; + pragma No_Return (Unimplemented); + -- This procedure raises a Program_Error with an appropriate message + -- indicating that an unimplemented feature has been used. + + ---------- + -- Name -- + ---------- + + function Name (Number : Positive) return Port_Name is + begin + Unimplemented; + return ""; + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (Port : out Serial_Port; + Name : Port_Name) is + begin + Unimplemented; + end Open; + + --------- + -- Set -- + --------- + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := B8; + Block : Boolean := True; + Timeout : Integer := 10) is + begin + Unimplemented; + end Set; + + ---------- + -- Read -- + ---------- + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset) is + begin + Unimplemented; + end Read; + + ----------- + -- Write -- + ----------- + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Stream_Element_Array) is + begin + Unimplemented; + end Write; + + ----------- + -- Close -- + ----------- + + procedure Close (Port : in out Serial_Port) is + begin + Unimplemented; + end Close; + + ------------------- + -- Unimplemented; -- + ------------------- + + procedure Unimplemented is + begin + raise Program_Error + with "Serial_Communications not implemented"; + end Unimplemented; + +end GNAT.Serial_Communications; diff --git a/gcc/ada/g-sercom.ads b/gcc/ada/g-sercom.ads new file mode 100644 index 0000000..bbd8f91 --- /dev/null +++ b/gcc/ada/g-sercom.ads @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007, 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- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Serial communications package, implemented on Windows and GNU/Linux + +with Ada.Streams; +with Interfaces.C; + +package GNAT.Serial_Communications is + + Serial_Error : exception; + -- Raised when a communication problem occurs + + type Port_Name is new String; + -- A serial com port name + + 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); + -- Speed of the communication + + type Data_Bits is (B8, B7); + -- Communication bits + + type Serial_Port is new Ada.Streams.Root_Stream_Type with private; + + procedure Open + (Port : out Serial_Port; + Name : Port_Name); + -- Open the given port name. Raises Serial_Error if the port cannot be + -- opened. + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := B8; + Block : Boolean := True; + Timeout : Integer := 10); + -- 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. + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Read a set of bytes, put result into Buffer and set Last accordingly. + -- Last is set to 0 if no byte has been read. + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Ada.Streams.Stream_Element_Array); + -- Write buffer into the port + + procedure Close (Port : in out Serial_Port); + -- Close port + +private + + type Port_Data; + type Port_Data_Access is access Port_Data; + + type Serial_Port is new Ada.Streams.Root_Stream_Type with record + H : Port_Data_Access; + 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); + +end GNAT.Serial_Communications; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index f9b1b2d..bf85def 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -42,13 +42,14 @@ package body Impunit is -- Ada 95 Units -- ------------------ - -- The following is a giant string list containing the names of all - -- non-implementation internal files, i.e. the complete list of files for + -- The following is a giant string list containing the names of all non- + -- implementation internal files, i.e. the complete list of files for -- internal units which a program may legitimately WITH when operating in -- either Ada 95 or Ada 05 mode. -- Note that this list should match the list of units documented in the - -- "GNAT Library" section of the GNAT Reference Manual. + -- "GNAT Library" section of the GNAT Reference Manual. A unit listed here + -- must either be documented in that section or described in the Ada RM. Non_Imp_File_Names_95 : constant File_List := ( @@ -160,7 +161,6 @@ package body Impunit is "a-ssicst", -- Ada.Streams.Stream_IO.C_Streams "a-suteio", -- Ada.Strings.Unbounded.Text_IO "a-swuwti", -- Ada.Strings.Wide_Unbounded.Wide_Text_IO - "a-taidim", -- Ada.Task_Identification.Image "a-tiocst", -- Ada.Text_IO.C_Streams "a-wtcstr", -- Ada.Wide_Text_IO.C_Streams @@ -175,14 +175,13 @@ package body Impunit is -- GNAT Special IO Units -- --------------------------- - -- As further explained elsewhere (see Sem_Ch10), the internal - -- packages of Text_IO and Wide_Text_IO are actually implemented - -- as separate children, but this fact is intended to be hidden - -- from the user completely. Any attempt to WITH one of these - -- units will be diagnosed as an error later on, but for now we - -- do not consider these internal implementation units (if we did, - -- then we would get a junk warning which would be confusing and - -- unecessary, given that we generate a clear error message). + -- As further explained elsewhere (see Sem_Ch10), the internal packages of + -- Text_IO and Wide_Text_IO are actually implemented as separate children, + -- but this fact is intended to be hidden from the user completely. Any + -- attempt to WITH one of these units will be diagnosed as an error later + -- on, but for now we do not consider these internal implementation units + -- (if we did, then we would get a junk warning which would be confusing + -- and unecessary, given that we generate a clear error message). "a-tideio", -- Ada.Text_IO.Decimal_IO "a-tienio", -- Ada.Text_IO.Enumeration_IO @@ -259,6 +258,7 @@ package body Impunit is "g-regist", -- GNAT.Registry "g-regpat", -- GNAT.Regpat "g-semaph", -- GNAT.Semaphores + "g-sercom", -- GNAT.Serial_Communications "g-sestin", -- GNAT.Secondary_Stack_Info "g-sha1 ", -- GNAT.SHA1 "g-signal", -- GNAT.Signals @@ -282,8 +282,6 @@ package body Impunit is "g-u3spch", -- GNAT.UTF_32_Spelling_Checker "g-wispch", -- GNAT.Wide_Spelling_Checker "g-wistsp", -- GNAT.Wide_String_Split - "g-zspche", -- GNAT.Wide_Wide_Spelling_Checker - "g-zstspl", -- GNAT.Wide_Wide_String_Split ----------------------------------------------------- -- Interface Hierarchy Units from Reference Manual -- diff --git a/gcc/ada/s-crtl.ads b/gcc/ada/s-crtl.ads index 30bca62..4ab0e7d 100644 --- a/gcc/ada/s-crtl.ads +++ b/gcc/ada/s-crtl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2007, 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- -- @@ -148,9 +148,6 @@ package System.CRTL is function popen (command, mode : System.Address) return System.Address; pragma Import (C, popen, "popen"); - function read (fd : int; buffer : chars; nbytes : int) return int; - pragma Import (C, read, "read"); - function realloc (Ptr : System.Address; Size : size_t) return System.Address; pragma Import (C, realloc, "realloc"); @@ -181,6 +178,15 @@ package System.CRTL is function unlink (filename : chars) return int; pragma Import (C, unlink, "unlink"); + function open (filename : chars; oflag : int) return int; + pragma Import (C, open, "open"); + + function close (fd : int) return int; + pragma Import (C, close, "close"); + + function read (fd : int; buffer : chars; nbytes : int) return int; + pragma Import (C, read, "read"); + function write (fd : int; buffer : chars; nbytes : int) return int; pragma Import (C, write, "write"); |