source: branches/qres/ccl/library/serial-streams.lisp @ 15278

Last change on this file since 15278 was 14049, checked in by gz, 9 years ago

Misc tweaks and fixes from trunk (r13550,r13560,r13568,r13569,r13581,r13583,r13633-13636,r13647,r13648,r13657-r13659,r13675,r13678,r13688,r13743,r13744,r13769,r13773,r13782,r13813,r13814,r13869,r13870,r13873,r13901,r13930,r13943,r13946,r13954,r13961,r13974,r13975,r13978,r13990,r14010,r14012,r14020,r14028-r14030)

File size: 9.0 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20;;; Real (RS-232) serial devices are pretty rare these days;
21;;; USB to serial devices are fairly common.
22
23(defclass serial-stream (fd-stream
24                         buffered-binary-io-stream-mixin
25                         buffered-character-io-stream-mixin)
26    ())
27
28(defmethod select-stream-class ((s serial-stream) in-p out-p char-p)
29  (declare (ignore in-p out-p char-p))
30  'serial-stream)
31
32
33(defun ttyname (fd)
34  (let* ((p (#_ttyname fd)))
35    (if (%null-ptr-p p)
36      "<unknown>"
37      (%get-cstring p))))
38
39(defvar *baud-rates*
40  '((50 . #.#$B50)
41    (75 . #.#$B75)
42    (110 . #.#$B110)
43    (134 . #.#$B134)
44    (150 . #.#$B150)
45    (200 . #.#$B200)
46    (300 . #.#$B300)
47    (600 . #.#$B600)
48    (1200 . #.#$B1200)
49    (1800 . #.#$B1800)
50    (2400 . #.#$B2400)
51    (4800 . #.#$B4800)
52    (9600 . #.#$B9600)
53    (19200 . #.#$B19200)
54    (38400 . #.#$B38400)
55    (57600 . #.#$B57600)
56    (115200 . #.#$B115200)
57    (230400 . #.#$B230400)
58    ;; It's the world's most advanced Operating System!
59    #-darwin-target
60    (460800 . #.#$B460800)))
61
62(defun encode-baud-rate (rate)
63  (or (cdr (assoc rate *baud-rates*))
64      (error "Unsupported baud rate - ~s." rate)))
65
66;;; There are supposedly ~60 flags that can be set in a termios
67;;; structure; this only allows a few of them to be set explicitly,
68;;; and is otherwise oriented towards "communicating with a device
69;;; via a serial port" rather than "comminicating with a user via
70;;; a serial port."
71(defun setup-serial-device (fd &key (baud-rate nil baud-rate-p)
72                               (parity nil parity-p)
73                               (char-bits nil char-bits-p)
74                               (stop-bits nil stop-bits-p)
75                               (flow-control nil flow-control-p)
76                               &allow-other-keys)
77  (rlet ((settings :termios))
78    (flet ((check-error (result operation)
79             (if (< result 0)
80               (error "Error trying to ~a for fd ~d : ~a" operation fd (%strerror (%get-errno)))
81               result)))
82      (check-error (#_tcgetattr fd settings) "get serial settings")
83      (let* ((orig-cflag (pref settings :termios.c_cflag))
84             (cflag orig-cflag)
85             (orig-iflag (pref settings :termios.c_cflag))
86             (iflag orig-iflag)
87             (orig-oflag (pref settings :termios.c_oflag))
88             (oflag orig-oflag)
89             (orig-lflag (pref settings :termios.c_lflag))
90             (lflag orig-lflag))
91        ;; Inhibit input/output translation/canonicalization
92        (setq oflag 0)
93        (setq iflag (logandc2 iflag
94                              (logior #$IGNBRK #$BRKINT #$ICRNL
95                                      #$INLCR #$PARMRK #$INPCK #$ISTRIP)))
96        (setq lflag (logandc2 lflag
97                              (logior #$ECHO #$ECHONL #$ICANON #$IEXTEN #$ISIG)))
98        (when baud-rate-p
99          (check-error (#_cfsetspeed settings (encode-baud-rate baud-rate))
100                       "set baud rate"))
101
102        (when parity-p
103          (setq cflag
104                (ecase parity
105                  (:even (logior #$PARENB (logandc2 cflag #$PARODD)))
106                  (:odd  (logior #$PARENB (logior cflag #$PARODD)))
107                  ((:none nil) (logandc2 cflag #$PARENB)))))
108        (when char-bits-p
109          (setq cflag
110                (logior (logandc2 cflag #$CSIZE)
111                        (ecase char-bits
112                          (5 #$CS5)
113                          (6 #$CS6)
114                          (7 #$CS7)
115                          (8 #$CS8)))))
116        (when flow-control-p
117          (setq iflag (logandc2 iflag (logior #$IXON #$IXOFF))
118                cflag (logandc2 cflag #$CRTSCTS))
119         
120          (ecase flow-control
121            ((:hardware :rts/cts) (setq cflag (logior cflag #$CRTSCTS)))
122            ((:software :xon/xoff) (setq iflag (logior iflag #$IXON #$IXOFF)))
123            ((:none nil))))
124        (when stop-bits-p
125          (setq cflag
126                (ecase stop-bits
127                  (1 (logandc2 cflag #$CSTOPB))
128                  (2 (logior cflag #$CSTOPB)))))
129        (unless (eql cflag orig-cflag)
130          (setf (pref settings :termios.c_cflag) cflag))
131        (unless (eql iflag orig-iflag)
132          (setf (pref settings :termios.c_iflag) iflag))
133        (unless (eq lflag orig-lflag)
134          (setf (pref settings :termios.c_lflag) lflag))
135        (unless (eq oflag orig-oflag)
136          (setf (pref settings :termios.c_lflag) oflag))
137        (check-error (#_tcsetattr fd #$TCSANOW settings) "set serial settings")))))
138
139(defmethod setup-serial-stream ((s serial-stream) &rest initargs)
140  (apply #'setup-serial-device (stream-device s :input) initargs))
141     
142
143(defun get-serial-attributes (fd)
144  (flet ((check-error (result operation)
145           (if (< result 0)
146             (error "Error trying to ~a for fd ~d : ~a" operation fd (%strerror (%get-errno)))
147             result)))
148    (rlet ((settings :termios))
149      (check-error (#_tcgetattr fd settings) "get serial attributes")
150      (let* ((cflag (pref settings :termios.c_cflag)))
151        (values
152         (car (rassoc
153                   (check-error (#_cfgetispeed settings) "determine baud rate")
154                   *baud-rates*))
155         (if (logtest #$PARENB cflag)
156                (if (logtest #$PARODD cflag)
157                  :odd
158                  :even)
159                :none)
160         (case (logand #$CSIZE cflag)
161                (#.#$CS5 5)
162                (#.#$CS6 6)
163                (#.#$CS7 7)
164                (#.#$CS8 8))
165         (if (logtest cflag #$CSTOPB)
166                2
167                1)
168         (if (logtest cflag #$CRTSCTS)
169           :rts/cts
170           (if (logtest (pref settings :termios.c_iflag)
171                        (logior #$IXON #$IXOFF))
172             :xon/xoff
173             :none)))))))
174
175(defmethod print-object ((s fd-stream) out)
176  (print-unreadable-object (s out :type t :identity t)
177    (let* ((ioblock (stream-ioblock s nil))
178           (fd (and ioblock (ioblock-device ioblock)))
179           (encoding (and ioblock (encoding-name (ioblock-encoding ioblock)))))
180      (if fd
181        (multiple-value-bind (baud parity char-bits stop-bits flow-control)
182            (ignore-errors (get-serial-attributes fd))
183          (format out "~s (~a [~d]) ~d,~c~d~d ~a"
184                  encoding
185                  (ttyname fd)
186                  fd
187                  baud
188                  (case parity
189                    (:even #\E)
190                    (:odd #\O)
191                    (t #\N))
192                  char-bits
193                  stop-bits
194                  (string-downcase flow-control)))
195        (format out "~s" :closed)))))
196
197(defun make-serial-stream (device-name
198                           &rest initargs
199                           &key (format :bivalent)
200                           external-format
201                           (class 'serial-stream)
202                           sharing
203                           (basic nil)
204                           (auto-close t)
205                           input-timeout
206                           output-timeout
207                           deadline
208                           &allow-other-keys)
209 
210  (let* ((external-format (normalize-external-format t external-format))
211         (element-type (ecase format
212                         ((nil :text) 'character)
213                         ((:binary :bivalent) '(unsigned-byte 8))))
214         (fd (fd-open device-name (logior #$O_RDWR #$O_NOCTTY))))
215    (when (< fd 0)
216      (error "Error opening ~s: ~a" device-name (%strerror (%get-errno))))
217    (unless (isatty fd)
218      (fd-close fd)
219      (error "Not a serial device: ~s." device-name))
220    (let* ((stream (make-fd-stream fd
221                                   :class class
222                                   :direction :io
223                                   :element-type element-type
224                                   :sharing sharing
225                                   :character-p (not (eq format :binary))
226                                   :encoding (external-format-character-encoding external-format)
227                                   :line-termination (external-format-line-termination external-format)
228                                   :basic basic
229                                   :auto-close auto-close
230                                   :input-timeout input-timeout
231                                   :output-timeout output-timeout
232                                   :deadline deadline)))
233      (apply #'setup-serial-stream stream initargs)
234      stream)))
Note: See TracBrowser for help on using the repository browser.