;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.149
;;; Reason:
;;;  Well, we really do need a :force-output process for Server Telnet -- when you exit
;;;  the debugger, your Lisp listener does a :tyi before the error handler does its
;;;  :string-out.  Also seemed to be a race condition causing the "coroutine get" to
;;;  not recognize when input was available.  Recode to be more defensive...
;;; Written 7-Dec-87 15:55:37 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.148, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.0, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.12, SDU ROM 8.



; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#91 at 7-Dec-87 15:55:38
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "

(defvar *telnet-asynchronous-force-output-period* 60.)

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#91 at 7-Dec-87 15:56:15
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "

(defun telnet-server-function (remote-stream)
  (let* ((safe-input-stream (make-eof-throwing-stream remote-stream))
	 (terminal (make-stream-terminal nil remote-stream safe-input-stream))
	 (si:user-id nil)
	 (telnet-user:*term* nil)
	 (cvars '(telnet-user:*term* si:user-id)))
    (catch 'eof
      (send terminal :send-if-handles :send-initial-telnet-frobs)
      (format terminal "~%Welcome to ~A Server Telnet." (send si:local-host :name))
      (send terminal :force-output)
      (telnet-user-login terminal)
      (global:print-herald terminal)
      (terpri terminal)
      (send terminal :force-output)
      (subprocess :closure-variables cvars
		  (loop
		    (send terminal :force-output)
		    (sys:process-sleep *telnet-asynchronous-force-output-period*)))
      (multiple-value-bind (buffer-stream buffer)
	  (make-simple-io-buffer-stream)
	(send terminal :set-input-stream buffer-stream)
	(send terminal :set-more-p t)
	(send sys:current-process :set-priority 1)
	(catch 'telnet-server-logout
	  (telnet-server-input (subprocess :closure-variables cvars
					   (global:progw (append *telnet-user-process-bindings* si:*break-bindings*)
					     (catch 'telnet-server-logout
					       (si:lisp-top-level1 terminal))
					     (send (network-server-process *server*)
						   :interrupt #'telnet-user:logout)))
			       buffer
			       remote-stream))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#91 at 7-Dec-87 15:56:25
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "


(defun simple-io-buffer-put (buffer object)
  (let ((place (simple-io-buffer-put-place buffer)))
    (cond ((eq (car place) 'empty)
	   (without-interrupts
	     (setf (car place) object)
	     (setf (simple-io-buffer-put-place buffer) (cdr place))
	     (incf (simple-io-buffer-available buffer))))
	  ((eq (cadr place) 'empty)
	   (without-interrupts
	     (setf (cadr place) object)
	     (setf (simple-io-buffer-put-place buffer) (cddr place))
	     (incf (simple-io-buffer-available buffer))))
	  (t
	   (process-wait "coroutine put"
			 #'(lambda (p) (eq (car p) 'empty))
			 (cdr place))
	   (simple-io-buffer-put buffer object)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#91 at 7-Dec-87 15:56:27
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "


(defun simple-io-buffer-get (buffer &aux place)
  (loop
    (cond ((zerop (simple-io-buffer-available buffer))
	   (process-wait "coroutine get"
			 #'(lambda (buffer)
			     (plusp (simple-io-buffer-available buffer)))
			 buffer))
	  ((eq (car (setq place (simple-io-buffer-get-place buffer))) 'empty)
	   (error "non-zero available, yet get-place is empty??"))
	  (t
	   (return (without-interrupts
		     (prog1 (car place)
			    (setf (car place) 'empty)
			    (setf (simple-io-buffer-get-place buffer) (cdr place))
			    (decf (simple-io-buffer-available buffer)))))))))


))