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-2015, 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 (B75 => OSC.B75, 62 B110 => OSC.B110, 63 B150 => OSC.B150, 64 B300 => OSC.B300, 65 B600 => OSC.B600, 66 B1200 => OSC.B1200, 67 B2400 => OSC.B2400, 68 B4800 => OSC.B4800, 69 B9600 => OSC.B9600, 70 B19200 => OSC.B19200, 71 B38400 => OSC.B38400, 72 B57600 => OSC.B57600, 73 B115200 => OSC.B115200); 74 75 C_Bits : constant array (Data_Bits) of unsigned := 76 (CS7 => OSC.CS7, CS8 => OSC.CS8); 77 78 C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned := 79 (One => 0, Two => OSC.CSTOPB); 80 81 C_Parity : constant array (Parity_Check) of unsigned := 82 (None => 0, 83 Odd => OSC.PARENB or OSC.PARODD, 84 Even => OSC.PARENB); 85 86 procedure Raise_Error (Message : String; Error : Integer := Errno); 87 pragma No_Return (Raise_Error); 88 89 ---------- 90 -- Name -- 91 ---------- 92 93 function Name (Number : Positive) return Port_Name is 94 N : constant Natural := Number - 1; 95 N_Img : constant String := Natural'Image (N); 96 begin 97 return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last)); 98 end Name; 99 100 ---------- 101 -- Open -- 102 ---------- 103 104 procedure Open 105 (Port : out Serial_Port; 106 Name : Port_Name) 107 is 108 use OSC; 109 110 C_Name : constant String := String (Name) & ASCII.NUL; 111 Res : int; 112 113 begin 114 if Port.H = null then 115 Port.H := new Port_Data; 116 end if; 117 118 Port.H.all := Port_Data (open 119 (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY))); 120 121 if Port.H.all = -1 then 122 Raise_Error ("open: open failed"); 123 end if; 124 125 -- By default we are in blocking mode 126 127 Res := fcntl (int (Port.H.all), F_SETFL, 0); 128 129 if Res = -1 then 130 Raise_Error ("open: fcntl failed"); 131 end if; 132 end Open; 133 134 ----------------- 135 -- Raise_Error -- 136 ----------------- 137 138 procedure Raise_Error (Message : String; Error : Integer := Errno) is 139 begin 140 raise Serial_Error with Message 141 & (if Error /= 0 142 then " (" & Errno_Message (Err => Error) & ')' 143 else ""); 144 end Raise_Error; 145 146 ---------- 147 -- Read -- 148 ---------- 149 150 overriding procedure Read 151 (Port : in out Serial_Port; 152 Buffer : out Stream_Element_Array; 153 Last : out Stream_Element_Offset) 154 is 155 Len : constant size_t := Buffer'Length; 156 Res : ssize_t; 157 158 begin 159 if Port.H = null then 160 Raise_Error ("read: port not opened", 0); 161 end if; 162 163 Res := read (Integer (Port.H.all), Buffer'Address, Len); 164 165 if Res = -1 then 166 Raise_Error ("read failed"); 167 end if; 168 169 Last := Last_Index (Buffer'First, size_t (Res)); 170 end Read; 171 172 --------- 173 -- Set -- 174 --------- 175 176 procedure Set 177 (Port : Serial_Port; 178 Rate : Data_Rate := B9600; 179 Bits : Data_Bits := CS8; 180 Stop_Bits : Stop_Bits_Number := One; 181 Parity : Parity_Check := None; 182 Block : Boolean := True; 183 Local : Boolean := True; 184 Flow : Flow_Control := None; 185 Timeout : Duration := 10.0) 186 is 187 use OSC; 188 189 type termios is record 190 c_iflag : unsigned; 191 c_oflag : unsigned; 192 c_cflag : unsigned; 193 c_lflag : unsigned; 194 c_line : unsigned_char; 195 c_cc : Interfaces.C.char_array (0 .. 31); 196 c_ispeed : unsigned; 197 c_ospeed : unsigned; 198 end record; 199 pragma Convention (C, termios); 200 201 function tcgetattr (fd : int; termios_p : Address) return int; 202 pragma Import (C, tcgetattr, "tcgetattr"); 203 204 function tcsetattr 205 (fd : int; action : int; termios_p : Address) return int; 206 pragma Import (C, tcsetattr, "tcsetattr"); 207 208 function tcflush (fd : int; queue_selector : int) return int; 209 pragma Import (C, tcflush, "tcflush"); 210 211 Current : termios; 212 213 Res : int; 214 pragma Warnings (Off, Res); 215 -- Warnings off, since we don't always test the result 216 217 begin 218 if Port.H = null then 219 Raise_Error ("set: port not opened", 0); 220 end if; 221 222 -- Get current port settings 223 224 Res := tcgetattr (int (Port.H.all), Current'Address); 225 226 -- Change settings now 227 228 Current.c_cflag := C_Data_Rate (Rate) 229 or C_Bits (Bits) 230 or C_Stop_Bits (Stop_Bits) 231 or C_Parity (Parity) 232 or CREAD; 233 Current.c_iflag := 0; 234 Current.c_lflag := 0; 235 Current.c_oflag := 0; 236 237 if Local then 238 Current.c_cflag := Current.c_cflag or CLOCAL; 239 end if; 240 241 case Flow is 242 when None => 243 null; 244 when RTS_CTS => 245 Current.c_cflag := Current.c_cflag or CRTSCTS; 246 when Xon_Xoff => 247 Current.c_iflag := Current.c_iflag or IXON; 248 end case; 249 250 Current.c_ispeed := Data_Rate_Value (Rate); 251 Current.c_ospeed := Data_Rate_Value (Rate); 252 Current.c_cc (VMIN) := char'Val (0); 253 Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10)); 254 255 -- Set port settings 256 257 Res := tcflush (int (Port.H.all), TCIFLUSH); 258 Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address); 259 260 -- Block 261 262 Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY)); 263 264 if Res = -1 then 265 Raise_Error ("set: fcntl failed"); 266 end if; 267 end Set; 268 269 ----------- 270 -- Write -- 271 ----------- 272 273 overriding procedure Write 274 (Port : in out Serial_Port; 275 Buffer : Stream_Element_Array) 276 is 277 Len : constant size_t := Buffer'Length; 278 Res : ssize_t; 279 280 begin 281 if Port.H = null then 282 Raise_Error ("write: port not opened", 0); 283 end if; 284 285 Res := write (int (Port.H.all), Buffer'Address, Len); 286 287 if Res = -1 then 288 Raise_Error ("write failed"); 289 end if; 290 291 pragma Assert (size_t (Res) = Len); 292 end Write; 293 294 ----------- 295 -- Close -- 296 ----------- 297 298 procedure Close (Port : in out Serial_Port) is 299 procedure Unchecked_Free is 300 new Unchecked_Deallocation (Port_Data, Port_Data_Access); 301 302 Res : int; 303 pragma Unreferenced (Res); 304 305 begin 306 if Port.H /= null then 307 Res := close (int (Port.H.all)); 308 Unchecked_Free (Port.H); 309 end if; 310 end Close; 311 312end GNAT.Serial_Communications; 313