;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.198
;;; Reason:
;;;  Supdup server wasn't properly dealing with certain special Lisp Machine
;;;  graphics: 

;;; Written 2-Feb-88 12:51:00 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.197, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.3, 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#113 at 2-Feb-88 15:04:54
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "

(defun supdup-server-input (user-process buffer-stream remote-stream terminal)
  (declare (ignore terminal))
  (do (c bits code)
      ((null (setq c (send remote-stream :tyi))))
    (when (= c #o34)
      (setq bits (send remote-stream :tyi))
      (cond ((null bits)
	     (setq c nil))
	    ((= bits #o34)
	     (setq c (int-char c)))
	    (t
	     (setq bits (logand bits #o37))
	     (setq code (send remote-stream :tyi))
	     (cond ((null code)
		    (setq c nil))
		   (t
		    (setq c (dpb (logand bits #o20) (byte 5 7) (logand #o177 code)))
		    (setq c (make-char (cond ((cadr (assoc c *ascii-supdup-translations* :test #'eq)))
					     ((= bits #o20) code)
					     (t (global:char-flipcase code)))
				       (logand bits #o17))))))))
    (cond ((null c)				;End Of File
	   (send buffer-stream :tyo nil))
	  ((eq c #\Control-Abort)
	   (send user-process :interrupt 'network-user:handle-abort))
	  ((eq c #\Control-Meta-Abort)
	   (send user-process :interrupt 'network-user:handle-abort-all))
	  ((eq c #\Control-Break)
	   (send user-process :interrupt 'network-user:handle-break))
	  ((eq c #\Control-Meta-Break)
	   (send user-process :interrupt 'network-user:handle-error-break))
	  ((integerp c)				;Not prefixed by #o34 -- pass through
	   (send buffer-stream :tyo c))
	  ((graphic-char-p c)			;Special Printing character -- pass through
	   (send buffer-stream :tyo c))
	  (t
	   (send buffer-stream :tyo (char-int c))))))

))