;;; -*- Mode:LISP; Package:K-KBUG; Readtable:CL; Base:10 -*-

;;; This is a wimpy terminal connection to the K


(defmacro without-more-processing (the-window &body body)
  "execute body with more processing disabled"
  (let ((more-p (gentemp "morep"))
	(window (gentemp "window")))
    `(let* ((,window ,the-window)
	    (,more-p (si::send ,window :more-p)))
       (unwind-protect
	   (progn (si::send ,window :set-more-p nil)
		  ,@body)
	 (si::send ,window ':set-more-p ,more-p)))))

;; ||| Make half-duplex wimp work with the rubout handler.  -smh 22sep88
;; The rubout handler used to get an incorrect cursor position.  The wimp
;; main-line loop enters the rubout handler via READ-LINE, and then sends
;; the line to the falcon.  The loop immediately reenters READ-LINE, at
;; which entry the rubout-handler's X and Y origins are bound.  Some time
;; later the typeout receiving process gets printed result from the falcon
;; and send it to the stream -- typically before the user types anything --
;; but even so the rubout handler doesn't find out about the cursor updating.
;; You *don't* want to know how the fix works, but it has to do with making
;; a lexical closure over some of the rubout handler variables so the two
;; processes can share them.

tv:
(defmethod (stream-mixin :rubout-handler) (options function &rest args)
  (declare (arglist rubout-handler-options function &rest args))
  (if (and (eq rubout-handler self) (not (cdr (assq :nonrecursive options))))
      (let ((rubout-handler-options (append options rubout-handler-options)))
	(apply function args))
    (let ((rubout-handler-options options))
      (if ( (rhb-fill-pointer) (rhb-scan-pointer))
	  (setf (rhb-fill-pointer) 0)
	(copy-array-portion rubout-handler-buffer (rhb-scan-pointer) (rhb-fill-pointer)
			    rubout-handler-buffer 0 (array-length rubout-handler-buffer))
	(if (numberp (rhb-typein-pointer))
	    (decf (rhb-typein-pointer) (rhb-scan-pointer)))
	(decf (rhb-fill-pointer) (rhb-scan-pointer)))
      (setf (rhb-scan-pointer) 0 (rhb-status) :initial-entry)
      (catch 'return-from-rubout-handler
	(progv (unless (boundp 'prompt-starting-x)	;smh
		 '(prompt-starting-x prompt-starting-y
				     rubout-handler-starting-x
				     rubout-handler-starting-y))
	       (unless (boundp 'prompt-starting-x) '(nil nil nil nil))
	  (let ((rubout-handler self)
		(rubout-handler-inside self)
		(rubout-handler-re-echo-flag nil)
		(rubout-handler-activation-character nil))
	    (multiple-value (prompt-starting-x prompt-starting-y) (send self :read-cursorpos))
	    (setq rubout-handler-starting-x prompt-starting-x
		  rubout-handler-starting-y prompt-starting-y)
	    (do-forever
	      (setq rubout-handler-re-echo-flag nil)
	      (catch 'rubout-handler				;Throw here when rubbing out
		(condition-case (error)
				(return
				 (multiple-value-prog1
				   (apply function args)	;Call READ or whatever.
				   (setf (rhb-fill-pointer) (rhb-scan-pointer))
				   (and (rhb-typein-pointer)
					(> (rhb-typein-pointer) (rhb-fill-pointer))
					(setf (rhb-typein-pointer) (rhb-fill-pointer)))))
				(sys:parse-error
				 (send self :fresh-line)
				 (princ ">>ERROR: " self)
				 (send error :report self)
				 (send self :fresh-line)
				 (setq rubout-handler-re-echo-flag t)
				 (do-forever (send self :tyi)))))	;If error, force user to rub out
	      ;;Maybe return when user rubs all the way back
	      (and (zerop (rhb-fill-pointer))
		   (let ((full-rubout-option (assq :full-rubout rubout-handler-options)))
		     (when full-rubout-option
		       ;; Get rid of the prompt, if any.
		       (send self :clear-between-cursorposes
			     prompt-starting-x prompt-starting-y
			     (- cursor-x left-margin-size) (- cursor-y top-margin-size))
		       (send self :set-cursorpos prompt-starting-x prompt-starting-y)
		       (return (values nil (cadr full-rubout-option)))))))))))))

(defun wimp (&optional half-duplex)
  "communicate with the K stream"
  (without-more-processing *terminal-io*
    (si::*catch 'eof
      (let (p tv::prompt-starting-x tv::prompt-starting-y)
	(unwind-protect
	    (progn (setq p (si::process-run-function
			     "wimp input from K"
  			     (zl::closure '(tv::prompt-starting-x tv::prompt-starting-y
								  tv::rubout-handler-starting-x
								  tv::rubout-handler-starting-y)
					  #'(lambda (to superior)
					      (si::condition-case (x)
						  (do ((c)
						       (si:self to))
						      ((null (setq c (kbug:read-from-k-stream)))
						       (format to "~&***CONNECTION CLOSED AT REMOTE END***~%"))
						    (write-char c to)
						    ;; Work around a lambda compiler bug in multiple-value-setq.
						    ;; smh 22sep88
						    (let ((l (multiple-value-list (zl:send to :READ-CURSORPOS))))
						      (setq tv::prompt-starting-x (first l)
							    tv::prompt-starting-y (second l)))
						    (setq tv::rubout-handler-starting-x tv::prompt-starting-x
							  tv::rubout-handler-starting-y tv::prompt-starting-y))
						(si::error
						  (si::send x :report to)))
					      (si::send superior :interrupt
							#'(zl:lambda () (si::*throw 'eof nil)))
					      (si:process-wait-forever)))
			     ;;#'wimp-tty-characters-from-k
			     *terminal-io*
			     si::current-process))
		   (cond (half-duplex
			  (do ((line))
			      (nil)
			    (setq line (si::prompt-and-read :string ""))
			    (do ((j 0 (1+ j))
				 (n (length line)))
				((= j n))
			      (wimp-send-1-to-k (aref line j)))
			    (wimp-send-1-to-k #\return)))
			 ('else
			  (si::do-forever
			    (wimp-send-1-to-k (read-char *terminal-io*))))))
	  (and p (si::send p :kill)))))))


(defun wimp-tty-characters-from-k (to superior)
  (si::condition-case (x)
      (do ((c))
	  ((null (setq c (kbug:read-from-k-stream)))
	   (format to "~&***CONNECTION CLOSED AT REMOTE END***~%"))
	(write-char c to))
    (si::error
     (si::send x :report to)))
  (si::send superior :interrupt
	#'(lambda () (si::*throw 'eof nil)))
  (si:process-wait-forever))


(defun wimp-send-1-to-k (char)
  (write-to-k-character-stream char))

(defun wimput-proc (*terminal-io*)
  "communicate with the K stream"
  (without-more-processing *terminal-io*
    (si::*catch 'eof
      (do ((line))
	  (nil)
	(setq line (si::prompt-and-read :string ""))
	(do ((j 0 (1+ j))
	     (n (length line)))
	    ((= j n))
	  (wimp-send-1-to-k (aref line j)))
	(wimp-send-1-to-k #\return)))))

(defun wimpout-proc (*terminal-io*)
  (loop do
	(zl:catch-error-restart (sys:abort "Wimpout")
	  (si::condition-case (x)
	      (do ((c))
		  ()
		(unless (setq c (kbug:read-from-k-stream))
		  (format *terminal-io* "~&***CONNECTION CLOSED AT REMOTE END***~%")
		  (zl:process-wait "Reopen" #'(lambda ()
						(setq c (kbug:read-from-k-stream)))))
		(write-char c *terminal-io*))
	    (si::error
	      (si::send x :report *terminal-io*))))))



(zl:defflavor wimpy-falcon () (tv:process-mixin tv:pane-mixin tv:window))

(zl:defflavor falcon-food () (tv:process-mixin tv:pane-mixin tv:window))

(zl:defflavor wimp () (tv:bordered-constraint-frame-with-shared-io-buffer
			tv:select-mixin
			tv:FULL-SCREEN-HACK-MIXIN
			tv:FRAME-DONT-SELECT-INFERIORS-WITH-MOUSE-MIXIN
			tv:inferiors-not-in-select-menu-mixin
			tv:alias-for-inferiors-mixin
			tv:label-mixin)
  (:DEFAULT-INIT-PLIST :SAVE-BITS :DELAYED
    :panes '((falcon wimpy-falcon
		     :label nil
		     :more-p nil
		     :process (wimpout-proc))
	     (input falcon-food
		    :label "Input"
		    :more-p nil
		    :process (wimput-proc)))
    :constraints '((main . ((falcon input)
			    ((input 3 :lines))
			    ((falcon :even)))))))

(tv:add-system-key #\Greek-L 'wimp "Falcon Listener window. Do m-L in KBUG2")