Serial port communication in common lisp

Question

Is there a library for serial port communication in Common Lisp on Windows?

Answer 1

Here are a few functions that implement serial communication using SBCL foreign function POSIX calls. Its not as nice as a full library but I solved my problem of talking to the device according to this protocol

https://valelab.ucsf.edu/svn/micromanager2/branches/micromanager1.3/DeviceAdapters/ZeissCAN/ZeissCAN.cpp

package.lisp:

(defpackage :serial
  (:shadowing-import-from :cl close open ftruncate truncate time
              read write)
  (:use :cl :sb-posix)
  (:export #:open-serial
       #:close-serial
       #:fd-type
       #:serial-recv-length
       #:read-response
       #:write-zeiss
       #:talk-zeiss))

(defpackage :focus
  (:use :cl :serial)
  (:export #:get-position
       #:set-position
       #:connect
       #:disconnect))

serial.lisp:

(in-package :serial)

(defconstant FIONREAD #x541B)
(defconstant IXANY #o4000)
(defconstant CRTSCTS #o20000000000)

(deftype fd-type ()
  `(unsigned-byte 31))

(defun open-serial (tty)
  (declare (string tty)
       (values stream fd-type &optional))
  (let* ((fd (sb-posix:open
          tty (logior O-RDWR
              O-NOCTTY #+nil (this terminal can't control this program)
              O-NDELAY #+nil (we don't wait until dcd is space)
              )))
     (term (tcgetattr fd))
     (baud-rate B9600))

    (fcntl fd F-SETFL (logior O-RDWR O-NOCTTY)) #+nil (reset file status flags, clearing e.g. O-NDELAY)

    (cfsetispeed baud-rate term)
    (cfsetospeed baud-rate term)

    (macrolet ((set-flag (flag &key (on ()) (off ()))
         `(setf ,flag (logior ,@on (logand ,flag ,@off)))))

    (setf
     (aref (termios-cc term) VMIN) 1 #+nil (wake up after 32 chars are read)
     (aref (termios-cc term) VTIME) 5 #+nil (wake up when no char arrived for .1 s))

     ;; check and strip parity, handshake off
     (set-flag (termios-iflag term)
           :on ()
           :off (IXON IXOFF IXANY
             IGNBRK BRKINT PARMRK ISTRIP
             INLCR IGNCR ICRNL
              ))

     ;; process output
     (set-flag (termios-oflag term)
           :off (OPOST))

     ;; canonical input but no echo
     (set-flag (termios-lflag term)
           :on ()
           :off (ICANON ECHO ECHONL IEXTEN ISIG))

     ;; enable receiver, local mode, 8N1 (no parity)
     (set-flag (termios-cflag term)
           :on (CLOCAL CREAD 
               CS8 CRTSCTS)
           :off (CSTOPB CSIZE PARENB)))

    (tcflush fd TCIFLUSH) #+nil (throw away any input data)

    (tcsetattr fd TCSANOW term) #+nil (set terminal port attributes)
    (values
     (sb-sys:make-fd-stream fd :input t :output t
                :buffering :full)
     fd)))

(defun close-serial (fd)
  (declare (fd-type fd)
       (values null &optional))
  (fcntl fd F-SETFL 0) #+nil (reset file status flags, clearing e.g. O-NONBLOCK)
  (sb-posix:close fd) #+nil (this will set DTR low)
  nil)

(defun serial-recv-length (fd)
  (declare (fd-type fd)
       (values (signed-byte 32) &optional))
  (sb-alien:with-alien ((bytes sb-alien:int))
    (ioctl fd FIONREAD (sb-alien:addr bytes))
    bytes))

(defun read-response (tty-fd tty-stream)
  (declare (fd-type tty-fd)
       (stream tty-stream)
       (values string &optional))
  (declare (fd-type tty-fd)
       (stream tty-stream)
       (values string &optional))
  (let ((n (serial-recv-length tty-fd)))
    (if (eq 0 n)
    ""
    (let ((ret (make-string n)))
      (dotimes (i n)
        (setf (char ret i) (read-char tty-stream)))
      ret))))

(defun write-zeiss (tty-stream command)
  (declare (stream tty-stream)
       (string command))
  (format tty-stream "~a~a" command #\Return)
  (finish-output tty-stream))

(defun talk-zeiss (tty-fd tty-stream command)
  (declare (fd-type tty-fd)
       (stream tty-stream)
       (string command)
       (values string &optional))
  (write-zeiss tty-stream command)
  ;; I measured that the position is fully transmitted after 30 ms.
  (let ((n (do ((i 0 (1+ i))
        (n 0 (serial-recv-length tty-fd)))
           ((or (< 0 n) (<= 30 i)) n)
         (sleep .03d0))))
    (if (eq 0 n)
    ""
    (read-response tty-fd tty-stream))))

focus.lisp:

(in-package :focus)

(defvar *stream* nil)
(defvar *fd* nil)

(defun run-shell (command)
  (with-output-to-string (stream)
    (sb-ext:run-program "/bin/bash" (list "-c" command)
            :input nil
            :output stream)))

(defun find-zeiss-usb-adapter ()
  (let ((port (run-shell "dmesg|grep pl2303|grep ttyUSB|tail -n1|sed s+.*ttyUSB+/dev/ttyUSB+g|tr -d '\\n'")))
    (if (string-equal "" port)
    (error "dmesg output doesn't contain ttyUSB assignment. This can happen when the system ran a long time. You could reattach the USB adapter that is connected to the microscope.")
    port)))

#+nil
(find-zeiss-usb-adapter)

(defun connect (&optional (devicename (find-zeiss-usb-adapter)))
  (multiple-value-bind (s fd)
      (open-serial devicename)
    (defparameter *stream* s)
        (defparameter *fd* fd)))
#+nil
(connect)

(defun disconnect ()
  (close-serial *fd*)
  (setf *stream* nil))

#+nil
(disconnect)

#+nil
(serial-recv-length *fd*)

#+nil ;; do cat /dev/ttyUSB1 in some terminal, or use read-response below
(progn
  (format *stream* "HPTv0~a" #\Return)
  (finish-output *stream*))

#+nil
(progn
  (format *stream* "FPZp~a" #\Return)
  (finish-output *stream*))

#+nil
(read-response *fd* *stream*)

#+nil
(response->pos-um (read-response *fd* *stream*))

#+nil
(close-serial *fd2*)

#+nil
(time
 (response->pos-um (talk-zeiss *fd2* *s2* "FPZp")))

#+nil ;; measure the time it takes until the full response has arrived
(progn
 (format *s2* "FPZp~a" #\Return)
 (finish-output *s2*)
 (dotimes (i 10)
   (sleep .01d0)
   (format t "~a~%" (list i (serial-recv-length *fd2*))))
 (read-response *fd2* *s2*))

(defconstant +step-size+ .025s0 "Distance of one z step in micrometer.")

(defun response->pos-um (answer)
  (declare (string answer)
       (values single-float &optional))
  (if (equal "PF" (subseq answer 0 2))
    (let* ((uval (the fixnum (read-from-string
                  (format nil "#x~a" (subseq answer 2)))))
       (val (if (eq 0 (logand uval #x800000))
            uval ;; positive
            (- uval #xffffff 1))))
      (* +step-size+ val))
    (error "unexpected answer on serial port.")))

;; some tricks with two's complement here!  be sure to generate a
;; 24bit signed number consecutive application of pos-um->request and
;; response->pos-um should be the identity (if you don't consider the
;; prefix "PF" that response->pos-um expects)

(defun pos-um->request (pos-um)
  (declare (single-float pos-um)
       (values string &optional))
  (format nil "~6,'0X"
      (let ((val (round pos-um +step-size+)))
        (if (< val 0)
        (+ #xffffff val 1)
        val))))

(defun get-position ()
  (declare (values single-float &optional))
  (response->pos-um (talk-zeiss *fd* *stream* "FPZp")))

(defun set-position (position-um)
  "Decreasing the position moves away from sample."
  (declare (single-float position-um))
  (write-zeiss *stream*
           (format nil "FPZT~a" (pos-um->request position-um))))

#+nil
(format nil "FPZT~a" (pos-um->request -8.0d0))

#+nil
(defparameter current-pos (get-position *fd* *stream*))
#+nil
(format t "pos: ~a~%" (get-position *fd2* *s2*))
#    +nil
(time (format t "response ~a~%"
          (set-position *s2* (+ current-pos 0.7d0))))

#+nil
(progn
  (set-position *s2* (+ current-pos 135d0))
  (dotimes (i 20)
    (format t "pos ~a~%" (list i (get-position *fd2* *s2*)))))

#+nil
(loop for i below 100 do
     (sleep .1)
     (format t "~a~%" (response->pos-um (talk-zeiss "FPZp"))))

Answer 2

I don't know if there's a free one available, but LispWorks has one - SERIAL-PORT.

Failing that, you might have to write your own. You could try simply writing the FFI wrappers for the Windows calls (GetCommState, WaitCommEvent, etc.) as a start. It's most certainly doable.