;;; -*- Mode:LISP; Package:UNIX; Base:8; Lowercase:T; Readtable:ZL -*-

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

(defflavor unix-stream
	   (share-tty
	    buf-size
	    lisp-to-unix-array
	    unix-to-lisp-array
	    last-index-given-away
	    (port-number nil)
	    (ready-p nil)
	    shared-device
	    )
	   (si:buffered-stream)
  :settable-instance-variables
  )


(defmethod (unix-stream :after :describe) ()
  (declare (special si:share-tty-qs))
  (select-processor
    (:lambda
      (dolist (q si:share-tty-qs)
	(format t "~&~s:~40t~o" q (funcall q share-tty))))
    ((:explorer :cadr))))
  
(defmethod (unix-stream :after :init) (ignore)
  (send self :setup))

(defmethod (unix-stream :print-self) (stream &rest ignore)
  (format stream "#<UNIX PORT ~d>"
	  (send self ':port-number)))

(defmethod (unix-stream :clear-input) ()
  (setf (si:%share-tty-unix-to-lisp-out-ptr share-tty)
	(si:%share-tty-unix-to-lisp-in-ptr share-tty))
  (send self :interrupt-68000))

(defmethod (unix-stream :clear-output) ()
  (setf (si:%share-tty-lisp-to-unix-in-ptr share-tty)
	(si:%share-tty-lisp-to-unix-out-ptr share-tty))
  (send self :interrupt-68000))

(defmethod (unix-stream :close) (&optional abortp)
  (send self :clear-output)
  (send self :clear-input)
  (when abortp
    (send self :set-carrier nil)
    (sleep 1)
    (send self :set-carrier t))
  (send shared-device :close abortp))

(defmethod (unix-stream :setup) ()
  (select-processor
    ((:explorer :cadr)
     (ferror nil "only for lambda"))
    (:lambda))
  (setq ready-p nil)
  (cond ((not (si:share-mode-active-p))
	 (ferror nil "not in share mode")))
  (setq share-tty (get-share-tty-number port-number))
  (setq buf-size (si:%share-tty-buf-size share-tty))
  (cond ((zerop buf-size)
	 (ferror nil "share-tty not really set up")))
  (setq lisp-to-unix-array
	(make-array  buf-size
		     :type art-string
		     :displaced-to share-tty
		     :displaced-index-offset
		     (* 4 (si:%share-tty-lisp-to-unix-buffer share-tty))))
  (setq unix-to-lisp-array
	(make-array buf-size
		    :type art-string
		    :displaced-to share-tty
		    :displaced-index-offset
		    (* 4 (si:%share-tty-unix-to-lisp-buffer share-tty))))

  (send self :set-carrier t)
  (setq ready-p t))


(defmethod (unix-stream :carrier) ()
  (ldb-test si:%%share-tty-csr-carrier (si:%share-tty-lcsr share-tty)))

(defmethod (unix-stream :set-carrier) (on-p)
  (setf (ldb si:%%share-tty-csr-carrier (si:%share-tty-lcsr share-tty)) (if on-p 1 0))
  (send self :interrupt-68000))

(defmethod (unix-stream :space-available) ()
  "for output from lisp to unix"
;  (not (= 1
;	  (\ (+ (- (si:%share-tty-lisp-to-unix-out-ptr share-tty)
;		   (si:%share-tty-lisp-to-unix-in-ptr share-tty))
;		buf-size)
;	     buf-size)))
  (let ((in (si:%share-tty-lisp-to-unix-in-ptr share-tty))
	(out (si:%share-tty-lisp-to-unix-out-ptr share-tty)))
    (cond ((> out in)
	   (not (= out (1+ in))))
	  ((zerop out)
	   (not (= in (1- buf-size))))
	  (t
	   t)))
  )

;;; values are array, first index he is allowed to store in, and first index he
;;; is not allowed to store in
(defmethod (unix-stream :new-output-buffer) ()
  (process-wait "Unix Stream Output" #'(lambda (u) (send u :space-available)) self)
  (let ((in (si:%share-tty-lisp-to-unix-in-ptr share-tty))
	(out (si:%share-tty-lisp-to-unix-out-ptr share-tty)))
    (values lisp-to-unix-array in
	    (cond ((> out in)
		   (1- out))
		  ((zerop out)
		   (1- buf-size))
		  (t
		   buf-size)))))

;;; new-index is first index he didn't store in
(defmethod (unix-stream :send-output-buffer) (ignore new-index)
  (if (> new-index buf-size)
      (ferror nil "new-index is outside of buffer"))
  (if (= new-index buf-size)
      (setq new-index 0))
  (setf (si:%share-tty-lisp-to-unix-in-ptr share-tty) new-index)
  (send self :interrupt-68000)
  )

(defmethod (unix-stream :interrupt-68000) ()
  (let* ((intr (si:%share-tty-unix-intr share-tty))
	 (quad (ldb (byte 4 28.) intr)))
    (cond ((or (= quad #xe) (= quad #xf))
	   (%nubus-write (ldb (byte 8 24.) intr) (logand 77777777 intr) 1)))))

(defmethod (unix-stream :discard-output-buffer) (ignore)
  nil)

(defmethod (unix-stream :data-available) ()
  "data available from unix"
  (not (= (si:%share-tty-unix-to-lisp-in-ptr share-tty)
	  (si:%share-tty-unix-to-lisp-out-ptr share-tty))))

;;; values are array, first index that has data, and the first index that doesn't have data
(defmethod (unix-stream :next-input-buffer) (&optional no-hang-p)
  (let ((initial-data-available (send self :data-available)))
    (cond ((and (null initial-data-available) no-hang-p)
	   nil)
	  (t
	   (cond ((null initial-data-available)
		  (process-wait "Unix Stream Input"
				#'(lambda (u) (send u :data-available)) self)))
	   (let ((in (si:%share-tty-unix-to-lisp-in-ptr share-tty))
		 (out (si:%share-tty-unix-to-lisp-out-ptr share-tty)))
	     (setq last-index-given-away (if (< out in) in buf-size))
	     (values unix-to-lisp-array out last-index-given-away))))))

(defmethod (unix-stream :discard-input-buffer) (ignore)
  (setf (si:%share-tty-unix-to-lisp-out-ptr share-tty)
	(if (= last-index-given-away buf-size) 0 last-index-given-away))
  (send self :interrupt-68000))

(defmethod (unix-stream :after :tyo) (&rest ignore)
  (send self :force-output))

(defmethod (unix-stream :after :string-out) (&rest ignore)
  (send self :force-output))

(compile-flavor-methods unix-stream)

(defflavor unix-stream-shared-device
	   (share-tty)
	   (si:shared-device)
  )

(defvar *share-ttys* nil)

(defun assure-*share-ttys*-set-up ()
  (process-wait "Wait for *share-ttys* to get set up"
		#'(lambda () *share-ttys*)))

(defconst *max-share-ttys* 256
  "Maximum number of share-ttys that lisp will setup for unix.
   Introduced to workaround unix bug in Release 3.0.")

(defun make-all-share-ttys (&aux share-ttys)
  (select-processor
    (:lambda
      (setq *share-ttys* nil)
      (cond ((zerop (si:%system-configuration-number-of-share-ttys si:*sys-conf*))
	     (process-wait "unix share tty setup"
			   #'(lambda ()
			       (not (zerop (si:%system-configuration-number-of-share-ttys
					     si:*sys-conf*)))))
	     (process-sleep 60.)))
      (let ((base-adr (si:sdu-phys-to-virtual
			(si:%system-configuration-share-tty-0 si:*sys-conf*)))
	    (nttys (si:%system-configuration-number-of-share-ttys si:*sys-conf*))
	    share-tty-0)
	(setq share-tty-0 (si:make-share-tty-virtual base-adr))
	(dotimes (i (min *max-share-ttys* nttys))
	  (let* ((vaddr (+ base-adr
			   (* i (+ (max (si:%share-tty-lisp-to-unix-buffer share-tty-0)
					(si:%share-tty-unix-to-lisp-buffer share-tty-0))
				   (truncate (si:%share-tty-buf-size share-tty-0) 4)))))
		 (st (si:make-share-tty-virtual vaddr)))
	    (push st share-ttys)
	    (si:add-shared-device :name (format nil "UNIX-STREAM-~d" i)
				  :shared-device-flavor 'unix-stream-shared-device
				  :owner-virtual-address (+ vaddr si:%share-tty-owner)
				  :default-flavor-and-init-options `(unix-stream :port-number ,i)
				  :property-list `(share-tty ,st))
	    )))
      (setq *share-ttys* (reverse share-ttys)))
    ((:explorer :cadr))))

(defun get-share-tty-number (port-number)
  (assure-*share-ttys*-set-up)
  (let ((st (nth port-number *share-ttys*)))
    (if (null st)
	(ferror nil "bad port number ~d" port-number))
    st))

(defun find-unix-stream (with-login-p &aux str)
  (assure-*share-ttys*-set-up)
  (do-forever
    (catch-error-restart-explicit-if t (no-unix-stream nil "Try again.")
      (if (setq str (find-unix-stream-internal with-login-p))
	  (return-from find-unix-stream str))
      (ferror 'no-unix-stream
	      "couldn't find unix stream with~:[out~] login" with-login-p))))

(defun find-unix-stream-internal (with-login-p)
  (declare (values unix-stream-pathname port-number))
  (assure-*share-ttys*-set-up)
  (dotimes (i (length *share-ttys*))
    (let* ((shared-device-pathname (fs:parse-pathname (format nil "UNIX-STREAM-~d:" i)))
	   (shared-device (send shared-device-pathname :host)))
      (cond ((and (not (eq (car (send shared-device :lock)) current-process))
		  (send shared-device :get-lock nil))
	     (cond ((send shared-device :allocate-if-easy)
		    (cond ((eq (ldb-test si:%%share-tty-csr-opened
					 (si:%share-tty-ucsr
					   (get shared-device 'share-tty)))
			       with-login-p)
			   (return (values shared-device-pathname i))))
		    (send shared-device :deallocate)))
	     (send shared-device :free-lock))))))

(defun unix-stream-status ()
  (dotimes (i (length *share-ttys*))
    (format t "~2&Port ~d" i)
    (let* ((pathname (fs:parse-pathname (format nil "UNIX-STREAM-~d:" i)))
	   (shared-device (send pathname :host)))
      (print shared-device)
      (format t "~&Lock ~s" (car (send shared-device :lock)))
      (format t "~&Opened ~s" (ldb si:%%share-tty-csr-opened
				   (si:%share-tty-ucsr (get shared-device 'share-tty)))))))

(defun reset-unix-streams ()
  (dotimes (i (length *share-ttys*))
    (let* ((pathname (fs:parse-pathname (format nil "UNIX-STREAM-~d:" i)))
	   (shared-device (send pathname :host)))
      (rplaca (send shared-device :lock) nil)
      (send shared-device :deallocate))))

(add-initialization "Clear *share-ttys*"
		    '(setq *share-ttys* nil)
		    '(before-cold))

(add-initialization "Set up *share-ttys*"
		    '(process-run-function "Set up *share-ttys*" 'make-all-share-ttys)
		    '(warm now))

(defflavor simple-unix-window-mixin
	   ((unix-stream nil)
	    (inverse-video nil)
	    (insert-mode nil)
	    typein-process
	    typeout-process
	    (port-number nil)
	    )
	   ()
  (:default-init-plist :save-bits t)
  (:gettable-instance-variables)
  (:settable-instance-variables)
  )

(defflavor simple-unix-window
	   ()
	   (simple-unix-window-mixin
	    tv:list-mouse-buttons-mixin
	    tv:initially-invisible-mixin
	    tv:window)
  )

(defvar unix-stream-window-number 0)

(defmethod (simple-unix-window-mixin :before :init) (init-plist)
  (putprop init-plist nil :more-p))

(defmethod (simple-unix-window-mixin :set-more-p) ignore)

(defmethod (simple-unix-window-mixin :after :init) (init-plist)
  init-plist
  (setq typein-process (make-process "Simple Unix Stream Typein"))
  (send typein-process :preset 'simple-unix-typein-top-level self)
  (setq typeout-process (make-process "Simple Unix Stream Typeout"))
  (send typeout-process :preset 'simple-unix-typeout-top-level self)
  (send self :set-label (format nil "Unix Stream ~d" (incf unix-stream-window-number)))

  (setf (tv:io-buffer-last-output-process (send self :io-buffer))
	typein-process)
  )

;Delay starting up processes until they start to get used, to save paging on cold-boot
(defmethod (simple-unix-window-mixin :before :select) (&rest ignore)
  (maybe-reset-process typein-process)
  (maybe-reset-process typeout-process))

(defmethod (simple-unix-window-mixin :before :expose) (&rest ignore)
  (maybe-reset-process typein-process)
  (maybe-reset-process typeout-process))

(defun maybe-reset-process (process)
  (cond ((and process (typep process 'si:process))
	 (and (eq (process-wait-function process) 'si:flushed-process)
	      (send process :reset))
	 (send process :run-reason self))))

;; Return a list of our extra processes to be killed.
(defmethod (simple-unix-window-mixin :processes) ()
  (append (and typein-process (list typein-process))
	  (and typeout-process (list typeout-process))))

(defun simple-unix-typein-top-level (window)
  (let ((*terminal-io* window))
    (unless (send window :unix-stream)
      (setf (tv:io-buffer-last-output-process (send window :io-buffer))
	    (send window :typein-process))
      (when (not (si:share-mode-active-p))
	(process-wait "Share mode inactive" 'si:share-mode-active-p))
      (send window :clear-screen)
      (assure-*share-ttys*-set-up)
      (if (send window :port-number)
	  (send window :set-port-number (open (format nil "UNIX-STREAM-~d:"
						      (send window :port-number))))
	(multiple-value-bind (pathname port-number)
	    (find-unix-stream t)
	  (send window :set-unix-stream (open pathname))
	  (send window :set-port-number port-number))))
    (do-forever
      (send window :typein-top-level))))

;; crock to make CONTROL-{META-}ABORT handler not typeout to window
(defmethod (simple-unix-window-mixin :inhibit-output-for-abort-p) () t)

(defmethod (simple-unix-window-mixin :typein-top-level) ()
  (send self :tyo-lispm-char-to-unix (send terminal-io :tyi)))

(defmethod (simple-unix-window-mixin :tyo-lispm-char-to-unix) (c)
  (if (not (zerop (ldb %%kbd-meta c)))
      (send unix-stream :tyo 33))
  (selectq c
    (#\return
     (send unix-stream :tyo 15))
    (#\rubout
     (send unix-stream :tyo 177))
    (#\line
     (send unix-stream :tyo 12))
    (#\tab
     (send unix-stream :tyo 11))
    (t
     (send unix-stream :tyo (if (zerop (ldb %%kbd-control c))
				(logand c 177)
			      (logand c 37))))
    ))

(defun simple-unix-typeout-top-level (window)
  (cond ((si:share-mode-active-p)
	 (process-wait "Await initialization"
		       #'(lambda (window)
			   (and (send window :unix-stream)
				(send (send window :unix-stream) :ready-p)))
		       window)
	 (do-forever
	   (send window :typeout-top-level)))))

;not used
(defmethod (simple-unix-window-mixin :typeout-top-level-simple) ()
  (let ((c (send unix-stream :tyi)))
    (selectq c
      (10 (send self :tyo #\overstrike))
      (11 (send self :tyo #\tab))
      (12 (send self :tyo #\newline))
      (15)
      (t (send self :tyo c)))))

(defmethod (simple-unix-window-mixin :typeout-top-level) ()
  (multiple-value-bind (array starting ending)
      (send unix-stream :read-input-buffer)
    (do* ((search-start starting)
	  (first-hard (string-search-set '(10 11 12 15 33 #\space) array search-start ending)
		      (string-search-set '(10 11 12 15 33 #\space) array search-start ending))
	  )
	 ((null first-hard)
	  (send self :clear-then-string-out array starting ending)
	  (send unix-stream :advance-input-buffer ending))

      ;;; Hook so that other users can get at the characters as they are received from unix
      (send self :raw-unix-character-in first-hard)

      (selectq (aref array first-hard)
;	(10 (aset #\overstrike array first-hard)
;	    (setq search-start (1+ first-hard)))
	(10 (send self :clear-then-string-out array starting first-hard)
	    (setq starting (1+ first-hard))
	    (setq search-start starting)
	    (send self :tyo #\overstrike))
	(11 (aset #\tab array first-hard)
	    (setq search-start (1+ first-hard)))
	(12 (aset #\return array first-hard)
	    (setq search-start (1+ first-hard)))
	(15 (send self :clear-then-string-out array starting first-hard)
	    (setq starting (1+ first-hard))
	    (setq search-start starting))
	(#\space (send self :clear-then-string-out array starting first-hard)
		 (do ((n (1+ first-hard) (1+ n)))
		     ((or (= n ending)
			  (not (= (aref array n) #\space)))
		      (dotimes (x (- n first-hard))
			(send self :clear-char)
			(send self :forward-char))
		      (setq starting n)
		      (setq search-start n))))
	(33 (send self :clear-then-string-out array starting first-hard)
	    (send unix-stream :advance-input-buffer first-hard)
	    (send self :handle-escape)	   ;
	    (return nil))
	(t (ferror nil "internal bug: hard case not handled"))
	))))

;;; These methods don't actually do anything, but the user can attach daemons to them
(defmethod (simple-unix-window-mixin :raw-unix-character-in) (c) c)
(defmethod (simple-unix-window-mixin :unix-string-in) (str start end) str start end )

(defmethod (simple-unix-window-mixin :clear-then-string-out) (str &optional (start 0) end)
  (if (null end) (setq end (string-length str)))
  (cond ((null insert-mode)
	 (send self :clear-string str start end)
	 (send self :string-out str start end)

	 ;;; Hook so that other users can get at the strings as they are received from unix
	 (send self :unix-string-in str start end))


	(t
	 (send self :insert-string str start end))))

(defmethod (simple-unix-window-mixin :handle-escape) ()	   ;
  (if (not (= (send unix-stream :tyi) 33))
      (ferror nil "handle-escape called out of phase"))
  (selectq (send unix-stream :tyi)
    (#/L (send self :insert-line))		; termcap 'al'
    (#/J (send self :clear-eof))		;cd
    (#/K (send self :clear-eol))		;ce
    (#/E (send self :clear-screen))		;cl
    (#/Y (let* ((y (- (send unix-stream :tyi) #\space))	;cm
		(x (- (send unix-stream :tyi) #\space)))
	   (send self :set-cursorpos x y :character)))
    (#/N (send self :delete-char))		;dc
    (#/M (send self :delete-line))		;dl
    (#/B (send self :increment-cursorpos 0 1 :character))	;do
    (#/O (setq insert-mode nil))		;ei
    (#/H (send self :home-cursor))		;ho
    (#/@ (setq insert-mode t))			;im
    (#/C (send self :forward-char))		;nd
    (#/F nil)					;as - start alternate char set
    (#/G nil)					;ae - end alternate char set
    (#/I (multiple-value-bind (x y)		;sr
	     (send self :read-cursorpos)
	   (send self :home-cursor)
	   (send self :insert-line)
	   (send self :set-cursorpos x y)))
    (#/q (setq inverse-video nil))		;se
    (#/p (setq inverse-video t))		;so
    (#/A (send self :increment-cursorpos 0 -1 :character))	;up
    (#/x (send self :tyi))			;change cursor blinking mode
    (#/y (send self :tyi))			; dito
    ))

(tv:add-system-key #/U 'simple-unix-window "Login connection to Unix" t)

(compile-flavor-methods simple-unix-window)