1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2007-2013, AdaCore -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This is the GNU/Linux implementation of this package 33 34with Ada.Streams; use Ada.Streams; 35with Ada; use Ada; 36with Ada.Unchecked_Deallocation; 37 38with System; use System; 39with System.Communication; use System.Communication; 40with System.CRTL; use System.CRTL; 41with System.OS_Constants; 42 43with GNAT.OS_Lib; use GNAT.OS_Lib; 44 45package body GNAT.Serial_Communications is 46 47 package OSC renames System.OS_Constants; 48 49 use type Interfaces.C.unsigned; 50 51 type Port_Data is new int; 52 53 subtype unsigned is Interfaces.C.unsigned; 54 subtype char is Interfaces.C.char; 55 subtype unsigned_char is Interfaces.C.unsigned_char; 56 57 function fcntl (fd : int; cmd : int; value : int) return int; 58 pragma Import (C, fcntl, "fcntl"); 59 60 C_Data_Rate : constant array (Data_Rate) of unsigned := 61 (B1200 => OSC.B1200, 62 B2400 => OSC.B2400, 63 B4800 => OSC.B4800, 64 B9600 => OSC.B9600, 65 B19200 => OSC.B19200, 66 B38400 => OSC.B38400, 67 B57600 => OSC.B57600, 68 B115200 => OSC.B115200); 69 70 C_Bits : constant array (Data_Bits) of unsigned := 71 (CS7 => OSC.CS7, CS8 => OSC.CS8); 72 73 C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned := 74 (One => 0, Two => OSC.CSTOPB); 75 76 C_Parity : constant array (Parity_Check) of unsigned := 77 (None => 0, 78 Odd => OSC.PARENB or OSC.PARODD, 79 Even => OSC.PARENB); 80 81 procedure Raise_Error (Message : String; Error : Integer := Errno); 82 pragma No_Return (Raise_Error); 83 84 ---------- 85 -- Name -- 86 ---------- 87 88 function Name (Number : Positive) return Port_Name is 89 N : constant Natural := Number - 1; 90 N_Img : constant String := Natural'Image (N); 91 begin 92 return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last)); 93 end Name; 94 95 ---------- 96 -- Open -- 97 ---------- 98 99 procedure Open 100 (Port : out Serial_Port; 101 Name : Port_Name) 102 is 103 use OSC; 104 105 C_Name : constant String := String (Name) & ASCII.NUL; 106 Res : int; 107 108 begin 109 if Port.H = null then 110 Port.H := new Port_Data; 111 end if; 112 113 Port.H.all := Port_Data (open 114 (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY))); 115 116 if Port.H.all = -1 then 117 Raise_Error ("open: open failed"); 118 end if; 119 120 -- By default we are in blocking mode 121 122 Res := fcntl (int (Port.H.all), F_SETFL, 0); 123 124 if Res = -1 then 125 Raise_Error ("open: fcntl failed"); 126 end if; 127 end Open; 128 129 ----------------- 130 -- Raise_Error -- 131 ----------------- 132 133 procedure Raise_Error (Message : String; Error : Integer := Errno) is 134 begin 135 raise Serial_Error with Message 136 & (if Error /= 0 137 then " (" & Errno_Message (Err => Error) & ')' 138 else ""); 139 end Raise_Error; 140 141 ---------- 142 -- Read -- 143 ---------- 144 145 overriding procedure Read 146 (Port : in out Serial_Port; 147 Buffer : out Stream_Element_Array; 148 Last : out Stream_Element_Offset) 149 is 150 Len : constant size_t := Buffer'Length; 151 Res : ssize_t; 152 153 begin 154 if Port.H = null then 155 Raise_Error ("read: port not opened", 0); 156 end if; 157 158 Res := read (Integer (Port.H.all), Buffer'Address, Len); 159 160 if Res = -1 then 161 Raise_Error ("read failed"); 162 end if; 163 164 Last := Last_Index (Buffer'First, size_t (Res)); 165 end Read; 166 167 --------- 168 -- Set -- 169 --------- 170 171 procedure Set 172 (Port : Serial_Port; 173 Rate : Data_Rate := B9600; 174 Bits : Data_Bits := CS8; 175 Stop_Bits : Stop_Bits_Number := One; 176 Parity : Parity_Check := None; 177 Block : Boolean := True; 178 Local : Boolean := True; 179 Flow : Flow_Control := None; 180 Timeout : Duration := 10.0) 181 is 182 use OSC; 183 184 type termios is record 185 c_iflag : unsigned; 186 c_oflag : unsigned; 187 c_cflag : unsigned; 188 c_lflag : unsigned; 189 c_line : unsigned_char; 190 c_cc : Interfaces.C.char_array (0 .. 31); 191 c_ispeed : unsigned; 192 c_ospeed : unsigned; 193 end record; 194 pragma Convention (C, termios); 195 196 function tcgetattr (fd : int; termios_p : Address) return int; 197 pragma Import (C, tcgetattr, "tcgetattr"); 198 199 function tcsetattr 200 (fd : int; action : int; termios_p : Address) return int; 201 pragma Import (C, tcsetattr, "tcsetattr"); 202 203 function tcflush (fd : int; queue_selector : int) return int; 204 pragma Import (C, tcflush, "tcflush"); 205 206 Current : termios; 207 208 Res : int; 209 pragma Warnings (Off, Res); 210 -- Warnings off, since we don't always test the result 211 212 begin 213 if Port.H = null then 214 Raise_Error ("set: port not opened", 0); 215 end if; 216 217 -- Get current port settings 218 219 Res := tcgetattr (int (Port.H.all), Current'Address); 220 221 -- Change settings now 222 223 Current.c_cflag := C_Data_Rate (Rate) 224 or C_Bits (Bits) 225 or C_Stop_Bits (Stop_Bits) 226 or C_Parity (Parity) 227 or CREAD; 228 Current.c_iflag := 0; 229 Current.c_lflag := 0; 230 Current.c_oflag := 0; 231 232 if Local then 233 Current.c_cflag := Current.c_cflag or CLOCAL; 234 end if; 235 236 case Flow is 237 when None => 238 null; 239 when RTS_CTS => 240 Current.c_cflag := Current.c_cflag or CRTSCTS; 241 when Xon_Xoff => 242 Current.c_iflag := Current.c_iflag or IXON; 243 end case; 244 245 Current.c_ispeed := Data_Rate_Value (Rate); 246 Current.c_ospeed := Data_Rate_Value (Rate); 247 Current.c_cc (VMIN) := char'Val (0); 248 Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10)); 249 250 -- Set port settings 251 252 Res := tcflush (int (Port.H.all), TCIFLUSH); 253 Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address); 254 255 -- Block 256 257 Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY)); 258 259 if Res = -1 then 260 Raise_Error ("set: fcntl failed"); 261 end if; 262 end Set; 263 264 ----------- 265 -- Write -- 266 ----------- 267 268 overriding procedure Write 269 (Port : in out Serial_Port; 270 Buffer : Stream_Element_Array) 271 is 272 Len : constant size_t := Buffer'Length; 273 Res : ssize_t; 274 275 begin 276 if Port.H = null then 277 Raise_Error ("write: port not opened", 0); 278 end if; 279 280 Res := write (int (Port.H.all), Buffer'Address, Len); 281 282 if Res = -1 then 283 Raise_Error ("write failed"); 284 end if; 285 286 pragma Assert (size_t (Res) = Len); 287 end Write; 288 289 ----------- 290 -- Close -- 291 ----------- 292 293 procedure Close (Port : in out Serial_Port) is 294 procedure Unchecked_Free is 295 new Unchecked_Deallocation (Port_Data, Port_Data_Access); 296 297 Res : int; 298 pragma Unreferenced (Res); 299 300 begin 301 if Port.H /= null then 302 Res := close (int (Port.H.all)); 303 Unchecked_Free (Port.H); 304 end if; 305 end Close; 306 307end GNAT.Serial_Communications; 308