home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / objects-of-desire / serial-port.lisp < prev    next >
Encoding:
Text File  |  1992-07-10  |  9.0 KB  |  279 lines
  1. (in-package :oou)
  2. (oou-provide :serial-port)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; :serial-port.lisp
  5. ;;
  6. ;; Copyright ⌐ 1991 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; object for controling a Macintosh serial port
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :+Devices
  16.  :+Serial
  17.  :macptr-u
  18.  :traps-u
  19.  )
  20.  
  21. (export '(serial-port
  22.           port baud stop-bits parity data-bits
  23.           set-baud set-stop-bits set-parity set-data-bits
  24.           sport-open-p sport-open sport-close
  25.           sport-flush sport-chars-avail
  26.           sport-read-char sport-read-line
  27.           sport-write-char sport-write-line
  28.           ))
  29.  
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31.  
  32.  
  33.  
  34. (defclass serial-port ()
  35.   ((drvr-refnum-in    :reader      drvr-refnum-in
  36.                       :allocation :class)
  37.    (drvr-refnum-out   :reader      drvr-refnum-out
  38.                       :allocation :class)
  39.    (ref-count-modem   :initform    0
  40.                       :allocation :class)
  41.    (ref-count-printer :initform    0
  42.                       :allocation :class)
  43.    (port              :initarg    :port
  44.                       :reader      port)
  45.    (baud              :initarg    :baud
  46.                       :reader      baud)
  47.    (stop-bits         :initarg    :stop-bits
  48.                       :reader      stop-bits)
  49.    (parity            :initarg    :parity
  50.                       :reader      parity)
  51.    (data-bits         :initarg    :data-bits
  52.                       :reader      data-bits)
  53.    (eoln-char         :initarg    :eoln-char
  54.                       :accessor    eoln-char))
  55.   (:default-initargs
  56.     :port             :modem
  57.     :baud             9600
  58.     :stop-bits        1.0
  59.     :parity           :none
  60.     :data-bits        8
  61.     :open-on-init-p   t
  62.     :config-on-init-p t
  63.     :flush-on-init-p  t
  64.     :eoln-char        #\return))
  65.  
  66. (defmethod initialize-instance :after ((sp serial-port) &rest initargs
  67.                                        &key
  68.                                        open-on-init-p
  69.                                        config-on-init-p
  70.                                        flush-on-init-p)
  71.   (declare (dynamic-extent initargs)
  72.            (ignore initargs))
  73.   (when open-on-init-p (sport-open sp :config-p config-on-init-p :flush-p flush-on-init-p)))
  74.  
  75. (defmethod ref-count ((sp serial-port))
  76.   (ecase (port sp)
  77.     (:modem   (slot-value sp 'ref-count-modem))
  78.     (:printer (slot-value sp 'ref-count-printer))))
  79.  
  80. (defmethod (setf ref-count) (count (sp serial-port))
  81.   (ecase (port sp)
  82.     (:modem   (setf (slot-value sp 'ref-count-modem) count))
  83.     (:printer (setf (slot-value sp 'ref-count-printer) count))))
  84.  
  85. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86. ;; set methods for the serial port settings slots
  87.  
  88. (defmethod set-baud ((sp serial-port) baud &key (config-p t))
  89.   (setf (slot-value sp 'baud) baud)
  90.   (when config-p (sport-config sp)))
  91.  
  92. (defmethod set-stop-bits ((sp serial-port) stop-bits &key (config-p t))
  93.   (setf (slot-value sp 'stop-bits) stop-bits)
  94.   (when config-p (sport-config sp)))
  95.  
  96. (defmethod set-parity ((sp serial-port) parity &key (config-p t))
  97.   (setf (slot-value sp 'parity) parity)
  98.   (when config-p (sport-config sp)))
  99.  
  100. (defmethod set-data-bits ((sp serial-port) data-bits &key (config-p t))
  101.   (setf (slot-value sp 'data-bits) data-bits)
  102.   (when config-p (sport-config sp)))
  103.  
  104. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  105.  
  106. (defmethod sport-open-p ((sp serial-port))
  107.   (and (slot-boundp sp 'drvr-refnum-in)
  108.        (slot-boundp sp 'drvr-refnum-out)))
  109.  
  110.  
  111. (defmethod sport-open ((sp serial-port) &key (config-p t) (flush-p t))
  112.   (when (zerop (ref-count sp))
  113.     (with-pstrs ((in-name_p  (ecase (port sp) (:printer ".BIn")  (:modem ".AIn")))
  114.                  (out-name_p (ecase (port sp) (:printer ".BOut") (:modem ".AOut"))))
  115.       (rlet ((in-refNum_p  :integer)
  116.              (out-refNum_p :integer))
  117.         (trap-nz-echeck (#~OpenDriver in-name_p  in-refnum_p))
  118.         (trap-nz-echeck (#~OpenDriver out-name_p out-refnum_p))
  119.         (setf (slot-value sp 'drvr-refnum-in ) (%get-signed-word in-refnum_p))
  120.         (setf (slot-value sp 'drvr-refnum-out) (%get-signed-word out-refnum_p))))
  121.     (when config-p (sport-config sp))
  122.     (when flush-p (sport-flush sp)))
  123.   (incf (ref-count sp)))
  124.  
  125.  
  126. (defmethod sport-close ((sp serial-port))
  127.   (when (plusp (ref-count sp))
  128.     (decf (ref-count sp))
  129.     (when (zerop (ref-count sp))
  130.       (let ((in-refnum  (drvr-refnum-in sp))
  131.             (out-refnum (drvr-refnum-out sp)))
  132.         (slot-makunbound sp 'drvr-refnum-in)
  133.         (slot-makunbound sp 'drvr-refnum-out)
  134.         (trap-nz-echeck (#~CloseDriver in-refnum))
  135.         (trap-nz-echeck (#~CloseDriver out-refnum))))))
  136.  
  137.  
  138. (defmethod sport-config-bits ((sp serial-port))
  139.   (+ (ecase (baud sp)
  140.        (  300 #.#$baud300)
  141.        (  600 #.#$baud600)
  142.        ( 1200 #.#$baud1200)
  143.        ( 1800 #.#$baud1800)
  144.        ( 2400 #.#$baud2400)
  145.        ( 3600 #.#$baud3600)
  146.        ( 4800 #.#$baud4800)
  147.        ( 7200 #.#$baud7200)
  148.        ( 9600 #.#$baud9600)
  149.        (19200 #.#$baud19200)
  150.        (57600 #.#$baud57600))
  151.      (ecase (stop-bits sp)
  152.        (1.0 #.#$stop10)
  153.        (1.5 #.#$stop15)
  154.        (2.0 #.#$stop20))
  155.      (ecase (parity sp)
  156.        (:none #.#$noParity)
  157.        (:odd  #.#$oddParity)
  158.        (:even #.#$evenParity))
  159.      (ecase (data-bits sp)
  160.        (5 #.#$data5)
  161.        (6 #.#$data6)
  162.        (7 #.#$data7)
  163.        (8 #.#$data8))))
  164.  
  165.  
  166. (defmethod sport-config ((sp serial-port))
  167.   (let ((config-bits (sport-config-bits sp)))
  168.     (trap-nz-echeck (#~SerReset (drvr-refnum-in  sp) config-bits))
  169.     (trap-nz-echeck (#~SerReset (drvr-refnum-out sp) config-bits))))
  170.  
  171.  
  172. (defmethod sport-flush ((sp serial-port))
  173.   (let ((refnum (drvr-refnum-in sp)))
  174.     (rlet ((count_p :longint))
  175.       (trap-nz-echeck (#~SerGetBuf refnum count_p))
  176.       (let ((count (%get-signed-long count_p)))
  177.         (when (zerop count) (return-from sport-flush t))
  178.         (%stack-block ((buf_p count))
  179.           (trap-nz-echeck (#~FSRead refnum count_p buf_p)))))))
  180.  
  181.  
  182. (defmethod sport-chars-avail ((sp serial-port))
  183.   (let ((refnum (drvr-refnum-in sp)))
  184.     (rlet ((count_p :longint))
  185.       (trap-nz-echeck (#~SerGetBuf refnum count_p))
  186.       (%get-signed-long count_p))))
  187.  
  188.  
  189. (defmethod sport-read-char ((sp serial-port) &key (wait-p nil))
  190.   (let ((refnum (drvr-refnum-in sp)))
  191.     
  192.     ;wait/check for available char
  193.     (loop (when (plusp (sport-chars-avail sp)) (return))
  194.           (unless wait-p (return-from sport-read-char nil)))
  195.     
  196.     ;get the char
  197.     (rlet ((count_p :longint)
  198.            (char_p  :character))
  199.       (%put-long count_p 1)
  200.       (trap-nz-echeck (#~FSRead refnum count_p char_p))
  201.       (unless (= 1 (%get-signed-long count_p))
  202.         (error "Reading 1 characater from serial port failed."))
  203.       (%get-character char_p))))
  204.     
  205.  
  206. (defmethod sport-read-line ((sp serial-port)
  207.                             &key
  208.                             (wait-p nil)
  209.                             (wait-eoln-p wait-p)
  210.                             (eoln-char (eoln-char sp)))
  211.   (let ((str (make-array 0
  212.                          :element-type 'base-character
  213.                          :fill-pointer 0
  214.                          :adjustable t)))
  215.     (loop
  216.       (let ((c (sport-read-char sp :wait-p wait-p)))
  217.         (if c
  218.           (if (char= c eoln-char)
  219.             (return-from sport-read-line (values str t))
  220.             (vector-push-extend c str))
  221.           (unless (or wait-p (and wait-eoln-p (plusp (length str))))
  222.             (return-from sport-read-line (values str nil))))))))
  223.  
  224.  
  225. (defmethod sport-write-char ((sp serial-port) char)
  226.   (rlet ((count_p :longint)
  227.          (char_p  :character))
  228.     (%put-long count_p 1)
  229.     (%put-character char_p char)
  230.     (trap-nz-echeck (#~FSWrite (drvr-refnum-out sp) count_p char_p))
  231.     (unless (= 1 (%get-signed-long count_p))
  232.       (error "Writing 1 character to serial port failed (~a written)."
  233.              (%get-signed-long count_p))))
  234.   t)
  235.  
  236.  
  237. (defmethod sport-write-line ((sp serial-port) string &key (eoln-char (eoln-char sp)))
  238.   (let ((len (length string)))
  239.     (rlet ((count_p :longint))
  240.       (%put-long count_p (1+ len))
  241.       (with-cstrs ((text_p string))
  242.         (%put-character text_p eoln-char len)
  243.         (trap-nz-echeck (#~FSWrite (drvr-refnum-out sp) count_p text_p))
  244.         (unless (= (1+ len) (%get-signed-long count_p))
  245.           (error "Writing ~a characters to serial port failed (~a written)."
  246.                  (1+ len)
  247.                  (%get-signed-long count_p))))))
  248.   t)
  249.  
  250. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  251.  
  252. #|
  253.  
  254. ;a modest example - on a Pioneer laserdisc player
  255.  
  256. (setf sp (make-instance 'serial-port :port :printer :baud 1200 ))
  257.  
  258.  ;open drawer
  259. (progn
  260.   (sport-write-line sp "ST")
  261.   (list
  262.    (sport-read-line sp :wait-p t)
  263.    (sport-read-line sp :wait-p t)))
  264.  
  265. ;close drawer
  266. (progn
  267.   (sport-write-line sp "PL")
  268.   (list
  269.    (sport-read-line sp :wait-p t)
  270.    (sport-read-line sp :wait-p t)))
  271.  
  272. (progn
  273.   (sport-write-line sp "?D")
  274.   (sport-read-line sp :wait-p t))
  275.  
  276. (sport-chars-avail sp)
  277. (sport-close sp)
  278.  
  279. |#