Communicating with serial/parallel ports
Thomas M. Philip
with a serial and/or parallel port on a PC and Mac?
Thanks in advance.
David McClain
;;---------------------------------------------------
;; commports.lisp -- General Purpose COM Port Facility
;;
;; DM/HMSC 12/97
;; -------------------------------------------------------------
(defpackage "COMMPORTS"
(:use "USEFUL-MACROS" "COMMON-LISP")
(:nicknames "SIO")
(:export
"<COMMPORT>"
"PORT-OPEN"
"PORT-CLOSE"
"PORT-READ-BYTES"
"PORT-READ"
"PORT-READ-UNTIL"
"PORT-DRAIN-INPUT"
"PORT-WRITE-BYTES"
"PORT-WRITE"
"PORT-FLUSH"
"PORT-SETUP"
"PORT-GET-SETUP"
"PORT-SET-BUFFERS"
"PORT-GET-TIMEOUTS"
"PORT-SET-TIMEOUTS"
"PORT-OPEN?"
"$COM1"
"$COM2"
"$COM3"
"$COM4"))
(in-package "COMMPORTS")
;; abstract base class
(defclass <commport> ()
())
;; private instantiable class
(defclass <pc-commport> (<commport>)
((id
:accessor port-id
:initarg :id)
(handle
:accessor port-handle
:initform nil)
(scrap
:accessor port-scrap
:initform nil)))
(defmethod print-object ((port <pc-commport>) stream)
(format stream "#<PC-COMMPORT COM~A ~A>"
(port-id port)
(if (port-handle port)
"OPEN"
"CLOSED")))
(defvar $COM1
(make-instance '<pc-commport> :id 1))
(defvar $COM2
(make-instance '<pc-commport> :id 2))
(defvar $COM3
(make-instance '<pc-commport> :id 3))
(defvar $COM4
(make-instance '<pc-commport> :id 4))
(defconstant $IDLE-READ-SIZE 80)
(defmethod require-port-handle ((port <pc-commport>))
(or (port-handle port)
(error "SIO port COM~A not open." (port-id port))))
;; --- DLL Interface ----------------------------
(defvar **commlib** "commport.dll")
(fli:define-foreign-function (_Open "_Open_CommPort@4")
((which :long))
:module **commlib**
:result-type :long
:calling-convention :stdcall)
(fli:define-foreign-function (_Close "_Close_CommPort@4")
((handle :long))
:module **commlib**
:result-type :void
:calling-convention :stdcall)
(fli:define-foreign-function (_Read "_Read_CommPort@12")
((handle :long)
(buffer (:pointer (:unsigned :char)))
(buflen :long))
:module **commlib**
:result-type :long
:calling-convention :stdcall)
(fli:define-foreign-function (_Write "_Write_CommPort@12")
((handle :long)
(buffer (:pointer (:unsigned :char)))
(buflen :long))
:module **commlib**
:result-type :long
:calling-convention :stdcall)
(fli:define-foreign-function (_Setup "_Setup_CommPort@8")
((handle :long)
(settings (:pointer (:unsigned :char))))
:module **commlib**
:result-type :long
:calling-convention :stdcall)
(fli:define-foreign-function (_Get-Setup "_GetSetup_CommPort@12")
((handle :long)
(buf (:pointer (:unsigned :char)))
(buflen :long))
:module **commlib**
:result-type :long
:calling-convention :stdcall)
(fli:define-foreign-function (_Set-Buffers "_Setbuf_CommPort@12")
((handle :long)
(rxlen :long)
(txlen :long))
:module **commlib**
:result-type :long
:calling-convention :stdcall)
(fli:define-foreign-function (_Set-Timeouts "_SetTimeouts_CommPort@8")
((handle :long)
(tmouts (:pointer :long)))
:module **commlib**
:result-type :long
:calling-convention :stdcall)
(fli:define-foreign-function (_Get-Timeouts "_GetTimeouts_CommPort@8")
((handle :long)
(tmouts (:pointer :long)))
:module **commlib**
:result-type :long
:calling-convention :stdcall)
(fli:define-foreign-function (_Flush "_Flush_CommPort@4")
((handle :long))
:module **commlib**
:result-type :long
:calling-convention :stdcall)
;; -----------------------------------------------------------------
(defmethod Port-Open ((port <pc-commport>))
;;
;; Precondition: valid port number
;; Precondition: port available
;;
(unless (port-handle port) ;; already open?
(let ((handle (_Open (port-id port))))
(if (eql handle -1)
(error "Can't open serial port COM~A" (port-id port))
(setf (port-handle port) handle)))
))
(defmethod Port-Open? ((port <pc-commport>))
(port-handle port))
(defmethod Port-Close ((port <pc-commport>))
;;
;; Returns nil on failure, else non-nil
;;
(_Close (require-port-handle port))
(setf (port-handle port) nil
(port-scrap port) nil)
t)
(defmethod Port-Set-Buffers ((port <pc-commport>) rxlen txlen)
(_Set-Buffers (require-port-handle port) rxlen txlen))
(defmethod Port-Setup ((port <pc-commport>) setup-string)
;;
;; Precondition: valid handle
;; Precondition: (and (stringp setup-string)
;; (valid setup-string))
;;
(fli:with-dynamic-foreign-objects ()
(let ((settings
(fli:convert-to-dynamic-foreign-string setup-string)))
(_Setup (require-port-handle port) settings))))
(defmethod Port-Get-Setup ((port <pc-commport>))
;;
;; Precondition: valid handle
;;
(fli:with-dynamic-foreign-objects ()
(let ((str (fli:allocate-dynamic-foreign-object
:type '(:unsigned :char)
:nelems 512)))
(if (plusp (_Get-Setup (require-port-handle port) str 512))
(fli:convert-from-foreign-string str)))))
(defmethod Port-Get-Timeouts ((port <pc-commport>))
;;
;; Precondition: valid handle
;;
(fli:with-dynamic-foreign-objects ()
(let ((tmouts (fli:allocate-dynamic-foreign-object
:type :long
:nelems 5)))
(if (plusp (_Get-Timeouts (require-port-handle port) tmouts))
(let ((rslt (make-array 5)))
(dotimes (i 5)
(setf (aref rslt i)
(fli:dereference tmouts :index i)))
rslt))
)))
(defmethod Port-Set-Timeouts ((port <pc-commport>)
&key RI RM RK TM TK)
;;
;; Precondition: valid handle
;; Precondition: (every (mapcar (or (null item)
;; (and (integerp item)
;; (plusp item)))
;; (list RI RM RK TM TK)))
;;
(let ((handle (require-port-handle port)))
(fli:with-dynamic-foreign-objects ()
(let ((tmouts (fli:allocate-dynamic-foreign-object
:type :long
:nelems 5)))
(when (plusp (_Get-Timeouts handle tmouts))
(if RI
(setf (fli:dereference tmouts :index 0) RI))
(if RM
(setf (fli:dereference tmouts :index 1) RM))
(if RK
(setf (fli:dereference tmouts :index 2) RK))
(if TM
(setf (fli:dereference tmouts :index 3) TM))
(if TK
(setf (fli:dereference tmouts :index 4) TK))
(_Set-Timeouts handle tmouts))
))))
(defmethod Port-Read-Bytes ((port <pc-commport>)
&optional (rdlen 4096))
;;
;; Be careful with byte I/O -- make sure you're not using Xon/Xoff!
;;
;; Return a vector of integer char codes
;;
(let ((scrap (port-scrap port))
(rslt #()))
(when scrap
(if (>= rdlen (length scrap))
(progn
(decf rdlen (length scrap))
(setf rslt scrap
(port-scrap port) nil))
(progn
(setf rdlen 0
rslt (subseq scrap 0 rdlen)
(port-scrap port) (subseq scrap rdlen)))))
(if (plusp rdlen)
(concatenate 'vector rslt
(fli:with-dynamic-foreign-objects ()
(let* ((buf (fli:allocate-dynamic-foreign-object
:type '(:unsigned :char)
:nelems rdlen))
(nb (_Read (require-port-handle port) buf rdlen))
(rslt (make-array nb)))
(fli:with-coerced-pointer (ptr) buf
(dotimes (ix nb)
(setf (aref rslt ix) (fli:dereference ptr))
(fli:incf-pointer ptr)))
rslt)))
rslt)))
(defmethod Port-Read ((port <pc-commport>)
&optional (rdlen 4096))
;;
;; Return a string of characters. Uses the Port-Read-Bytes function
;; so that all possible character codes are accepted.
;;
(map 'string 'code-char (Port-Read-Bytes port rdlen)))
(defmethod Port-Read-Until ((port <pc-commport>)
(delim character))
;;
;; Accumulate read until delimiter is found.
;; Returns two values:
;; 1. The accumulated input string
;; 2. nil if delimiter not found by timeout period,
;; or else non-nil if delimiter is found.
;;
;; Delimiter is not returned as part of the returned string.
;;
(labels ((read ()
(port-read port $IDLE-READ-SIZE)))
(do* ((str (read) (read))
(pos (position delim str) (position delim str))
(rslt ""))
((or (zerop (length str))
pos)
(values
(if pos
(progn
(setf (port-scrap port) (subseq str (1+ pos)))
(concatenate 'string rslt (subseq str 0 pos)))
rslt)
pos))
(setf rslt (concatenate 'string rslt str)))
))
(defmethod Port-Drain-Input ((port <pc-commport>))
;;
;; Keep reading and discarding input until the port times-out waiting.
;;
(setf (port-scrap port) nil)
(labels ((read ()
(port-read-bytes port $IDLE-READ-SIZE)))
(do ((str (read) (read)))
((zerop (length str)))
)))
(defmethod Port-Write-Bytes ((port <pc-commport>) (seq sequence))
;;
;; Be careful with byte I/O -- make sure you're not using Xon/Xoff!
;;
(fli:with-dynamic-foreign-objects ()
(let* ((nelems (length seq))
(buf (fli:allocate-dynamic-foreign-object
:type '(:unsigned :char)
:nelems nelems
:initial-contents (coerce seq 'list))))
(_Write (require-port-handle port) buf nelems))
))
(defmethod Port-Write ((port <pc-commport>) (str string))
(Port-Write-Bytes port (map 'list 'char-code str)))
(defmethod Port-Flush ((port <pc-commport>))
(_Flush (require-port-handle port)))
;; -- end of commports.lisp -- ;;
David McClain, Sr. Scientist
Raytheon Systems Co.
Tucson, AZ
Thomas M. Philip <tmph...@ocf.Berkeley.EDU> wrote in message
news:Pine.SOL.4.21.00021...@conquest.OCF.Berkeley.EDU...