home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Environments / AllegroCL11 / Library / serial-streams.lisp < prev    next >
Encoding:
Text File  |  1987-10-27  |  8.7 KB  |  246 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;serial-streams.lisp
  3. ;;
  4. ;;copyright © 1987, Coral Software Corp.
  5. ;;
  6. ;The following knowledge is helpful in understanding the code:
  7. ;;   Use of Macintosh Drivers and Serial Ports
  8. ;;   Use of the Allegro CL low-level system interface
  9. ;;   Use of Object Lisp
  10. ;;   Use of Allegro CL stream implementation
  11. ;;
  12. ;;
  13. ;;   If you just evaluate this file, it will create four streams, two input
  14. ;;   and two output (one of each for each serial port).  You can print and
  15. ;;   read from these streams, just like any other streams.  One caveat is that
  16. ;;   you must ask them to STREAM-OPEN before you use them.
  17. ;;
  18. ;;
  19. ;
  20. ;;   You could probably use this file to figure out how to implement other kinds
  21. ;;   of streams, as well
  22. ;;
  23.  
  24.  
  25. (eval-when (eval compile)
  26.   (require 'traps))
  27.  
  28. ;Some Macintosh system constants {for referencing into parameter blocks}
  29. (defconstant $IOREFNUM 24)
  30. (defconstant $IOPERMSSN 27)
  31. (defconstant $IOFILENAME 18)
  32. (defconstant $IOBUFFER 32)
  33. (defconstant $IOREQCOUNT 36)
  34. (defconstant $CSCODE 26)
  35. (defconstant $CSPARAM 28)
  36.  
  37. (proclaim '(object-variable driver-open driver-pb driver-open-p
  38.             driver-unread-char driver-name))
  39.  
  40.  
  41. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43. ;;
  44. ;;the driver object
  45. ;;
  46. ;;drivers inherit from streams (because they are used for io).
  47. ;;
  48. ;;serial streams communicate through the Macintosh serial drivers
  49. ;;
  50.  
  51. (defobject *driver* *stream*)
  52.  
  53. (defobfun (exist *driver*) (init-list)
  54.   (usual-exist init-list)
  55.   (have 'driver-name (getf init-list :driver-name "Unspecified Driver"))
  56.   (have 'driver-open-p nil)
  57.   (have 'driver-pb
  58.      (_NewPtr :errchk                        ;should this be errchk? {}
  59.               :d0 (getf init-list :pb-size 80)
  60.               :a0))
  61.   (have 'driver-unread-char nil)
  62.   (%put-word driver-pb 0 $ioRefNum)          ;address, value, offset
  63.   (%put-byte driver-pb 0 $ioPermssn)         ;address, value, offset
  64.   nil)
  65.  
  66. (defobfun (driver-dispose *driver*) ()
  67.  (if driver-open-p (stream-close))           ;maybe be a continuable error? {}
  68.  (_DisposPtr :errchk :a0 driver-pb))
  69.  
  70. (defobfun (stream-open *driver*) ()
  71.   (unless driver-open-p
  72.     (stream-close)                           ;close stream just in case? {} 
  73.     (with-pstrs ((np driver-name))           ;get name string in mac format
  74.       (%put-ptr driver-pb np $ioFileName)    ;address, value, offset
  75.       (_Open :errchk :a0 driver-pb :d0))     ;open the driver
  76.     (setq driver-open-p t)))                 ;set open-p to t
  77.  
  78. (defobfun (stream-close *driver*) ()
  79.   (when driver-open-p                        ;don't close if its already closed
  80.     (_Close :errchk :a0 driver-pb :d0)       ;close the driver
  81.     (setq driver-open-p nil)))               ;set open-p to nil
  82.  
  83. (defobfun (stream-tyo *driver*) (char)       ;function for writing to stream
  84.   (%stack-block ((cp 1))                     ;make room on stack for character
  85.     (%put-byte cp char)                      ;put character there
  86.     (%put-ptr driver-pb cp $ioBuffer)        ;set up the parameter block
  87.     (%put-long driver-pb 1 $ioReqCount)      ;
  88.     (_Write :errchk :a0 driver-pb :d0)))     ;write the character
  89.  
  90. (defobfun (stream-tyi *driver*) ()           ;function for reading from stream
  91.   (when (not driver-open-p)                  ;error if driver not open
  92.     (error "Driver: ~s is not open" (self)))
  93.   (if driver-unread-char                     ;if a character has been 'unread'
  94.     (prog1 driver-unread-char                ; return it, and set unread-char
  95.            (setq driver-unread-char nil))    ; to nil
  96.     (%stack-block ((cp 2))                   ;otherwise read in a character
  97.       (%put-ptr driver-pb cp $ioBuffer)
  98.       (%put-long driver-pb 1 $ioReqCount)
  99.       (_Read :errchk :a0 driver-pb :d0)
  100.       (%get-byte cp))))
  101.  
  102. (defobfun (stream-untyi *driver*) (char)     ;function 'unreads' a character
  103.   (setq driver-unread-char char))
  104.  
  105. (defobfun (driver-control *driver*) (code)   ;{} find out what this does
  106.   (if (not driver-open-p) (error "Driver: ~s is not open" (self)))
  107.   (%put-word driver-pb code $csCode)
  108.   (_Control :errchk :a0 driver-pb))
  109.  
  110. (defobfun (driver-status *driver*) (code)    ;{} find out what this does
  111.   (if (not driver-open-p) (error "Driver: ~s is not open" (self)))
  112.   (%put-word driver-pb code $csCode)
  113.   (_Status :errchk :a0 driver-pb))
  114.  
  115.  
  116. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  117. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  118. ;;
  119. ;;Serial Streams
  120. ;;
  121. ;;Serial Streams inherit from drivers.
  122. ;;
  123. ;;They provide a stream interface to some specific drivers on the Macintosh,
  124. ;;  namely, the serial drivers.
  125. ;;
  126.  
  127. (defobject *serial-stream* *driver*)         ;define the new class
  128.  
  129. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  130. ;;
  131. ;;set-serial-port
  132. ;;
  133. ;;  used to configure the serial port
  134. ;;
  135. ;;  Takes keywords  :BAUD
  136. ;;                  :STOP
  137. ;;                  :PARITY
  138. ;;                  :LENGTH
  139. ;;
  140. ;;  Default values are: 9600 baud, 1 stop bit and parity 0.
  141. ;;
  142. ;;  This function does fancy argument checking.  It checks all args before
  143. ;;  erroring on any single one of them.
  144. ;;
  145.  
  146. (defobfun (set-serial-port *serial-stream*)
  147.           (&key (baud 9600) (stop 1) (parity 0)
  148.                 (length nil length-supplied?))
  149.   (if (not driver-open-p) (stream-open))   ;open if not already
  150.   (let ((bad-args nil)
  151.         (config (if length-supplied?
  152.                   (case (floor length)
  153.                     (5 0)
  154.                     (7 1024)
  155.                     (6 2048)
  156.                     (8 3072))
  157.                   3072))
  158.         (%baud (floor baud))
  159.         (%stop (* 1.5 (floor (coerce stop 'number))))
  160.         (%parity (floor parity)))
  161.     ;Check arguments one at a time.
  162.      (unless config (push `(length ,length) bad-args))
  163.      (unless (<= 112 %baud 57600) (push `(baud ,baud) bad-args))
  164.      (unless (<= 1 %stop 3) (push `(stop ,stop) bad-args))
  165.      (unless (<= 0 %parity 2) (push `(parity ,parity) bad-args))
  166.      (when bad-args
  167.        (error "Invalid argument~p to set-serial-port. ~:{~a: ~s~:[~;, ~]~}"
  168.               (length bad-args)
  169.               (maplist #'(lambda (bad-arg-list)
  170.                            `(,@(car bad-arg-list)
  171.                              ,(> (length bad-arg-list) 1)))
  172.                        bad-args)))
  173.      (%put-word driver-pb
  174.                   (+ config
  175.                      (- (round (/ 114750 %baud)) 2)
  176.                      (ash (truncate %stop) 14)
  177.                      (ash (if (eq %parity 2) 
  178.                             3 %parity)
  179.                           12))
  180.                   $csParam)
  181.        (driver-control 8))
  182.   (self))
  183.  
  184. ;;;;;;;;;;;;;;;
  185. ;;
  186. ;;set-hand-shake
  187. ;;
  188. ;;  A hairy function to set the handshaking.  It takes a list of numbers, but
  189. ;;  should probably be converted to keywords.
  190. ;;
  191. ;;  The list of numbers are as follows:
  192. ;;
  193. ;;     (fXon fCTS xOn xOff errs evts fInX)
  194. ;;
  195. ;;     If fXon is nonzero Xon/Xoff output flow control is enabled
  196. ;;     If fInX is nonzero Xon/Xoff input flow control is enabled
  197. ;;     XOn and XOff specify the characters used for Xon/Xoff
  198. ;;     If fCTS is nonzero, CTS hardware handshake is enabled
  199. ;;     errs indicates which errors cause input requests to be aborted
  200. ;;       it should be the sum of the following:
  201. ;;          16 for parity errors
  202. ;;          32 for hardware overrun errors
  203. ;;          64 for framing errors
  204. ;;     evts indicates whether changes in the CTS or break status will cause
  205. ;;       device driver events to be posted;  it should be the sum of the
  206. ;;       following
  207. ;;          32 if CTS change should generate events
  208. ;;          128 if break status change should generate events
  209. ;;       Note that these driver events are unsupported and degrade performance.
  210. ;;
  211. (defobfun (set-hand-shake *serial-stream*)
  212.           (num-list &aux (param-ptr (%inc-ptr driver-pb $csParam)))
  213.   (if (not driver-open-p) (stream-open))
  214.   (dotimes (i 7)
  215.     (%put-byte param-ptr (pop num-list) i))
  216.   (driver-control 10))
  217.  
  218. (defobfun (stream-tyi *serial-stream*) ()
  219.   (if (not driver-open-p) (stream-open))
  220.   (loop (if (stream-listen) (return))) ;so it won't hang
  221.   (usual-stream-tyi))
  222.  
  223. (defobfun (stream-eofp *serial-stream*) ()
  224.   nil) ;always more
  225.  
  226. (defobfun (stream-listen *serial-stream*) ()
  227.   (if (not driver-open-p) (stream-open))
  228.   (or driver-unread-char
  229.       (progn
  230.         (driver-status 2)
  231.         (neq 0 (%get-long driver-pb $csParam)))))
  232.  
  233. ;;;;;;;;;;;;;;;;;;;
  234. ;;
  235. ;;  define some globals and bind them to serial streams
  236. ;;
  237. ;;  printer port is b
  238. ;;  modem port is a
  239. (defvar *serial-a-in* (oneof *serial-stream* :driver-name ".AIn"))
  240. (defvar *serial-a-out* (oneof *serial-stream* :driver-name ".AOut"))
  241. (defvar *serial-b-in* (oneof *serial-stream* :driver-name ".BIn"))
  242. (defvar *serial-b-out* (oneof *serial-stream* :driver-name ".BOut"))
  243.  
  244.  
  245. (provide 'serial-streams)
  246. (pushnew :serial-streams *features*)