├── .travis.yml ├── README.markdown ├── appveyor.yml ├── cserial-port.asd └── src ├── ffi-types-unix.lisp ├── gray.lisp ├── interfaces.lisp ├── main.lisp ├── package.lisp ├── posix.lisp └── win32.lisp /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | env: 5 | global: 6 | - PATH=~/.roswell/bin:$PATH 7 | - ROSWELL_BRANCH=release 8 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 9 | matrix: 10 | - LISP=sbcl-bin 11 | - LISP=ccl-bin 12 | 13 | os: 14 | - osx 15 | - linux 16 | 17 | #addons: 18 | # apt: 19 | # packages: 20 | # - libc6-i386 21 | 22 | install: 23 | - curl -L https://raw.githubusercontent.com/roswell/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh 24 | 25 | script: 26 | - ros -Q -l cserial-port.asd -e '(ql:quickload :cserial-port)' -e '(apropos "serial" :cserial-port)' 27 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # cserial-port 2 | 3 | [![Build Status](https://travis-ci.org/snmsts/cserial-port.svg?branch=master)](https://travis-ci.org/snmsts/cserial-port) 4 | [![Build status](https://ci.appveyor.com/api/projects/status/nq0k756e7baeh5gy?svg=true)](https://ci.appveyor.com/project/snmsts/cserial-port) 5 | 6 | 7 | Common Lisp library for interacting with serial ports. 8 | 9 | ## Usage 10 | 11 | ```common-lisp 12 | (with-serial (rs1 1) 13 | (write-serial-byte-vector 14 | (babel:string-to-octets "Hello") 15 | rs1)) 16 | 17 | ;; Interacting with 2 serial ports. 18 | (with-serial (rs2 2) 19 | (with-serial (rs1 1) 20 | 21 | (write-serial-byte-vector 22 | (babel:string-to-octets "こんにちは。") 23 | rs1) 24 | 25 | (let ((res (make-array 18 :element-type '(unsigned-byte 8)))) 26 | (read-serial-sequence res rs2)))) 27 | 28 | ;; Using a gray-stream interface 29 | (with-serial (rs1 1) 30 | (let ((stream (make-serial-stream rs1))) 31 | ;; Allow to use write/read-sequence. 32 | (write-sequence 33 | ;; Sending 'Hi' 34 | (make-array 2 :element-type '(unsigned-byte 8) :initial-contents '(72 105)) 35 | stream))) 36 | 37 | ;; Using a timeout 38 | (with-serial (rs1 1) 39 | (handler-case 40 | (write-serial-byte-vector 41 | (babel:string-to-octets "Hello") 42 | rs1 43 | :timeout-ms 500) 44 | (timeout-error () 45 | (error "The request timed out.")))) 46 | 47 | ;; Using timeout with gray-stream interface 48 | (with-serial (rs1 1) 49 | (let ((stream (make-serial-stream rs1))) 50 | (handler-case 51 | (with-timeout (500) ;; ms 52 | ...) 53 | (timeout-error () 54 | (error "The request timed out."))))) 55 | ``` 56 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | platform: 2 | - x64 3 | environment: 4 | matrix: 5 | - MSYS2_BITS: 64 6 | MSYSTEM: MINGW64 7 | ROSWELL_BRANCH: master 8 | 9 | install: 10 | - SET PATH=%USERPROFILE%\.roswell\bin;%PATH% 11 | 12 | build_script: 13 | - C:\msys%MSYS2_BITS%\usr\bin\bash -lc "cd $APPVEYOR_BUILD_FOLDER;curl -L https://raw.githubusercontent.com/roswell/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh; exec 0" 6 | :version "0.0.3" 7 | :licence "MIT" 8 | :defsystem-depends-on (:trivial-features (:feature (:not :os-windows) :cffi-grovel)) 9 | :depends-on (:trivial-features 10 | :trivial-gray-streams 11 | :cffi 12 | (:feature (:not :os-windows) :cffi-grovel) 13 | (:feature (:not :os-windows) :osicat)) 14 | :components 15 | ((:module "src" 16 | :components 17 | ((:file "package") 18 | (:file "interfaces") 19 | ;; Can switch to :IF-FEATURE once 20 | ;; https://gitlab.common-lisp.net/asdf/asdf/-/issues/63 is 21 | ;; addressed. 22 | #-windows 23 | ("cffi-grovel:grovel-file" "ffi-types" :pathname "ffi-types-unix") 24 | (:file "posix" :if-feature (:not :os-windows)) 25 | (:file "win32" :if-feature :os-windows) 26 | (:file "main") 27 | (:file "gray")))) 28 | :serial t) 29 | -------------------------------------------------------------------------------- /src/ffi-types-unix.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cserial-port) 2 | 3 | (include "sys/ioctl.h") 4 | (include "termios.h") 5 | 6 | (constant (B0 "B0")) 7 | (constant (B50 "B50")) 8 | (constant (B75 "B75")) 9 | (constant (B110 "B110")) 10 | (constant (B134 "B134")) 11 | (constant (B150 "B150")) 12 | (constant (B200 "B200")) 13 | (constant (B300 "B300")) 14 | (constant (B600 "B600")) 15 | (constant (B1200 "B1200")) 16 | (constant (B1800 "B1800")) 17 | (constant (B2400 "B2400")) 18 | (constant (B4800 "B4800")) 19 | (constant (B9600 "B9600")) 20 | (constant (B19200 "B19200")) 21 | (constant (B38400 "B38400")) 22 | (constant (B57600 "B57600")) 23 | (constant (B115200 "B115200")) 24 | (constant (B230400 "B230400")) 25 | (constant (b460800 "B460800")) 26 | (constant (B500000 "B500000")) 27 | (constant (B576000 "B576000")) 28 | (constant (B921600 "B921600")) 29 | (constant (B1000000 "B1000000")) 30 | (constant (B1152000 "B1152000")) 31 | (constant (B1500000 "B1500000")) 32 | (constant (B2000000 "B2000000")) 33 | (constant (B2500000 "B2500000")) 34 | (constant (B3000000 "B3000000")) 35 | (constant (B3500000 "B3500000")) 36 | (constant (B4000000 "B4000000")) 37 | 38 | ;;c_iflag 39 | (constant (IGNBRK "IGNBRK")) 40 | (constant (BRKINT "BRKINT")) 41 | (constant (IGNPAR "IGNPAR")) 42 | (constant (PARMRK "PARMRK")) 43 | (constant (INPCK "INPCK")) 44 | (constant (ISTRIP "ISTRIP")) 45 | (constant (INLCR "INLCR")) 46 | (constant (IGNCR "IGNCR")) 47 | (constant (ICRNL "ICRNL")) 48 | (constant (IXON "IXON")) 49 | (constant (IXANY "IXANY")) 50 | (constant (IXOFF "IXOFF")) 51 | 52 | ;;c_oflag 53 | (constant (OPOST "OPOST")) 54 | (constant (ONLCR "ONLCR")) 55 | (constant (OCRNL "OCRNL")) 56 | (constant (ONOCR "ONOCR")) 57 | (constant (ONLRET "ONLRET")) 58 | (constant (OFILL "OFILL")) 59 | 60 | ;;c_cflag 61 | (constant (CSIZE "CSIZE")) 62 | (constant (CSTOPB "CSTOPB")) 63 | (constant (CREAD "CREAD")) 64 | (constant (PARENB "PARENB")) 65 | (constant (PARODD "PARODD")) 66 | (constant (HUPCL "HUPCL")) 67 | (constant (CLOCAL "CLOCAL")) 68 | 69 | (constant (CS5 "CS5")) 70 | (constant (CS6 "CS6")) 71 | (constant (CS7 "CS7")) 72 | (constant (CS8 "CS8")) 73 | 74 | ;;c_lflag 75 | (constant (ISIG "ISIG")) 76 | (constant (ICANON "ICANON")) 77 | (constant (ECHO "ECHO")) 78 | (constant (ECHOE "ECHOE")) 79 | (constant (ECHOK "ECHOK")) 80 | (constant (ECHONL "ECHONL")) 81 | (constant (NOFLSH "NOFLSH")) 82 | (constant (TOSTOP "TOSTOP")) 83 | (constant (IEXTEN "IEXTEN")) 84 | 85 | 86 | ;;c_cc 87 | (constant (VINTR "VINTR")) 88 | (constant (VQUIT "VQUIT")) 89 | (constant (VERASE "VERASE")) 90 | (constant (VKILL "VKILL")) 91 | (constant (VEOF "VEOF")) 92 | (constant (VMIN "VMIN")) 93 | (constant (VEOL "VEOL")) 94 | (constant (VTIME "VTIME")) 95 | (constant (VSTART "VSTART")) 96 | (constant (VSTOP "VSTOP")) 97 | (constant (VSUSP "VSUSP")) 98 | 99 | ;;tcsetattr optional_actions 100 | (constant (TCSANOW "TCSANOW")) 101 | (constant (TCSADRAIN "TCSADRAIN")) 102 | (constant (TCSAFLUSH "TCSAFLUSH")) 103 | 104 | (constant (NCCS "NCCS")) 105 | 106 | (ctype tcflag-t "tcflag_t") 107 | (ctype cc-t "cc_t") 108 | (ctype speed-t "speed_t") 109 | (ctype pid-t "pid_t") 110 | 111 | (cstruct termios "struct termios" 112 | "The termios structure" 113 | (iflag "c_iflag" :type tcflag-t) 114 | (oflag "c_oflag" :type tcflag-t) 115 | (cflag "c_cflag" :type tcflag-t) 116 | (lflag "c_lflag" :type tcflag-t) 117 | (cc "c_cc" :type cc-t :count NCCS)) 118 | 119 | ;;ioctl 120 | 121 | (constant (TIOCMGET "TIOCMGET")) 122 | (constant (TIOCMSET "TIOCMSET")) 123 | (constant (TIOCMBIC "TIOCMBIC")) 124 | (constant (TIOCMBIS "TIOCMBIS")) 125 | (constant (FIONREAD "FIONREAD")) 126 | 127 | (bitfield modem-state 128 | ((:dsr "TIOCM_DSR")) 129 | ((:dtr "TIOCM_DTR")) 130 | ((:rts "TIOCM_RTS")) 131 | ((:cts "TIOCM_CTS")) 132 | ((:dcd "TIOCM_CAR")) 133 | ((:ring "TIOCM_RNG"))) 134 | -------------------------------------------------------------------------------- /src/gray.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cserial-port) 2 | 3 | (defclass serial-stream (trivial-gray-stream-mixin 4 | fundamental-input-stream 5 | fundamental-output-stream 6 | fundamental-binary-stream) 7 | ((serial :initarg :serial 8 | :reader stream-serial))) 9 | 10 | (defun make-serial-stream (serial) 11 | (make-instance 'serial-stream :serial serial)) 12 | 13 | (defmethod stream-element-type ((stream serial-stream)) 14 | '(unsigned-byte 8)) 15 | 16 | (defmethod stream-read-byte ((stream serial-stream)) 17 | (read-serial-byte (stream-serial stream))) 18 | 19 | (defmethod stream-read-sequence ((stream serial-stream) sequence start end &key) 20 | (read-serial-byte-vector sequence (stream-serial stream) :start start :end end)) 21 | 22 | (defmethod stream-write-byte ((stream serial-stream) byte) 23 | (write-serial-byte byte (stream-serial stream)) 24 | byte) 25 | 26 | (defmethod stream-write-sequence ((stream serial-stream) sequence start end &key) 27 | (write-serial-byte-vector sequence (stream-serial stream) :start start :end end) 28 | sequence) 29 | 30 | (defmethod stream-listen ((stream serial-stream)) 31 | (serial-input-available-p (stream-serial stream))) -------------------------------------------------------------------------------- /src/interfaces.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cserial-port) 2 | 3 | (defclass serial () 4 | ((name :initarg :name 5 | :reader serial-name 6 | :documentation "Device name") 7 | (fd :initarg :fd 8 | :reader serial-fd 9 | :documentation "opend handle") 10 | (encoding :initarg :encoding 11 | :reader serial-encoding 12 | :documentation "encoding") 13 | (baud-rate :initarg :baud-rate 14 | :reader serial-baud-rate 15 | :documentation "baud-rate") 16 | (data-bits :initarg :data-bits 17 | :reader serial-data-bits 18 | :documentation "Number of data-bits.") 19 | (stop-bits :initarg :stop-bits 20 | :accessor serial-stop-bits 21 | :documentation "Number of stop-bits") 22 | (parity :initarg :parity 23 | :accessor serial-parity 24 | :documentation "Parity checking.")) 25 | (:documentation "")) 26 | 27 | (defvar *serial-class* 'serial) 28 | 29 | (define-condition timeout-error (error) () 30 | (:report (lambda (c s) 31 | (declare (ignore c)) 32 | (format s "Process timeout"))) 33 | (:documentation "An error signaled when the duration specified in the [with-timeout][] is exceeded.")) 34 | 35 | (defmacro defgeneric% (fname params &key export doc) 36 | `(progn 37 | (defgeneric ,fname ,params 38 | (:method ((,(first params) t) ,@(rest params)) 39 | (error "not yet implemented method ~A for ~A" 40 | ',fname (type-of ,(first params)))) 41 | ,@(when doc `((:documentation ,doc)))) 42 | ,@(when export 43 | `((export ',fname))))) 44 | 45 | ;;convert to native form. 46 | (defgeneric% %baud-rate (class &optional baud-rate)) 47 | (defgeneric% %data-bits (class &optional data-bits)) 48 | (defgeneric% %stop-bits (class &optional stop-bits)) 49 | (defgeneric% %parity (class &optional parity)) 50 | 51 | (defgeneric% %valid-fd-p (class)) 52 | (defgeneric% %set-invalid-fd (class)) 53 | (defgeneric% %input-available-p (class)) 54 | (defgeneric% %default-name (class &optional number)) 55 | 56 | (defgeneric% %close (class)) 57 | (defgeneric% %open (class &key)) 58 | 59 | (defgeneric% %write (class buffer write-size timeout-ms)) 60 | (defgeneric% %read (class buffer buffer-size timeout-ms)) 61 | 62 | (defgeneric% %get-serial-state (class keys)) 63 | (defgeneric% %set-serial-state (class &key dtr rts break)) 64 | -------------------------------------------------------------------------------- /src/main.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cserial-port) 2 | 3 | (defvar *default-name* 4 | (%default-name *serial-class*)) 5 | 6 | (defvar *default-timeout-ms* nil) 7 | 8 | (defvar *default-baud-rate* 9600) 9 | (defvar *default-encoding* :latin-1) 10 | (defvar *default-data-bits* 8) 11 | (defvar *default-stop-bits* 1) 12 | (defvar *default-parity* :none) 13 | 14 | ;;interfaces borrowed from lisp works 15 | (defun open-serial 16 | (&optional name 17 | &rest args 18 | &key 19 | (baud-rate *default-baud-rate*) 20 | (encoding *default-encoding*) 21 | (data-bits *default-data-bits*) 22 | (stop-bits *default-stop-bits*) 23 | (parity *default-parity*) 24 | ;; below are not yet supported 25 | cts-flow-p 26 | dsr-flow-p 27 | dtr 28 | rts 29 | read-interval-timeout 30 | read-total-base-timeout 31 | read-total-byte-timeout 32 | write-total-base-timeout 33 | write-total-byte-timeout) 34 | "Attempts to open the named serial port and return a serial object." 35 | (setq name (let ((name (or name *default-name*))) 36 | (if (numberp name) (%default-name *serial-class* name) name))) 37 | (%open (apply #'make-instance *serial-class* 38 | :baud-rate baud-rate 39 | :data-bits data-bits 40 | :stop-bits stop-bits 41 | :parity parity 42 | :encoding encoding 43 | args) 44 | :name name)) 45 | 46 | (defun close-serial (serial) 47 | "Closes a serial port" 48 | (unless (%valid-fd-p serial) 49 | (error "serial port ~S already closed" serial)) 50 | (%close serial) 51 | t) 52 | 53 | (defun get-serial-state (serial keys) 54 | "The function get-serial-state queries various aspects of the state of the serial port associated with serial . 55 | The argument keys should be a list of one or more of the keywords :dsr and :cts . These cause get-serial-state to check the DSR and CTS lines respectively. 56 | The result state is a list giving the state of each line in the same order as they appear in the argument keys ." 57 | (%get-serial-state serial keys)) 58 | 59 | (defun read-serial-char (serial &key (timeout-ms *default-timeout-ms*)) 60 | "Reads a character from a serial port. will return a character." 61 | (unless (%valid-fd-p serial) 62 | (error "invalid serial port ~S" serial)) 63 | (cffi:with-foreign-object (b :unsigned-char 1) 64 | (let ((v (make-array 65 | 20 66 | :fill-pointer 0 67 | :element-type '(unsigned-byte 8)))) 68 | (loop 69 | :do (when (= (%read serial b 1 timeout-ms) 1) 70 | (vector-push-extend (cffi:mem-aref b :unsigned-char) v) 71 | (let ((res (ignore-errors (babel:octets-to-string 72 | v 73 | :errorp t 74 | :encoding (serial-encoding serial))))) 75 | (when res 76 | (return (aref res 0))))))))) 77 | 78 | (defun read-serial-byte (serial &key (timeout-ms *default-timeout-ms*)) 79 | "Reads a byte from a serial port. will return byte." 80 | (unless (%valid-fd-p serial) 81 | (error "invalid serial port ~S" serial)) 82 | (cffi:with-foreign-object (b :unsigned-char 1) 83 | (when (= (%read serial b 1 timeout-ms) 1) 84 | (cffi:mem-aref b :unsigned-char)))) 85 | 86 | (defun read-serial-byte-vector (buf serial &key (timeout-ms *default-timeout-ms*) (start 0) (end (length buf))) 87 | "Reads a byte from a serial port. will return count-read-bytes or nil when timeout." 88 | (unless (%valid-fd-p serial) 89 | (error "invalid serial port ~S" serial)) 90 | (cffi:with-pointer-to-vector-data (buf-sap buf) 91 | (%read serial (cffi:inc-pointer buf-sap start) (- end start) timeout-ms))) 92 | 93 | (defun read-serial-string (string serial &key (timeout-ms *default-timeout-ms*) (start 0) (end nil)) 94 | "Reads a string from a serial port." 95 | (loop :repeat (- (or end (length string)) start) 96 | :for i :from start 97 | :for nread :from 1 98 | :do (setf (aref string i) (read-serial-char serial :timeout-ms timeout-ms)) 99 | :finally (return nread))) 100 | 101 | (defun serial-input-available-p (serial) 102 | "Checks whether a character is available on a serial port." 103 | (%input-available-p serial)) 104 | 105 | (defun set-serial-state (serial &rest args &key dtr rts break) 106 | "Changes various aspects of the state of a serial port." 107 | (declare (ignore dtr rts break)) 108 | t 109 | "Description 110 | The function set-serial-state changes various aspects of the state of the serial port associated with serial . 111 | The argument dtr , if supplied, controls the DTR line. A true value means set and nil means clear. If dtr is not supplied, the state is unchanged. 112 | The argument rts controls the RTS line in the same way. 113 | The argument break controls the break state of the data line in the same way." 114 | (apply #'%set-serial-state serial args)) 115 | 116 | (defun wait-serial-state (serial keys &key (timeout-ms *default-timeout-ms*)) 117 | "Waits for some aspect of the state of a serial port to change." 118 | t 119 | "Description 120 | The function wait-serial-state waits for some state in the serial port associated with serial to change. 121 | The argument keys should be a list of one or more of the keywords :cts , :dsr , :err , :ring , :rlsd and :break . 122 | result is a list giving the keys for which the state has changed. 123 | If timeout is non-nil then the function will return nil after that many seconds even if the state has not changed." 124 | (error "not yet implemented") 125 | nil) 126 | 127 | (defun write-serial-char (char serial &key (timeout-ms *default-timeout-ms*)) 128 | "Writes a character to a serial port. will return written char." 129 | (write-serial-string (string char) serial :timeout-ms timeout-ms)) 130 | 131 | (defun write-serial-string (string serial &key (timeout-ms *default-timeout-ms*) (start 0) (end nil)) 132 | "Writes a string to a serial port. will return written-bytes count." 133 | (unless (%valid-fd-p serial) 134 | (error "invalid serial port ~S" serial)) 135 | (cffi:with-foreign-string ((b l) (subseq string start end) 136 | :encoding (serial-encoding serial)) 137 | (%write serial b (1- l) timeout-ms))) 138 | 139 | (defun write-serial-byte (byte serial &key (timeout-ms *default-timeout-ms*)) 140 | "Writes a byte to a serial port. will return written byte." 141 | (let ((data (make-array 1 142 | :element-type '(unsigned-byte 8) 143 | :initial-contents (list byte)))) 144 | (write-serial-byte-vector data serial :timeout-ms timeout-ms) 145 | byte)) 146 | 147 | (defun write-serial-byte-vector (bytes serial &key (timeout-ms *default-timeout-ms*) (start 0) (end (length bytes))) 148 | "Writes bytes to a serial port. will return written-bytes count." 149 | (unless (%valid-fd-p serial) 150 | (error "invalid serial port ~S" serial)) 151 | (cffi:with-pointer-to-vector-data (data-sap bytes) 152 | (%write serial (cffi:inc-pointer data-sap start) (- end start) timeout-ms))) 153 | 154 | ;;more 155 | 156 | (defmacro with-serial ((serial name &rest params) &body body) 157 | `(let ((,serial (open-serial ,name ,@params))) 158 | (unwind-protect 159 | (progn ,@body) 160 | (close-serial ,serial)))) 161 | 162 | (defmacro with-timeout ((ms) &body body) 163 | `(let ((*default-timeout-ms* ,ms)) 164 | ,@body)) 165 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package :common-lisp) 2 | 3 | (defpackage :cserial-port 4 | (:use :cl 5 | :trivial-gray-streams) 6 | #-windows 7 | (:shadowing-import-from :osicat-posix :open :close :write :read) 8 | #-windows 9 | (:import-from :osicat-posix :o-rdwr :o-noctty :o-ndelay :getpgrp :fcntl :f-setfl) 10 | (:import-from :cffi 11 | :defcfun 12 | :foreign-bitfield-symbols 13 | :foreign-bitfield-value 14 | :with-foreign-object 15 | :with-foreign-slots 16 | :mem-aref 17 | :mem-ref) 18 | (:export :open-serial 19 | :close-serial 20 | :get-serial-state 21 | :read-serial-char 22 | :read-serial-byte 23 | :read-serial-byte-vector 24 | :read-serial-string 25 | :serial-input-available-p 26 | :set-serial-state 27 | :wait-serial-state 28 | :write-serial-char 29 | :write-serial-byte 30 | :write-serial-string 31 | :write-serial-byte-vector 32 | :serial-stream 33 | :make-serial-stream 34 | :with-serial 35 | :with-timeout 36 | :timeout-error)) 37 | -------------------------------------------------------------------------------- /src/posix.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cserial-port) 2 | 3 | (defcfun ("tcgetattr" tcgetattr) :int 4 | (fd :int) 5 | (termios-p :pointer)) ;;struct termios * 6 | (defcfun ("tcsetattr" tcsetattr) :int 7 | (fd :int) 8 | (optional-actions :int) 9 | (termios-p :pointer)) ;;struct termios * 10 | (defcfun ("tcsetpgrp" tcsetpgrp) pid-t 11 | (fd :int) 12 | (pgrp pid-t)) 13 | (defcfun ("tcsendbreak" tcsendbreak) :int 14 | (fd :int) 15 | (duration :int)) 16 | (defcfun ("tcdrain" tcdrain) :int 17 | (fd :int)) 18 | (defcfun ("tcflush" tcflush) :int 19 | (fd :int) 20 | (queue_selector :int)) 21 | (defcfun ("tcflow" tcflow) :int 22 | (fd :int) 23 | (action :int)) 24 | (defcfun ("cfsetispeed" cfsetispeed) :int 25 | (termios-p :pointer) ;;struct termios * 26 | (speed speed-t)) 27 | (defcfun ("cfsetospeed" cfsetospeed) :int 28 | (termios-p :pointer) ;;struct termios * 29 | (speed speed-t)) 30 | (defcfun ("ioctl" ioctl) :int 31 | (fd :int) 32 | (request :unsigned-long) 33 | (arg-p :pointer)) 34 | 35 | ;; I'm not sure 'lognot' are available for this use or not. and in this case speed is not a matter at all. 36 | (defun off (flag &rest patterns) 37 | (loop :for pattern :in patterns 38 | :do (decf flag (logand flag pattern))) 39 | flag) 40 | 41 | (defclass posix-serial (serial) 42 | ((tty :initarg :tty 43 | :reader serial-tty 44 | :documentation "tty") 45 | (current-timeout-ds 46 | :initform nil 47 | :documentation "The current value of the timeout on the serial port, in 48 | deci-seconds."))) 49 | 50 | (defparameter *serial-class* 'posix-serial) 51 | 52 | (defmethod %baud-rate ((s posix-serial) &optional baud-rate) 53 | (case (or baud-rate (serial-baud-rate s)) 54 | ((0) B0) 55 | ((50) B50) 56 | ((75) B75) 57 | ((110) B110) 58 | ((134) B134) 59 | ((150) B150) 60 | ((200) B200) 61 | ((300) B300) 62 | ((600) B600) 63 | ((1200) B1200) 64 | ((2400) B2400) 65 | ((4800) B4800) 66 | ((9600) B9600) 67 | ((19200) B19200) 68 | ((38400) B38400) 69 | ((57600) B57600) 70 | ((115200) B115200) 71 | ((230400) B230400) 72 | ((460800) B460800) 73 | ((500000) B500000) 74 | ((576000) B576000) 75 | ((921600) B921600) 76 | ((1000000) B1000000) 77 | ((1152000) B1152000) 78 | ((1500000) B1500000) 79 | ((2000000) B2000000) 80 | ((2500000) B2500000) 81 | ((3000000) B3000000) 82 | ((3500000) B3500000) 83 | ((4000000) B4000000) 84 | 85 | (t (error "not supported baud rate ~A [bps]" baud-rate)))) 86 | 87 | (defmethod %data-bits ((s posix-serial) &optional data-bits) 88 | (let ((val (or data-bits (serial-data-bits s)))) 89 | (case val 90 | ((5) CS5) 91 | ((6) CS6) 92 | ((7) CS7) 93 | ((8) CS8) 94 | (t (error "unsupported data-bits ~A" val))))) 95 | 96 | (defmethod %stop-bits ((s posix-serial) &optional stop-bits) 97 | (let ((val (or stop-bits (serial-stop-bits s)))) 98 | (case val 99 | (1 0) 100 | (2 CSTOPB) 101 | (t (error "unsupported stop bits ~A" val))))) 102 | 103 | (defmethod %parity ((s posix-serial) &optional parity) 104 | (ecase (or parity (serial-parity s)) 105 | (:none 0) 106 | (:even (logior PARENB)) 107 | (:odd (logior PARENB PARODD)) 108 | (:mark (error "not supported mark")) 109 | (:space (error "not supported space")))) 110 | 111 | (defmethod %valid-fd-p ((s posix-serial)) 112 | (numberp (serial-fd s))) 113 | 114 | (defmethod %set-invalid-fd ((s posix-serial)) 115 | (setf (slot-value s 'fd) nil)) 116 | 117 | (defmethod %default-name ((s (eql 'posix-serial)) &optional (number 0)) 118 | (format nil 119 | (or #+linux "/dev/ttyS~A" 120 | #+freebsd "/dev/cuaa~A" 121 | #+windows (if (> number 9) 122 | "\\\\.\\COM~A" 123 | "COM~A") 124 | "/dont/know/where~A") 125 | number)) 126 | 127 | (defmethod %close ((s posix-serial)) 128 | (let ((fd (serial-fd s))) 129 | (fcntl fd f-setfl 0) 130 | (close fd)) 131 | (%set-invalid-fd s) 132 | t) 133 | 134 | (defmethod %open ((s posix-serial) 135 | &key 136 | name) 137 | (let* ((ratedef (%baud-rate s)) 138 | (fd (open name (logior o-rdwr o-noctty)))) 139 | (when (= -1 fd) 140 | (error "~A open error!!" name)) 141 | (setf (slot-value s 'fd) fd) 142 | (with-foreign-object (tty '(:struct termios)) 143 | (unless (and 144 | (zerop (tcgetattr fd tty)) 145 | (zerop (cfsetispeed tty ratedef)) 146 | (zerop (cfsetospeed tty ratedef))) 147 | (%close fd) 148 | (error "~A setspeed error!!" name)) 149 | 150 | (with-foreign-slots ((lflag iflag cflag oflag cc) tty (:struct termios)) 151 | (setf lflag (off lflag ICANON ECHO ECHONL IEXTEN ISIG)) 152 | (setf iflag (off iflag BRKINT ICRNL INPCK ISTRIP IXON)) 153 | (setf cflag (logior (off cflag PARENB CSTOPB CSIZE) 154 | (%data-bits s) 155 | (%parity s) 156 | (%stop-bits s) 157 | HUPCL CLOCAL)) 158 | (setf oflag (off oflag OPOST)) 159 | (setf (mem-aref cc 'cc-t VTIME) 0) 160 | (setf (mem-aref cc 'cc-t VMIN) 1)) 161 | (unless (zerop (tcsetattr fd TCSANOW tty)) 162 | (%close fd) 163 | (error "unable to setup serial port")) 164 | s))) 165 | 166 | (defmethod %write ((s posix-serial) buffer write-size timeout-ms) 167 | (declare (ignorable timeout-ms)) ;; not supported yet 168 | (with-slots (fd) s 169 | ;;TODO: do something if return value is -1. 170 | (write fd buffer write-size))) 171 | 172 | (defmethod %read ((s posix-serial) buffer buffer-size timeout-ms) 173 | (with-slots (fd current-timeout-ds) s 174 | ;; Use ceiling to ensure a value of 1 doesn't turn into 0 (no timeout) 175 | (let ((timeout-ds (unless (null timeout-ms) (ceiling (/ timeout-ms 100))))) 176 | (unless (eql timeout-ds current-timeout-ds) 177 | (flet ((signal-error () 178 | (error "Unable to set serial timeout"))) 179 | ;; User has changed the timeout. Update it in foreign land and locally. 180 | (with-foreign-object (tty '(:struct termios)) 181 | (unless (zerop (tcgetattr fd tty)) 182 | (signal-error)) 183 | (with-foreign-slots ((cc) tty (:struct termios)) 184 | (let ((desired-vtime (if (null timeout-ds) 0 timeout-ds)) 185 | (desired-vmin (if (null timeout-ds) 1 0))) 186 | (setf (mem-aref cc 'cc-t VTIME) desired-vtime 187 | (mem-aref cc 'cc-t VMIN) desired-vmin) 188 | ;; tcsetattr returns success if any change is made. So we need 189 | ;; to getattr again and make sure both values were set 190 | ;; appropriately. 191 | (unless (and (zerop (tcsetattr fd TCSANOW tty)) 192 | (zerop (tcgetattr fd tty)) 193 | (= desired-vtime (mem-aref cc 'cc-t VTIME)) 194 | (= desired-vmin (mem-aref cc 'cc-t VMIN))) 195 | (signal-error)))))) 196 | (setf current-timeout-ds timeout-ds))) 197 | (let ((count (read fd buffer buffer-size))) 198 | (when (and (zerop count) 199 | (not (null timeout-ms))) 200 | (error 'timeout-error)) 201 | count))) 202 | 203 | (defmethod %get-serial-state ((s posix-serial) keys) 204 | (with-slots (fd) s 205 | (with-foreign-object (status :int) 206 | (unless (zerop (ioctl fd TIOCMGET status)) 207 | (error "Unable to get serial state")) 208 | (let ((state (foreign-bitfield-symbols 'modem-state (mem-ref status :int)))) 209 | (mapcar (lambda (entry) (when (member entry state) t)) keys))))) 210 | 211 | (defmethod %set-serial-state ((s posix-serial) 212 | &key 213 | (dtr nil dtr-supplied-p) 214 | (rts nil rts-supplied-p) 215 | (break nil break-supplied-p)) 216 | (declare (ignore break)) 217 | (when break-supplied-p 218 | (error "BREAK not yet implemented")) 219 | (with-slots (fd) s 220 | (let ((bits-to-clear nil) 221 | (bits-to-set nil)) 222 | (flet ((process-bit (name value set-p) 223 | (when set-p 224 | (if value 225 | (push name bits-to-set) 226 | (push name bits-to-clear))))) 227 | (process-bit :dtr dtr dtr-supplied-p) 228 | (process-bit :rts rts rts-supplied-p) 229 | (unless (null bits-to-clear) 230 | (with-foreign-object (bits :int) 231 | (setf (mem-ref bits :int) (foreign-bitfield-value 'modem-state bits-to-clear)) 232 | (unless (zerop (ioctl fd TIOCMBIC bits)) 233 | (error "Unable to clear bits")))) 234 | (unless (null bits-to-set) 235 | (with-foreign-object (bits :int) 236 | (setf (mem-ref bits :int) (foreign-bitfield-value 'modem-state bits-to-set)) 237 | (unless (zerop (ioctl fd TIOCMBIS bits)) 238 | (error "Unable to set bits")))))))) 239 | 240 | (defmethod %input-available-p ((s posix-serial)) 241 | (with-slots (fd) s 242 | (with-foreign-object (nbytes :int) 243 | (unless (zerop (ioctl fd FIONREAD nbytes)) 244 | (error "Unable to get number of bytes available")) 245 | (> (mem-ref nbytes :int) 0)))) 246 | -------------------------------------------------------------------------------- /src/win32.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2012, Blueswitch Pty Ltd. 2 | ;; All rights reserved. 3 | 4 | ;; Redistribution and use in source and binary forms, with or without 5 | ;; modification, are permitted provided that the following conditions are met: 6 | ;; * Redistributions of source code must retain the above copyright 7 | ;; notice, this list of conditions and the following disclaimer. 8 | ;; * Redistributions in binary form must reproduce the above copyright 9 | ;; notice, this list of conditions and the following disclaimer in the 10 | ;; documentation and/or other materials provided with the distribution. 11 | ;; * Neither the name of the Blueswitch Pty Ltd. nor the 12 | ;; names of its contributors may be used to endorse or promote products 13 | ;; derived from this software without specific prior written permission. 14 | 15 | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | ;; DISCLAIMED. IN NO EVENT SHALL BLUESWITCH PTY LTD. BE LIABLE FOR ANY 19 | ;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | ;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | 26 | (in-package :cserial-port) 27 | 28 | (defconstant +GENERIC_READ+ #x80000000) 29 | (defconstant +GENERIC_WRITE+ #x40000000) 30 | (defconstant +FILE_ATTRIBUTE_NORMAL+ #x80) 31 | (defconstant +FILE_FLAG_OVERLAPPED+ #x40000000) 32 | (defconstant +OPEN_EXISTING+ 3) 33 | 34 | (defconstant +MAXDWORD+ 4294967295) 35 | 36 | (defconstant +ONESTOPBIT+ 0) 37 | (defconstant +ONE5STOPBITS+ 1) 38 | (defconstant +TWOSTOPBITS+ 2) 39 | 40 | (defconstant +CBR_110+ 110) 41 | (defconstant +CBR_300+ 300) 42 | (defconstant +CBR_600+ 600) 43 | (defconstant +CBR_1200+ 1200) 44 | (defconstant +CBR_2400+ 2400) 45 | (defconstant +CBR_4800+ 4800) 46 | (defconstant +CBR_9600+ 9600) 47 | (defconstant +CBR_14400+ 14400) 48 | (defconstant +CBR_19200+ 19200) 49 | (defconstant +CBR_38400+ 38400) 50 | (defconstant +CBR_56000+ 56000) 51 | (defconstant +CBR_57600+ 57600) 52 | (defconstant +CBR_115200+ 115200) 53 | (defconstant +CBR_128000+ 128000) 54 | (defconstant +CBR_256000+ 256000) 55 | 56 | (defconstant +XON+ 17) 57 | (defconstant +XOFF+ 19) 58 | 59 | (defconstant +NOPARITY+ 0) 60 | (defconstant +ODDPARITY+ 1) 61 | (defconstant +EVENPARITY+ 2) 62 | (defconstant +MARKPARITY+ 3) 63 | (defconstant +SPACEPARITY+ 4) 64 | 65 | (defconstant +RTS_CONTROL_DISABLE+ 0) 66 | (defconstant +RTS_CONTROL_ENABLE+ 1) 67 | (defconstant +RTS_CONTROL_HANDSHAKE+ 2) 68 | (defconstant +RTS_CONTROL_TOGGLE+ 3) 69 | (defconstant +SETRTS+ 3) 70 | (defconstant +CLRRTS+ 4) 71 | 72 | (defconstant +DTR_CONTROL_DISABLE+ 0) 73 | (defconstant +DTR_CONTROL_ENABLE+ 1) 74 | (defconstant +DTR_CONTROL_HANDSHAKE+ 2) 75 | (defconstant +SETDTR+ 5) 76 | (defconstant +CLRDTR+ 6) 77 | 78 | (defconstant +ERROR_IO_PENDING+ 997) 79 | (defconstant +WAIT_OBJECT_0+ 0) 80 | (defconstant +WAIT_TIMEOUT+ 258) 81 | (defconstant +INFINITE+ #xFFFFFFFF) 82 | 83 | (defconstant +PURGE_TXCLEAR+ 4) 84 | (defconstant +PURGE_TXABORT+ 1) 85 | (defconstant +PURGE_RXCLEAR+ 8) 86 | (defconstant +PURGE_RXABORT+ 2) 87 | 88 | (cffi:load-foreign-library "kernel32") 89 | 90 | (cffi:defctype dword :uint32) 91 | (cffi:defctype word :uint16) 92 | (cffi:defctype bool :uchar) 93 | 94 | (cffi:defbitfield dcb-flags 95 | fBinary; /* Binary Mode (skip EOF check) */ 96 | fParity; /* Enable parity checking */ 97 | fOutxCtsFlow; /* CTS handshaking on output */ 98 | fOutxDsrFlow; /* DSR handshaking on output */ 99 | fDtrControl1; /* DTR Flow control */ 100 | fDtrControl2; /* DTR Flow control */ 101 | fDsrSensitivity; /* DSR Sensitivity */ 102 | fTXContinueOnXoff; /* Continue TX when Xoff sent */ 103 | fOutX; /* Enable output X-ON/X-OFF */ 104 | fInX; /* Enable input X-ON/X-OFF */ 105 | fErrorChar; /* Enable Err Replacement */ 106 | fNull; /* Enable Null stripping */ 107 | fRtsControl1; /* Rts Flow control */ 108 | fRtsControl2; /* Rts Flow control */ 109 | fAbortOnError; /* Abort all reads and writes on Error */ 110 | ) 111 | 112 | (cffi:defcstruct dcb 113 | (DCBlength dword); /* sizeof(DCB) */ 114 | (BaudRate dword); /* Baudrate at which running */ 115 | (dcbflags dword); 116 | (wReserved word); /* Not currently used */ 117 | (XonLim word); /* Transmit X-ON threshold */ 118 | (XoffLim word); /* Transmit X-OFF threshold */ 119 | (ByteSize :uint8); /* Number of bits/byte, 4-8 */ 120 | (Parity :uint8); /* 0-4=None,Odd,Even,Mark,Space */ 121 | (StopBits :uint8); /* 0,1,2 = 1, 1.5, 2 */ 122 | (XonChar :char); /* Tx and Rx X-ON character */ 123 | (XoffChar :char); /* Tx and Rx X-OFF character */ 124 | (ErrorChar :char); /* Error replacement char */ 125 | (EofChar :char); /* End of Input character */ 126 | (EvtChar :char); /* Received Event character */ 127 | (wReserved1 word)); /* Fill for now. */ 128 | 129 | (cffi:defcstruct commtimeouts 130 | (ReadIntervalTimeout dword) 131 | (ReadTotalTimeoutMultiplier dword) 132 | (ReadTotalTimeoutConstant dword) 133 | (WriteTotalTimeoutMultiplier dword) 134 | (WriteTotalTimeoutConstant dword)) 135 | 136 | ;; typedef struct _COMSTAT { 137 | ;; DWORD fCtsHold : 1; 138 | ;; DWORD fDsrHold : 1; 139 | ;; DWORD fRlsdHold : 1; 140 | ;; DWORD fXoffHold : 1; 141 | ;; DWORD fXoffSent : 1; 142 | ;; DWORD fEof : 1; 143 | ;; DWORD fTxim : 1; 144 | ;; DWORD fReserved : 25; 145 | ;; DWORD cbInQue; 146 | ;; DWORD cbOutQue; 147 | ;; } COMSTAT, *LPCOMSTAT; 148 | 149 | (cffi:defcstruct comstat 150 | (flags dword) ; see definition of flags above 151 | (cbInQue dword) 152 | (cbOutQue dword)) 153 | 154 | (cffi:defctype pvoid (:pointer :void)) 155 | (cffi:defctype lpvoid (:pointer :void)) 156 | (cffi:defctype dword-ptr (:pointer dword)) 157 | (cffi:defctype ulong-ptr dword-ptr) 158 | (cffi:defctype handle pvoid) 159 | (cffi:defctype lpdword (:pointer dword)) 160 | (cffi:defctype lpword (:pointer word)) 161 | (cffi:defctype lpcomstat (:pointer comstat)) 162 | (cffi:defctype lpctstr :string) 163 | 164 | (cffi:defcstruct overlapped-us 165 | (Offset dword) 166 | (OffsetHigh dword)) 167 | 168 | (cffi:defcunion overlapped-u 169 | (overlapped-us overlapped-us) 170 | (Pointer pvoid)) 171 | 172 | (cffi:defcstruct overlapped 173 | (Internal ulong-ptr) 174 | (InternalHigh ulong-ptr) 175 | (overlapped-u overlapped-u) 176 | (hEvent handle)) 177 | 178 | (cffi:defctype lpoverlapped (:pointer overlapped)) 179 | 180 | (cffi:defcstruct security-attributes 181 | (nLength dword) 182 | (lpSecurityDescriptor lpvoid) 183 | (bInheritHandle bool)) 184 | 185 | (cffi:defctype lpsecurity-attributes (:pointer security-attributes)) 186 | 187 | 188 | (cffi:defcfun (win32-reset-event "ResetEvent" :convention :stdcall) bool 189 | (hevent handle)) 190 | 191 | (cffi:defcfun (win32-clear-comm-error "ClearCommError" :convention :stdcall) bool 192 | (hfile handle) 193 | (lperrors lpdword) 194 | (lpstat lpcomstat)) 195 | 196 | (cffi:defcfun (win32-wait-for-single-object "WaitForSingleObject" :convention :stdcall) dword 197 | (hHandle handle) 198 | (dwMilliseconds dword)) 199 | 200 | (cffi:defcfun (win32-get-overlapped-result "GetOverlappedResult" :convention :stdcall) :boolean 201 | (hFile handle) 202 | (lpOverlapped lpoverlapped) 203 | (lpNumberOfBytesTransferred lpword) 204 | (bWait :boolean)) 205 | 206 | (cffi:defcfun (win32-purge-comm "PurgeComm" :convention :stdcall) bool 207 | (hFile handle) 208 | (flags dword)) 209 | 210 | (cffi:defcfun (win32-create-event "CreateEventA" :convention :stdcall) handle 211 | (lpEventAttributes lpsecurity-attributes) 212 | (bManualReset :boolean) 213 | (bInitialState :boolean) 214 | (lpName lpctstr)) 215 | 216 | (cffi:defcfun (win32-get-comm-timeouts "GetCommTimeouts" :convention :stdcall) bool 217 | (hFile handle) 218 | (timeouts (:pointer commtimeouts))) 219 | 220 | (cffi:defcfun (win32-create-file "CreateFileA" :convention :stdcall) handle 221 | (filename :string) 222 | (desired-access :uint32) 223 | (share-mode :uint32) 224 | (security-attribute :pointer) 225 | (creation-disposition :uint32) 226 | (flags-and-attributes :uint32) 227 | (template-file :pointer)) 228 | 229 | (cffi:defcfun (win32-setup-comm "SetupComm" :convention :stdcall) bool 230 | (file :pointer) 231 | (dwInQueue dword) 232 | (dwOutQueue dword)) 233 | 234 | (cffi:defcfun (win32-escape-comm-function "EscapeCommFunction" :convention :stdcall) bool 235 | (file :pointer) 236 | (escape dword)) 237 | 238 | (cffi:defcfun (win32-set-comm-timeouts "SetCommTimeouts" :convention :stdcall) bool 239 | (file :pointer) 240 | (timeouts (:pointer commtimeouts))) 241 | 242 | (cffi:defcfun (win32-set-comm-state "SetCommState" :convention :stdcall) bool 243 | (file :pointer) 244 | (dcb (:pointer dcb))) 245 | 246 | (cffi:defcfun (win32-get-comm-state "GetCommState" :convention :stdcall) bool 247 | (file :pointer) 248 | (dcb (:pointer dcb))) 249 | 250 | (cffi:defcfun (win32-memset "memset") :pointer 251 | (dest :pointer) 252 | (fill :int) 253 | (size :uint)) 254 | 255 | (cffi:defcfun (win32-close-handle "CloseHandle" :convention :stdcall) bool 256 | (object :pointer)) 257 | 258 | (cffi:defcfun (win32-read-file "ReadFile" :convention :stdcall) bool 259 | (file handle) 260 | (buffer :pointer) 261 | (size word) 262 | (readBytes (:pointer word)) 263 | (overlapped :pointer)) 264 | 265 | (cffi:defcfun (win32-write-file "WriteFile" :convention :stdcall) bool 266 | (file :pointer) 267 | (buffer :pointer) 268 | (size word) 269 | (writtenBytes (:pointer word)) 270 | (overlapped-p :pointer)) 271 | 272 | (cffi:defcfun (win32-get-last-error "GetLastError" :convention :stdcall) dword) 273 | 274 | (defun valid-pointer-p (pointer) 275 | (not (cffi:pointer-eq pointer (cffi:make-pointer #xFFFFFFFF)))) 276 | 277 | (defmacro win32-confirm (form success fail) 278 | `(if (zerop ,form) 279 | (progn 280 | (print (win32-get-last-error)) 281 | ,fail) 282 | ,success)) 283 | 284 | (defmacro win32-onerror (form &body error-form) 285 | `(win32-confirm ,form 286 | t 287 | (progn 288 | ,@error-form))) 289 | 290 | ;; 291 | (defparameter *serial-class* 'win32-serial) 292 | 293 | (defclass win32-serial (serial) 294 | ()) 295 | 296 | (defmethod %baud-rate ((s win32-serial) &optional baud-rate) 297 | (case (or baud-rate (serial-baud-rate s)) 298 | ((110) +CBR_110+) 299 | ((300) +CBR_300+) 300 | ((600) +CBR_600+) 301 | ((1200) +CBR_1200+) 302 | ((2400) +CBR_2400+) 303 | ((4800) +CBR_4800+) 304 | ((9600) +CBR_9600+) 305 | ((14400) +CBR_14400+) 306 | ((19200) +CBR_19200+) 307 | ((38400) +CBR_38400+) 308 | ((56000) +CBR_56000+) 309 | ((57600) +CBR_57600+) 310 | ((115200) +CBR_115200+) 311 | ((128000) +CBR_128000+) 312 | ((256000) +CBR_256000+) 313 | (t (error "not supported baud rate ~A [bps]" baud-rate)))) 314 | 315 | (defmethod %data-bits ((s win32-serial) &optional data-bits) 316 | (let ((val (or data-bits (serial-data-bits s)))) 317 | (if (<= 4 val 8) 318 | val 319 | (error "unsupported data-bits ~A" val)))) 320 | 321 | (defmethod %stop-bits ((s win32-serial) &optional stop-bits) 322 | (let ((stop-bits (or stop-bits (serial-stop-bits s)))) 323 | (cond 324 | ((= stop-bits 1) +ONESTOPBIT+) 325 | ((= stop-bits 1.5) +ONE5STOPBITS+) 326 | ((= stop-bits 2) +TWOSTOPBITS+) 327 | (t (error "unsupported stop-bits"))))) 328 | 329 | (defmethod %parity ((s win32-serial) &optional parity) 330 | (ecase (or parity (serial-parity s)) 331 | (:none +NOPARITY+) 332 | (:even +EVENPARITY+) 333 | (:odd +ODDPARITY+) 334 | (:mark +MARKPARITY+) 335 | (:space +SPACEPARITY+))) 336 | 337 | (defmethod %valid-fd-p ((s win32-serial)) 338 | (let ((fd (serial-fd s))) 339 | (and (cffi:pointerp fd) 340 | (valid-pointer-p fd) 341 | t))) 342 | 343 | (defmethod %set-invalid-fd ((s win32-serial)) 344 | (setf (slot-value s 'fd) (cffi:make-pointer #xFFFFFFFF))) 345 | 346 | (defmethod %default-name ((s (eql 'win32-serial)) &optional (number 1)) 347 | (format nil (if (> number 9) 348 | "\\\\.\\COM~A" 349 | "COM~A") number)) 350 | 351 | (defmethod %close ((s win32-serial)) 352 | (win32-close-handle (serial-fd s)) 353 | (%set-invalid-fd s) 354 | t) 355 | 356 | (defmethod %open ((s win32-serial) 357 | &key 358 | name) 359 | (let* ((null (cffi:null-pointer)) 360 | (fd (win32-create-file name 361 | (logior +GENERIC_READ+ +GENERIC_WRITE+) 362 | 0 null +OPEN_EXISTING+ +FILE_FLAG_OVERLAPPED+ null))) 363 | (unless (valid-pointer-p fd) 364 | (error "Create file invalid pointer")) 365 | (setf (slot-value s 'fd) fd) 366 | (cffi:with-foreign-object (ptr '(:struct dcb)) 367 | (win32-memset ptr 0 (cffi:foreign-type-size '(:struct dcb))) 368 | (cffi:with-foreign-slots ((DCBlength) ptr (:struct dcb)) 369 | (setf DCBlength (cffi:foreign-type-size '(:struct dcb)))) 370 | (win32-onerror (win32-get-comm-state fd ptr) 371 | (error "GetCommState failed")) 372 | (cffi:with-foreign-slots ((baudrate bytesize parity stopbits dcbflags) 373 | ptr (:struct dcb)) 374 | (setf baudrate (%baud-rate s)) 375 | (setf bytesize (%data-bits s)) 376 | (setf stopbits (%stop-bits s)) 377 | (setf parity (%parity s)) 378 | (setf dcbflags (cffi:foreign-bitfield-value 'dcb-flags '(fbinary)))) 379 | (win32-onerror (win32-set-comm-state fd ptr) 380 | (error "SetCommState failed")))) 381 | s) 382 | 383 | (defmethod %write ((s win32-serial) buffer write-size timeout-ms) 384 | (cffi:with-foreign-object (poverlapped '(:struct overlapped)) 385 | (win32-memset poverlapped 0 (cffi:foreign-type-size '(:struct overlapped))) 386 | (let* ((null (cffi:null-pointer)) 387 | (evt (win32-create-event null t nil null))) 388 | (unless (valid-pointer-p evt) 389 | (error "Create event failed")) 390 | (unwind-protect 391 | (progn 392 | (cffi:with-foreign-slots ((hEvent) poverlapped (:struct overlapped)) 393 | (setf hEvent evt)) 394 | (with-slots (fd) s 395 | (cffi:with-foreign-object (writtenbytes 'word) 396 | (let ((rt (win32-write-file fd buffer write-size writtenbytes poverlapped))) 397 | (if (zerop rt) 398 | (let ((errno (win32-get-last-error))) 399 | (if (= errno +ERROR_IO_PENDING+) 400 | (let ((rt (cffi:with-foreign-slots ((hEvent) poverlapped (:struct overlapped)) 401 | (win32-wait-for-single-object hEvent (or timeout-ms +INFINITE+))))) 402 | (case rt 403 | (#.+WAIT_OBJECT_0+ 404 | (let ((rt (win32-get-overlapped-result fd poverlapped writtenbytes nil))) 405 | (if (null rt) 406 | (error "Error on GetOverlappedResult (~a)" (win32-get-last-error)) 407 | (cffi:mem-ref writtenbytes 'word)))) 408 | (#.+WAIT_TIMEOUT+ (error 'timeout-error)) 409 | (otherwise 410 | (error "Error on WaitForSingleObject (~a)" rt)))) 411 | (error "Error on read (~a)" errno))) 412 | (cffi:mem-ref writtenbytes 'word)))))) 413 | (progn 414 | (win32-reset-event evt) 415 | (win32-close-handle evt)))))) 416 | 417 | (defmethod %read ((s win32-serial) buffer buffer-size timeout-ms) 418 | (cffi:with-foreign-object (poverlapped '(:struct overlapped)) 419 | (win32-memset poverlapped 0 (cffi:foreign-type-size '(:struct overlapped))) 420 | (let* ((null (cffi:null-pointer)) 421 | (evt (win32-create-event null t nil null))) 422 | (unless (valid-pointer-p evt) 423 | (error "Create event failed")) 424 | (unwind-protect 425 | (progn 426 | (cffi:with-foreign-slots ((hEvent) poverlapped (:struct overlapped)) 427 | (setf hEvent evt)) 428 | (with-slots (fd) s 429 | (cffi:with-foreign-object (readbytes 'word) 430 | (let ((rt (win32-read-file fd buffer buffer-size readbytes poverlapped))) 431 | (if (zerop rt) 432 | (let ((errno (win32-get-last-error))) 433 | (if (= errno +ERROR_IO_PENDING+) 434 | (let ((rt (cffi:with-foreign-slots ((hEvent) poverlapped (:struct overlapped)) 435 | (win32-wait-for-single-object hEvent (or timeout-ms +INFINITE+))))) 436 | (case rt 437 | (#.+WAIT_OBJECT_0+ 438 | (let ((rt (win32-get-overlapped-result fd poverlapped readbytes nil))) 439 | (if (null rt) 440 | (error "Error on GetOverlappedResult (~a)" (win32-get-last-error)) 441 | (cffi:mem-ref readbytes 'word)))) 442 | (#.+WAIT_TIMEOUT+ (error 'timeout-error)) 443 | (otherwise 444 | (error "Error on WaitForSingleObject (~a)" rt)))) 445 | (error "Error on read (~a)" errno))) 446 | (cffi:mem-ref readbytes 'word)))))) 447 | (progn 448 | (win32-reset-event evt) 449 | (win32-close-handle evt)))))) 450 | 451 | (defmethod %input-available-p ((s win32-serial)) 452 | (cffi:with-foreign-object (error-flags 'lpdword) 453 | (cffi:with-foreign-object (com-stat 'lpcomstat) 454 | (win32-clear-comm-error (serial-fd s) error-flags com-stat) 455 | ;; cbInQue: number of bytes received by the serial provider but not yet read 456 | ;; converted to boolean 457 | (plusp (cffi:foreign-slot-value com-stat '(:struct comstat) 'cbInQue))))) 458 | 459 | --------------------------------------------------------------------------------