;;; -*- Mode:LISP; Package:UNIX; Lowercase:T; Base:10 -*-

;;; Copyright (c) 1984, Lisp Machine, Inc.
;;;   See the file "Copyright" for
;;; licensing and release information.

;;; The Unix-Stream flavor gets :CLEAR-INPUT and :CLEAR-OUTPUT methods
;;; to reset the buffer pointers and buffer arrays.  For example, if the
;;; program(s) running under Unix accessing the Unix stream terminates,
;;; and the Lisp program is restarted, then the :CLEAR-OUTPUT method
;;; should be called to flush the buffer.

;;; :CLEAR-OUTPUT is probably safe to call whenever the Lisp program is
;;; starting up. However, the :CLEAR-INPUT method should not be called if
;;; a Unix program thinks it has pending output to Lisp...

;;; The :ABORT method has been defined for WITH-OPEN-STREAM, which sends
;;; an :ABORT message on abnormal :CLOSE. The modified :CLOSE and new
;;; :ABORT methods work so that an abnormal exit causes :CLEAR-OUTPUT to
;;; be invoked.

;;; An even nicer interface is defined by WITH-SAFE-UNIX-STREAM.  For an
;;; example of opening a "safe" unix stream with clear output and
;;; abort-protection, see (and run) UNIX:SAFE-UNIX-STREAM-DEMO, below.

(defmethod (unix-stream :clear-input) ()
  "Clear any pending input to Lisp from Unix by
resetting pointers and zeroing the buffer."
  (setf (si:%share-tty-unix-to-lisp-in-ptr share-tty) 0)
  (setf (si:%share-tty-unix-to-lisp-out-ptr share-tty) 0)
  (fillarray unix-to-lisp-array nil)
  nil)

(defmethod (unix-stream :clear-output) ()
  "Clear any pending output from Lisp to Unix by
resetting pointers and zeroing the buffer."
  (setf (si:%share-tty-lisp-to-unix-in-ptr share-tty) 0)
  (setf (si:%share-tty-lisp-to-unix-out-ptr share-tty) 0)
  (fillarray lisp-to-unix-array nil)
  nil)

(defmethod (unix-stream :port-id) ()
  "Return a symbol corresponding to the Unix stream's 
shared device name, (e.g. UNIX-STREAM-4:)."
  (intern
    (send (send self :shared-device)
	  :string-for-printing)))

(defmethod (unix-stream :set-abort-safety) (&optional safety)
  "Set the abort-safety property for this Unix stream."
  (setf (get (send self :port-id) :abort-safety-set) safety))

(defmethod (unix-stream :abort-safety-set) ()
  "Return the abort-safety property for this Unix stream."
  (get (send self :port-id) :abort-safety-set))

(defmethod (unix-stream :abort) ()
  "If this Unix stream has the abort-safety property set,
clear any pending output from Lisp to Unix."
  (if (send self :abort-safety-set)
      (send self :clear-output)))

(defmethod (unix-stream :close) (&optional abortp)
  "Modified Unix-stream method to close and honor the
:ABORT method by clearing output, if ABORTP is non-NIL."
  (if abortp (send self :abort))
  (send shared-device :close abortp))

(export 'with-safe-unix-stream 'user)
(defmacro with-safe-unix-stream ((stream port-name . options) &body body)
  "Execute the BODY with the variable STREAM bound to a stream for Unix port PORT-NAME.
PORT-NAME is opened using OPTIONS, which are the same as for the OPEN function.
Any pending output from Lisp to Unix is cleared away.
On normal exit, close STREAM normally.
On abnormal exit (throwing, errors, etc) close STREAM with argument :ABORT,
which includes clearing the output from Lisp to Unix."
  `(with-open-stream (,stream (open ,port-name . ,options))
     (send ,stream :set-abort-safety t)
     (send ,stream :clear-output)
     . ,body))
 
(defun safe-unix-stream-demo()
  "Demo safe abort with open Unix stream."
  (macrolet(
	    (note(txt str)
		 `(format t "~&~a~& Lisp-to-Unix buffer contains ~s~%"
			  ,txt
			  (send ,str :lisp-to-unix-array)))
	    )
    (let*((port-name "UNIX-STREAM-4:")
	  (stream-id (open port-name)))
      (send stream-id :string-out "You won't ever see this.")
      (note "At first" stream-id)
      (catch 'safety-demo
	(with-safe-unix-stream (s port-name)
	  (note "Inside WITH-SAFE-UNIX-STREAM" s)
	  (send s :string-out "this is a test")
	  (note "After output" s)
	  (throw 'safety-demo nil)
	  ;; Can't get here from there
	  ))
      (note "After THROWing out of WITH-SAFE-UNIX-STREAM" stream-id))))