;;;Windows that hack the network -*- Mode:LISP; Package:SUPDUP -*-

(DEFFLAVOR BUFFERED-OUTPUT-MIXIN ((OUTPUT-BUFFER (MAKE-ARRAY NIL 'ART-STRING 200 NIL '(0))))
			   ()
  (:REQUIRED-METHODS :BUFFERED-TYO))

(DEFMETHOD (BUFFERED-OUTPUT-MIXIN :BUFFERED-TYO) (CH)
  (DO () ((ARRAY-PUSH OUTPUT-BUFFER CH))
    (FUNCALL-SELF ':FORCE-OUTPUT)))

(DEFMETHOD (BUFFERED-OUTPUT-MIXIN :FORCE-OUTPUT) ()
  (TV:SHEET-STRING-OUT SELF OUTPUT-BUFFER)
  (STORE-ARRAY-LEADER 0 OUTPUT-BUFFER 0))

(DEFFLAVOR BASIC-NVT
	   ((ESCAPE-CHAR #\BREAK)	;Escape character (in Lisp machine character set)
	    (CONNECTION NIL)		;The connection itself
	    (CONNECT-TO NIL)		;Host to connect to (for TYPEIN-TOP-LEVEL)
	    STREAM			;A stream to the above
	    (TERMINAL-STREAM NIL)	;Stream for output. If NIL, (which is the usual case)
					; output to SELF.
	    (TYPEOUT-PROCESS NIL)	;Network  screen
	    (TYPEIN-PROCESS NIL)	;Keyboard  network
	    (OUTPUT-LOCK NIL)		;Some typeout occurs in TYPEIN-PROCESS
	    (RETURN-TO-CALLER NIL)	;Set to T when :TYPEIN-TOP-LEVEL should return
	    ORDINARY-IO-BUFFER		;Lisp machine character set
	    NVT-IO-BUFFER)		;Special character set and turns off CALL key
	    (BUFFERED-OUTPUT-MIXIN TV:ANY-TYI-MIXIN)
  (:INCLUDED-FLAVORS TV:LABEL-MIXIN TV:STREAM-MIXIN)
  (:GETTABLE-INSTANCE-VARIABLES CONNECTION STREAM)
  (:INITABLE-INSTANCE-VARIABLES ESCAPE-CHAR TYPEIN-PROCESS TYPEOUT-PROCESS)
  (:SETTABLE-INSTANCE-VARIABLES CONNECT-TO TERMINAL-STREAM)
  (:REQUIRED-METHODS :CONNECT :GOBBLE-GREETING :TRANSLATE-INPUT-CHAR :NET-OUTPUT)
  (:DOCUMENTATION :SPECIAL-PURPOSE "Network virtual terminal windows"))

(DEFMACRO LOCK-OUTPUT BODY
  `(UNWIND-PROTECT
     (PROGN
       (PROCESS-LOCK (LOCATE-IN-INSTANCE SELF 'OUTPUT-LOCK))
       . ,BODY)
     (COND ((EQ CURRENT-PROCESS OUTPUT-LOCK)
	    (PROCESS-UNLOCK (LOCATE-IN-INSTANCE SELF 'OUTPUT-LOCK))))))

;The following is just like TV:PROCESS-MIXIN except that there are two processes
;Also we have to provide for the two I/O buffers
(DEFMETHOD (BASIC-NVT :AFTER :INIT) (IGNORE)
  (SETQ ORDINARY-IO-BUFFER TV:IO-BUFFER
	NVT-IO-BUFFER (TV:MAKE-IO-BUFFER 100 NIL NIL))
  (PUTPROP (LOCF (TV:IO-BUFFER-PLIST NVT-IO-BUFFER)) T ':SUPER-IMAGE)
  (OR TYPEOUT-PROCESS
      (SETQ TYPEOUT-PROCESS (PROCESS-CREATE (STRING-APPEND TV:NAME "-Typeout")
					    ':SPECIAL-PDL-SIZE 2000.)))
  (COND ((NULL TYPEIN-PROCESS)
	 (SETQ TYPEIN-PROCESS (PROCESS-CREATE (STRING-APPEND TV:NAME "-Typein")
					      ':SPECIAL-PDL-SIZE 2000.))
	 (PROCESS-PRESET TYPEIN-PROCESS 'TYPEIN-TOP-LEVEL SELF)))
  (PROCESS-PRESET TYPEOUT-PROCESS SELF ':TYPEOUT-TOP-LEVEL))

;Delay starting up processes until they start to get used, to save paging on cold-boot
(DEFMETHOD (BASIC-NVT :BEFORE :SELECT) (&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) #'FALSE)
	      (FUNCALL PROCESS ':RESET))
	 (FUNCALL PROCESS ':RUN-REASON SELF))))

;Don't kill the process until all methods
;and wrappers have run first.  This is because we might be
;executing inside the process that belongs to the window,
;and we don't want to go away before finishing.
(DEFWRAPPER (BASIC-NVT :KILL) (() . BODY)
  `(PROGN ,@BODY
	  (AND TYPEIN-PROCESS (FUNCALL TYPEIN-PROCESS ':KILL))
	  (AND TYPEOUT-PROCESS (FUNCALL TYPEOUT-PROCESS ':KILL))))

(DEFMETHOD (BASIC-NVT :CONNECTED-P) ()
  (AND CONNECTION (EQ (CHAOS:STATE CONNECTION) 'CHAOS:OPEN-STATE)))

(DEFMETHOD (BASIC-NVT :BEFORE :CONNECT) (&REST IGNORE)
  (FUNCALL-SELF ':DISCONNECT))

(DEFMETHOD (BASIC-NVT :AFTER :SET-CONNECT-TO) (&REST IGNORE)
  (AND TYPEIN-PROCESS (FUNCALL TYPEIN-PROCESS ':RESET)))

(DEFMETHOD (BASIC-NVT :NEW-CONNECTION) (PATH WINDOW CONTACT-NAME ARPA-SOCKET
				        &AUX LABEL-SPEC CONN)
  (MULTIPLE-VALUE (PATH CONTACT-NAME LABEL-SPEC)
    (PARSE-PATH PATH CONTACT-NAME ARPA-SOCKET))
  (SETQ CONN (CHAOS:CONNECT PATH CONTACT-NAME WINDOW))
  (IF (STRINGP CONN) CONN
      (FUNCALL-SELF ':SET-LABEL LABEL-SPEC)
      (FUNCALL-SELF ':SET-CONNECTION CONN)))

;;;Parse the user's pathname, returns chaosnet host, contact name, and label spec
(DEFUN PARSE-PATH (PATH CONTACT-NAME ARPA-SOCKET &AUX BRIDGE CNAME LSPEC)
  (AND (NUMBERP PATH) (SETQ PATH (CHAOS:HOST-DATA PATH)))
  (AND PATH (SYMBOLP PATH) (SETQ PATH (GET-PNAME PATH)))
  (COND ((NULL PATH)
	 (SETQ PATH "AI"))
	((NUMBERP PATH))
	(T
	 (AND (SETQ BRIDGE (STRING-SEARCH-CHAR #/ PATH))
	      (PSETQ PATH (SUBSTRING PATH (1+ BRIDGE))
		     BRIDGE (SUBSTRING PATH 0 BRIDGE)))
	 (COND ((NOT (ASSOC (OR BRIDGE PATH) CHAOS:HOST-ALIST))
		(AND BRIDGE (SETQ CNAME PATH
				  PATH BRIDGE))
		(SETQ BRIDGE "AI"))
	       ((SETQ CNAME (STRING-SEARCH-CHAR #/ PATH))
		(PSETQ CNAME (SUBSTRING PATH (1+ CNAME))
		       PATH (SUBSTRING PATH 0 CNAME))))))
  (IF (NULL BRIDGE)
      (SETQ LSPEC PATH
	    BRIDGE PATH
	    PATH (OR CNAME CONTACT-NAME))
      (SETQ LSPEC (STRING-APPEND BRIDGE "  " PATH)
	    PATH (FORMAT NIL "ARPA ~A ~:[~O~*~;~*~A~]" PATH CNAME ARPA-SOCKET CNAME)))
  (PROG () (RETURN BRIDGE PATH (STRING-APPEND CONTACT-NAME " -- " LSPEC))))

(DEFMETHOD (BASIC-NVT :SET-CONNECTION) (NEW-CONNECTION)
  (FUNCALL TYPEIN-PROCESS ':FLUSH)
  (FUNCALL TYPEOUT-PROCESS ':FLUSH)
  (SETQ CONNECTION NEW-CONNECTION)
  (SETQ STREAM (CHAOS:STREAM CONNECTION))
  (FUNCALL-SELF ':GOBBLE-GREETING)
  (FUNCALL TYPEIN-PROCESS ':RESET)
  (FUNCALL TYPEOUT-PROCESS ':RESET))

(DEFMETHOD (BASIC-NVT :DISCONNECT) ()
  (FUNCALL TYPEIN-PROCESS ':FLUSH)
  (FUNCALL TYPEOUT-PROCESS ':FLUSH)
  (COND (CONNECTION
	 (CHAOS:CLOSE CONNECTION)
	 (CHAOS:REMOVE-CONN CONNECTION)
	 (SETQ CONNECTION NIL)))
  (FUNCALL TYPEIN-PROCESS ':RESET)
  (FUNCALL TYPEOUT-PROCESS ':RESET))

;;;This is the typein process
(DEFUN TYPEIN-TOP-LEVEL (WINDOW)
  (DO () (())
    (FUNCALL WINDOW ':TYPEIN-TOP-LEVEL)
    (TV:DELAYING-SCREEN-MANAGEMENT
      (FUNCALL WINDOW ':DESELECT T)
      (FUNCALL WINDOW ':BURY))))

(DEFMETHOD (BASIC-NVT :TYPEIN-TOP-LEVEL) (&OPTIONAL (TOP-LEVEL-P T) &AUX (TERMINAL-IO SELF))
  (DO ((STR NIL NIL)) (NIL)
    (SETQ RETURN-TO-CALLER NIL)
    (*CATCH (IF TOP-LEVEL-P 'SI:TOP-LEVEL 'THIS-TAG-WILL-NEVER-GET-THROWN-TO)
      (CONDITION-BIND ((CHAOS:READ-ON-LOS-CONNECTION NET-ERROR)
		       (CHAOS:HOST-DOWN NET-ERROR))
	(SETQ STR
	      (IF CONNECTION
		  (*CATCH 'NVT-DONE
		    (PROG READ-INPUT ()
		      (FUNCALL-SELF ':SET-IO-BUFFER NVT-IO-BUFFER)
		      (DO ((CH)) (NIL)
			(OR (FUNCALL-SELF ':LISTEN) (FUNCALL STREAM ':FORCE-OUTPUT))
			(SETQ CH (FUNCALL-SELF ':ANY-TYI))
			(IF (LISTP CH)
			    (SELECTQ (CAR CH)
			      (:ERROR (RETURN-FROM READ-INPUT (CADR CH)))
			      (:MORE (FUNCALL-SELF ':MORE-TYI)))
			    (SELECTQ (CHAOS:STATE CONNECTION)
			      (CHAOS:OPEN-STATE)
			      (CHAOS:HOST-DOWN-STATE
			       (RETURN-FROM READ-INPUT "Foreign Host died"))
			      (CHAOS:CLS-RECEIVED-STATE
			       (RETURN-FROM READ-INPUT "Closed by foreign host"))
			      (CHAOS:LOS-RECEIVED-STATE
			       (RETURN-FROM READ-INPUT "Connection closed due to lossage:"))
			      (OTHERWISE
			       (RETURN-FROM READ-INPUT
					    (FORMAT NIL "Connection in unknown state:~S"
						    (CHAOS:STATE CONNECTION)))))
			    (IF (OR (= (CHAR-UPCASE CH) ESCAPE-CHAR)
				    (= CH #\NETWORK))
				;;Handle the escape character,
				(FUNCALL-SELF ':HANDLE-ESCAPE)
				;; otherwise just send through what user typed.
				(SETQ CH (FUNCALL-SELF ':TRANSLATE-INPUT-CHAR CH))
				(FUNCALL-SELF ':NET-OUTPUT CH))))))
		  (COND (CONNECT-TO
			 (FUNCALL-SELF ':CLEAR-SCREEN)
			 (FUNCALL-SELF ':CONNECT (PROG1 CONNECT-TO (SETQ CONNECT-TO NIL))))
			(T (FUNCALL-SELF ':SET-IO-BUFFER ORDINARY-IO-BUFFER)
			   (FORMAT T "~%Connect to host: ")
			   (FUNCALL-SELF ':CONNECT (READLINE))))))))
    (COND ((STRINGP STR)
	   (FUNCALL-SELF ':DISCONNECT)
	   (FORMAT SELF "~%~A~%" STR)
	   (AND RETURN-TO-CALLER (RETURN T))))))

;;;Condition handler for typein side.
(DEFUN NET-ERROR (IGNORE STRING &REST ARGS)
  (*THROW 'NVT-DONE (LEXPR-FUNCALL #'FORMAT NIL STRING ARGS)))

;;;Handle a command to the SUPDUP program itself.
(DEFMETHOD (BASIC-NVT :HANDLE-ESCAPE) (&AUX CH XPOS YPOS)
  (UNWIND-PROTECT
    (PROGN
      (MULTIPLE-VALUE (XPOS YPOS) (TV:SHEET-READ-CURSORPOS SELF))
      (PUT-DOWN-STRING SELF "CMND-->")
      (SETQ CH (CHAR-UPCASE (FUNCALL-SELF ':TYI)))
      (SELECTQ CH
	((#\CALL #/P)
	 (FUNCALL-SELF ':DESELECT T))
	((#/B)
	 (FUNCALL-SELF ':SET-IO-BUFFER ORDINARY-IO-BUFFER)
	 (BREAK BREAK T)
	 (FUNCALL-SELF ':SET-IO-BUFFER NVT-IO-BUFFER))
	(#/C			      ;C = Change escape character.
	 (PUT-DOWN-STRING SELF "CHANGE ESCAPE CHARACTER TO -->")
	 (FUNCALL-SELF ':SET-IO-BUFFER ORDINARY-IO-BUFFER)
	 (SETQ ESCAPE-CHAR (CHAR-UPCASE (FUNCALL-SELF ':TYI)))
	 (FUNCALL-SELF ':SET-IO-BUFFER NVT-IO-BUFFER))
	(#/D                         ;D = Disconnect, ask for new host to connect to.
	 (FUNCALL-SELF ':DISCONNECT)
	 (*THROW 'NVT-DONE "Disconnected"))
	(#/L			      ;L = Logout.
	 (FUNCALL-SELF ':LOGOUT)
	 (QUIT "Logout"))
	(#/Q			      ;Q = Quit.
	 (QUIT))
	(#/M			      ;M = More.
	 (FUNCALL-SELF ':SET-MORE-P (NOT (FUNCALL-SELF ':MORE-P))))
	(#/I			      ;I = Imlac.
	 (FUNCALL-SELF ':TOGGLE-IMLAC-SIMULATION))
	((#\HELP #/?)		      ;<HELP> or ? = Help
	 (TV:SHEET-HOME SELF)
	 (TV:SHEET-CLEAR-EOL SELF)
	 (FORMAT SELF "After typing the Escape character, which is ~:C,
you can type these commands:~%" ESCAPE-CHAR)
	 (FORMAT SELF "
CALL -- Do a local CALL (return to top window).
B    -- Enter a breakpoint.
C    -- Change the SUPDUP escape character.
D    -- Disconnect and connect to new host.
L    -- Log out of remote host, and break the connection.
P    -- Return to top window, but don't break connection.
Q    -- Disconnect and return to top window.
~:[~;M    -- Toggle more processing.
I    -- Toggle imlac simulation.
~]
?    -- Type this cruft.
" (GET-HANDLER-FOR SELF ':TOGGLE-IMLAC-SIMULATION))
	 (FORMAT SELF "~4A -- Send ~:C through~%"
		 (FORMAT NIL "~:C" ESCAPE-CHAR)
		 ESCAPE-CHAR))
	(#\RUBOUT)				;<RUBOUT> = Do nothing.
	(OTHERWISE
	  (COND ((OR (= CH ESCAPE-CHAR) (= CH #\NETWORK))
		 (FUNCALL-SELF ':NET-OUTPUT (FUNCALL-SELF ':TRANSLATE-INPUT-CHAR CH))
		 (FUNCALL STREAM ':FORCE-OUTPUT))
		(T (TV:BEEP))))))
    (TV:SHEET-FORCE-ACCESS (SELF)
      (PUT-DOWN-STRING SELF "")      ;Clear the bottom line.
      (TV:SHEET-SET-CURSORPOS SELF XPOS YPOS))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-NVT)
(DEFUN QUIT (&OPTIONAL (STRING "Quit"))
  (FUNCALL-SELF ':DISCONNECT)
  (SETQ RETURN-TO-CALLER T)
  (*THROW 'NVT-DONE STRING)))

(DEFUN PUT-DOWN-STRING (SHEET STRING)
  (TV:SHEET-HOME-DOWN SHEET)
  (TV:SHEET-CLEAR-EOL SHEET)
  (TV:SHEET-STRING-OUT SHEET STRING))

;;;This is the output process
(DEFMETHOD (BASIC-NVT :TYPEOUT-TOP-LEVEL) (&AUX (TERMINAL-IO SELF))
  (PROCESS-WAIT "Never-open" #'CAR (LOCATE-IN-INSTANCE SELF 'CONNECTION))
  (CONDITION-BIND ((CHAOS:READ-ON-LOS-CONNECTION TYPEOUT-NET-ERROR)
		   (CHAOS:HOST-DOWN TYPEOUT-NET-ERROR))
    (DO ((OUTPUT-FUN (OR TERMINAL-STREAM (GET-HANDLER-FOR SELF ':BUFFERED-TYO))))
	(NIL)
      (DO ((CH (NVT-NETI) (FUNCALL STREAM ':TYI-NO-HANG)))
	  ((NULL CH)
	   (OR TERMINAL-STREAM (FUNCALL-SELF ':FORCE-OUTPUT)))
	(FUNCALL OUTPUT-FUN ':TYO CH)))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-NVT)
(DEFUN NVT-NETI (&AUX CH)
  (COND ((SETQ CH (FUNCALL STREAM ':TYI)))
	(T
	 (FUNCALL-SELF ':FORCE-KBD-INPUT '(:ERROR "Closed by foreign host"))
	 (PROCESS-WAIT "Connection closed" #'FALSE)))))

(DEFUN TYPEOUT-NET-ERROR (IGNORE STRING &REST ARGS)
  (FUNCALL-SELF ':FORCE-KBD-INPUT (LIST ':ERROR (LEXPR-FUNCALL #'FORMAT NIL STRING ARGS)))
  (SI:PROCESS-WAIT-FOREVER))

(DEFFLAVOR BASIC-SUPDUP () (BASIC-NVT)
  (:DOCUMENTATION :SPECIAL-PURPOSE "A SUPDUP NVT"))

(DEFFLAVOR SUPDUP () (BASIC-SUPDUP TV:FULL-SCREEN-HACK-MIXIN TV:WINDOW)
  (:DEFAULT-INIT-PLIST :SAVE-BITS T)
  (:DOCUMENTATION :COMBINATION))

(DEFRESOURCE TYPEOUT-PROCESSES
 (PROCESS-CREATE "NVT-Typeout" ':SPECIAL-PDL-SIZE 2000.))

(DEFVAR *SUPDUP-WINDOWS* NIL)
(DEFVAR *SUPDUP-DEFAULT-PATH* "AI")
(DEFVAR *SUPDUP-MODE* T)			;NIL => New window default

(DEFUN FIND-SELECTABLE-SUPDUP (CONNECTED-P &OPTIONAL (SUP TV:MOUSE-SHEET))
  (DOLIST (W *SUPDUP-WINDOWS*)
    (AND (EQ (FUNCALL W ':CONNECTED-P) CONNECTED-P)
	 (OR (NULL SUP) (EQ SUP (TV:SHEET-SUPERIOR W)))
	 (RETURN W))))

(DEFUN SUPDUP (&OPTIONAL PATH (MODE *SUPDUP-MODE*))
  (IF MODE
      (SUPDUP-SEPARATE PATH)
      (SUPDUP-BIND PATH)))

(DEFUN SUPDUP-SEPARATE (&OPTIONAL PATH &AUX SW)
  "Create a separate supdup"
  (COND ((AND (NULL PATH) (SETQ SW (FIND-SELECTABLE-SUPDUP T NIL)))
	 (FUNCALL SW ':SELECT)
	 NIL)
	(T
	 (SETQ SW (OR (FIND-SELECTABLE-SUPDUP NIL) (TV:WINDOW-CREATE 'SUPDUP)))
	 (FUNCALL SW ':SET-CONNECT-TO (OR PATH *SUPDUP-DEFAULT-PATH*))
	 (FUNCALL SW ':EXPOSE NIL ':CLEAN) ;Don't come up with old garbage
	 (FUNCALL SW ':SELECT)
	 T)))

(DEFUN SUPDUP-BIND (&OPTIONAL PATH (WINDOW TERMINAL-IO) &AUX SW)
  "Run supdup in the current window by window pushing"
  (COND ((AND (NULL PATH) (SETQ SW (FIND-SELECTABLE-SUPDUP T)))
	 (FUNCALL SW ':SELECT)
	 NIL)
	(T
	 (OR PATH (SETQ PATH *SUPDUP-DEFAULT-PATH*))
	 (WITH-RESOURCE (TV:BIT-ARRAYS BIT-ARRAY)
	   (WITH-RESOURCE (TYPEOUT-PROCESSES TP)
	     (TV:WINDOW-BIND (WINDOW 'SUPDUP ':TYPEIN-PROCESS CURRENT-PROCESS
				     ':BIT-ARRAY BIT-ARRAY
				     ':TYPEOUT-PROCESS TP)
			     (FUNCALL WINDOW ':CONNECT PATH)
			     (*CATCH 'SI:TOP-LEVEL (FUNCALL WINDOW ':TYPEIN-TOP-LEVEL NIL))
			     (SETF (TV:SHEET-BIT-ARRAY WINDOW) NIL)
			     T))))))

(DEFMETHOD (BASIC-SUPDUP :BEFORE :INIT) (INIT-PLIST)
  (SETQ TV:LABEL "Supdup -- not connected")
  (PUTPROP INIT-PLIST NIL ':MORE-P))

(DEFMETHOD (BASIC-SUPDUP :BEFORE :SELECT) (&REST IGNORE)
  ;Move ourselves to the head of the list
  (WITHOUT-INTERRUPTS
    (SETQ *SUPDUP-WINDOWS* (DELQ SELF *SUPDUP-WINDOWS*))
    (PUSH SELF *SUPDUP-WINDOWS*)))

(DEFMETHOD (BASIC-SUPDUP :BEFORE :DEACTIVATE) (&REST IGNORE)
  (WITHOUT-INTERRUPTS (SETQ *SUPDUP-WINDOWS* (DELQ SELF *SUPDUP-WINDOWS*))))

(DEFMETHOD (BASIC-SUPDUP :AFTER :ACTIVATE) (&REST IGNORE)
  (WITHOUT-INTERRUPTS
    (OR (MEMQ SELF *SUPDUP-WINDOWS*)
	(IF *SUPDUP-WINDOWS*
	    (RPLACD (LAST *SUPDUP-WINDOWS*) (NCONS SELF))
	    (SETQ *SUPDUP-WINDOWS* (NCONS SELF))))))

(DEFMETHOD (BASIC-SUPDUP :VERIFY-NEW-EDGES) (NEW-LEFT NEW-TOP NEW-WIDTH NEW-HEIGHT)
  NEW-LEFT NEW-TOP				;Unused
  (AND CONNECTION
       (OR ( NEW-WIDTH TV:WIDTH) ( NEW-HEIGHT TV:HEIGHT))
       "Attempt to change size while connected"))

(DEFMETHOD (BASIC-SUPDUP :CONNECT) (&OPTIONAL PATH (NET-WINDOW 3))
  (AND (NUMBERP PATH) (SETQ PATH (CHAOS:HOST-DATA PATH)))
  (LET ((SUPDUP-%TOCID (IF (STRING-SEARCH PATH "SAIL") T
			   SUPDUP-%TOCID)))
    (FUNCALL-SELF ':NEW-CONNECTION PATH NET-WINDOW "SUPDUP" 137)))

(DEFMETHOD (BASIC-SUPDUP :GOBBLE-GREETING) ()
  (SEND-TTY-VARIABLES STREAM SELF)
  (SEND-FINGER-STRING STREAM)
  ;;Print out the greeting message ITS sends in ASCII.
  (DO ((CH #\CR (FUNCALL STREAM ':TYI)))
      ((OR (NULL CH) (= CH 210)))	;The end is marked with a %TDNOP, NIL is eof
    (AND (< CH 40) (SETQ CH (+ 200 CH)))
    (OR (= CH 212)			;Don't type linefeeds (ITS sends CRLFs).
	(TYO CH SELF))))

;;;Send the initial information describing the Lisp Machine as an
;;;intelligent terminal.  The TTYOPT word contains the following:
;;;%TOERS+%TOMVB+%TOSAI+%TOOVR+%TOMVU+%TOLWR+%TOFCI+%TOMOR+%TOLID,,%TPCBS+%TPORS+%TPRSC
(DEFVAR SUPDUP-%TOCID NIL)

(DEFUN SEND-TTY-VARIABLES (STREAM SHEET)
    (18BIT-OUT STREAM -5)		;First word is -5,,0
    (18BIT-OUT STREAM 0)
    (18BIT-OUT STREAM 0)		;TCTYP word must be %TNSFW: 0,,7
    (18BIT-OUT STREAM 7)
    (18BIT-OUT STREAM (IF SUPDUP-%TOCID 55633 55632))	;TTYOPT word explained above.
    (18BIT-OUT STREAM 54)
    (18BIT-OUT STREAM 0)		;TCMXV
    (18BIT-OUT STREAM (1- (// (TV:SHEET-INSIDE-HEIGHT SHEET) (TV:SHEET-LINE-HEIGHT SHEET))))
    (18BIT-OUT STREAM 0)		;TCMXH
    (18BIT-OUT STREAM (1- (// (TV:SHEET-INSIDE-WIDTH SHEET) (TV:SHEET-CHAR-WIDTH SHEET))))
    (18BIT-OUT STREAM 0)		;TTYROL
    (18BIT-OUT STREAM 0)		;No scrolling
    (FUNCALL STREAM ':FORCE-OUTPUT))

(DEFUN 18BIT-OUT (STREAM N)
    (FUNCALL STREAM ':TYO (LDB 1406 N))
    (FUNCALL STREAM ':TYO (LDB 0606 N))
    (FUNCALL STREAM ':TYO (LDB 0006 N)))

;;;Send the string to TELSER saying where we are, so that NAME can find it inside
;;;the TELSER and print it.  Boy, what a kludge.
(DEFUN SEND-FINGER-STRING (STREAM &AUX ID)
  (SETQ ID (OR (CDR (ASSQ CHAOS:MY-ADDRESS CHAOS:FINGER-ALIST))
	       (CHAOS:HOST-DATA CHAOS:MY-ADDRESS)))
  (FUNCALL STREAM ':TYO 300)		;SUPDUP escape string meaning that the FINGER
  (FUNCALL STREAM ':TYO 302)		;identification string follows.
  (FUNCALL STREAM ':STRING-OUT ID)
  (FUNCALL STREAM ':TYO 0)		; End with a 0.
  (FUNCALL STREAM ':FORCE-OUTPUT))

(DEFMETHOD (BASIC-SUPDUP :AFTER :DISCONNECT) ()
  (FUNCALL-SELF ':SET-LABEL "Supdup -- not connected"))

(DEFVAR SUPDUP-KEYS (MAKE-ARRAY NIL 'ART-16B 200))
(FILLARRAY SUPDUP-KEYS '(0 4102 4103 32		;null, break, clear, call
			 4101 37 4110 177	;esc, backnext, help, rubout
			 10 11 12 13		;bs, tab, lf, vt
			 14 15 4102 323		;form, cr, quote, hold-output
			 37 4103 310 0		;stop-output, abort, resume, status
			 233 0 0 0 0		;end, I, II, III, IV
			 0 0 0 0 0 4102))	;up, down, left, right, system, network


(DEFMETHOD (BASIC-SUPDUP :TRANSLATE-INPUT-CHAR) (CH)
  (COND ((LISTP CH) CH)
	((= CH #\ESC)	;I don't think this clause can go off --Moon
	 (TV:KBD-ESC)
	 NIL)
	(T
	 (LET ((CHAR (LDB %%KBD-CHAR CH)))
	   (LOGIOR (LSH (LDB %%KBD-CONTROL-META CH) 7)
		   (COND ((= CHAR 33) CHAR)    ;(Special case)
			 ((< CHAR 40) (LOGIOR CHAR 4000))
			 ((< CHAR 200) CHAR)
			 (T (AREF SUPDUP-KEYS (- CHAR 200)))))))))

;;;This sends a character of the ITS 12-bit character set to the network,
;;;using the ITS Intelligent Terminal Protocol to get the extra bits through.
(DEFMETHOD (BASIC-SUPDUP :NET-OUTPUT) (CH &AUX BITS)
  (SETQ BITS (LDB 0705 CH))
  (COND ((NOT (ZEROP BITS))
	 (LOCK-OUTPUT
	   (FUNCALL STREAM ':TYO 34)
	   (FUNCALL STREAM ':TYO (LOGIOR 100 BITS))
	   (FUNCALL STREAM ':TYO (LOGAND 177 CH))))
	((= CH 34)
	 (LOCK-OUTPUT
	   (FUNCALL STREAM ':TYO 34)
	   (FUNCALL STREAM ':TYO CH)))
	(T (FUNCALL STREAM ':TYO CH))))

(DEFMETHOD (BASIC-SUPDUP :LOGOUT) ()
  (LOCK-OUTPUT
    (FUNCALL STREAM ':TYO 300)
    (FUNCALL STREAM ':TYO 301)
    (FUNCALL STREAM ':FORCE-OUTPUT)))

;;;Dispatch table for the %TD codes.
(DEFVAR SUPDUP-%TD-DISPATCH (MAKE-ARRAY NIL 'ART-Q 40))
(FILLARRAY SUPDUP-%TD-DISPATCH
   '(SUPDUP-TDMOV SUPDUP-TDMV0 TV:SHEET-CLEAR-EOF TV:SHEET-CLEAR-EOL TV:SHEET-CLEAR-CHAR
;;;  %TDMOV       %TDMV0       %TDEOF		  %TDEOL	     %TDDLF

     SUPDUP-NOTHING SUPDUP-GT40 TV:SHEET-CRLF SUPDUP-NOTHING SUPDUP-NOTHING SUPDUP-NOTHING
;;;  %TDMTF	    %TDMTN      %TDCRL	      %TDNOP         %TDBS          %TDLF

     SUPDUP-NOTHING SUPDUP-TDORS SUPDUP-TDQOT TV:SHEET-SPACE SUPDUP-TDMV0 SUPDUP-CLEAR
;;;  %TDCR	    %TDORS       %TDQOT       %TDFS    %TDMV0       %TDCLR

     SUPDUP-BEEP    SUPDUP-NOTHING SUPDUP-INSERT-LINE SUPDUP-DELETE-LINE
;;;  %TDBEL	    %TDINI	   %TDILP	      %TDDLP

     SUPDUP-INSERT-CHAR SUPDUP-DELETE-CHAR SUPDUP-NOTHING SUPDUP-NOTHING SUPDUP-NOTHING 
;;;  %TDICP	    	%TDDCP		   %TDBOW	  %TDRST	 %TDGRF
     SUPDUP-REGION-UP SUPDUP-REGION-DOWN
;;;  %TDRSU		%TDRSD

;;; PTV compatibility hacks (ARDS, etc.)
     SUPDUP-NOTHING SUPDUP-ARDS-SET
;;;  %TDGXT         %TDLNG

     SUPDUP-ARDS-LONG   SUPDUP-ARDS-SHORT
;;;  %TDLV              %TDSV
     ))

(DEFMETHOD (BASIC-SUPDUP :BUFFERED-TYO) (CH)
    (COND ((< CH 200)
	   (DO () ((ARRAY-PUSH OUTPUT-BUFFER CH))
	     (FUNCALL-SELF ':FORCE-OUTPUT)))
	  (T
	   (FUNCALL-SELF ':FORCE-OUTPUT)
	   (OR (>= (SETQ CH (- CH 200)) (ARRAY-LENGTH SUPDUP-%TD-DISPATCH))
	       (FUNCALL (AREF SUPDUP-%TD-DISPATCH CH) SELF)))))

;;;Handle %TDMOV by ignoring two characters and then acting as if it were a %TDMV0.
(DEFUN SUPDUP-TDMOV (SHEET)
  (NVT-NETI)
  (NVT-NETI)
  (SUPDUP-TDMV0 SHEET))

;;;Handle %TDMV0 or %TDMV1 by moving the cursor.  This is kludgey because
;;;ITS sends out positions as VPOS followed by HPOS.
(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP)
(DEFUN SUPDUP-TDMV0 (SHEET &AUX YPOS)
  (SETQ YPOS (* (NVT-NETI) TV:LINE-HEIGHT))
  (TV:SHEET-SET-CURSORPOS SHEET
			  (* (NVT-NETI) TV:CHAR-WIDTH)
			  YPOS)))

;;;This "null function" is used for codes which we should ignore.
(DEFUN SUPDUP-NOTHING (IGNORE) NIL)

;;;Handle %TDORS.  Just tell ITS where the cursor position is, using the
;;;Intelligent Terminal Protocol's ^\ ^P command.
(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP)
(DEFUN SUPDUP-TDORS (SHEET &AUX VPOS HPOS)
  (MULTIPLE-VALUE (HPOS VPOS)
    (TV:SHEET-READ-CURSORPOS SHEET))
  (LOCK-OUTPUT
    (FUNCALL STREAM ':TYO 34) ;^\
    (FUNCALL STREAM ':TYO 20) ;^P
    (FUNCALL STREAM ':TYO (// VPOS TV:LINE-HEIGHT))
    (FUNCALL STREAM ':TYO (// HPOS TV:CHAR-WIDTH))
    (FUNCALL STREAM ':FORCE-OUTPUT))))

;;;%TDQOT means the next character should be quoted.
(DEFUN SUPDUP-TDQOT (SHEET)
  (TV:SHEET-TYO SHEET (NVT-NETI)))

;;;%TDBEL means to ring the "bell".
;;;To avoid gross obnoxosity, we merge multiple consecutive beeps into one
(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP)
(DEFUN SUPDUP-BEEP (IGNORE)
  (TV:BEEP)
  (DO ((CH (FUNCALL STREAM ':TYI-NO-HANG) (FUNCALL STREAM ':TYI-NO-HANG)))
      ((OR (NULL CH) ( CH 221))
       (AND CH (FUNCALL STREAM ':UNTYI CH))))))

;;;%TDCLR
(DEFUN SUPDUP-CLEAR (SHEET)
  (TV:SHEET-CLEAR SHEET)
  (FILLARRAY GT40-DISPLAY-LIST '(NIL)))
    
;;;%TDILP means to insert lines, takes one arg from stream which is number of lines to insert
;;;Lines are inserted at current VPOS.  The current line is affected.
(DEFUN SUPDUP-INSERT-LINE (SHEET)
  (TV:SHEET-INSERT-LINE SHEET (NVT-NETI)))

;;;%TDDLP means to delete lines, takes one arg from stream which is the number of lines.
;;;Affects the current line.
(DEFUN SUPDUP-DELETE-LINE (SHEET)
  (TV:SHEET-DELETE-LINE SHEET (NVT-NETI)))

;;;%TDRSU, %TDRSD followed by height, n-lines
(DEFUN SUPDUP-REGION-UP (SHEET)
  (LET ((REGION-HEIGHT (NVT-NETI))
	(SCROLL-AMOUNT (NVT-NETI)))
    (TV:PREPARE-SHEET (SHEET)
      (LET ((ARRAY (TV:SHEET-SCREEN-ARRAY SHEET))
	    (WIDTH (TV:SHEET-INSIDE-WIDTH SHEET))
	    (LINE-HEIGHT (TV:SHEET-LINE-HEIGHT SHEET))
	    REGION-BOTTOM
	    DELTA-HEIGHT)
	(SETQ REGION-HEIGHT (* REGION-HEIGHT LINE-HEIGHT)
	      REGION-BOTTOM (MIN (+ (TV:SHEET-CURSOR-Y SHEET) REGION-HEIGHT)
				 (* LINE-HEIGHT
				    (// (TV:SHEET-INSIDE-BOTTOM SHEET)
					LINE-HEIGHT)))
	      REGION-HEIGHT (- REGION-BOTTOM (TV:SHEET-CURSOR-Y SHEET))
	      SCROLL-AMOUNT (MIN (* SCROLL-AMOUNT LINE-HEIGHT) REGION-HEIGHT))
	;; Get size of region to BLT up
	(SETQ DELTA-HEIGHT (- REGION-HEIGHT SCROLL-AMOUNT))
	(OR (<= DELTA-HEIGHT 0)			;If some bits to move, move them
	    (BITBLT TV:ALU-SETA
		    WIDTH DELTA-HEIGHT
		    ARRAY (TV:SHEET-INSIDE-LEFT SHEET)
		          (+ (TV:SHEET-CURSOR-Y SHEET) SCROLL-AMOUNT)
		    ARRAY (TV:SHEET-INSIDE-LEFT SHEET) (TV:SHEET-CURSOR-Y SHEET)))
	(TV:%DRAW-RECTANGLE WIDTH SCROLL-AMOUNT
			    (TV:SHEET-INSIDE-LEFT SHEET)
			    (- REGION-BOTTOM SCROLL-AMOUNT)
			    (TV:SHEET-ERASE-ALUF SHEET) SHEET)))))

(DEFUN SUPDUP-REGION-DOWN (SHEET)
  (LET ((REGION-HEIGHT (NVT-NETI))
	(SCROLL-AMOUNT (NVT-NETI)))
    (TV:PREPARE-SHEET (SHEET)
      (LET ((ARRAY (TV:SHEET-SCREEN-ARRAY SHEET))
	    (WIDTH (TV:SHEET-INSIDE-WIDTH SHEET))
	    (LINE-HEIGHT (TV:SHEET-LINE-HEIGHT SHEET))
	    REGION-BOTTOM
	    DELTA-HEIGHT)
	(SETQ REGION-HEIGHT (* REGION-HEIGHT LINE-HEIGHT)
	      REGION-BOTTOM (MIN (+ (TV:SHEET-CURSOR-Y SHEET) REGION-HEIGHT)
				 (* LINE-HEIGHT
				    (// (TV:SHEET-INSIDE-BOTTOM SHEET)
					LINE-HEIGHT)))
	      REGION-HEIGHT (- REGION-BOTTOM (TV:SHEET-CURSOR-Y SHEET))
	      SCROLL-AMOUNT (MIN (* SCROLL-AMOUNT LINE-HEIGHT) REGION-HEIGHT))
	;; Get negative size of region to BLT down
	(SETQ DELTA-HEIGHT (- SCROLL-AMOUNT REGION-HEIGHT))
	(OR (>= DELTA-HEIGHT 0)			;If some bits to move, move them
	    (BITBLT TV:ALU-SETA
		    WIDTH DELTA-HEIGHT
		    ARRAY (TV:SHEET-INSIDE-LEFT SHEET) (TV:SHEET-CURSOR-Y SHEET)
		    ARRAY (TV:SHEET-INSIDE-LEFT SHEET)
		          (+ (TV:SHEET-CURSOR-Y SHEET) SCROLL-AMOUNT)))
	(TV:%DRAW-RECTANGLE WIDTH SCROLL-AMOUNT
			    (TV:SHEET-INSIDE-LEFT SHEET) (TV:SHEET-CURSOR-Y SHEET)
			    (TV:SHEET-ERASE-ALUF SHEET) SHEET)))))

;;;%TDICP insert character positions, takes an arg.
(DEFUN SUPDUP-INSERT-CHAR (SHEET)
  (TV:SHEET-INSERT-CHAR SHEET (NVT-NETI)))

;;;%TDDCP delete character positions, takes an arg.
(DEFUN SUPDUP-DELETE-CHAR (SHEET)
  (TV:SHEET-DELETE-CHAR SHEET (NVT-NETI)))

;;; Always have at least one supdup window in the world
(OR *SUPDUP-WINDOWS*
    (TV:WITHOUT-SCREEN-MANAGEMENT (FUNCALL (TV:WINDOW-CREATE 'SUPDUP) ':ACTIVATE)))

;;; GT40 Simulator (used with the DEC simulator on I.T.S. for running SUDS)

;;; This crock maintains a display list for writing, erasing, and moving display objects
;;; consisting of characters, vectors, and points.  This protocol is not documented
;;; anywhere except in the code for DECUUO.

;; Dispatch table for the GT40 simulator.  These functions take one argument, the pc-ppr.
(DEFVAR GT40-DISPATCH (MAKE-ARRAY NIL 'ART-Q 17))
(FILLARRAY GT40-DISPATCH
	   '(GT40-INSERT-OR-DELETE
	     GT40-INSERT
	     GT40-DELETE
;	     GT40-RESET
;	     GT40-TURN-ON
;	     GT40-TURN-OFF
;	     GT40-COPY
;	     GT40-MOVE
;	     GT40-MODE
;	     GT40-APPEND
;	     GT40-SUBROUTINIZE
;	     GT40-UNSUBROUTINIZE
	     SUPDUP-NOTHING))			;most are not used by DECUUO

;;; Display list array.
(DEFVAR GT40-DISPLAY-LIST (MAKE-ARRAY NIL 'ART-Q-LIST 10.))
(DEFVAR GT40-BLINKER NIL)
(DEFVAR GT40-CURRENT-ITEM-NUMBER)
(DEFVAR SUDS-KBD-NEW-TABLE			;allows thumb keys to be used
  (LET ((TBL (SI:KBD-MAKE-NEW-TABLE)))
    (DOLIST (L '((176 #// #/ #// #/) (106 #/\ #/| #/\ #/|)
		 (117 #/[ #/{ #/[ #/{) (17 #/] #/} #/] #/})))
      (LET ((NCH (FIRST L)) (LCH (REST1 L)))
	(DOTIMES (I 5)
	  (ASET (CAR LCH) TBL I NCH)
	  (IF (REST1 LCH) (SETQ LCH (REST1 LCH))))))
    TBL))

;; %TDMTN is a crock for simulating GT-40's, used by DECUUO on ITS for Imlacs...

(DEFUN SUPDUP-GT40 (SHEET &AUX (BYTE (- (NVT-NETI) 100)))
  (IF ( (AREF SUDS-KBD-NEW-TABLE 0 176)	;crock for thumb keys, only when
	 (AREF SI:KBD-NEW-TABLE 0 176))		;doing GT40 simulation
      (SETQ SI:KBD-NEW-TABLE SUDS-KBD-NEW-TABLE))
  (OR (< BYTE 0)
      (FUNCALL (AREF GT40-DISPATCH (LOGAND 17 BYTE)) SHEET)))

;;; Macros used below to pack characters into words, decode vector formats, etc.

;;; Make a 16-bit "word" from 3 chars in 6-4-6 format
(DEFMACRO GT40-WORD ()
  '(DPB (NVT-NETI) 0006
	(DPB (NVT-NETI) 0604
	     (DPB (NVT-NETI) 1206 0))))

;;; Get a word count
(DEFMACRO GT40-COUNT () '(LSH (- (GT40-WORD) 5) -1))

;;; Used in constructing display objects - used only in GT40-INSERT.
(DEFMACRO APUSH (DOB ITEM) `(ARRAY-PUSH-EXTEND ,DOB ,ITEM 500.))

;;; Compute the index of the last thing pushed
(DEFMACRO GT40-LAST-INDEX (DOB) `(1- (ARRAY-ACTIVE-LENGTH ,DOB)))

;;; Get the last item pushed onto a display object
(DEFMACRO GT40-LAST-ITEM (DOB) `(AREF ,DOB (GT40-LAST-INDEX ,DOB)))

;;; Short vector format
(DEFMACRO GT40-SHORT (DOB WORD)
  `(PROGN
     (APUSH ,DOB (* (LDB 0706 ,WORD) (IF (BIT-TEST 20000 ,WORD) -1 1)))
     (APUSH ,DOB (* (LDB 0006 ,WORD) (IF (BIT-TEST 100 ,WORD) -1 1)))
     (APUSH ,DOB (BIT-TEST 40000 ,WORD))))

;;; Long vector format
(DEFMACRO GT40-LONG (DOB WORD1 WORD2)
   `(LET ((WORD2 ,WORD2))
      (APUSH ,DOB (* (LOGAND 1777 ,WORD1) (IF (BIT-TEST 20000 ,WORD1) -1 1)))
      (APUSH ,DOB (* (LOGAND 1777 WORD2) (IF (BIT-TEST 20000 WORD2) -1 1)))
      (APUSH ,DOB (BIT-TEST 40000 ,WORD1))))

;;; Coordinate scaling macro
(DEFMACRO GT40-COORD (X) `(MAX 0 (// (* 7 ,X) 10.)))

;;; Draw a string.  Note special end of line hackery.  XPOS and YPOS must be symbols.
(DEFMACRO GT40-DRAW-STRING (STRING XPOS YPOS SHEET)
  `(LET ((MAX-Y 750.))
     (TV:SHEET-STRING-OUT-EXPLICIT ,SHEET ,STRING (GT40-COORD ,XPOS)
				   (- MAX-Y (GT40-COORD ,YPOS) 11.)
				   (TV:SHEET-INSIDE-RIGHT ,SHEET)
				   (TV:SHEET-CURRENT-FONT ,SHEET)
				   TV:ALU-XOR)))

;;; Draw a vector.  XPOS and YPOS must be symbols
(DEFMACRO GT40-DRAW-VECTOR (XPOS YPOS X Y FLAG SHEET)
  `(LET ((MAX-Y 750.) (OXPOS ,XPOS) (OYPOS ,YPOS))
     (SETQ ,XPOS (+ ,XPOS ,X) ,YPOS (+ ,YPOS ,Y))
     (IF ,FLAG
	 (TV:%DRAW-LINE (GT40-COORD OXPOS) (- MAX-Y (GT40-COORD OYPOS))
			(GT40-COORD ,XPOS) (- MAX-Y (GT40-COORD ,YPOS))
			TV:ALU-XOR NIL ,SHEET))))

;;; Read a vector out of the display list and draw it
(DEFMACRO GT40-VECTOR (DOB XPOS YPOS SHEET)
  `(LET ((I (GT40-LAST-INDEX ,DOB)))
     (GT40-DRAW-VECTOR
      ,XPOS ,YPOS
      (AREF ,DOB (- I 2)) (AREF ,DOB (- I 1))	;new x y
      (AREF ,DOB I) ,SHEET)))			;visibility flag

;;; Display list format:  The display list is an ART-Q array of display objects, each of
;;; which is, in turn, an ART-Q array.  The format of display objects is a sequence of
;;; display items.  A display item is either a single string of characters or an in-line
;;; subsequence consisting of a symbol describing the item-type followed by 2 numbers (x,y)
;;; and a visibility flag.  Numbers and flags are repeated until a new symbol is encountered
;;; indicating a type change.

;;; GT40 Command 0 - Insert or delete display items
(DEFUN GT40-INSERT-OR-DELETE (SHEET)
  (SELECTQ (LOGAND 3 (GT40-WORD))		;only 1 and 2 are recognized for now
    (1 (GT40-INSERT SHEET))			;insert a new display item
    (2 (GT40-DELETE SHEET (1+ (GT40-COUNT))))))	;delete n items

;;; GT40 Command 1 - Insert a display item into the display list.
(DEFUN GT40-INSERT (SHEET &AUX (WORD-COUNT (GT40-COUNT)))
  (GT40-DELETE SHEET 1 NIL)		;Delete the item we are about to insert
  (DO ((I 0 (1+ I))			;Loop over words, contructing a display list
       (WORD)(MODE -1)			;Mode is initially undefined.
       (XPOS 0) (YPOS 0) (BLINK-THIS)
       (DOB				;Display OBject
	(OR (AREF GT40-DISPLAY-LIST GT40-CURRENT-ITEM-NUMBER)	;Already an array or
	    (ASET (MAKE-ARRAY NIL ART-Q 200. NIL '(NIL 0))	;cons an array with leader
		  GT40-DISPLAY-LIST GT40-CURRENT-ITEM-NUMBER))))	;and install it
      (( I WORD-COUNT)
       (IF (= 0 MODE)			; was char mode, display the string
	   (GT40-DRAW-STRING (GT40-LAST-ITEM DOB) XPOS YPOS SHEET))
       (IF BLINK-THIS (STORE-ARRAY-LEADER 'ON DOB 1)))
    (SETQ WORD (GT40-WORD))
    (COND ((BIT-TEST 100000 WORD)	;If command, only look at blink bit and mode
	   (IF (NOT (BIT-TEST 40000 WORD))	;ignore words with the 40000 bit on
	       (LET ((NMODE (LDB 1303 WORD))
		     (BLINK-FLAG (AND (BIT-TEST 20 WORD) (BIT-TEST 10 WORD))))
		  (COND ((NOT (= MODE NMODE))	;get the new datatype mode
			 (IF (= 0 MODE)	; was char mode, display the string
			     (GT40-DRAW-STRING (GT40-LAST-ITEM DOB) XPOS YPOS SHEET))
			 (SETQ MODE NMODE)
			 (APUSH DOB (SELECTQ MODE	;initializings
				      (0 (MAKE-ARRAY NIL 'ART-STRING 10. NIL '(0)))
				      (1 'VECTOR)
				      (2 'VECTOR)
				      (3 'POINT)
				      (6 'RPOINT)
				      ((4 5 7) 'UNKNOWN)))))
		  (COND (BLINK-FLAG
			 (OR (MEMQ GT40-BLINKER (TV:SHEET-BLINKER-LIST SHEET))
			     (SETQ GT40-BLINKER
				   (TV:DEFINE-BLINKER SHEET 'GT40-BLINKER)))
			 (SETQ BLINK-THIS T))))))
	  (T (SELECTQ MODE
	       (0 (DO ((CHAR (LDB 0007 WORD) (LDB 1007 WORD))	;character mode
		       (STRING (GT40-LAST-ITEM DOB))
		       (I 0 (1+ I)))
		      ((= I 2))
		      (OR (= 0 CHAR) (= 17 CHAR) (ARRAY-PUSH-EXTEND STRING CHAR))))
	       (1 (GT40-SHORT DOB WORD)	;short vector
		  (GT40-VECTOR DOB XPOS YPOS SHEET))
	       (2 (SETQ I (1+ I))	;long vector
		  (GT40-LONG DOB WORD (GT40-WORD))
		  (GT40-VECTOR DOB XPOS YPOS SHEET))
	       (3 (SETQ I (1+ I))	;point data
		  (GT40-LONG DOB WORD (GT40-WORD))
		  (LET ((I (GT40-LAST-INDEX DOB)))
		       (SETQ XPOS (AREF DOB (- I 2))
			     YPOS (AREF DOB (- I 1)))
		       (GT40-DRAW-VECTOR XPOS YPOS 0 0 (AREF DOB I) SHEET)))
	       (4)			;graphplot x data (not used)
	       (5)			;graphplot y data (not used)
	       (6 (GT40-SHORT DOB WORD)	;relative point data
		  (LET ((I (GT40-LAST-INDEX DOB)))
		       (SETQ XPOS (+ XPOS (AREF DOB (- I 2)))
			     YPOS (+ YPOS (AREF DOB (- I 1))))
		       (GT40-DRAW-VECTOR XPOS YPOS 0 0 (AREF DOB I) SHEET)))
	       (7)))))			;not used
  (GT40-WORD))				;gobble the checksum

;;; GT40 Command 2 - Delete a display item from the display list
(DEFUN GT40-DELETE (SHEET &OPTIONAL (NITEMS 1) (CHECKSUM-FLAG T))
  (DO ((I 0 (1+ I)) (DOB) (ITEM-NUMBER))
      (( I NITEMS))
    (SETQ ITEM-NUMBER (GT40-WORD)
	  GT40-CURRENT-ITEM-NUMBER ITEM-NUMBER	;record item # being hacked
	  DOB (AREF GT40-DISPLAY-LIST ITEM-NUMBER))
    (IF DOB (PROGN (OR (EQ 'OFF (ARRAY-LEADER DOB 1))	;don't erase if its already off
		       (GT40-DISPLAY-ITEM DOB SHEET))
		   (FILLARRAY DOB '(NIL))
		   (STORE-ARRAY-LEADER 0 DOB 0)	;zero the fill pointer
		   (STORE-ARRAY-LEADER NIL DOB 1))))	;blinking is off
  (IF CHECKSUM-FLAG (GT40-WORD)))		;gobble the checksum

;;; Display a display item.
(DEFUN GT40-DISPLAY-ITEM (DOB SHEET)
  (DO ((I 0 (1+ I))
       (END (ARRAY-ACTIVE-LENGTH DOB))
       (ITEM) (X) (Y) (FLAG) (XPOS 0) (YPOS 0))
      ((>= I END))
    (SETQ ITEM (AREF DOB I))
    (COND ((STRINGP ITEM) (GT40-DRAW-STRING ITEM XPOS YPOS SHEET))
	  ((EQ 'UNKNOWN ITEM))		;ignore
	  (T (DO NIL
		 ((OR (<= (- END I) 3)
		      (SYMBOLP (AREF DOB (1+ I)))
		      (STRINGP (AREF DOB (1+ I)))))
		 (SETQ I (+ 3 I)
		       X    (AREF DOB (- I 2))
		       Y    (AREF DOB (- I 1))
		       FLAG (AREF DOB I))
		 (SELECTQ ITEM
		   (VECTOR (GT40-DRAW-VECTOR XPOS YPOS X Y FLAG SHEET))
		   (POINT (SETQ XPOS X YPOS Y)
			  (GT40-DRAW-VECTOR XPOS YPOS 0 0 FLAG SHEET))
		   (RPOINT (SETQ XPOS (+ XPOS X) YPOS (+ YPOS Y))
			   (GT40-DRAW-VECTOR XPOS YPOS 0 0 FLAG SHEET))))))))

(DEFFLAVOR GT40-BLINKER () (TV:BLINKER))

;;; Blink a display item
(DEFMETHOD (GT40-BLINKER :BLINK) ()
  (LET-GLOBALLY ((TV:PHASE NIL))
    (DO ((ITEM (G-L-P GT40-DISPLAY-LIST) (CDR ITEM))
	 (BLINK-FLAG NIL NIL)
	 (DITEM))
	((NULL ITEM))
      (SETQ DITEM (CAR ITEM))
      (IF DITEM (SETQ BLINK-FLAG (ARRAY-LEADER DITEM 1)))
      (IF (MEMQ BLINK-FLAG '(ON OFF))
	  (PROGN (GT40-DISPLAY-ITEM DITEM TV:SHEET)
		 (STORE-ARRAY-LEADER (SELECTQ BLINK-FLAG (ON 'OFF) (OFF 'ON)) DITEM 1))))))

(DEFMETHOD (GT40-BLINKER :SIZE) ()
  (PROG () (RETURN (TV:SHEET-INSIDE-WIDTH TV:SHEET) (TV:SHEET-INSIDE-HEIGHT TV:SHEET))))

;;; ARDS simulator (for compatibility with PTV's)

;;; Todo: these variables should be instance variables
;;;       scaling and offset doesn't work right in this version...
;;;       SHOULD SEND LINE DRAWING MESSAGES RATHER THAN CALLING %DRAW-LINE

(DEFVAR ARDS-XPOS 0)				;current pos in ARDS coordinates
(DEFVAR ARDS-YPOS 0)
(DEFVAR ARDS-SCALE 1.0)
(DEFVAR ARDS-SCR-XPOS 0)			;current pos in screen coordinates
(DEFVAR ARDS-SCR-YPOS 0)

;;; Setup scaling and offsets, then loop until exit condition
(DEFMACRO ARDS-LOOP (&REST BODY)
  `(LET* ((ARDS-MAX-X (+ TV:X-OFFSET TV:WIDTH))
	  (ARDS-MAX-Y (+ TV:Y-OFFSET TV:HEIGHT))
	  (ARDS-X-OFFSET TV:X-OFFSET)
	  (ARDS-Y-OFFSET TV:Y-OFFSET)
	  (ARDS-SCR-SCALE (* ARDS-SCALE (// (MIN TV:WIDTH TV:HEIGHT) 1023.0)))
	  (ARDS-CENTER-OFFSET (// (1+ (- (MAX TV:WIDTH TV:HEIGHT) (MIN TV:WIDTH TV:HEIGHT)))
				  2))
	  (ARDS-FLAG NIL))
     (IF (< TV:WIDTH TV:HEIGHT) (SETQ ARDS-MAX-Y (- ARDS-MAX-Y ARDS-CENTER-OFFSET))
	 (SETQ ARDS-X-OFFSET (+ ARDS-X-OFFSET ARDS-CENTER-OFFSET)))
     (*CATCH 'ARDS-RETURN
	     (DO NIL (NIL) ,@BODY))))

;;; Convert -512./511. to 0/1023. and scale if the user wants it.
(DEFMACRO ARDS-COORD (X)
  `(MAX 1 (FIX (+ .5 (* ARDS-SCR-SCALE (+ 512. ,X))))))

;;; Get a character and punt out of graphics mode if it is a control char or %TD code
(DEFMACRO ARDS-GET ()
  '(LET ((X (NVT-NETI)))
     (IF (OR (< X 100) (> X 177))
	 (*THROW 'ARDS-RETURN
		 (PROGN (FUNCALL STREAM ':UNTYI X)
			(TV:SHEET-SET-CURSORPOS SHEET
						ARDS-SCR-XPOS
						(- ARDS-SCR-YPOS 11.)))))
     X))

;;; Unpack long and short format coordinates
(DEFMACRO ARDS-LONG (F)
  `(LET ((A (ARDS-GET)) (B (ARDS-GET)))
     ,(IF F '(SETQ ARDS-FLAG (NOT (BIT-TEST B 40))))
     (* (IF (BIT-TEST A 1) -1 1)
	(LOGIOR (LSH (LOGAND 77 A) -1) (LSH (LOGAND 37 B) 5)))))

(DEFMACRO ARDS-SHORT ()
  `(LET ((A (ARDS-GET)))
     (SETQ ARDS-FLAG T)
     (* (IF (BIT-TEST A 1) -1 1)
	(LSH (LOGAND 77 A) -1))))

;;; Draw a vector
(DEFMACRO ARDS-VECTOR (DX DY)
  `(LET ((X0 ARDS-XPOS) (Y0 ARDS-YPOS))
     (SETQ ARDS-XPOS (+ ARDS-XPOS ,DX)
	   ARDS-YPOS (+ ARDS-YPOS ,DY)
	   ARDS-SCR-XPOS (MIN ARDS-MAX-X (+ ARDS-X-OFFSET (ARDS-COORD ARDS-XPOS)))
	   ARDS-SCR-YPOS (MAX ARDS-Y-OFFSET (- ARDS-MAX-Y (ARDS-COORD ARDS-YPOS))))
     (IF ARDS-FLAG
	 (TV:%DRAW-LINE (MIN ARDS-MAX-X (+ ARDS-X-OFFSET (ARDS-COORD X0)))
			(MAX ARDS-Y-OFFSET (- ARDS-MAX-Y (ARDS-COORD Y0)))
			ARDS-SCR-XPOS
			ARDS-SCR-YPOS
			TV:ALU-IOR
			T
			SHEET))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP)

(DEFUN SUPDUP-ARDS-SET (SHEET)
  (ARDS-LOOP
    (SETQ ARDS-XPOS (ARDS-LONG T) ARDS-YPOS (ARDS-LONG NIL))
    (ARDS-VECTOR 0 0)))		;for plotting points

(DEFUN SUPDUP-ARDS-LONG (SHEET)
  (ARDS-LOOP (ARDS-VECTOR (ARDS-LONG T) (ARDS-LONG NIL))))

(DEFUN SUPDUP-ARDS-SHORT (SHEET)
  (ARDS-LOOP (ARDS-VECTOR (ARDS-SHORT) (ARDS-SHORT))))

)

(DEFFLAVOR BASIC-TELNET
	    ((NEW-TELNET-P NIL)
	     (MORE-FLAG NIL)
	     (ECHO-FLAG NIL)
	     (SIMULATE-IMLAC-FLAG NIL))
	    (BASIC-NVT)
  (:DOCUMENTATION :SPECIAL-PURPOSE "A TELNET NVT")
  (:SETTABLE-INSTANCE-VARIABLES SIMULATE-IMLAC-FLAG))

(DEFFLAVOR TELNET () (BASIC-TELNET TV:FULL-SCREEN-HACK-MIXIN TV:WINDOW)
  (:DEFAULT-INIT-PLIST :SAVE-BITS T)
  (:DOCUMENTATION :COMBINATION))

(DEFUN TELNET (&OPTIONAL (PATH "AI") SIMULATE-IMLAC-P (WINDOW TERMINAL-IO))
  (WITH-RESOURCE (TV:BIT-ARRAYS BIT-ARRAY)
   (WITH-RESOURCE (TYPEOUT-PROCESSES TP)
    (TV:WINDOW-BIND (WINDOW 'TELNET ':TYPEIN-PROCESS CURRENT-PROCESS
			    ':BIT-ARRAY BIT-ARRAY
			    ':TYPEOUT-PROCESS TP
			    ':SIMULATE-IMLAC-FLAG SIMULATE-IMLAC-P)
      (FUNCALL WINDOW ':CONNECT PATH)
      (*CATCH 'SI:TOP-LEVEL (FUNCALL WINDOW ':TYPEIN-TOP-LEVEL NIL))
      (SETF (TV:SHEET-BIT-ARRAY WINDOW) NIL)
      T))))

(DEFMETHOD (BASIC-TELNET :BEFORE :INIT) (IGNORE)
  (SETQ TV:LABEL "Telnet -- not connected"))

(DEFMETHOD (BASIC-TELNET :CONNECT) (&OPTIONAL PATH (NET-WINDOW 3))
  (IF (STRINGP (SETQ PATH (FUNCALL-SELF ':NEW-CONNECTION PATH NET-WINDOW "TELNET" 27)))
      PATH
      (TELNET-ECHO (NOT ECHO-FLAG))))

(DEFMETHOD (BASIC-TELNET :GOBBLE-GREETING) ()
  (TERPRI SELF))

(DEFMETHOD (BASIC-TELNET :AFTER :DISCONNECT) ()
  (SETQ ECHO-FLAG NIL NEW-TELNET-P NIL)
  (FUNCALL-SELF ':SET-LABEL "Telnet -- not connected"))

(DEFVAR TELNET-KEYS (MAKE-ARRAY NIL 'ART-16B 200))
(FILLARRAY TELNET-KEYS '(0 100101 100370 100364	;null, break, clear, call
			 0 37 37 177 10 11 12	;esc, back-next, help, rubout, bs, tab, lf
			 13 14 15 21 0		;vt, form, return, quote, hold-output
			 100365 100363 0 100366	;stop-output, abort, resume, status
			 0 0 0 0 0 0 0 0 0 0	;end, ...
			 100101 0))		;network

;;;Convert to NVT ASCII (except don't convert CR to two characters).
(DEFMETHOD (BASIC-TELNET :TRANSLATE-INPUT-CHAR) (CH)
  (COND ((LISTP CH) CH)
	((= CH #\ESC)
	 (TV:KBD-ESC)
	 NIL)
	(T
	 (LET ((CHAR (LDB %%KBD-CHAR CH)))
	   (AND ECHO-FLAG (FUNCALL SELF ':TYO CHAR))
	   (AND (LDB-TEST %%KBD-CONTROL CH) (SETQ CHAR (LDB 0005 CH)))	;controlify
	   (AND (> CHAR 200) (SETQ CHAR (AREF TELNET-KEYS (- CHAR 200))))
	   (AND (LDB-TEST %%KBD-META CH) (SETQ CHAR (+ CHAR 200)))
	   CHAR))))

(DEFVAR NVT-IAC 377)
(DEFVAR NVT-DONT 376)
(DEFVAR NVT-DO 375)
(DEFVAR NVT-WONT 374)
(DEFVAR NVT-WILL 373)
(DEFVAR NVT-SUBNEGOTIATION-BEGIN 372)
(DEFVAR NVT-SUBNEGOTIATION-END 360)

(DEFVAR NVT-SUPDUP-OUTPUT 26)
(DEFVAR NVT-TIMING-MARK 6)
(DEFVAR NVT-SUPPRESS-GO-AHEAD 3)
(DEFVAR NVT-ECHO 1)
(DEFVAR NVT-TRANSMIT-BINARY 0)
(DEFVAR NVT-LOGOUT 22)

(DEFMETHOD (BASIC-TELNET :NET-OUTPUT) (CH)
  (LOCK-OUTPUT
    (COND ((LDB-TEST 1701 CH)
	   (AND NEW-TELNET-P (FUNCALL STREAM ':TYO NVT-IAC))
	   (SETQ CH (LDB 0010 CH))))
    (FUNCALL STREAM ':TYO CH)
    (COND ((= CH 15)
	   (FUNCALL STREAM ':TYO 12))		;CR is two chars
	  ((AND (= CH NVT-IAC) NEW-TELNET-P)
	   (FUNCALL STREAM ':TYO 377)))))	;IAC's must be quoted

(DEFMETHOD (BASIC-TELNET :BUFFERED-TYO) (CH &AUX CH1)
  (COND ((= CH NVT-IAC)
	 (FUNCALL-SELF ':HANDLE-IAC))		;Perform new telnet negotiations.
	(( CH 200))				;Ignore otelnet negotiations
	((= CH 7) (TV:BEEP))			;^G rings the bell.
	((AND (= CH 15)
	      (IF (= (SETQ CH1 (NVT-NETI)) 12)	;CR LF is NVT newline "character"
		  NIL				;Output normally
		  (FUNCALL-SELF ':FORCE-OUTPUT)
		  (MULTIPLE-VALUE-BIND (IGNORE Y) (FUNCALL-SELF ':READ-CURSORPOS)
		    (FUNCALL-SELF ':SET-CURSORPOS 0 Y))
		  (ZEROP CH1))))		;CR NUL is bare carriage return
	((AND (= CH 177) SIMULATE-IMLAC-FLAG)	;Escape character
	 (FUNCALL-SELF ':HANDLE-IMLAC-ESCAPE))
	(T
	 (AND ( CH 10) ( CH 15) ( CH 13)	;Convert formatting controls
	      (SETQ CH (+ CH 200)))		;to Lisp machine char set.
	 (DO () ((ARRAY-PUSH OUTPUT-BUFFER CH))
	   (FUNCALL-SELF ':FORCE-OUTPUT)))))

;;;New telnet protocol IAC handler
(DEFMETHOD (BASIC-TELNET :HANDLE-IAC) (&AUX COMMAND OPTION)
  (COND ((NULL NEW-TELNET-P)
	 (TELNET-SEND-OPTION NVT-DO NVT-ECHO)
	 (TELNET-SEND-OPTION NVT-DO NVT-SUPPRESS-GO-AHEAD)
	 (SETQ NEW-TELNET-P T)))
  (SETQ COMMAND (NVT-NETI))
  (AND ( COMMAND NVT-WILL) ( COMMAND NVT-DONT)
       (SETQ OPTION (NVT-NETI)))
  (SELECT COMMAND
    (NVT-WILL
     (SELECT OPTION
       (NVT-ECHO
        (TELNET-ECHO NIL))
       (NVT-SUPPRESS-GO-AHEAD)		;ignore things we requested
       (NVT-TRANSMIT-BINARY
	(TELNET-SEND-OPTION NVT-DO OPTION))
       (NVT-SUPDUP-OUTPUT
	(TELNET-START-SUPDUP-OUTPUT))
       (OTHERWISE
	(TELNET-SEND-OPTION NVT-DONT OPTION))))
    (NVT-DO
     (COND ((= OPTION NVT-ECHO) (TELNET-ECHO T))
	   ((OR (= OPTION NVT-SUPPRESS-GO-AHEAD) (= OPTION NVT-TIMING-MARK))
	    (TELNET-SEND-OPTION NVT-WILL OPTION))
	   (T (TELNET-SEND-OPTION NVT-WONT OPTION))))
    (NVT-DONT
     (COND ((= OPTION NVT-ECHO) (TELNET-ECHO NIL))
	   ((= OPTION NVT-TRANSMIT-BINARY)
	    (TELNET-SEND-OPTION NVT-WONT OPTION))))
    (NVT-WONT
     (COND ((= OPTION NVT-ECHO) (TELNET-ECHO T))
	   ((= OPTION NVT-TRANSMIT-BINARY)
	    (TELNET-SEND-OPTION NVT-DONT OPTION))))
    (NVT-SUBNEGOTIATION-BEGIN
     (TELNET-HANDLE-SUBNEGOTIATION))))

(DEFMETHOD (BASIC-TELNET :HANDLE-IMLAC-ESCAPE) (&AUX CH)
  (FUNCALL-SELF ':FORCE-OUTPUT)
  (SETQ CH (+ (NVT-NETI) 176))
  (COND ((= CH 177)
	 (LET ((SIMULATE-IMLAC-FLAG NIL))
	   (FUNCALL-SELF ':BUFFERED-TYO CH)))
	((< (SETQ CH (- CH 200)) (ARRAY-LENGTH SUPDUP-%TD-DISPATCH))
	 (FUNCALL (AREF SUPDUP-%TD-DISPATCH CH) SELF))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
(DEFUN TELNET-ECHO (ON-P)
  (COND ((NEQ ECHO-FLAG ON-P) ;If not the right way already
	 (SETQ ECHO-FLAG ON-P)
	 (TELNET-SEND-OPTION (IF ON-P NVT-DO NVT-WILL) NVT-ECHO)))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
(DEFUN TELNET-SEND-OPTION (COMMAND OPTION)
  (LOCK-OUTPUT
    (FUNCALL STREAM ':TYO NVT-IAC)
    (FUNCALL STREAM ':TYO COMMAND)
    (FUNCALL STREAM ':TYO OPTION)
    (FUNCALL STREAM ':FORCE-OUTPUT))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
(DEFUN TELNET-START-SUPDUP-OUTPUT ()
  (LOCK-OUTPUT
    (FUNCALL STREAM ':TYO NVT-IAC)
    (FUNCALL STREAM ':TYO NVT-SUBNEGOTIATION-BEGIN)
    (FUNCALL STREAM ':TYO NVT-SUPDUP-OUTPUT)
    (FUNCALL STREAM ':TYO 1)
    (SEND-TTY-VARIABLES STREAM SELF)
    (FUNCALL STREAM ':TYO NVT-IAC)
    (FUNCALL STREAM ':TYO NVT-SUBNEGOTIATION-END)
    (FUNCALL STREAM ':FORCE-OUTPUT))))

(DEFUN TELNET-HANDLE-SUBNEGOTIATION ()
  (IF (AND (= (NVT-NETI) NVT-SUPDUP-OUTPUT) (= (NVT-NETI) 2))
      (TELNET-SUPDUP-OUTPUT-SUBNEGOTIATION)
      (DO ((CH) (STATE)) (NIL)
	(SETQ CH (NVT-NETI))
	(COND (STATE
	       (AND (= CH NVT-SUBNEGOTIATION-END)
		    (RETURN NIL))
	       (SETQ STATE NIL))
	      ((= CH NVT-IAC)
	       (SETQ STATE T))))))

(LOCAL-DECLARE ((SPECIAL SUPDUP-OUTPUT-BYTE-COUNT SUPDUP-OUTPUT-OLD-STREAM))
(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
(DEFUN TELNET-SUPDUP-OUTPUT-SUBNEGOTIATION ()
  (DO ((SUPDUP-OUTPUT-BYTE-COUNT (NVT-NETI))
       (SUPDUP-OUTPUT-OLD-STREAM STREAM)
       (STREAM 'SUPDUP-OUTPUT-COUNTING-STREAM))
      (( SUPDUP-OUTPUT-BYTE-COUNT 0)
       (OR (AND (= SUPDUP-OUTPUT-BYTE-COUNT 0)
		(NVT-NETI) (NVT-NETI)			;We already know the cursor position
		(= (NVT-NETI) NVT-IAC) (= (NVT-NETI) NVT-SUBNEGOTIATION-END))
	   (FERROR NIL "SUPDUP-OUTPUT subnegotiation out of phase")))
    (BASIC-SUPDUP-BUFFERED-TYO-METHOD ':BUFFERED-TYO (NVT-NETI)))))

(DEFUN SUPDUP-OUTPUT-COUNTING-STREAM (OP &REST ARGS)
  (PROG1 (LEXPR-FUNCALL SUPDUP-OUTPUT-OLD-STREAM OP ARGS)
	 (AND (EQ OP ':TYI)
	      (SETQ SUPDUP-OUTPUT-BYTE-COUNT (1- SUPDUP-OUTPUT-BYTE-COUNT))))))

(DEFMETHOD (BASIC-TELNET :LOGOUT) ()
  (TELNET-SEND-OPTION NVT-DO NVT-LOGOUT))

(DEFMETHOD (BASIC-TELNET :TOGGLE-IMLAC-SIMULATION) ()
  (SETQ SIMULATE-IMLAC-FLAG (NOT SIMULATE-IMLAC-FLAG)))

(DEFMETHOD (BASIC-TELNET :MORE-EXCEPTION) ()
  (TV:SHEET-MORE-HANDLER ':MORE-TYI))

(DEFMETHOD (BASIC-TELNET :MORE-TYI) ()
  (SETQ MORE-FLAG T)
  (COND ((EQ CURRENT-PROCESS TYPEOUT-PROCESS)
	 (FUNCALL-SELF ':FORCE-KBD-INPUT '(:MORE))
	 (PROCESS-WAIT "MORE"
		       #'(LAMBDA (LOC) (NOT (CAR LOC)))
		       (LOCATE-IN-INSTANCE SELF 'MORE-FLAG)))
	(T
	 (FUNCALL-SELF ':TYI)
	 (SETQ MORE-FLAG NIL))))

(COMPILE-FLAVOR-METHODS SUPDUP TELNET)