;;; -*- Mode:LISP; Package:SERIAL-PROTO; Base:10; Readtable:ZL -*-

#|

  Copyright GigaMos Systems, Inc. 1988
   See filename "Copyright.Text" for
  licensing and release information.


This is part of the implementation of the "Serial IP" interface for the new
network system.  This code implements the actual packet protocol and
low-level serial I/O.

EXPLANATION:

A PACKET is expected to be an array of 8-byte words/characters whose
fill-pointer indicates the number of characters already in the packet,
and thus it is the index with which the next character should be read or
written.

The protocol is taken from a "Serial Line Interface" protocol by
"rick@seismo.ARPA", which does not packetize I/O per se.  Rather, a
special character, SP-FRAME-END, indicates the end-of-packet.  Another
character, SP-FRAME-ESCAPE, is used to precede and "escape" special
characters.  However, the SP-FRAME-END and SP-FRAME-ESCAPE characters
themselves are not send following an escape; translation characters,
SP-FRAME-XEND and SP-FRAME-XESCAPE, are sent.  Thus an SP-FRAME-ESCAPE
or SP-FRAME-END received in the data stream always mean what they say.

Any data loss or synchronization problem will not be detected by the
protocol; rather, the user of these packets must figure out whether they
got the right stuff.  In the worst case, an escape or end character
could be dropped; on the other hand, eventually an end character will be
found, and the packets will be "in synch" again.

This protocol has the advantage of low processing overhead.  It is
acceptable for serial Internet, I suppose, because the higher-level
protocols check the packets and will retransmit as needed.

|#

(in-package "SERIAL-PROTO")

(export '(*serial-proto-max-packet-size*
	   make-serial-proto-stream
	   new-serial-proto-packet
	   serial-port-open-p
	   serial-port-listen
	   with-serial-port-allocated
	   serial-proto-receive
	   serial-proto-send))

;;;Packet character constants:

(defconstant *serial-proto-max-packet-size* #o1006)
(defconstant *sp-frame-end*     #o300)
(defconstant *sp-frame-escape*  #o333)
(defconstant *sp-frame-xend*    #o334)
(defconstant *sp-frame-xescape* #o335)


;;;Utility functions

;;;Callers can use this to make a serial packet, or use some other array type

(defun new-serial-proto-packet()
  (make-array (* 2 *serial-proto-max-packet-size*)
	      :type 'art-string
	      :initial-element 0.
	      :fill-pointer 0))

;;;These are definitely system-dependent; they don't belong here,
;;;but they don't belong anywhere else either.

(defun serial-port-open-p(stream)
  (and stream
       #+LMI
       (and (funcall stream :input-unibus-channel)
	    (funcall stream :output-unibus-channel))))

(defun serial-port-listen(stream)
  (and stream
       #+LMI
       (send stream :listen)))

(defun serial-port-locate(&optional (name "sdu-serial-b"))
  (declare(values device))
  (setq name (string-right-trim ":" name))
  (find name si:all-shared-devices
		  :key  #'(lambda(dev)(send dev :name))
		  :test #'string-equal))

(defun serial-port-allocate(&optional (name "SDU-SERIAL-B"))
  (let((dev (serial-port-locate name)))
    (cond
      ((null dev)
       (ferror nil "No such device ~a" name))
      ((not(typep dev 'si:sdu-serial-b-shared-device))
       (ferror nil "Device ~s is not an SDU Serial device?"))
      ((null
	 (progn
	   (send dev :allocate)
	   (send dev :allocate-if-easy)))
       nil)
      ((eq (car (send dev :lock)) si:current-process)
       ;;It's ours, or was
	 dev)
      (t
       (or
	 (null (car (send dev :lock)))
	 (cerror "Free the device and hope the other user doesn't use it"
		 "The serial device ~s~% is locked by ~s"
		 dev (car(send dev :lock))))
       (send dev :steal-lock)
       dev))))

(defun serial-port-deallocate(dev)
  (send dev :free-lock)
  (send dev :deallocate))

(defmacro with-serial-port-allocated(device-name &body body)
  `(let(dev)
     (unwind-protect
	 (progn
	   (setq dev (serial-port-allocate ,device-name))
	   ,@body)
       (and dev (serial-port-deallocate dev)))))


#|
Protocol I/O Stream

This code uses DEFSELECT, which is similar to the Flavors system; it
defines a function which dispatches on a message with, optionally,
arguments.  The stream created by MAKE-SERIAL-PROTO-STREAM is a function
closure over special variables.

A SERIAL-PROTO-OUTPUT-STREAM stream is never CLOSED by the protocol, but
when its :CLOSE method is invoked, output is finished and null packets
are sent.  A SERIAL-PROTO-INPUT-STREAM is closed whenever a packet is
sent; it must be "reOPENed" by sending it a :REOPEN message, and it
should then be send a :PACKET message with 1 arg, the new packet array.

|#

;;;SERIAL-PROTO-<mode>-STREAM methods

;;Default handler

(defun serial-proto-stream-pass(&rest args)
  (declare(special stream))
  (apply stream args))

;;Gettable/settable instance variables

(defun serial-proto-stream-var(op &optional arg &rest ignore)
  (declare(special escaping closed status packet))
  (ecase op
    (:escaping escaping)
    (:closed closed)
    (:status status)
    (:packet
     (when arg (setq packet arg))
     packet)))

;;;Input methods

(defun serial-proto-stream-full-packet(ignore)
  (declare(special packet closed status))
  (when (>= (fill-pointer packet) (array-length packet))
    (setq status (setq closed :full))))

(defun serial-proto-stream-tyi(&optional op &aux ch)
  (declare(special stream closed status escaping packet))
  (serial-proto-stream-full-packet op)
  (when (not closed)
    (block nil
      (setq ch (funcall stream op))
      (unless ch (return))
      (setf (aref packet (fill-pointer packet)) 
	    (if (not escaping)
		(cond
		  ((char= ch *sp-frame-end*)
		   (setq closed(setq status :done))
		   (return))
		  ((char= ch *sp-frame-escape*)
		   (print 'escaping)
		   (setq escaping t)
		   (return))
		  (t ch))
	      (cond
		((char= ch *sp-frame-xend*)
		 *sp-frame-end*)
		((char= ch *sp-frame-xescape*)
		 *sp-frame-escape*)
		(t ch))))
      (setq escaping nil)
      (incf (fill-pointer packet))
      ch)))

;;;Output methods

(defun serial-proto-stream-tyo(ch)
  (declare(special stream closed))
  (unless closed
    (cond
      ((null ch) nil)
      ((char= ch *sp-frame-escape*)
       (funcall stream :tyo *sp-frame-escape*)
       (funcall stream :tyo *sp-frame-xescape*))
      ((char= ch *sp-frame-end*)
       (funcall stream :tyo *sp-frame-escape*)
       (funcall stream :tyo *sp-frame-xend*))
      (t
       (funcall stream :tyo ch)))))

(defun serial-proto-stream-finish-output(&optional ignore)
  (declare(special stream closed packet))
  (unless closed
    (funcall stream :tyo *sp-frame-end*)
    ;;For the Lambda's sake we do :FORCE-OUTPUT to the serial stream when
    ;;we're done outputting a packet.  This yields a minor improvement over
    ;;the default, where characters are forced out by :TYO and :STRING-OUT.
    (funcall stream :force-output))
  (when (arrayp packet) (setf (fill-pointer packet) 0)))

;;;Close methods

(defun serial-proto-stream-close(&optional ignore abort-p)
  (declare(special stream packet closed status))
  (setq packet nil)
  (setq closed (setq status :closed))
  (and (serial-port-open-p stream)
       (close stream abort-p)))

(defun serial-proto-stream-close-output(&optional op abort-p)
  ;;This sends 3 null packets to tell the other side to shut down.
  (dotimes(p 3)
    (serial-proto-stream-finish-output))
  ;;Now close as usual
  (serial-proto-stream-close op abort-p))

;;;The stream select-methods

(defselect (serial-proto-input-stream serial-proto-stream-pass)
  (:escaping . serial-proto-stream-var)
  (:closed   . serial-proto-stream-var)
  (:status   . serial-proto-stream-var)
  (:packet   . serial-proto-stream-var)
  (:full-p   . serial-proto-stream-full-packet)
  (:close    . serial-proto-stream-close)
  (:finish ())
  ;;
  ;;Input
  ;;
  (:tyi-no-hang . serial-proto-stream-tyi)
  (:tyi         . serial-proto-stream-tyi)
  (:reopen ()
    (declare(special closed status))
    (setq closed nil)
    (setq status :open)))

(defselect (serial-proto-output-stream serial-proto-stream-pass)
  (:escaping . serial-proto-stream-var)
  (:closed   . serial-proto-stream-var)
  (:status   . serial-proto-stream-var)
  (:packet   . serial-proto-stream-var)
  (:full-p   . serial-proto-stream-full-packet)
  (:close    . serial-proto-stream-close-output)
  ;;
  ;;Output
  ;;
  (:tyo (ch) (serial-proto-stream-tyo ch))
  (:finish   . serial-proto-stream-finish-output)
  (:send-packet ()
    (declare(special stream packet closed))
    (unless closed
      (do*((indx 0 (1+ indx))
	   (ch (aref packet indx) (aref packet indx)))
	  ((>= indx (fill-pointer packet))
	 (serial-proto-stream-finish-output)
      (serial-proto-stream-tyo ch))))))

(defun make-serial-proto-stream (stream mode &optional packet)
  "  Depending on MODE, returns a SERIAL-PROTO-<mode>-STREAM, which supports
normal uni-directional stream operations, with SLIP protocol character handling.
  A PACKET is an array of 8-bit bytes. To initialize with a specified packet,
you should set the packet's fill-pointer appropriately."
  (declare(special stream packet))
  (declare(values serial-proto-io-stream))
  (assert (typep mode '(member :input :output))
	  (mode)
	  "Mode must be :INPUT or :OUTPUT")
  (setq packet (or packet (new-serial-proto-packet)))
  (let((escaping nil)
       (closed nil)
       (status :open)
       (direction mode)
       self)
    (declare(special escaping closed status direction self))
    (setq self
	  (closure '(stream packet escaping closed status direction self)
		   (case mode
		     (:input  'serial-proto-input-stream)
		     (:output 'serial-proto-output-stream))))))


;;;External interfaces

;;;Input:
;;;
;;;This routine packs characters into a PACKET if they are available.
;;;Initially the packet should have its fill-pointer set to 0.  This
;;;probably must be called several times before the packet will be
;;;filled. The routine always returns whenever a :TYI-NO-HANG returns
;;;NIL, meaning there's no input.  This behaviour means more passes
;;;through this routine, but nobody need ever hang waiting for input,
;;;and no time-out computation.  We return non-NIL eventually when the
;;;packet is full or the end-of-packet character is received.  After
;;;using the packet, the caller is responsible for sending a :REOPEN
;;;message to the stream before it can be used again.
;;;

(defun serial-proto-receive(stream)
  (do((result (funcall stream :tyi-no-hang)
	      (funcall stream :tyi-no-hang)))
     ((null result)
      (funcall stream :closed))))

;;;Output:
;;;
;;;Send PACKET immediately on STREAM.
;;;

(defun serial-proto-send(stream packet)
  (funcall stream :packet packet)
  (funcall stream :send-packet))