;;;Windows that hack the network -*- Mode:LISP; Package:SUPDUP -*- ;;; "Connect to:" may be answered by hostname, bridgehostname, bridgehostname/socket, ;;; or hostname/contactname. (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 #\NETWORK) ;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 to screen (TYPEIN-PROCESS NIL) ;Keyboard to 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 PROGRAM-NAME) ;In the "Connect to host" message and help message. (BUFFERED-OUTPUT-MIXIN TV:ANY-TYI-MIXIN) (:INCLUDED-FLAVORS TV:LABEL-MIXIN TV:STREAM-MIXIN TV:SHEET) (:GETTABLE-INSTANCE-VARIABLES CONNECTION STREAM) (:INITABLE-INSTANCE-VARIABLES ESCAPE-CHAR TYPEIN-PROCESS TYPEOUT-PROCESS PROGRAM-NAME) (:SETTABLE-INSTANCE-VARIABLES CONNECT-TO TERMINAL-STREAM) (:REQUIRED-METHODS :CONNECT :GOBBLE-GREETING :NET-OUTPUT :NET-OUTPUT-TRANSLATED) (:DEFAULT-INIT-PLIST :DEEXPOSED-TYPEOUT-ACTION ':NOTIFY) (: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 (MAKE-PROCESS (STRING-APPEND TV:NAME "-Typeout") ':SPECIAL-PDL-SIZE 2000.))) (COND ((NULL TYPEIN-PROCESS) (SETQ TYPEIN-PROCESS (MAKE-PROCESS (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)) (DEFMETHOD (BASIC-NVT :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) #'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 :AFTER :REFRESH) (&OPTIONAL IGNORE) (OR TV:RESTORED-BITS-P (FUNCALL-SELF ':HOME-CURSOR))) (DEFMETHOD (BASIC-NVT :CONNECTED-P) () (AND CONNECTION (EQ (CHAOS:STATE CONNECTION) 'CHAOS:OPEN-STATE))) (DEFMETHOD (BASIC-NVT :BEFORE :CONNECT) (&REST IGNORE) (IF CONNECTION (FUNCALL-SELF ':DISCONNECT) (FS:FORCE-USER-TO-LOGIN))) (DEFMETHOD (BASIC-NVT :AFTER :SET-CONNECT-TO) (&REST IGNORE) (AND TYPEIN-PROCESS (FUNCALL TYPEIN-PROCESS ':RESET))) (DEFMETHOD (BASIC-NVT :NEW-CONNECTION) (PROGNAME HOST GATEWAY CONTACT CONTACT-P WINDOW &AUX LABEL-SPEC CONN) (MULTIPLE-VALUE (HOST CONTACT LABEL-SPEC) (EXPAND-PATH PROGNAME HOST GATEWAY CONTACT CONTACT-P)) (SETQ CONN (CHAOS:CONNECT HOST CONTACT WINDOW)) (IF (STRINGP CONN) CONN (FUNCALL-SELF ':SET-LABEL LABEL-SPEC) (FUNCALL-SELF ':SET-CONNECTION CONN))) ;;; Path may be any of these: ;;; NIL: Use associated machine. ;;; a fixnum: Use the host whose Chaos address is that number. ;;; host-name: Use that host. ;;; gateway-host-namearpa-host-name: Use that gateway and arpa host. ;;; host-name/contact-string: Use that chaos host and that contact string. ;;; arpa-host-name/number: Use that arpa host and that socket. ;;; gateway-host-namearpa-host-name/number: (Obvious.) ;;; The ARPA-SOCKET and CONNECT-NAME arguments are overriden by the above. ;;; Socket numbers are in octal. (DEFUN PARSE-PATH (PATH CONTACT-NAME ARPA-SOCKET) (DECLARE (RETURN-LIST HOST GATEWAY-HOST CONTACT CONTACT-SPECIFIED-P)) (AND (SYMBOLP PATH) (SETQ PATH (STRING PATH))) (LET ((HOST NIL) (GATEWAY NIL) (SPECIFIED-CONTACT NIL)) (COND ((FIXP PATH) ;; Allow an unknown number through (OR (SETQ HOST (SI:GET-HOST-FROM-ADDRESS PATH ':CHAOS)) (SETQ HOST PATH))) ((NULL PATH) (SETQ HOST SI:ASSOCIATED-MACHINE)) ((NOT (STRINGP PATH)) (SETQ HOST PATH)) (T (LET ((GATE-P (STRING-SEARCH-CHAR #/ PATH))) (COND ((NOT GATE-P) (LET ((SLASH-P (STRING-SEARCH-CHAR #// PATH))) (IF (NOT SLASH-P) ;; Format is "host-name". (IF (LET ((HST (SI:PARSE-HOST PATH T))) (AND HST (FUNCALL HST ':NETWORK-TYPEP ':CHAOS))) (SETQ HOST PATH) (LET ((NUMBER (GET-OCTAL-SUBSTRING PATH))) (IF NUMBER (OR (SETQ HOST (SI:GET-HOST-FROM-ADDRESS NUMBER ':CHAOS)) (SETQ HOST NUMBER)) ;; Attempt to get info on an arpa host, but don't lose ;; if no network host table servers available. (SETQ HOST PATH GATEWAY T)))) (LET ((NUMBER (GET-OCTAL-SUBSTRING PATH (1+ SLASH-P)))) (IF (NULL NUMBER) ;; Format is "host-name/contact-string". (SETQ HOST (SUBSTRING PATH 0 SLASH-P) SPECIFIED-CONTACT (SUBSTRING PATH (1+ SLASH-P))) ;; Format is "arpa-host-name/number". (SETQ HOST (SUBSTRING PATH 0 SLASH-P) GATEWAY T SPECIFIED-CONTACT NUMBER)))))) (T (SETQ GATEWAY (SUBSTRING PATH 0 GATE-P)) (LET ((SLASH-P (STRING-SEARCH-CHAR #// PATH (1+ GATE-P)))) (IF (NOT SLASH-P) ;; Format is "gateway-host-namearpa-host-name". (SETQ HOST (SUBSTRING PATH (1+ GATE-P))) ;; Format is "gateway-host-namearpa-host-name/number". (LET ((NUMBER-P (GET-OCTAL-SUBSTRING PATH (1+ SLASH-P)))) (IF (NULL NUMBER-P) (FERROR "~S is not a meaninful specification" PATH)) (SETQ HOST (SUBSTRING PATH (1+ GATE-P) SLASH-P) SPECIFIED-CONTACT NUMBER-P))))))))) (COND (GATEWAY (AND (EQ GATEWAY T) (SETQ GATEWAY (CAR (SI:GET-SITE-OPTION ':ARPA-GATEWAYS)))) (SETQ GATEWAY (SI:PARSE-HOST GATEWAY)) (SETQ HOST (OR (SI:PARSE-HOST HOST T T) HOST))) ((STRINGP HOST) (SETQ HOST (SI:PARSE-HOST HOST)))) (VALUES HOST GATEWAY (OR SPECIFIED-CONTACT (IF GATEWAY ARPA-SOCKET CONTACT-NAME)) (NOT (NULL SPECIFIED-CONTACT))))) (DEFUN EXPAND-PATH (PROGNAME HOST GATEWAY-HOST CONTACT CONTACT-P &AUX LABEL) (DECLARE (RETURN-LIST CHAOS-HOST CONTACT LABEL)) (SETQ LABEL (FORMAT NIL "~A -- ~@[~A  ~]~A~:[ (~:[~A~;~O~])~]" PROGNAME GATEWAY-HOST HOST (NOT CONTACT-P) GATEWAY-HOST CONTACT)) (VALUES (OR GATEWAY-HOST HOST) (IF GATEWAY-HOST (FORMAT NIL "ARPA ~A ~O" HOST CONTACT) CONTACT) LABEL)) (DEFUN GET-OCTAL-SUBSTRING (STRING &OPTIONAL START END) (IF (NULL START) (SETQ START 0)) (IF (NULL END) (SETQ END (STRING-LENGTH STRING))) (LOOP FOR INDEX FROM START BELOW END WITH VALUE = 0 DO (LET ((CHAR (AREF STRING INDEX))) (IF (AND ( CHAR #/0) ( CHAR #/7)) (SETQ VALUE (+ (* VALUE 8) (- CHAR #/0))) (RETURN NIL))) FINALLY (RETURN VALUE))) (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:DESELECT-AND-MAYBE-BURY-WINDOW WINDOW))) (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 'SYS:COMMAND-LEVEL 'THIS-TAG-WILL-NEVER-GET-THROWN-TO) (CONDITION-BIND ((CHAOS:READ-ON-LOS-CONNECTION #'NET-ERROR) (CHAOS:LOS-RECEIVED-STATE #'NET-ERROR) (CHAOS:HOST-DOWN #'NET-ERROR)) (SETQ STR (*CATCH 'NVT-DONE (COND ((NOT (NULL CONNECTION)) (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 (*THROW 'NVT-DONE (CADR CH))) (:MORE (FUNCALL-SELF ':MORE-TYI)) (OTHERWISE (FUNCALL-SELF ':NET-OUTPUT-TRANSLATED CH))) (SELECTQ (CHAOS:STATE CONNECTION) (CHAOS:OPEN-STATE) (CHAOS:HOST-DOWN-STATE (*THROW 'NVT-DONE "Foreign Host died")) (CHAOS:CLS-RECEIVED-STATE (*THROW 'NVT-DONE "Closed by foreign host")) (CHAOS:LOS-RECEIVED-STATE (*THROW 'NVT-DONE "Connection closed due to lossage:")) (OTHERWISE (*THROW 'NVT-DONE (FORMAT NIL "Connection in unknown state:~S" (CHAOS:STATE CONNECTION))))) (IF (= (CHAR-UPCASE CH) ESCAPE-CHAR) ;;Handle the escape character, (FUNCALL-SELF ':HANDLE-ESCAPE) ;; otherwise just send through what user typed. (FUNCALL-SELF ':NET-OUTPUT-TRANSLATED CH))))) (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) (DO () (()) ;; Loop until loser types in something non-blank. (FORMAT T "~&~A. Type the HELP key for help.~@ Connect to host: " PROGRAM-NAME) ;; Allow NETWORK escape to work while waiting for host names. (FUNCALL-SELF ':ALLOW-ESCAPE) (LET ((HOST-NAME (STRING-TRIM '(#\SPACE #\TAB) (READLINE)))) (COND ((PLUSP (STRING-LENGTH HOST-NAME)) (RETURN (FUNCALL-SELF ':CONNECT HOST-NAME)))))))))))) (COND ((STRINGP STR) (FUNCALL-SELF ':DISCONNECT) (FORMAT SELF "~%~A~%" STR) (AND RETURN-TO-CALLER (RETURN T)))))) ;;; Call this before inputting things. It peeks for an escape and handles it. (DEFMETHOD (BASIC-NVT :ALLOW-ESCAPE) () (DO () ((LET ((CHAR (FUNCALL STANDARD-INPUT ':ANY-TYI))) (COND ((AND (NUMBERP CHAR) (= (CHAR-UPCASE CHAR) ESCAPE-CHAR)) (FUNCALL-SELF ':HANDLE-ESCAPE) ; Handle the escape character. NIL) ; Keep looping. ((AND (NUMBERP CHAR) (= CHAR #\HELP)) (FUNCALL-SELF ':HELP-MESSAGE) ; Give the user some help. NIL) ; Keep looping. (T (FUNCALL-SELF ':UNTYI CHAR) ; Put back character, exit loop. T))) NIL))) ;;; Default help message. (DEFMETHOD (BASIC-NVT :HELP-MESSAGE) () (COND ((NULL CONNECTION) (FUNCALL STANDARD-OUTPUT ':CLEAR-SCREEN) (FORMAT T "~ ~&You are using the ~A remote-login program. To connect to any Chaosnet or Arpanet host, just type the target host name. If you want to connect to an Arpanet host and specify a particular gateway host, type the gateway host name, an altmode, and the target host name. If you want to connect to a specific socket on an Arpanet host, follow the name of the Arpanet host by a slash and the socket number in octal. If you want to connect to a specific connect-name on a Chaosnet host, follow the name of the Chaosnet host by a slash and the connect name. Summary: host (for either network) gatewayarpa-host chaos-host//connect-name arpa-host//socket-number (octal) gatewayarpa-host//socket-number (octal) At any time you can type the [Network] key to give any of a number of useful commands. For descriptions of the available commands, type [Network] [Help]. Connect to host: " PROGRAM-NAME)))) ;;;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) (TV:DESELECT-AND-MAYBE-BURY-WINDOW SELF)) (#/A (IF (NOT (NULL CONNECTION)) (FUNCALL-SELF ':SEND-IP))) (#/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. (COND ((NULL CONNECTION) (*THROW 'NVT-DONE "(Already disconnected.)")) (T (FUNCALL-SELF ':DISCONNECT) (*THROW 'NVT-DONE "Disconnected")))) (#/E (FUNCALL-SELF ':SET-IO-BUFFER ORDINARY-IO-BUFFER)) (#/L ;L = Logout. (COND ((NULL CONNECTION) (QUIT)) (T (FUNCALL-SELF ':LOGOUT) (QUIT "Logout")))) (#/Q ;Q = Quit. (QUIT)) (#/M ;M = More. (IF (NOT (NULL CONNECTION)) (FUNCALL-SELF ':SET-MORE-P (NOT (FUNCALL-SELF ':MORE-P))))) (#/I ;I = Imlac. (IF (NOT (NULL CONNECTION)) (FUNCALL-SELF ':TOGGLE-IMLAC-SIMULATION))) ((#\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). A -- Send an ATTN (in Telnet, a New Telnet /"Interrupt Process/"). 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) ; = Do nothing. (OTHERWISE (COND ((= CH ESCAPE-CHAR) (FUNCALL-SELF ':NET-OUTPUT-TRANSLATED 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 pretty dumb. SUPDUP doesn't have IP, so this must be here. ;;; Wedging SUPDUP and TELENT together like this is not totally flavorful -- DLW. (DEFMETHOD (BASIC-NVT :SEND-IP) () NIL) ;;;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:LOS-RECEIVED-STATE #'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))))) (DEFUN NVT-NETI (&AUX CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-NVT) (COND ((SETQ CH (FUNCALL STREAM ':TYI))) (T (FUNCALL TERMINAL-IO ':FORCE-KBD-INPUT '(:ERROR "Closed by foreign host")) (PROCESS-WAIT "Connection closed" #'FALSE))))) (DEFUN TYPEOUT-NET-ERROR (IGNORE STRING &REST ARGS) (FUNCALL TERMINAL-IO ':FORCE-KBD-INPUT (LIST ':ERROR (LEXPR-FUNCALL #'FORMAT NIL STRING ARGS))) (SI:PROCESS-WAIT-FOREVER)) (DEFMETHOD (BASIC-NVT :REMOTE-BEEP) () (OR (ZEROP (TV:SHEET-EXCEPTIONS)) ;Subject to output holding (TV:SHEET-HANDLE-EXCEPTIONS SELF)) (FUNCALL-SELF ':BEEP)) ;;; Suppress notification if we do not have a connection (DEFMETHOD (BASIC-NVT :NOTICE) (EVENT &REST IGNORE) (AND (MEMQ EVENT '(:INPUT :OUTPUT)) (NOT CONNECTION))) ;SUPDUP Graphics Protocol (DEFFLAVOR GRAPHICS-MIXIN (GRAPHICS-X-OFFSET GRAPHICS-Y-OFFSET GRAPHICS-VIRT-SCALE GRAPHICS-XPOS GRAPHICS-YPOS GRAPHICS-LEFT GRAPHICS-TOP GRAPHICS-RIGHT GRAPHICS-BOTTOM GRAPHICS-XOR-MODE GRAPHICS-VIRTUAL-MODE) () (:INCLUDED-FLAVORS TV:SHEET)) ;Note that ALL four edge coordinates are INCLUSIVE: ;they are values corresponding to points which actually exist. ;This is in contrast to the window system, ;in which the lower limits are inclusive and the upper are exclusive. (DEFMETHOD (GRAPHICS-MIXIN :AFTER :INIT) (&REST IGNORE) (GRAPHICS-RESET SELF) (SETQ GRAPHICS-XPOS 0 GRAPHICS-YPOS 0)) ;Initialize all the variables used for graphics commands. (DEFUN GRAPHICS-RESET (WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (LET ((CORRECTED-RIGHT (+ (TV:SHEET-INSIDE-LEFT WINDOW) (* (TV:SHEET-CHAR-WIDTH WINDOW) (// (TV:SHEET-INSIDE-WIDTH WINDOW) (TV:SHEET-CHAR-WIDTH WINDOW))))) (CORRECTED-BOTTOM (+ (TV:SHEET-INSIDE-TOP WINDOW) (* (TV:SHEET-LINE-HEIGHT WINDOW) (// (TV:SHEET-INSIDE-HEIGHT WINDOW) (TV:SHEET-LINE-HEIGHT WINDOW)))))) (SETQ GRAPHICS-X-OFFSET (// (+ (TV:SHEET-INSIDE-LEFT WINDOW) CORRECTED-RIGHT) 2) GRAPHICS-Y-OFFSET (// (+ (TV:SHEET-INSIDE-TOP WINDOW) CORRECTED-BOTTOM) 2) GRAPHICS-XPOS 0 GRAPHICS-YPOS 0 GRAPHICS-VIRT-SCALE (// (MIN (- CORRECTED-RIGHT (TV:SHEET-INSIDE-LEFT WINDOW)) (- CORRECTED-BOTTOM (TV:SHEET-INSIDE-TOP WINDOW))) 2.0S0 4000) GRAPHICS-XOR-MODE NIL GRAPHICS-VIRTUAL-MODE NIL GRAPHICS-LEFT (- (TV:SHEET-INSIDE-LEFT WINDOW) GRAPHICS-X-OFFSET) GRAPHICS-RIGHT (- (TV:SHEET-INSIDE-RIGHT WINDOW) GRAPHICS-X-OFFSET 1) GRAPHICS-BOTTOM (- GRAPHICS-Y-OFFSET (1- (TV:SHEET-INSIDE-BOTTOM WINDOW))) GRAPHICS-TOP (- GRAPHICS-Y-OFFSET (TV:SHEET-INSIDE-TOP WINDOW)))))) (DEFVAR GRAPHICS-DISPATCH (MAKE-ARRAY 100)) (FILLARRAY GRAPHICS-DISPATCH '(GRAPHICS-NOTHING GRAPHICS-MOVE GRAPHICS-XOR GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-ERASE-SCREEN GRAPHICS-PUSH GRAPHICS-VIRTUAL GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-LIMIT GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-MOVE GRAPHICS-IOR GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-PHYSICAL GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING GRAPHICS-NOTHING)) (DEFVAR DRAW-DISPATCH (MAKE-ARRAY 20)) (FILLARRAY DRAW-DISPATCH '(GRAPHICS-NOTHING GRAPHICS-DRAW-LINE GRAPHICS-DRAW-POINT GRAPHICS-DRAW-RECT GRAPHICS-DRAW-STRING GRAPHICS-DRAW-BITS GRAPHICS-DRAW-RUNS GRAPHICS-NOTHING)) (DEFUN SUPDUP-GRAPHICS (WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (*CATCH 'SUPDUP-GRAPHICS (DO (CH) (()) (SETQ CH (GRAPHICS-NETI)) (COND ((BIT-TEST CH 100) (FUNCALL (OR (AREF DRAW-DISPATCH (LOGAND CH 17)) 'GRAPHICS-NOTHING) WINDOW CH)) (T (FUNCALL (OR (AREF GRAPHICS-DISPATCH CH) 'GRAPHICS-NOTHING) WINDOW CH))))))) ;Subroutines for graphics commands. (DEFUN GRAPHICS-NETI () (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP) (LET ((CH (NVT-NETI))) (AND (BIT-TEST CH 200) (*THROW 'SUPDUP-GRAPHICS (FUNCALL STREAM ':UNTYI CH))) CH))) (DEFUN GRAPHICS-READ-POINT (CH &AUX CH1 CH2 CH3 CH4) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (COND ((BIT-TEST CH 20) (SETQ GRAPHICS-XPOS (14-BIT-SIGN-EXTEND (+ (SETQ CH1 (GRAPHICS-NETI)) (LSH (SETQ CH2 (GRAPHICS-NETI)) 7)))) (SETQ GRAPHICS-YPOS (14-BIT-SIGN-EXTEND (+ (SETQ CH3 (GRAPHICS-NETI)) (LSH (SETQ CH4 (GRAPHICS-NETI)) 7))))) (T (INCF GRAPHICS-XPOS (SETQ CH1 (7-BIT-SIGN-EXTEND (GRAPHICS-NETI)))) (INCF GRAPHICS-YPOS (SETQ CH2 (7-BIT-SIGN-EXTEND (GRAPHICS-NETI)))))))) (DEFUN 7-BIT-SIGN-EXTEND (NUMBER) (COND ((BIT-TEST NUMBER 100) (- NUMBER 200)) (T NUMBER))) (DEFUN 14-BIT-SIGN-EXTEND (NUMBER) (COND ((BIT-TEST NUMBER 20000) (- NUMBER 40000)) (T NUMBER))) (DEFUN GRAPHICS-ALU (CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (COND (GRAPHICS-XOR-MODE TV:ALU-XOR) ((BIT-TEST CH 40) TV:ALU-ANDCA) (T TV:ALU-IOR)))) (DEFUN GRAPHICS-X-COORD (COORD) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (AND GRAPHICS-VIRTUAL-MODE (SETQ COORD (FIXR (* COORD GRAPHICS-VIRT-SCALE)))) (+ GRAPHICS-X-OFFSET (MIN GRAPHICS-RIGHT (MAX GRAPHICS-LEFT COORD))))) (DEFUN GRAPHICS-Y-COORD (COORD) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (AND GRAPHICS-VIRTUAL-MODE (SETQ COORD (FIXR (* COORD GRAPHICS-VIRT-SCALE)))) (- GRAPHICS-Y-OFFSET (MIN GRAPHICS-TOP (MAX GRAPHICS-BOTTOM COORD))))) (DEFUN GRAPHICS-Y-IN-RANGE (&AUX COORD) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (SETQ COORD GRAPHICS-YPOS) (AND GRAPHICS-VIRTUAL-MODE (SETQ COORD (FIXR (* COORD GRAPHICS-VIRT-SCALE)))) (<= GRAPHICS-BOTTOM COORD GRAPHICS-TOP))) ;Graphics commands. (DEFUN GRAPHICS-NOTHING (IGNORE IGNORE) NIL) (DEFUN GRAPHICS-XOR (IGNORE IGNORE) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (SETQ GRAPHICS-XOR-MODE T))) (DEFUN GRAPHICS-IOR (IGNORE IGNORE) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (SETQ GRAPHICS-XOR-MODE NIL))) (DEFUN GRAPHICS-VIRTUAL (IGNORE IGNORE) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (SETQ GRAPHICS-VIRTUAL-MODE T))) (DEFUN GRAPHICS-PHYSICAL (IGNORE IGNORE) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (SETQ GRAPHICS-VIRTUAL-MODE NIL))) (DEFUN GRAPHICS-MOVE (IGNORE CH) (GRAPHICS-READ-POINT CH)) (DEFUN GRAPHICS-PUSH (WINDOW IGNORE) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (LET ((GRAPHICS-XPOS GRAPHICS-XPOS) (GRAPHICS-YPOS GRAPHICS-YPOS) (GRAPHICS-RIGHT GRAPHICS-RIGHT) (GRAPHICS-LEFT GRAPHICS-LEFT) (GRAPHICS-TOP GRAPHICS-TOP) (GRAPHICS-BOTTOM GRAPHICS-BOTTOM) (GRAPHICS-XOR-MODE GRAPHICS-XOR-MODE) (GRAPHICS-VIRTUAL-MODE GRAPHICS-VIRTUAL-MODE)) (DO (CH) (()) (SETQ CH (GRAPHICS-NETI)) (COND ((BIT-TEST CH 100) (FUNCALL (OR (AREF DRAW-DISPATCH (LOGAND CH 17)) 'GRAPHICS-NOTHING) WINDOW CH)) (T (FUNCALL (OR (AREF GRAPHICS-DISPATCH CH) 'GRAPHICS-NOTHING) WINDOW CH))))))) (DEFUN GRAPHICS-LIMIT (IGNORE CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (GRAPHICS-READ-POINT CH) (LET ((OXPOS GRAPHICS-XPOS) (OYPOS GRAPHICS-YPOS)) (GRAPHICS-READ-POINT CH) (SETQ GRAPHICS-LEFT (MIN GRAPHICS-XPOS OXPOS) GRAPHICS-RIGHT (MAX GRAPHICS-XPOS OXPOS) GRAPHICS-BOTTOM (MIN GRAPHICS-YPOS OYPOS) GRAPHICS-TOP (MAX GRAPHICS-YPOS OYPOS))))) ;Drawing commands. (DEFUN GRAPHICS-DRAW-LINE (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (TV:PREPARE-SHEET (WINDOW) (LET ((OXPOS GRAPHICS-XPOS) (OYPOS GRAPHICS-YPOS)) (GRAPHICS-READ-POINT CH) (SYSTEM:%DRAW-LINE (GRAPHICS-X-COORD OXPOS) (GRAPHICS-Y-COORD OYPOS) (GRAPHICS-X-COORD GRAPHICS-XPOS) (GRAPHICS-Y-COORD GRAPHICS-YPOS) (GRAPHICS-ALU CH) T WINDOW))))) (DEFUN GRAPHICS-DRAW-POINT (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (TV:PREPARE-SHEET (WINDOW) (GRAPHICS-READ-POINT CH) (SYSTEM:%DRAW-LINE (GRAPHICS-X-COORD GRAPHICS-XPOS) (GRAPHICS-Y-COORD GRAPHICS-YPOS) (GRAPHICS-X-COORD GRAPHICS-XPOS) (GRAPHICS-Y-COORD GRAPHICS-YPOS) (GRAPHICS-ALU CH) T WINDOW)))) (DEFUN GRAPHICS-DRAW-RECT (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (TV:PREPARE-SHEET (WINDOW) (LET ((OXPOS GRAPHICS-XPOS) (OYPOS GRAPHICS-YPOS)) (GRAPHICS-READ-POINT CH) (TV:%DRAW-RECTANGLE (ABS (1+ (- (GRAPHICS-X-COORD GRAPHICS-XPOS) (GRAPHICS-X-COORD OXPOS)))) (ABS (1+ (- (GRAPHICS-Y-COORD GRAPHICS-YPOS) (GRAPHICS-Y-COORD OYPOS)))) (MIN (GRAPHICS-X-COORD GRAPHICS-XPOS) (GRAPHICS-X-COORD OXPOS)) (MIN (GRAPHICS-Y-COORD GRAPHICS-YPOS) (GRAPHICS-Y-COORD OYPOS)) (GRAPHICS-ALU CH) WINDOW))))) (DEFUN GRAPHICS-ERASE-SCREEN (WINDOW IGNORE) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (TV:PREPARE-SHEET (WINDOW) (TV:%DRAW-RECTANGLE (1+ (- (GRAPHICS-X-COORD GRAPHICS-RIGHT) (GRAPHICS-X-COORD GRAPHICS-LEFT))) (1+ (- (GRAPHICS-Y-COORD GRAPHICS-BOTTOM) (GRAPHICS-Y-COORD GRAPHICS-TOP))) (GRAPHICS-X-COORD GRAPHICS-LEFT) (GRAPHICS-Y-COORD GRAPHICS-TOP) (TV:SHEET-ERASE-ALUF WINDOW) WINDOW)))) (DEFUN GRAPHICS-DRAW-STRING (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (LET ((STRING (MAKE-ARRAY 100 ':TYPE ART-STRING ':LEADER-LIST '(0)))) (DO () (()) (LET ((CH (GRAPHICS-NETI))) (AND (ZEROP CH) (RETURN)) (ARRAY-PUSH-EXTEND STRING CH))) (TV:SHEET-STRING-OUT-EXPLICIT WINDOW STRING (GRAPHICS-X-COORD GRAPHICS-XPOS) (GRAPHICS-Y-COORD GRAPHICS-YPOS) (GRAPHICS-X-COORD GRAPHICS-RIGHT) (TV:SHEET-CURRENT-FONT WINDOW) (GRAPHICS-ALU CH)) (RETURN-ARRAY STRING)))) (DEFUN GRAPHICS-DRAW-BITS (WINDOW CH &AUX BIT-CHANGE-FUNCTION) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (TV:PREPARE-SHEET (WINDOW) (SETQ BIT-CHANGE-FUNCTION (GRAPHICS-ALU CH)) (DO ((I 1 (1+ I))) (()) (LET ((NBITS (COND ((ZEROP (\ I 3)) 4) (T 6))) (X (GRAPHICS-X-COORD GRAPHICS-XPOS)) (Y (GRAPHICS-Y-COORD GRAPHICS-YPOS)) (CH (GRAPHICS-NETI))) (AND (BIT-TEST CH 100) (RETURN)) (AND (GRAPHICS-Y-IN-RANGE) (DOTIMES (BIT NBITS) (OR (>= GRAPHICS-XPOS GRAPHICS-RIGHT) (AND (BIT-TEST (LSH 1 (- NBITS 1 BIT)) CH) (SETF (AREF TV:SCREEN-ARRAY (+ BIT X) Y) (BOOLE BIT-CHANGE-FUNCTION (AREF TV:SCREEN-ARRAY (+ BIT X) Y) 1)))))) (INCF GRAPHICS-XPOS NBITS)))))) (DEFUN GRAPHICS-DRAW-RUNS (WINDOW CH &AUX BIT-CHANGE-FUNCTION) (DECLARE-FLAVOR-INSTANCE-VARIABLES (GRAPHICS-MIXIN) (TV:PREPARE-SHEET (WINDOW) (SETQ BIT-CHANGE-FUNCTION (GRAPHICS-ALU CH)) (DO () (()) (LET ((CH (GRAPHICS-NETI)) (OLDX (GRAPHICS-X-COORD GRAPHICS-XPOS)) (Y (GRAPHICS-Y-COORD GRAPHICS-YPOS))) (AND (ZEROP CH) (RETURN)) (INCF GRAPHICS-XPOS (LOGAND CH 77)) (AND (BIT-TEST CH 100) (GRAPHICS-Y-IN-RANGE) (SYSTEM:%DRAW-LINE OLDX Y (MAX OLDX (1- (GRAPHICS-X-COORD GRAPHICS-XPOS))) Y BIT-CHANGE-FUNCTION T WINDOW))))))) (DEFFLAVOR BASIC-SUPDUP () (BASIC-NVT GRAPHICS-MIXIN) (:DEFAULT-INIT-PLIST :PROGRAM-NAME "Supdup") (:DOCUMENTATION :SPECIAL-PURPOSE "A SUPDUP NVT")) (DEFFLAVOR SUPDUP () (BASIC-SUPDUP TV:INITIALLY-INVISIBLE-MIXIN TV:FULL-SCREEN-HACK-MIXIN TV:WINDOW) (:DEFAULT-INIT-PLIST :SAVE-BITS T) (:DOCUMENTATION :COMBINATION)) (DEFRESOURCE TYPEOUT-PROCESSES () :CONSTRUCTOR (MAKE-PROCESS "NVT-Typeout" ':SPECIAL-PDL-SIZE 2000.)) (DEFVAR *SUPDUP-WINDOWS*) (DEFVAR *SUPDUP-DEFAULT-PATH*) (DEFVAR *SUPDUP-MODE*) (FORWARD-VALUE-CELL '*SUPDUP-WINDOWS* 'SUPDUP-WINDOWS) (FORWARD-VALUE-CELL '*SUPDUP-DEFAULT-PATH* 'SUPDUP-DEFAULT-PATH) (FORWARD-VALUE-CELL '*SUPDUP-MODE* 'SUPDUP-MODE) (DEFVAR SUPDUP-WINDOWS NIL) (DEFVAR SUPDUP-DEFAULT-PATH "AI") (DEFVAR SUPDUP-MODE T) ;NIL => New window default (DEFVAR JOURNAL-STREAM NIL) ;Stream for reccording history of events for debugging. (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))) (DEFVAR SUPDUP-FLAVOR 'LOCAL-EDITING-SUPDUP) ;LOCAL-EDITING-SUPDUP does not work with some broken hosts (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:MAKE-WINDOW SUPDUP-FLAVOR))) (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)) (USING-RESOURCE (BIT-ARRAY TV:BIT-ARRAYS) (USING-RESOURCE (TP TYPEOUT-PROCESSES) (TV:WINDOW-BIND (WINDOW SUPDUP-FLAVOR ':TYPEIN-PROCESS CURRENT-PROCESS ':BIT-ARRAY BIT-ARRAY ':TYPEOUT-PROCESS TP) (FUNCALL WINDOW ':CONNECT PATH) (*CATCH 'SYS:COMMAND-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)) (MULTIPLE-VALUE-BIND (HOST GATEWAY CONTACT CONTACT-P) (PARSE-PATH PATH "SUPDUP" 137) ;; If the host runs the WAITS operating system, it will require char i/d. (LET ((SUPDUP-%TOCID (COND ((TYPEP HOST 'SI:HOST) (EQ (FUNCALL HOST ':SYSTEM-TYPE) ':WAITS)) ((STRINGP HOST) ;No host name server. flush this when (MEMBER HOST '("SAIL" "S1-A"))) ;above thing wins. (T SUPDUP-%TOCID)))) (FUNCALL-SELF ':NEW-CONNECTION "Supdup" HOST GATEWAY CONTACT CONTACT-P NET-WINDOW)))) (DEFMETHOD (BASIC-SUPDUP :GOBBLE-GREETING) () (SEND-TTY-VARIABLES STREAM SELF NIL) (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 ;;; Furthermore, if SUPDUP-%TOCID is non-NIL, then %TOCID will be on as well. ;;; It is off by default, because the Lispm is so fast at outputting characters ;;; that EMACS is effectively faster for the user without CID capability. ;;; SUPDUPing to SAIL and using SUPDUP-OUTPUT are kludged to bind this to T. (DEFVAR SUPDUP-%TOCID NIL) (DEFUN SEND-TTY-VARIABLES (STREAM SHEET LOCAL-EDIT-FLAG) (18BIT-OUT STREAM -6) ;First word LH has minus the count of following wds. (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 (18BIT-OUT STREAM (+ (LSH (TV:SHEET-LINE-HEIGHT SHEET) 10.) ;TTYSMT (LSH (TV:SHEET-CHAR-WIDTH SHEET) 6) 55)) (18BIT-OUT STREAM (+ 040000 (IF LOCAL-EDIT-FLAG (+ 100000 ;Don't turn on line-saving. It slows TECO a lot to think about it. - RMS 0 ;(LSH 5 11.) ) 0))) (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) (FUNCALL STREAM ':TYO 300) ;SUPDUP escape string meaning that the FINGER (FUNCALL STREAM ':TYO 302) ;identification string follows. (FUNCALL STREAM ':STRING-OUT SI:LOCAL-FINGER-LOCATION) (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 :NET-OUTPUT-TRANSLATED) (CH) (COND ((LISTP CH) (FUNCALL-SELF ':NET-OUTPUT CH)) ((= CH #\ESC) ;I don't think this clause can go off --Moon (TV:KBD-ESC) NIL) (T (LET ((CHAR (LDB %%KBD-CHAR CH))) (FUNCALL-SELF ':NET-OUTPUT (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 ':FINISH))) ;;;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-RESET SUPDUP-GRAPHICS ;;; %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. (DEFUN SUPDUP-TDMV0 (SHEET &AUX YPOS) (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP) (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. (DEFUN SUPDUP-TDORS (SHEET &AUX VPOS HPOS) (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP) (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 (DEFUN SUPDUP-BEEP (IGNORE) (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP) (FUNCALL-SELF ':REMOTE-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 &OPTIONAL (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 &OPTIONAL (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))) (DEFUN SUPDUP-RESET (SHEET) (GRAPHICS-RESET SHEET)) ;;; 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:PREPARE-SHEET (,SHEET) (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:MAKE-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:PREPARE-SHEET (SHEET) (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)))) ) ;This is a sort of SUPDUP which records the current contents of the screen ;at all times in a vector of lines. Each line is a string of fixed length ;whose unused chars at the end are all filled with #\RETURN. ;It is building block for the SUPDUP which does local editing operations. ;SCREEN-LINE-ARRAY is an array of strings, one per screen line. ;Each string is as long as the width of the terminal. ;It has a leader containing a fill pointer (always constant) ;and two other slots, which record whether the line begins ;or ends with a continuation. (DEFSUBST SCREEN-LINE-BEG-CONTINUED (VPOS) (ARRAY-LEADER (AREF SCREEN-LINE-ARRAY VPOS) 1)) (DEFSUBST SCREEN-LINE-END-CONTINUED (VPOS) (ARRAY-LEADER (AREF SCREEN-LINE-ARRAY VPOS) 2)) (DEFFLAVOR RECORDING-SUPDUP (SCREEN-LINE-ARRAY OLD-SCREEN-LINE-ARRAY (CURRENT-XPOS 0) (CURRENT-YPOS 0) HEIGHT-IN-LINES (FIRST-COL-TO-SAVE 0) LAST-COL-TO-SAVE+1 (LINE-LABEL-MAX 2000) REDISPLAY-STRING SAVED-LINE-ARRAY (MULTI-POS-CHAR-BEG 0) (MULTI-POS-CHAR-END 0) (ALLOW-LOCAL-EDITING NIL)) (SUPDUP)) (DEFMETHOD (RECORDING-SUPDUP :AFTER :CHANGE-OF-SIZE-OR-MARGINS) (&REST IGNORE) (SETQ HEIGHT-IN-LINES (1- (// (TV:SHEET-INSIDE-HEIGHT SELF) (TV:SHEET-LINE-HEIGHT SELF)))) (LET ((WIDTH (// (TV:SHEET-INSIDE-WIDTH SELF) (TV:SHEET-CHAR-WIDTH SELF)))) ;; Record one line which doesn't appear on the screen. ;; This is so that line saving can be used to save a line ;; which isn't actually needed now, in case it is needed later. (SETQ SCREEN-LINE-ARRAY (MAKE-ARRAY (1+ HEIGHT-IN-LINES))) (SETQ OLD-SCREEN-LINE-ARRAY (MAKE-ARRAY HEIGHT-IN-LINES)) (SETQ LAST-COL-TO-SAVE+1 WIDTH) (SETQ SAVED-LINE-ARRAY (MAKE-ARRAY LINE-LABEL-MAX)) (SETQ REDISPLAY-STRING (MAKE-ARRAY WIDTH ':TYPE ART-FAT-STRING ':LEADER-LENGTH 1)) (DOTIMES (I (1+ HEIGHT-IN-LINES)) (SETF (AREF SCREEN-LINE-ARRAY I) (MAKE-ARRAY WIDTH ':TYPE ART-FAT-STRING ':LEADER-LENGTH 3)) (SETF (ARRAY-LEADER (AREF SCREEN-LINE-ARRAY I) 0) WIDTH)))) (DEFMETHOD (RECORDING-SUPDUP :AFTER :INIT) (&REST IGNORE) (FUNCALL-SELF ':CHANGE-OF-SIZE-OR-MARGINS)) ;This is what the recording supdup puts in a character position ;to record the fact that a %TDTSP was used to space over that position. ;We use code 211 so that its word-syntax will be correct. (DEFVAR TAB-PLACEHOLDER 211) ;;;Dispatch table for the %TD codes. (DEFVAR REC-SUPDUP-%TD-DISPATCH (MAKE-ARRAY NIL 'ART-Q 100)) (FILLARRAY REC-SUPDUP-%TD-DISPATCH '(SUPDUP-TDMOV SUPDUP-TDMV0 REC-SUPDUP-EOF REC-SUPDUP-EOL REC-SUPDUP-DLF ;;; %TDMOV %TDMV0 %TDEOF %TDEOL %TDDLF SUPDUP-NOTHING SUPDUP-GT40 REC-SUPDUP-CRLF SUPDUP-NOTHING SUPDUP-NOTHING SUPDUP-NOTHING ;;; %TDMTF %TDMTN %TDCRL %TDNOP %TDBS %TDLF SUPDUP-NOTHING SUPDUP-TDORS SUPDUP-TDQOT TV:SHEET-SPACE SUPDUP-TDMV0 REC-SUPDUP-CLEAR ;;; %TDCR %TDORS %TDQOT %TDFS %TDMV0 %TDCLR SUPDUP-BEEP SUPDUP-NOTHING REC-SUPDUP-INSERT-LINE REC-SUPDUP-DELETE-LINE ;;; %TDBEL %TDINI %TDILP %TDDLP REC-SUPDUP-INSERT-CHAR REC-SUPDUP-DELETE-CHAR SUPDUP-NOTHING SUPDUP-RESET SUPDUP-GRAPHICS ;;; %TDICP %TDDCP %TDBOW %TDRST %TDGRF REC-SUPDUP-REGION-UP REC-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 L-E-SUPDUP-RESYNCH-REPLY-RECEIVED ;;; %TDSYN L-E-SUPDUP-ALLOW-LOCAL-EDITING ;;; %TDECO L-E-SUPDUP-DEFINE-COMMAND ;;; %TDEDF L-E-SUPDUP-STOP-LOCAL-EDITING ;;; %TDNLE REC-SUPDUP-SPACE-FOR-TAB ;;; %TDTSP REC-SUPDUP-LINE-BEG-CONTINUED REC-SUPDUP-LINE-END-CONTINUED ;;; %TDCTB %TDCTE REC-SUPDUP-MULTI-POS-CHAR ;;; %TDMLT REC-SUPDUP-SAVE-LINES REC-SUPDUP-RESTORE-LINES ;;; %TDSVL %TDSVL REC-SUPDUP-SET-SAVING-RANGE REC-SUPDUP-SET-LOCAL-LABEL ;;; %TDSSR %TDSLL )) (DEFMETHOD (RECORDING-SUPDUP :BUFFERED-TYO) (CH &AUX LINE) (COND ((< CH 200) (SETF (AREF (SETQ LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)) CURRENT-XPOS) CH) (INCF CURRENT-XPOS) ;; Prevent errors storing past end of line ;; if remote site sends garbage. (AND (= CURRENT-XPOS (ARRAY-LENGTH LINE)) (DECF CURRENT-XPOS)) ;; Use top 8 bits of char to indicate start and end ;; of multi-position chars. ;; Put in 1 for 1st char, 2 for remaining chars. (AND (= CURRENT-XPOS MULTI-POS-CHAR-END) (DO ((I MULTI-POS-CHAR-BEG (1+ I))) ((= I MULTI-POS-CHAR-END)) (INCF (AREF (AREF SCREEN-LINE-ARRAY CURRENT-YPOS) I) (IF (= I MULTI-POS-CHAR-BEG) 400 1000)))) ;; Output below the screen bottom is just for recording. ;; Don't try to put the characters up-- it would bomb out. (OR (>= CURRENT-YPOS HEIGHT-IN-LINES) (DO () ((ARRAY-PUSH OUTPUT-BUFFER CH)) (FUNCALL-SELF ':FORCE-OUTPUT)))) (T (FUNCALL-SELF ':FORCE-OUTPUT) (SETQ MULTI-POS-CHAR-BEG 0 MULTI-POS-CHAR-END 0) (OR (>= (SETQ CH (- CH 200)) (ARRAY-LENGTH REC-SUPDUP-%TD-DISPATCH)) (FUNCALL (AREF REC-SUPDUP-%TD-DISPATCH CH) SELF)) (SETQ CURRENT-XPOS (// (- TV:CURSOR-X (TV:SHEET-INSIDE-LEFT SELF)) TV:CHAR-WIDTH) CURRENT-YPOS (// (- TV:CURSOR-Y (TV:SHEET-INSIDE-TOP SELF)) TV:LINE-HEIGHT))))) (DEFUN REC-SUPDUP-EOF (WINDOW) (REC-SUPDUP-EOF-1 WINDOW) (TV:SHEET-CLEAR-EOF WINDOW)) (DEFUN REC-SUPDUP-EOF-1 (WINDOW &OPTIONAL REGION-END) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (OR REGION-END (SETQ REGION-END (1+ HEIGHT-IN-LINES))) (REC-SUPDUP-EOL-1 WINDOW) (DO ((I (1+ CURRENT-YPOS) (1+ I))) ((= I REGION-END)) (SETF (SCREEN-LINE-BEG-CONTINUED I) NIL) (SETF (SCREEN-LINE-END-CONTINUED I) NIL) (FILLARRAY (AREF SCREEN-LINE-ARRAY I) '(#\RETURN))))) (DEFUN REC-SUPDUP-EOL (WINDOW) (REC-SUPDUP-EOL-1 WINDOW) (TV:SHEET-CLEAR-EOL WINDOW)) (DEFUN REC-SUPDUP-EOL-1 (WINDOW) WINDOW (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (SETF (SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL) (LET ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))) (DO ((XPOS CURRENT-XPOS (1+ XPOS)) (END (ARRAY-LENGTH LINE))) ((= XPOS END)) (SETF (AREF LINE XPOS) #\RETURN))))) (DEFUN REC-SUPDUP-CRLF (WINDOW) (TV:SHEET-CRLF WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (SETQ CURRENT-XPOS (// (- TV:CURSOR-X (TV:SHEET-INSIDE-LEFT SELF)) TV:CHAR-WIDTH) CURRENT-YPOS (// (- TV:CURSOR-Y (TV:SHEET-INSIDE-TOP SELF)) TV:LINE-HEIGHT))) (REC-SUPDUP-EOL-1 WINDOW)) ;It is ok to store #\RETURN into the erased char unconditionally ;because EMACS only uses this when it is about to ;write something into the cleared positions. (DEFUN REC-SUPDUP-DLF (WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (LET ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))) (SETF (AREF LINE CURRENT-XPOS) #\RETURN)) (TV:SHEET-CLEAR-CHAR WINDOW))) (DEFUN REC-SUPDUP-SPACE-FOR-TAB (WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (SETF (AREF (AREF SCREEN-LINE-ARRAY CURRENT-YPOS) CURRENT-XPOS) TAB-PLACEHOLDER) (TV:SHEET-SPACE WINDOW))) (DEFUN REC-SUPDUP-CLEAR (WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (LET ((CURRENT-XPOS 0) (CURRENT-YPOS 0)) (REC-SUPDUP-EOF-1 WINDOW))) (TV:SHEET-CLEAR WINDOW) (FILLARRAY GT40-DISPLAY-LIST '(NIL))) ;Miracle of modularity (DEFUN REC-SUPDUP-INSERT-LINE (WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (LET ((N-LINES (NVT-NETI))) (LET ((CURRENT-YPOS (- HEIGHT-IN-LINES N-LINES)) (CURRENT-XPOS 0)) (REC-SUPDUP-EOF-1 WINDOW)) (COPY-ARRAY-CONTENTS SCREEN-LINE-ARRAY OLD-SCREEN-LINE-ARRAY) (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY CURRENT-YPOS (- HEIGHT-IN-LINES N-LINES) SCREEN-LINE-ARRAY (+ CURRENT-YPOS N-LINES) HEIGHT-IN-LINES) (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY (- HEIGHT-IN-LINES N-LINES) HEIGHT-IN-LINES SCREEN-LINE-ARRAY CURRENT-YPOS (+ CURRENT-YPOS N-LINES)) (TV:SHEET-INSERT-LINE WINDOW N-LINES)))) (DEFUN REC-SUPDUP-DELETE-LINE (WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (LET ((N-LINES (NVT-NETI))) (COPY-ARRAY-CONTENTS SCREEN-LINE-ARRAY OLD-SCREEN-LINE-ARRAY) (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY (+ CURRENT-YPOS N-LINES) HEIGHT-IN-LINES SCREEN-LINE-ARRAY CURRENT-YPOS (- HEIGHT-IN-LINES N-LINES)) (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY CURRENT-YPOS (+ CURRENT-YPOS N-LINES) SCREEN-LINE-ARRAY (- HEIGHT-IN-LINES N-LINES) HEIGHT-IN-LINES) (LET ((CURRENT-YPOS (- HEIGHT-IN-LINES N-LINES)) (CURRENT-XPOS 0)) (REC-SUPDUP-EOF-1 WINDOW)) (TV:SHEET-DELETE-LINE WINDOW N-LINES)))) (DEFUN REC-SUPDUP-REGION-DOWN (WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (LET* ((REGION-HEIGHT (NVT-NETI)) (N-LINES (NVT-NETI)) (REGION-END (+ REGION-HEIGHT CURRENT-YPOS))) (LET ((CURRENT-YPOS (- REGION-END N-LINES)) (CURRENT-XPOS 0)) (REC-SUPDUP-EOF-1 WINDOW REGION-END)) (COPY-ARRAY-CONTENTS SCREEN-LINE-ARRAY OLD-SCREEN-LINE-ARRAY) (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY CURRENT-YPOS (- REGION-END N-LINES) SCREEN-LINE-ARRAY (+ CURRENT-YPOS N-LINES) REGION-END) (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY (- REGION-END N-LINES) REGION-END SCREEN-LINE-ARRAY CURRENT-YPOS (+ CURRENT-YPOS N-LINES)) (SUPDUP-REGION-DOWN WINDOW REGION-HEIGHT N-LINES)))) (DEFUN REC-SUPDUP-REGION-UP (WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (LET* ((REGION-HEIGHT (NVT-NETI)) (N-LINES (NVT-NETI)) (REGION-END (+ CURRENT-YPOS REGION-HEIGHT))) (COPY-ARRAY-CONTENTS SCREEN-LINE-ARRAY OLD-SCREEN-LINE-ARRAY) (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY (+ CURRENT-YPOS N-LINES) REGION-END SCREEN-LINE-ARRAY CURRENT-YPOS (- REGION-END N-LINES)) (COPY-ARRAY-PORTION OLD-SCREEN-LINE-ARRAY CURRENT-YPOS (+ CURRENT-YPOS N-LINES) SCREEN-LINE-ARRAY (- REGION-END N-LINES) REGION-END) (LET ((CURRENT-YPOS (- REGION-END N-LINES)) (CURRENT-XPOS 0)) (REC-SUPDUP-EOF-1 WINDOW REGION-END)) (SUPDUP-REGION-UP WINDOW REGION-HEIGHT N-LINES)))) (DEFUN REC-SUPDUP-INSERT-CHAR (WINDOW &OPTIONAL COUNT) (OR COUNT (SETQ COUNT (NVT-NETI))) (TV:SHEET-INSERT-CHAR WINDOW COUNT) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (LET ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))) (DO ((I (1- (ARRAY-LENGTH LINE)) (1- I))) ((< I CURRENT-XPOS)) (SETF (AREF LINE I) (IF (< (- I COUNT) CURRENT-XPOS) #\SPACE (AREF LINE (- I COUNT)))))))) (DEFUN REC-SUPDUP-DELETE-CHAR (WINDOW &OPTIONAL COUNT) (OR COUNT (SETQ COUNT (NVT-NETI))) (TV:SHEET-DELETE-CHAR WINDOW COUNT) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (LET ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))) (DO ((I CURRENT-XPOS (1+ I)) (END (ARRAY-LENGTH LINE))) ((= I END)) (SETF (AREF LINE I) (IF (>= (+ I COUNT) END) #\RETURN (AREF LINE (+ I COUNT)))))))) (DEFUN REC-SUPDUP-REDISPLAY (WINDOW) (TV:SHEET-CLEAR WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (DO ((I 0 (1+ I)) (END HEIGHT-IN-LINES) LINE-END) ((= I END)) (FUNCALL WINDOW ':SET-CURSORPOS 0 I ':CHARACTER) (SETQ LINE-END (STRING-REVERSE-SEARCH-NOT-CHAR #\RETURN (AREF SCREEN-LINE-ARRAY I))) (COND (LINE-END (COPY-ARRAY-PORTION (AREF SCREEN-LINE-ARRAY I) 0 (1+ LINE-END) REDISPLAY-STRING 0 (1+ LINE-END)) (SETF (ARRAY-LEADER REDISPLAY-STRING 0) (1+ LINE-END)) (DO ((XPOS 0 (1+ XPOS))) ((> XPOS LINE-END)) (LET ((CH (LOGAND 377 (AREF REDISPLAY-STRING XPOS)))) (AND (OR (= CH TAB-PLACEHOLDER) (= CH #\RETURN)) (SETF (AREF REDISPLAY-STRING XPOS) #\SPACE)))) (FUNCALL WINDOW ':STRING-OUT REDISPLAY-STRING)))) (FUNCALL WINDOW ':SET-CURSORPOS CURRENT-XPOS CURRENT-YPOS ':CHARACTER))) (DEFUN REC-SUPDUP-LINE-BEG-CONTINUED (WINDOW) WINDOW (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (SETF (SCREEN-LINE-BEG-CONTINUED CURRENT-YPOS) T))) (DEFUN REC-SUPDUP-LINE-END-CONTINUED (WINDOW) WINDOW (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (SETF (SCREEN-LINE-END-CONTINUED CURRENT-YPOS) T))) (DEFUN REC-SUPDUP-MULTI-POS-CHAR (WINDOW) WINDOW (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (SETQ MULTI-POS-CHAR-BEG CURRENT-XPOS) (SETQ MULTI-POS-CHAR-END (+ MULTI-POS-CHAR-BEG (NVT-NETI))) (NVT-NETI))) (DEFMETHOD (RECORDING-SUPDUP :ALLOW-LOCAL-EDITING) () NIL) (DEFMETHOD (RECORDING-SUPDUP :DEFINE-COMMAND) () (NVT-NETI) (NVT-NETI)) (DEFUN REC-SUPDUP-SAVE-LINES (WINDOW) WINDOW (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (LET ((N-LINES (NVT-NETI)) (LABEL (+ (NVT-NETI) (LSH (NVT-NETI) 7))) (HEIGHT (1+ HEIGHT-IN-LINES))) (DO ((I CURRENT-YPOS (1+ I)) (N N-LINES (1- N))) ((OR (= I HEIGHT) (<= N 0))) (LET ((LINE (AREF SCREEN-LINE-ARRAY I))) (OR (AREF SAVED-LINE-ARRAY LABEL) (SETF (AREF SAVED-LINE-ARRAY LABEL) (MAKE-ARRAY (ARRAY-LENGTH LINE) ':TYPE ART-STRING))) (FILLARRAY (AREF SAVED-LINE-ARRAY LABEL) '(#\RETURN)) (COPY-ARRAY-PORTION LINE FIRST-COL-TO-SAVE LAST-COL-TO-SAVE+1 (AREF SAVED-LINE-ARRAY LABEL) FIRST-COL-TO-SAVE LAST-COL-TO-SAVE+1)) (SETQ LABEL (LOGAND (1- LINE-LABEL-MAX) (1+ LABEL))))))) (DEFUN REC-SUPDUP-RESTORE-LINES (WINDOW) (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (LET ((N-LINES (NVT-NETI)) (LABEL (+ (NVT-NETI) (LSH (NVT-NETI) 7))) (HEIGHT (1+ HEIGHT-IN-LINES))) (DO ((I CURRENT-YPOS (1+ I)) (N N-LINES (1- N))) ((OR (= I HEIGHT) (<= N 0))) (LET ((LINE (AREF SCREEN-LINE-ARRAY I)) (SAVED-LINE (AREF SAVED-LINE-ARRAY LABEL)) LINE-END) (COND (SAVED-LINE (COPY-ARRAY-PORTION SAVED-LINE FIRST-COL-TO-SAVE LAST-COL-TO-SAVE+1 LINE FIRST-COL-TO-SAVE LAST-COL-TO-SAVE+1) ;; Output changes onto screen, unless now off-screen. (COND ((< I HEIGHT-IN-LINES) (FUNCALL WINDOW ':SET-CURSORPOS FIRST-COL-TO-SAVE I ':CHARACTER) (TV:SHEET-CLEAR-EOL WINDOW) (SETQ LINE-END (STRING-REVERSE-SEARCH-NOT-CHAR #\RETURN LINE)) (COND (LINE-END (COPY-ARRAY-PORTION (AREF SCREEN-LINE-ARRAY I) 0 (1+ LINE-END) REDISPLAY-STRING 0 (1+ LINE-END)) (SETF (ARRAY-LEADER REDISPLAY-STRING 0) (1+ LINE-END)) (DO ((XPOS 0 (1+ XPOS))) ((> XPOS LINE-END)) (LET ((CH (LOGAND 377 (AREF REDISPLAY-STRING XPOS)))) (AND (OR (= CH TAB-PLACEHOLDER) (= CH #\RETURN)) (SETF (AREF REDISPLAY-STRING XPOS) #\SPACE)))) (FUNCALL WINDOW ':STRING-OUT REDISPLAY-STRING)))))))) (SETQ LABEL (LOGAND (1- LINE-LABEL-MAX) (1+ LABEL)))) (FUNCALL WINDOW ':SET-CURSORPOS CURRENT-XPOS CURRENT-YPOS ':CHARACTER)))) (DEFUN REC-SUPDUP-SET-SAVING-RANGE (WINDOW) WINDOW (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (SETQ FIRST-COL-TO-SAVE (NVT-NETI)) (SETQ LAST-COL-TO-SAVE+1 (NVT-NETI)))) ;No need to support this until we support local handling ;of something that can move lines off the screen. ;But do pass by the arguments. (DEFUN REC-SUPDUP-SET-LOCAL-LABEL (WINDOW) WINDOW (DECLARE-FLAVOR-INSTANCE-VARIABLES (RECORDING-SUPDUP) (NVT-NETI) (NVT-NETI))) (DEFCONST TOP-BIT 4000) (DEFFLAVOR LOCAL-EDITING-SUPDUP (INPUT-CHAR-COUNT LAST-RESYNCH-CHAR-COUNT LAST-RESYNCH-CODE RESYNCH-REPLY-CODE RESYNCH-REPLY-CHAR-COUNT (SEND-RESYNCH-NOW NIL) (LOCAL-EDITING-ENABLE NIL) (LOCAL-EDIT-METER 0) (CHAR-TABLE (MAKE-ARRAY 2000)) (WORD-SYNTAX-TABLE (MAKE-ARRAY 200 ':TYPE ART-1B)) (TOP-EDITING-MARGIN 0) (BOTTOM-EDITING-MARGIN 0) (LEFT-EDITING-MARGIN 0) (RIGHT-EDITING-MARGIN 0) (INSERT-MODE 'INSERT)) (RECORDING-SUPDUP)) (DEFMETHOD (LOCAL-EDITING-SUPDUP :AFTER :SET-CONNECTION) (&REST IGNORE) (SETQ INPUT-CHAR-COUNT 0 LOCAL-EDIT-METER 0 LAST-RESYNCH-CODE NIL SEND-RESYNCH-NOW T ALLOW-LOCAL-EDITING NIL LOCAL-EDITING-ENABLE NIL)) (DEFVAR BEEP-ON-LOCAL-EDIT NIL) (DEFVAR INPUT-CHAR-IN-SUPDUP-CODE) ;Given a Lispm keyboard character to "send" to the server, ;first we consider processing it locally if that is enabled now. (DEFMETHOD (LOCAL-EDITING-SUPDUP :NET-OUTPUT-TRANSLATED) (CH) (COND ((LISTP CH) (FUNCALL-SELF ':NET-OUTPUT CH)) (T ;; If we aren't doing local echoing now, but could do it, ;; then send a resynch every so often, so that we are never ;; more than 200. or so input chars past a resynch ;; unless we are already local editing. ;; This is so that the #-chars-since-resynch in a %TDSYN ;; always fits in one character. ;; Send the resynch BEFORE the input char ;; so we don't pre-empt TECO output by mistake. (COND ((AND ALLOW-LOCAL-EDITING (NOT LOCAL-EDITING-ENABLE) (OR SEND-RESYNCH-NOW (> (- INPUT-CHAR-COUNT LAST-RESYNCH-CHAR-COUNT) 200.))) (FUNCALL-SELF ':NET-OUTPUT (+ TOP-BIT #/S)) (COND ((NULL LAST-RESYNCH-CODE) (SETQ LAST-RESYNCH-CODE 40)) ((= LAST-RESYNCH-CODE 176) (SETQ LAST-RESYNCH-CODE 40)) (T (INCF LAST-RESYNCH-CODE))) (FUNCALL-SELF ':NET-OUTPUT LAST-RESYNCH-CODE) (SETQ LAST-RESYNCH-CHAR-COUNT INPUT-CHAR-COUNT))) ;; Translate char to SUPDUP char set and send it. (LET* ((CHAR (LDB %%KBD-CHAR CH)) (INPUT-CHAR-IN-SUPDUP-CODE (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))))))) (AND LOCAL-EDITING-ENABLE (< INPUT-CHAR-IN-SUPDUP-CODE 1000) (IF (FUNCALL (OR (AREF CHAR-TABLE INPUT-CHAR-IN-SUPDUP-CODE) 'NOT-HANDLED) SELF INPUT-CHAR-IN-SUPDUP-CODE) ;; If char has just been echoed here, ;; tell the remote machine that it is a pre-echoed char. (PROGN (AND BEEP-ON-LOCAL-EDIT (BEEP)) (INCF LOCAL-EDIT-METER) (AND JOURNAL-STREAM (FUNCALL JOURNAL-STREAM ':STRING-OUT "L:")) (SETQ CURRENT-XPOS (// (- TV:CURSOR-X (TV:SHEET-INSIDE-LEFT SELF)) TV:CHAR-WIDTH) CURRENT-YPOS (// (- TV:CURSOR-Y (TV:SHEET-INSIDE-TOP SELF)) TV:LINE-HEIGHT)) (FUNCALL-SELF ':NET-OUTPUT (+ TOP-BIT #/E)) (FUNCALL-SELF ':NET-OUTPUT 1)) ;; Any char that can't be echoed here ;; turns off local echo. (SETQ LOCAL-EDITING-ENABLE NIL))) (FUNCALL-SELF ':NET-OUTPUT INPUT-CHAR-IN-SUPDUP-CODE) (AND JOURNAL-STREAM (FORMAT JOURNAL-STREAM "~C " CH))) (INCF INPUT-CHAR-COUNT)))) (DEFUN NOT-HANDLED (&REST IGNORE) NIL) ;When the remote machine decides we can do local editing, ;it sends us a %TDSYN based on the last resynch we sent. ;The output process comes here and tells the input process ;to go ahead and do local editing (LOCAL-EDITING-ENABLE <- T). ;Local editing stops when LOCAL-EDITING-ENABLE becomes NIL again. ;This can be because the input process sees something it can't handle locally, ;or it can be because more output arrives from the remote machine. ;In the latter case, we assume we are talking to a different program ;which does not understand the local editing protocol, so we turn ;off the use of it, until further notice is received. ;If we receive a resynch reply when we are not expecting one, ;or we get a mismatched reply, then we set flags to send another ;resynch in the hope of unconfusing the other side. (DEFUN L-E-SUPDUP-RESYNCH-REPLY-RECEIVED (WINDOW) WINDOW (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) (COND (ALLOW-LOCAL-EDITING (SETQ RESYNCH-REPLY-CODE (NVT-NETI) RESYNCH-REPLY-CHAR-COUNT (+ (NVT-NETI) LAST-RESYNCH-CHAR-COUNT)) (AND JOURNAL-STREAM (PRINC "Resynch: " JOURNAL-STREAM)) (IF (AND LAST-RESYNCH-CODE (= RESYNCH-REPLY-CODE LAST-RESYNCH-CODE) (= RESYNCH-REPLY-CHAR-COUNT INPUT-CHAR-COUNT)) (LET-GLOBALLY ((LOCAL-EDITING-ENABLE T)) (AND JOURNAL-STREAM (PRINC "Enable: " JOURNAL-STREAM)) (PROCESS-WAIT "LOCAL EDIT" #'(LAMBDA (LOC STREAM) (IF (OR (NOT (CDR LOC)) (LET ((CH (FUNCALL STREAM ':TYI-NO-HANG))) (AND CH (FUNCALL STREAM ':UNTYI CH)) CH)) T)) (FOLLOW-CELL-FORWARDING (VALUE-CELL-LOCATION LOCAL-EDITING-ENABLE) T) STREAM) (AND LOCAL-EDITING-ENABLE (SETQ ALLOW-LOCAL-EDITING NIL))) (PROGN (AND JOURNAL-STREAM (FORMAT JOURNAL-STREAM "~D ~D ~D ~D " LAST-RESYNCH-CODE RESYNCH-REPLY-CODE RESYNCH-REPLY-CHAR-COUNT INPUT-CHAR-COUNT)) (SETQ SEND-RESYNCH-NOW T)))) (T (NVT-NETI) (NVT-NETI) (FUNCALL WINDOW ':ALLOW-LOCAL-EDITING))))) ;This is where we process a %TDECO, which says that we should ;start attempting to use the local editing protocol ;by sending resynchs from time to time. (DEFUN L-E-SUPDUP-ALLOW-LOCAL-EDITING (WINDOW) (FUNCALL WINDOW ':ALLOW-LOCAL-EDITING)) (DEFUN L-E-SUPDUP-STOP-LOCAL-EDITING (WINDOW) (FUNCALL WINDOW ':STOP-LOCAL-EDITING)) (DEFMETHOD (LOCAL-EDITING-SUPDUP :ALLOW-LOCAL-EDITING) () (SETQ ALLOW-LOCAL-EDITING T) (SETQ SEND-RESYNCH-NOW T)) (DEFMETHOD (LOCAL-EDITING-SUPDUP :STOP-LOCAL-EDITING) () (SETQ ALLOW-LOCAL-EDITING NIL) (SETQ LOCAL-EDITING-ENABLE NIL)) (DEFMETHOD (LOCAL-EDITING-SUPDUP :GOBBLE-GREETING) () (SEND-TTY-VARIABLES STREAM SELF T) (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)))) ;Editing commands for local-editing-supdup. ;%TDEDF nn specifies what a certain character should do, for local editing. ;nn represents two 7-bit characters of information, which are merged into ;a 14-bit number, which is then divided into its top 5 bits (the function code) ;and its bottom 9 bits (which are the character, in SUPDUP code, whose ;meaning is being defined). ;These are the function codes: ; 0 -- random (no remote echo possible) ; 1 -- fwd char ; 2 -- back char ; 3 -- fwd delete ; 4 -- back delete ; 5 -- back char, no tabs ; 6 -- back delete, no tabs ; 7 -- self insert or replace ; 10 - vert. up. ; 11 - vert down. ; 12 - vert up, no tabs ; 13 - vert down, no tabs ; 14 - up to line beginning ; 15 - down to line beginning ; 16 - insert CRLF after point ; 17 - insert CRLF before point ; 20 - beg of line ; 21 - end of line ; 22 - equivalence to another character's definition. ;A char whose low 7 bits are lower case ;equivs to the corresponding upper case char. ;Any other char which has the control bit ;equivs to the char with bits 300 cleared out ;(control-I and control-Tab both go to Tab). ; 23 - fwd word ; 24 - back word ; 25 - fwd del word ; 26 - back del word ; 27 - arg digit ; 30 - begins arg, followed by digits ; 31 - specify word syntax of associated character. ;Since only 7-bit chars have a word syntax, the 200 bit is used ;to say what the syntax is: 1 means the character is a separator. ; 32 - specify insert vs replace for chars with definition code 7. ;The arg for this command (what is supplied as the "character ;to be defined") says what to do with all characters whose ;definition code is 7. ;An arg of 0 means they cannot be handled at all. ;An arg of 1 means they insert. 2 means they replace. ; 33 - reset all characters to an initial state: ;All characters 40 to 176 self-insert except l.c. letters, ;L.c. letters with any combination of control/meta are equivalenced, ;Digits with control and/or meta are are digits, ;All other characters defined as NIL. ;Syntax table: digits and letters (both cases) make up words. ;Insert mode. ;Margins all zero. ; 34 - specify right, left, top or bottom margin ;outside of which any text that appears is not text to be edited. ;The "ASCII character" is the margin value. ;The control/meta bits say which margin to set: ;0 - left 1 - top 2 - right 3 - bottom. (DEFVAR DEFINITION-CODE-TABLE (MAKE-ARRAY 40)) (FILLARRAY DEFINITION-CODE-TABLE `(NIL L-E-SUPDUP-FORWARD-CHAR L-E-SUPDUP-BACKWARD-CHAR L-E-SUPDUP-FORWARD-DELETE-CHAR L-E-SUPDUP-BACKWARD-DELETE-CHAR L-E-SUPDUP-BACKWARD-CHAR-NO-TABS L-E-SUPDUP-BACKWARD-DELETE-CHAR-NO-TABS L-E-SUPDUP-INSERT-CHAR NIL NIL ; L-E-SUPDUP-VERTICALLY-UP L-E-SUPDUP-VERTICALLY-DOWN NIL NIL ; L-E-SUPDUP-VERTICALLY-UP-NO-TABS L-E-SUPDUP-VERTICALLY-DOWN-NO-TABS NIL NIL ; L-E-SUPDUP-UP-TO-LINE-BEG L-E-SUPDUP-DOWN-TO-LINE-BEG NIL NIL ; L-E-SUPDUP-CRLF-AFTER-POINT L-E-SUPDUP-CRLF-BEFORE-POINT L-E-SUPDUP-BEG-OF-LINE L-E-SUPDUP-END-OF-LINE L-E-SUPDUP-EQUIVALENCE L-E-SUPDUP-FORWARD-WORD L-E-SUPDUP-BACKWARD-WORD L-E-SUPDUP-FORWARD-KILL-WORD L-E-SUPDUP-BACKWARD-KILL-WORD NIL NIL ; L-E-SUPDUP-ARG-DIGIT L-E-SUPDUP-ARG-STARTER (L-E-SUPDUP-SET-WORD-SYNTAX) (L-E-SUPDUP-SET-INSERT-MODE) (L-E-SUPDUP-INITIALIZE) (L-E-SUPDUP-SET-MARGIN) NIL)) (DEFUN L-E-SUPDUP-DEFINE-COMMAND (WINDOW) (FUNCALL WINDOW ':DEFINE-COMMAND-CHARACTER)) ;Process one %TDEDF. (DEFMETHOD (LOCAL-EDITING-SUPDUP :DEFINE-COMMAND-CHARACTER) () (LET* ((ARG (+ (LSH (NVT-NETI) 7) (NVT-NETI))) (CH (LDB 0011 ARG)) (CODE (LDB 1105 ARG)) (DEFN (AREF DEFINITION-CODE-TABLE CODE))) (IF (ATOM DEFN) (SETF (AREF CHAR-TABLE CH) DEFN) (FUNCALL (CAR DEFN) CH)))) (DEFUN L-E-SUPDUP-INITIALIZE (IGNORE) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) (FILLARRAY CHAR-TABLE '(NIL)) (DO ((I 40 (1+ I))) ((= I 177)) (SETF (AREF CHAR-TABLE I) 'L-E-SUPDUP-INSERT-CHAR)) (DO ((I #/a (1+ I))) ((> I #/z)) (SETF (AREF CHAR-TABLE I) 'L-E-SUPDUP-EQUIVALENCE) (SETF (AREF CHAR-TABLE (+ I 200)) 'L-E-SUPDUP-EQUIVALENCE) (SETF (AREF CHAR-TABLE (+ I 400)) 'L-E-SUPDUP-EQUIVALENCE) (SETF (AREF CHAR-TABLE (+ I 600)) 'L-E-SUPDUP-EQUIVALENCE)) ; (DO ((I #/0 (1+ I))) ; ((> I #/9)) ; (SETF (AREF CHAR-TABLE (+ I 200)) 'L-E-SUPDUP-ARG-DIGIT) ; (SETF (AREF CHAR-TABLE (+ I 400)) 'L-E-SUPDUP-ARG-DIGIT) ; (SETF (AREF CHAR-TABLE (+ I 600)) 'L-E-SUPDUP-ARG-DIGIT)) (FILLARRAY WORD-SYNTAX-TABLE '(0)) (DO ((I #/A (1+ I))) ((> I #/Z)) (SETF (AREF WORD-SYNTAX-TABLE I) 1) (SETF (AREF WORD-SYNTAX-TABLE (+ I 40)) 1)) (DO ((I #/0 (1+ I))) ((> I #/9)) (SETF (AREF WORD-SYNTAX-TABLE I) 1)) (SETQ INSERT-MODE 'INSERT) (SETQ LEFT-EDITING-MARGIN 0 TOP-EDITING-MARGIN 0 RIGHT-EDITING-MARGIN 0 BOTTOM-EDITING-MARGIN 0))) (DEFUN L-E-SUPDUP-SET-WORD-SYNTAX (CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) (SETF (AREF WORD-SYNTAX-TABLE (LDB 0007 CH)) (LDB 0701 CH)))) (DEFUN L-E-SUPDUP-SET-INSERT-MODE (CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) (SETQ INSERT-MODE (SELECTQ CH (1 'INSERT) (2 'REPLACE))))) (DEFUN L-E-SUPDUP-SET-MARGIN (CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) (SET (NTH (LDB 0702 CH) '(LEFT-EDITING-MARGIN TOP-EDITING-MARGIN RIGHT-EDITING-MARGIN BOTTOM-EDITING-MARGIN)) (LDB 0007 CH)))) ;Return T if there is a tab in the current line after the cursor. (DEFUN L-E-SUPDUP-TAB-CHECK () (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) (LET ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))) (%STRING-SEARCH-CHAR TAB-PLACEHOLDER LINE CURRENT-XPOS (ARRAY-LENGTH LINE))))) (DEFUN L-E-SUPDUP-FORWARD-CHAR (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) CH (LET ((BUFFER-CHAR (AREF (AREF SCREEN-LINE-ARRAY CURRENT-YPOS) CURRENT-XPOS))) (IF (>= CURRENT-XPOS (- (ARRAY-LENGTH (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)) 1 RIGHT-EDITING-MARGIN)) NIL (IF (LDB-TEST 1010 BUFFER-CHAR) NIL (SELECT BUFFER-CHAR (#\RETURN NIL) (TAB-PLACEHOLDER NIL) ;a tab. (T (FUNCALL WINDOW ':SET-CURSORPOS (1+ CURRENT-XPOS) CURRENT-YPOS ':CHARACTER) T))))))) (DEFUN L-E-SUPDUP-BACKWARD-CHAR-NO-TABS (WINDOW CH) (L-E-SUPDUP-BACKWARD-CHAR WINDOW CH T)) (DEFUN L-E-SUPDUP-BACKWARD-CHAR (WINDOW CH &OPTIONAL NO-TABS) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) CH (COND ((<= CURRENT-XPOS LEFT-EDITING-MARGIN) NIL) (T (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)) (PREV-CHAR (AREF LINE (- CURRENT-XPOS 1)))) (COND ((LDB-TEST 1010 PREV-CHAR) NIL) ((AND (NOT NO-TABS) (= PREV-CHAR TAB-PLACEHOLDER)) NIL) (T (FUNCALL WINDOW ':SET-CURSORPOS (1- CURRENT-XPOS) CURRENT-YPOS ':CHARACTER)))))))) (DEFUN L-E-SUPDUP-FORWARD-DELETE-CHAR (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) CH (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)) (BUFFER-CHAR (AREF LINE CURRENT-XPOS))) (IF (LDB-TEST 1010 BUFFER-CHAR) NIL (SELECT BUFFER-CHAR (#\RETURN NIL) (TAB-PLACEHOLDER NIL) ;a tab. (T (COND ((SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL) ((L-E-SUPDUP-TAB-CHECK) NIL) (T (REC-SUPDUP-DELETE-CHAR WINDOW 1) T)))))))) (DEFUN L-E-SUPDUP-BACKWARD-DELETE-CHAR-NO-TABS (WINDOW CH) (L-E-SUPDUP-BACKWARD-DELETE-CHAR WINDOW CH T)) (DEFUN L-E-SUPDUP-BACKWARD-DELETE-CHAR (WINDOW CH &OPTIONAL NO-TABS) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) CH (COND ((<= CURRENT-XPOS LEFT-EDITING-MARGIN) NIL) ((L-E-SUPDUP-TAB-CHECK) NIL) ((SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL) (T (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)) (PREV-CHAR (IF (AND (= CURRENT-XPOS (1+ LEFT-EDITING-MARGIN)) (SCREEN-LINE-BEG-CONTINUED CURRENT-YPOS)) -1 (AREF LINE (- CURRENT-XPOS 1))))) (COND ((LDB-TEST 1010 PREV-CHAR) NIL) ((AND (NOT NO-TABS) (= PREV-CHAR TAB-PLACEHOLDER)) NIL) (T (FUNCALL WINDOW ':SET-CURSORPOS (SETQ CURRENT-XPOS (1- CURRENT-XPOS)) CURRENT-YPOS ':CHARACTER) (REC-SUPDUP-DELETE-CHAR WINDOW 1) T))))))) (DEFUN L-E-SUPDUP-INSERT-CHAR (WINDOW IGNORE &AUX CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) (SETQ CH (LOGAND 177 INPUT-CHAR-IN-SUPDUP-CODE)) (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)) (END-XPOS (1+ (OR (STRING-REVERSE-SEARCH-NOT-CHAR #\RETURN LINE) -1)))) (COND ((SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL) ((= END-XPOS (- (ARRAY-LENGTH LINE) 1)) NIL) ((NULL INSERT-MODE) NIL) ((L-E-SUPDUP-TAB-CHECK) NIL) ((OR (EQ INSERT-MODE 'INSERT) (= END-XPOS CURRENT-XPOS)) (REC-SUPDUP-INSERT-CHAR WINDOW 1) (FUNCALL WINDOW ':BUFFERED-TYO CH) (FUNCALL WINDOW ':FORCE-OUTPUT) T) ((NOT (LDB-TEST 1010 (AREF LINE CURRENT-XPOS))) (REC-SUPDUP-DLF WINDOW) (FUNCALL WINDOW ':BUFFERED-TYO CH) (FUNCALL WINDOW ':FORCE-OUTPUT) T))))) (DEFUN L-E-SUPDUP-BEG-OF-LINE (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) CH (COND ((ZEROP CURRENT-YPOS) NIL) ((SCREEN-LINE-BEG-CONTINUED CURRENT-YPOS) NIL) (T (FUNCALL WINDOW ':SET-CURSORPOS 0 CURRENT-YPOS ':CHARACTER) T)))) (DEFUN L-E-SUPDUP-END-OF-LINE (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) CH (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)) (END-XPOS (OR (STRING-REVERSE-SEARCH-NOT-CHAR #\RETURN LINE) -1))) (COND ((SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL) (T (FUNCALL WINDOW ':SET-CURSORPOS (1+ END-XPOS) CURRENT-YPOS ':CHARACTER) T))))) (DEFUN L-E-SUPDUP-EQUIVALENCE (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) (PROG (NEW-CH) (COND ((= (LOGAND CH 140) 140) (SETQ NEW-CH (LOGXOR CH 40))) ;; If control bit is present, clear it and also alphabetic bit. ((= (LOGAND CH 200) 200) (SETQ NEW-CH (LOGAND CH 477))) (T (RETURN NIL))) (RETURN (FUNCALL (OR (AREF CHAR-TABLE NEW-CH) 'NOT-HANDLED) WINDOW NEW-CH))))) (DEFUN L-E-SUPDUP-FORWARD-WORD (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) CH (LET (FOUND-WORD (LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS))) (DO ((I CURRENT-XPOS (1+ I)) (END (IF (SCREEN-LINE-END-CONTINUED CURRENT-YPOS) (1- (ARRAY-LENGTH LINE)) (ARRAY-LENGTH LINE)))) ((= I END) NIL) (LET ((CHAR (AREF LINE I))) (COND ((LDB-TEST 1010 CHAR) (RETURN NIL)) ((NOT (ZEROP (AREF WORD-SYNTAX-TABLE (SETQ CHAR (LDB 0007 CHAR))))) (SETQ FOUND-WORD T)) ;; Is this a separator reached after we passed a word? (FOUND-WORD (FUNCALL WINDOW ':SET-CURSORPOS I CURRENT-YPOS ':CHARACTER) (RETURN T)))))))) (DEFUN L-E-SUPDUP-BACKWARD-WORD (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) CH (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)) FOUND-WORD) (DO ((I CURRENT-XPOS (1- I))) ((= I 0) ;; If we reach the beginning of the line, ;; that is a fine stopping place for the word ;; as long as the previous lineis not continued. (AND (NOT (SCREEN-LINE-BEG-CONTINUED CURRENT-YPOS)) FOUND-WORD (PROGN (FUNCALL WINDOW ':SET-CURSORPOS 0 CURRENT-YPOS ':CHARACTER) T))) (AND (LDB-TEST 1010 (AREF LINE (1- I))) (RETURN NIL)) (COND ((NOT (ZEROP (AREF WORD-SYNTAX-TABLE (LDB 0007 (AREF LINE (1- I)))))) (SETQ FOUND-WORD T)) (FOUND-WORD (FUNCALL WINDOW ':SET-CURSORPOS I CURRENT-YPOS ':CHARACTER) (RETURN T))))))) (DEFUN L-E-SUPDUP-FORWARD-KILL-WORD (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) CH (LET* (FOUND-WORD (LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)) (END (ARRAY-LENGTH LINE))) (COND ((SCREEN-LINE-END-CONTINUED CURRENT-YPOS) NIL) ((L-E-SUPDUP-TAB-CHECK) NIL) (T (DO ((I CURRENT-XPOS (1+ I))) ((= I END) NIL) (LET ((CHAR (AREF LINE I))) (COND ((LDB-TEST 1010 CHAR) (RETURN NIL)) ((NOT (ZEROP (AREF WORD-SYNTAX-TABLE (SETQ CHAR (LDB 0007 CHAR))))) (SETQ FOUND-WORD T)) ;; Is this a separator reached after we passed a word? (FOUND-WORD (REC-SUPDUP-DELETE-CHAR WINDOW (- I CURRENT-XPOS)) (RETURN T)))))))))) (DEFUN L-E-SUPDUP-BACKWARD-KILL-WORD (WINDOW CH) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LOCAL-EDITING-SUPDUP) CH (LET* ((LINE (AREF SCREEN-LINE-ARRAY CURRENT-YPOS)) (OLD-XPOS CURRENT-XPOS) FOUND-WORD) (AND (NOT (SCREEN-LINE-END-CONTINUED CURRENT-YPOS)) (NOT (L-E-SUPDUP-TAB-CHECK)) (DO ((I CURRENT-XPOS (1- I))) ((= I 0) ;; If we reach the beginning of the line, ;; that is a fine stopping place for the word ;; as long as the previous lineis not continued. (AND (> CURRENT-YPOS 0) (NOT (SCREEN-LINE-BEG-CONTINUED CURRENT-YPOS)) FOUND-WORD (PROGN (FUNCALL WINDOW ':SET-CURSORPOS 0 CURRENT-YPOS ':CHARACTER) (SETQ CURRENT-XPOS 0) (REC-SUPDUP-DELETE-CHAR WINDOW OLD-XPOS) T))) (AND (LDB-TEST 1010 (AREF LINE (1- I))) (RETURN NIL)) (COND ((NOT (ZEROP (AREF WORD-SYNTAX-TABLE (LDB 0007 (AREF LINE (1- I)))))) (SETQ FOUND-WORD T)) (FOUND-WORD (LET ((OLD-XPOS CURRENT-XPOS)) (FUNCALL WINDOW ':SET-CURSORPOS I CURRENT-YPOS ':CHARACTER) (SETQ CURRENT-XPOS I) (REC-SUPDUP-DELETE-CHAR WINDOW (- OLD-XPOS I))) (RETURN T)))))))) (DEFFLAVOR BASIC-TELNET ((NEW-TELNET-P NIL) (MORE-FLAG NIL) (ECHO-FLAG NIL) (SIMULATE-IMLAC-FLAG NIL) (BINARY-OUTPUT-FLAG NIL) (SUPDUP-OUTPUT-FLAG NIL)) (BASIC-NVT TV:LIST-MOUSE-BUTTONS-MIXIN) (:DEFAULT-INIT-PLIST :PROGRAM-NAME "Telnet") (: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)) (USING-RESOURCE (BIT-ARRAY TV:BIT-ARRAYS) (USING-RESOURCE (TP TYPEOUT-PROCESSES) (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 'SYS:COMMAND-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) &AUX CONN) (MULTIPLE-VALUE-BIND (HOST GATEWAY CONTACT CONTACT-P) (PARSE-PATH PATH "TELNET" 27) (SETQ CONN (FUNCALL-SELF ':NEW-CONNECTION "Telnet" HOST GATEWAY CONTACT CONTACT-P NET-WINDOW))) (IF (STRINGP CONN) ;; Lose, return "error code". CONN ;; Win, request remote echoing. (TELNET-ECHO T))) (DEFMETHOD (BASIC-TELNET :GOBBLE-GREETING) () (TERPRI SELF)) (DEFMETHOD (BASIC-TELNET :AFTER :DISCONNECT) () (SETQ ECHO-FLAG NIL NEW-TELNET-P NIL SUPDUP-OUTPUT-FLAG NIL BINARY-OUTPUT-FLAG 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 :NET-OUTPUT-TRANSLATED) (CH) (COND ((LISTP CH) (SELECTQ (FIRST CH) (:MOUSE-BUTTON (IF SUPDUP-OUTPUT-FLAG (MOUSE-OUT (FOURTH CH) (FIFTH CH) (SECOND CH)))) (OTHERWISE (FUNCALL-SELF ':NET-OUTPUT CH)))) ((= CH #\ESC) (TV:KBD-ESC) NIL) (T (LET ((CHAR (LDB %%KBD-CHAR CH))) (COND ((NOT ECHO-FLAG) ;; Echo the character. (IF (LDB-TEST %%KBD-CONTROL CH) (FUNCALL SELF ':TYO #/ )) (FUNCALL SELF ':TYO CHAR))) (COND ((AND SUPDUP-OUTPUT-FLAG (= CHAR #\END)) (FUNCALL-SELF ':NET-OUTPUT 30) ;control X (FUNCALL-SELF ':NET-OUTPUT 23)) ;control S (T (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))) (FUNCALL-SELF ':NET-OUTPUT CHAR))))))) (DEFCONST NVT-IP 364) (DEFCONST NVT-DM 362) (DEFCONST NVT-IAC 377) (DEFCONST NVT-DONT 376) (DEFCONST NVT-DO 375) (DEFCONST NVT-WONT 374) (DEFCONST NVT-WILL 373) (DEFCONST NVT-SUBNEGOTIATION-BEGIN 372) (DEFCONST NVT-SUBNEGOTIATION-END 360) (DEFCONST NVT-SUPDUP-OUTPUT 26) (DEFCONST NVT-TIMING-MARK 6) (DEFCONST NVT-SUPPRESS-GO-AHEAD 3) (DEFCONST NVT-ECHO 1) (DEFCONST NVT-TRANSMIT-BINARY 0) (DEFCONST 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 ((AND (= CH 7) (NOT (AND SIMULATE-IMLAC-FLAG BINARY-OUTPUT-FLAG))) (FUNCALL-SELF ':REMOTE-BEEP)) ;^G rings the bell. ((AND (= CH 15) (IF (= (SETQ CH1 (NVT-NETI)) 12) ;CR LF is NVT newline "character" NIL ;Output normally ;; A CR not followed by a LF. Move the "carriage" to the start of the ;; current line. Then if the next character is anything other than a NUL, ;; assume the other end if not obeying protocol and output it too. (FUNCALL-SELF ':FORCE-OUTPUT) (MULTIPLE-VALUE-BIND (IGNORE Y) (FUNCALL-SELF ':READ-CURSORPOS) (FUNCALL-SELF ':SET-CURSORPOS 0 Y)) (= (SETQ CH CH1) 0)))) ;If NUL, skip any output ((AND (= CH 177) SIMULATE-IMLAC-FLAG) ;Escape character (FUNCALL-SELF ':HANDLE-IMLAC-ESCAPE)) (T (AND ( CH 10) ( CH 15) ( CH 13) ;Convert formatting controls (NOT (AND SIMULATE-IMLAC-FLAG BINARY-OUTPUT-FLAG)) (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 T)) (NVT-SUPPRESS-GO-AHEAD) ;ignore things we requested (NVT-TRANSMIT-BINARY (SETQ BINARY-OUTPUT-FLAG T) (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 NIL)) ((OR (= OPTION NVT-SUPPRESS-GO-AHEAD) (= OPTION NVT-TIMING-MARK) (= OPTION NVT-TRANSMIT-BINARY)) (TELNET-SEND-OPTION NVT-WILL OPTION)) (T (TELNET-SEND-OPTION NVT-WONT OPTION)))) (NVT-DONT (COND ((= OPTION NVT-ECHO) (TELNET-ECHO T)) ((= OPTION NVT-TRANSMIT-BINARY) (TELNET-SEND-OPTION NVT-WONT OPTION)))) (NVT-WONT (COND ((= OPTION NVT-ECHO) (TELNET-ECHO NIL)) ((= OPTION NVT-TRANSMIT-BINARY) (SETQ BINARY-OUTPUT-FLAG NIL) (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)))) ;;; Set our idea of who is echoing, and send a DO or DONT, ;;; unless the state is already this way. ;;; The argument to TELNET-ECHO is the new value of ECHO-FLAG, ;;; which is NIL for local echo (the official default) and T for remote echo. ;;; So (TELNET-ECHO T) means that we want remote echoing. (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-DONT) 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 () (SETQ SUPDUP-OUTPUT-FLAG T) (LOCK-OUTPUT (FUNCALL STREAM ':TYO NVT-IAC) (FUNCALL STREAM ':TYO NVT-SUBNEGOTIATION-BEGIN) (FUNCALL STREAM ':TYO NVT-SUPDUP-OUTPUT) (FUNCALL STREAM ':TYO 1) (LET ((SUPDUP-%TOCID T)) (SEND-TTY-VARIABLES STREAM SELF NIL)) (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"))) (FUNCALL #'(:METHOD BASIC-SUPDUP :BUFFERED-TYO) ':BUFFERED-TYO (NVT-NETI))))) (DEFMETHOD (BASIC-TELNET :WHO-LINE-DOCUMENTATION-STRING) () (IF SUPDUP-OUTPUT-FLAG "Left: Move point. Middle: Select buffer. Right: Get buffer editor." "")) (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET) (DEFUN MOUSE-OUT (X Y BUTTONS) (FUNCALL-SELF ':NET-OUTPUT 33) (MOUSE-COORD-OUT (// X TV:CHAR-WIDTH)) (MOUSE-COORD-OUT (// Y TV:LINE-HEIGHT)) (FUNCALL-SELF ':NET-OUTPUT (+ (1+ (LDB 0003 BUTTONS)) (IF (NOT (ZEROP (LDB 0303 BUTTONS))) 1 0) #/0)) (FUNCALL-SELF ':NET-OUTPUT 33) (FUNCALL-SELF ':NET-OUTPUT 12)) ) (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET) (DEFUN MOUSE-COORD-OUT (N) (FUNCALL-SELF ':NET-OUTPUT (+ #/0 (// N 100.))) (SETQ N (\ N 100.)) (FUNCALL-SELF ':NET-OUTPUT (+ #/0 (// N 10.))) (SETQ N (\ N 10.)) (FUNCALL-SELF ':NET-OUTPUT (+ #/0 N))) ) (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 ':ALLOW-ESCAPE) (FUNCALL-SELF ':TYI) (SETQ MORE-FLAG NIL)))) (DEFMETHOD (BASIC-TELNET :SEND-IP) () ;; Send a New Telnet "Interrupt Process". (LOCK-OUTPUT (FUNCALL STREAM ':FORCE-OUTPUT) (LET* ((PKT (CHAOS:GET-PKT)) (STRING (CHAOS:PKT-STRING PKT))) ;; Send a Chaosnet packet with opcode 201 to the ARPA server. This ;; opcode is magic, and means to send a network host-to-host interrupt ;; before sending the data in the packet. We also put a New Telnet ;; "Data Mark" into the packet. (ASET NVT-IAC STRING 0) (ASET NVT-IP STRING 1) (ASET NVT-IAC STRING 2) (ASET NVT-DM STRING 3) (SETF (CHAOS:PKT-NBYTES PKT) 4) (CHAOS:SEND-PKT CONNECTION PKT 201)))) (COMMENT ;; assumes instance vars LINE-EDITOR-BUFFER (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-NVT) (DEFMETHOD READLINE-FOR-NVT () (COND ((NOT RUBOUT-HANDLER) ;;Stream with rubouts assumed not to have EOFs (FUNCALL STREAM ':RUBOUT-HANDLER '() (FUNCTION READLINE-FOR-NVT) SELF)) ;; Accumulate a string until CR, ignoring control characters (T (DO ((IDX 0) (LEN (ARRAY-ACTIVE-LENGTH LINE-EDITOR-BUFFER)) (CH)) (NIL) (SETQ CH (FUNCALL SELF ':TYI)) (COND ((OR (NULL CH) (= CH #\CR)) (RETURN NIL)) ((LDB-TEST %%KBD-CONTROL-META CH) ) ;Ignore controls (T (AND (= IDX LEN) (ADJUST-ARRAY-SIZE LINE-EDITOR-BUFFER (SETQ LEN (+ LEN 100)))) (ASET CH LINE-EDITOR-BUFFER IDX) (SETQ IDX (1+ IDX)))))))) ) );end COMMENT (COMPILE-FLAVOR-METHODS SUPDUP TELNET LOCAL-EDITING-SUPDUP) ;;; Always have at least one supdup window in the world (OR SUPDUP-WINDOWS (TV:WITHOUT-SCREEN-MANAGEMENT (FUNCALL (TV:WINDOW-CREATE SUPDUP-FLAVOR) ':ACTIVATE)))