root/trunk/lisp/lmwin/supdup.lisp @ 222

Revision 222, 44.3 KB (checked in by rjs, 3 years ago)

Update.

Line 
1;;;Windows that hack the network -*- Mode:LISP; Package:SUPDUP -*-
2
3(DEFFLAVOR BUFFERED-OUTPUT-MIXIN ((OUTPUT-BUFFER (MAKE-ARRAY NIL 'ART-STRING 200 NIL '(0))))
4                           ()
5  (:REQUIRED-METHODS :BUFFERED-TYO))
6
7(DEFMETHOD (BUFFERED-OUTPUT-MIXIN :BUFFERED-TYO) (CH)
8  (DO () ((ARRAY-PUSH OUTPUT-BUFFER CH))
9    (FUNCALL-SELF ':FORCE-OUTPUT)))
10
11(DEFMETHOD (BUFFERED-OUTPUT-MIXIN :FORCE-OUTPUT) ()
12  (TV:SHEET-STRING-OUT SELF OUTPUT-BUFFER)
13  (STORE-ARRAY-LEADER 0 OUTPUT-BUFFER 0))
14
15(DEFFLAVOR BASIC-NVT
16           ((ESCAPE-CHAR #\BREAK)       ;Escape character (in Lisp machine character set)
17            (CONNECTION NIL)            ;The connection itself
18            (CONNECT-TO NIL)            ;Host to connect to (for TYPEIN-TOP-LEVEL)
19            STREAM                      ;A stream to the above
20            (TERMINAL-STREAM NIL)       ;Stream for output. If NIL, (which is the usual case)
21                                        ; output to SELF.
22            (TYPEOUT-PROCESS NIL)       ;Network screen
23            (TYPEIN-PROCESS NIL)        ;Keyboard network
24            (OUTPUT-LOCK NIL)           ;Some typeout occurs in TYPEIN-PROCESS
25            (RETURN-TO-CALLER NIL)      ;Set to T when :TYPEIN-TOP-LEVEL should return
26            ORDINARY-IO-BUFFER          ;Lisp machine character set
27            NVT-IO-BUFFER)              ;Special character set and turns off CALL key
28            (BUFFERED-OUTPUT-MIXIN TV:ANY-TYI-MIXIN)
29  (:INCLUDED-FLAVORS TV:LABEL-MIXIN TV:STREAM-MIXIN)
30  (:GETTABLE-INSTANCE-VARIABLES CONNECTION STREAM)
31  (:INITABLE-INSTANCE-VARIABLES ESCAPE-CHAR TYPEIN-PROCESS TYPEOUT-PROCESS)
32  (:SETTABLE-INSTANCE-VARIABLES CONNECT-TO TERMINAL-STREAM)
33  (:REQUIRED-METHODS :CONNECT :GOBBLE-GREETING :TRANSLATE-INPUT-CHAR :NET-OUTPUT)
34  (:DOCUMENTATION :SPECIAL-PURPOSE "Network virtual terminal windows"))
35
36(DEFMACRO LOCK-OUTPUT BODY
37  `(UNWIND-PROTECT
38     (PROGN
39       (PROCESS-LOCK (LOCATE-IN-INSTANCE SELF 'OUTPUT-LOCK))
40       . ,BODY)
41     (COND ((EQ CURRENT-PROCESS OUTPUT-LOCK)
42            (PROCESS-UNLOCK (LOCATE-IN-INSTANCE SELF 'OUTPUT-LOCK))))))
43
44;The following is just like TV:PROCESS-MIXIN except that there are two processes
45;Also we have to provide for the two I/O buffers
46(DEFMETHOD (BASIC-NVT :AFTER :INIT) (IGNORE)
47  (SETQ ORDINARY-IO-BUFFER TV:IO-BUFFER
48        NVT-IO-BUFFER (TV:MAKE-IO-BUFFER 100 NIL NIL))
49  (PUTPROP (LOCF (TV:IO-BUFFER-PLIST NVT-IO-BUFFER)) T ':SUPER-IMAGE)
50  (OR TYPEOUT-PROCESS
51      (SETQ TYPEOUT-PROCESS (PROCESS-CREATE (STRING-APPEND TV:NAME "-Typeout")
52                                            ':SPECIAL-PDL-SIZE 2000.)))
53  (COND ((NULL TYPEIN-PROCESS)
54         (SETQ TYPEIN-PROCESS (PROCESS-CREATE (STRING-APPEND TV:NAME "-Typein")
55                                              ':SPECIAL-PDL-SIZE 2000.))
56         (PROCESS-PRESET TYPEIN-PROCESS 'TYPEIN-TOP-LEVEL SELF)))
57  (PROCESS-PRESET TYPEOUT-PROCESS SELF ':TYPEOUT-TOP-LEVEL))
58
59;Delay starting up processes until they start to get used, to save paging on cold-boot
60(DEFMETHOD (BASIC-NVT :BEFORE :SELECT) (&REST IGNORE)
61  (MAYBE-RESET-PROCESS TYPEIN-PROCESS)
62  (MAYBE-RESET-PROCESS TYPEOUT-PROCESS))
63
64(DEFUN MAYBE-RESET-PROCESS (PROCESS)
65  (COND ((AND PROCESS (TYPEP PROCESS 'SI:PROCESS))
66         (AND (EQ (PROCESS-WAIT-FUNCTION PROCESS) #'FALSE)
67              (FUNCALL PROCESS ':RESET))
68         (FUNCALL PROCESS ':RUN-REASON SELF))))
69
70;Don't kill the process until all methods
71;and wrappers have run first.  This is because we might be
72;executing inside the process that belongs to the window,
73;and we don't want to go away before finishing.
74(DEFWRAPPER (BASIC-NVT :KILL) (() . BODY)
75  `(PROGN ,@BODY
76          (AND TYPEIN-PROCESS (FUNCALL TYPEIN-PROCESS ':KILL))
77          (AND TYPEOUT-PROCESS (FUNCALL TYPEOUT-PROCESS ':KILL))))
78
79(DEFMETHOD (BASIC-NVT :CONNECTED-P) ()
80  (AND CONNECTION (EQ (CHAOS:STATE CONNECTION) 'CHAOS:OPEN-STATE)))
81
82(DEFMETHOD (BASIC-NVT :BEFORE :CONNECT) (&REST IGNORE)
83  (FUNCALL-SELF ':DISCONNECT))
84
85(DEFMETHOD (BASIC-NVT :AFTER :SET-CONNECT-TO) (&REST IGNORE)
86  (AND TYPEIN-PROCESS (FUNCALL TYPEIN-PROCESS ':RESET)))
87
88(DEFMETHOD (BASIC-NVT :NEW-CONNECTION) (PATH WINDOW CONTACT-NAME ARPA-SOCKET
89                                        &AUX LABEL-SPEC CONN)
90  (MULTIPLE-VALUE (PATH CONTACT-NAME LABEL-SPEC)
91    (PARSE-PATH PATH CONTACT-NAME ARPA-SOCKET))
92  (SETQ CONN (CHAOS:CONNECT PATH CONTACT-NAME WINDOW))
93  (IF (STRINGP CONN) CONN
94      (FUNCALL-SELF ':SET-LABEL LABEL-SPEC)
95      (FUNCALL-SELF ':SET-CONNECTION CONN)))
96
97;;;Parse the user's pathname, returns chaosnet host, contact name, and label spec
98(DEFUN PARSE-PATH (PATH CONTACT-NAME ARPA-SOCKET &AUX BRIDGE CNAME LSPEC)
99  (AND (NUMBERP PATH) (SETQ PATH (CHAOS:HOST-DATA PATH)))
100  (AND PATH (SYMBOLP PATH) (SETQ PATH (GET-PNAME PATH)))
101  (COND ((NULL PATH)
102         (SETQ PATH "AI"))
103        ((NUMBERP PATH))
104        (T
105         (AND (SETQ BRIDGE (STRING-SEARCH-CHAR #/ PATH))
106              (PSETQ PATH (SUBSTRING PATH (1+ BRIDGE))
107                     BRIDGE (SUBSTRING PATH 0 BRIDGE)))
108         (COND ((NOT (ASSOC (OR BRIDGE PATH) CHAOS:HOST-ALIST))
109                (AND BRIDGE (SETQ CNAME PATH
110                                  PATH BRIDGE))
111                (SETQ BRIDGE "AI"))
112               ((SETQ CNAME (STRING-SEARCH-CHAR #/ PATH))
113                (PSETQ CNAME (SUBSTRING PATH (1+ CNAME))
114                       PATH (SUBSTRING PATH 0 CNAME))))))
115  (IF (NULL BRIDGE)
116      (SETQ LSPEC PATH
117            BRIDGE PATH
118            PATH (OR CNAME CONTACT-NAME))
119      (SETQ LSPEC (STRING-APPEND BRIDGE " " PATH)
120            PATH (FORMAT NIL "ARPA ~A ~:[~O~*~;~*~A~]" PATH CNAME ARPA-SOCKET CNAME)))
121  (PROG () (RETURN BRIDGE PATH (STRING-APPEND CONTACT-NAME " -- " LSPEC))))
122
123(DEFMETHOD (BASIC-NVT :SET-CONNECTION) (NEW-CONNECTION)
124  (FUNCALL TYPEIN-PROCESS ':FLUSH)
125  (FUNCALL TYPEOUT-PROCESS ':FLUSH)
126  (SETQ CONNECTION NEW-CONNECTION)
127  (SETQ STREAM (CHAOS:STREAM CONNECTION))
128  (FUNCALL-SELF ':GOBBLE-GREETING)
129  (FUNCALL TYPEIN-PROCESS ':RESET)
130  (FUNCALL TYPEOUT-PROCESS ':RESET))
131
132(DEFMETHOD (BASIC-NVT :DISCONNECT) ()
133  (FUNCALL TYPEIN-PROCESS ':FLUSH)
134  (FUNCALL TYPEOUT-PROCESS ':FLUSH)
135  (COND (CONNECTION
136         (CHAOS:CLOSE CONNECTION)
137         (CHAOS:REMOVE-CONN CONNECTION)
138         (SETQ CONNECTION NIL)))
139  (FUNCALL TYPEIN-PROCESS ':RESET)
140  (FUNCALL TYPEOUT-PROCESS ':RESET))
141
142;;;This is the typein process
143(DEFUN TYPEIN-TOP-LEVEL (WINDOW)
144  (DO () (())
145    (FUNCALL WINDOW ':TYPEIN-TOP-LEVEL)
146    (TV:DELAYING-SCREEN-MANAGEMENT
147      (FUNCALL WINDOW ':DESELECT T)
148      (FUNCALL WINDOW ':BURY))))
149
150(DEFMETHOD (BASIC-NVT :TYPEIN-TOP-LEVEL) (&OPTIONAL (TOP-LEVEL-P T) &AUX (TERMINAL-IO SELF))
151  (DO ((STR NIL NIL)) (NIL)
152    (SETQ RETURN-TO-CALLER NIL)
153    (*CATCH (IF TOP-LEVEL-P 'SI:TOP-LEVEL 'THIS-TAG-WILL-NEVER-GET-THROWN-TO)
154      (CONDITION-BIND ((CHAOS:READ-ON-LOS-CONNECTION NET-ERROR)
155                       (CHAOS:HOST-DOWN NET-ERROR))
156        (SETQ STR
157              (IF CONNECTION
158                  (*CATCH 'NVT-DONE
159                    (PROG READ-INPUT ()
160                      (FUNCALL-SELF ':SET-IO-BUFFER NVT-IO-BUFFER)
161                      (DO ((CH)) (NIL)
162                        (OR (FUNCALL-SELF ':LISTEN) (FUNCALL STREAM ':FORCE-OUTPUT))
163                        (SETQ CH (FUNCALL-SELF ':ANY-TYI))
164                        (IF (LISTP CH)
165                            (SELECTQ (CAR CH)
166                              (:ERROR (RETURN-FROM READ-INPUT (CADR CH)))
167                              (:MORE (FUNCALL-SELF ':MORE-TYI)))
168                            (SELECTQ (CHAOS:STATE CONNECTION)
169                              (CHAOS:OPEN-STATE)
170                              (CHAOS:HOST-DOWN-STATE
171                               (RETURN-FROM READ-INPUT "Foreign Host died"))
172                              (CHAOS:CLS-RECEIVED-STATE
173                               (RETURN-FROM READ-INPUT "Closed by foreign host"))
174                              (CHAOS:LOS-RECEIVED-STATE
175                               (RETURN-FROM READ-INPUT "Connection closed due to lossage:"))
176                              (OTHERWISE
177                               (RETURN-FROM READ-INPUT
178                                            (FORMAT NIL "Connection in unknown state:~S"
179                                                    (CHAOS:STATE CONNECTION)))))
180                            (IF (OR (= (CHAR-UPCASE CH) ESCAPE-CHAR)
181                                    (= CH #\NETWORK))
182                                ;;Handle the escape character,
183                                (FUNCALL-SELF ':HANDLE-ESCAPE)
184                                ;; otherwise just send through what user typed.
185                                (SETQ CH (FUNCALL-SELF ':TRANSLATE-INPUT-CHAR CH))
186                                (FUNCALL-SELF ':NET-OUTPUT CH))))))
187                  (COND (CONNECT-TO
188                         (FUNCALL-SELF ':CLEAR-SCREEN)
189                         (FUNCALL-SELF ':CONNECT (PROG1 CONNECT-TO (SETQ CONNECT-TO NIL))))
190                        (T (FUNCALL-SELF ':SET-IO-BUFFER ORDINARY-IO-BUFFER)
191                           (FORMAT T "~%Connect to host: ")
192                           (FUNCALL-SELF ':CONNECT (READLINE))))))))
193    (COND ((STRINGP STR)
194           (FUNCALL-SELF ':DISCONNECT)
195           (FORMAT SELF "~%~A~%" STR)
196           (AND RETURN-TO-CALLER (RETURN T))))))
197
198;;;Condition handler for typein side.
199(DEFUN NET-ERROR (IGNORE STRING &REST ARGS)
200  (*THROW 'NVT-DONE (LEXPR-FUNCALL #'FORMAT NIL STRING ARGS)))
201
202;;;Handle a command to the SUPDUP program itself.
203(DEFMETHOD (BASIC-NVT :HANDLE-ESCAPE) (&AUX CH XPOS YPOS)
204  (UNWIND-PROTECT
205    (PROGN
206      (MULTIPLE-VALUE (XPOS YPOS) (TV:SHEET-READ-CURSORPOS SELF))
207      (PUT-DOWN-STRING SELF "CMND-->")
208      (SETQ CH (CHAR-UPCASE (FUNCALL-SELF ':TYI)))
209      (SELECTQ CH
210        ((#\CALL #/P)
211         (FUNCALL-SELF ':DESELECT T))
212        ((#/B)
213         (FUNCALL-SELF ':SET-IO-BUFFER ORDINARY-IO-BUFFER)
214         (BREAK BREAK T)
215         (FUNCALL-SELF ':SET-IO-BUFFER NVT-IO-BUFFER))
216        (#/C                          ;C = Change escape character.
217         (PUT-DOWN-STRING SELF "CHANGE ESCAPE CHARACTER TO -->")
218         (FUNCALL-SELF ':SET-IO-BUFFER ORDINARY-IO-BUFFER)
219         (SETQ ESCAPE-CHAR (CHAR-UPCASE (FUNCALL-SELF ':TYI)))
220         (FUNCALL-SELF ':SET-IO-BUFFER NVT-IO-BUFFER))
221        (#/D                         ;D = Disconnect, ask for new host to connect to.
222         (FUNCALL-SELF ':DISCONNECT)
223         (*THROW 'NVT-DONE "Disconnected"))
224        (#/L                          ;L = Logout.
225         (FUNCALL-SELF ':LOGOUT)
226         (QUIT "Logout"))
227        (#/Q                          ;Q = Quit.
228         (QUIT))
229        (#/M                          ;M = More.
230         (FUNCALL-SELF ':SET-MORE-P (NOT (FUNCALL-SELF ':MORE-P))))
231        (#/I                          ;I = Imlac.
232         (FUNCALL-SELF ':TOGGLE-IMLAC-SIMULATION))
233        ((#\HELP #/?)                 ;<HELP> or ? = Help
234         (TV:SHEET-HOME SELF)
235         (TV:SHEET-CLEAR-EOL SELF)
236         (FORMAT SELF "After typing the Escape character, which is ~:C,
237you can type these commands:~%" ESCAPE-CHAR)
238         (FORMAT SELF "
239CALL -- Do a local CALL (return to top window).
240B    -- Enter a breakpoint.
241C    -- Change the SUPDUP escape character.
242D    -- Disconnect and connect to new host.
243L    -- Log out of remote host, and break the connection.
244P    -- Return to top window, but don't break connection.
245Q    -- Disconnect and return to top window.
246~:[~;M    -- Toggle more processing.
247I    -- Toggle imlac simulation.
248~]
249?    -- Type this cruft.
250" (GET-HANDLER-FOR SELF ':TOGGLE-IMLAC-SIMULATION))
251         (FORMAT SELF "~4A -- Send ~:C through~%"
252                 (FORMAT NIL "~:C" ESCAPE-CHAR)
253                 ESCAPE-CHAR))
254        (#\RUBOUT)                              ;<RUBOUT> = Do nothing.
255        (OTHERWISE
256          (COND ((OR (= CH ESCAPE-CHAR) (= CH #\NETWORK))
257                 (FUNCALL-SELF ':NET-OUTPUT (FUNCALL-SELF ':TRANSLATE-INPUT-CHAR CH))
258                 (FUNCALL STREAM ':FORCE-OUTPUT))
259                (T (TV:BEEP))))))
260    (TV:SHEET-FORCE-ACCESS (SELF)
261      (PUT-DOWN-STRING SELF "")      ;Clear the bottom line.
262      (TV:SHEET-SET-CURSORPOS SELF XPOS YPOS))))
263
264(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-NVT)
265(DEFUN QUIT (&OPTIONAL (STRING "Quit"))
266  (FUNCALL-SELF ':DISCONNECT)
267  (SETQ RETURN-TO-CALLER T)
268  (*THROW 'NVT-DONE STRING)))
269
270(DEFUN PUT-DOWN-STRING (SHEET STRING)
271  (TV:SHEET-HOME-DOWN SHEET)
272  (TV:SHEET-CLEAR-EOL SHEET)
273  (TV:SHEET-STRING-OUT SHEET STRING))
274
275;;;This is the output process
276(DEFMETHOD (BASIC-NVT :TYPEOUT-TOP-LEVEL) (&AUX (TERMINAL-IO SELF))
277  (PROCESS-WAIT "Never-open" #'CAR (LOCATE-IN-INSTANCE SELF 'CONNECTION))
278  (CONDITION-BIND ((CHAOS:READ-ON-LOS-CONNECTION TYPEOUT-NET-ERROR)
279                   (CHAOS:HOST-DOWN TYPEOUT-NET-ERROR))
280    (DO ((OUTPUT-FUN (OR TERMINAL-STREAM (GET-HANDLER-FOR SELF ':BUFFERED-TYO))))
281        (NIL)
282      (DO ((CH (NVT-NETI) (FUNCALL STREAM ':TYI-NO-HANG)))
283          ((NULL CH)
284           (OR TERMINAL-STREAM (FUNCALL-SELF ':FORCE-OUTPUT)))
285        (FUNCALL OUTPUT-FUN ':TYO CH)))))
286
287(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-NVT)
288(DEFUN NVT-NETI (&AUX CH)
289  (COND ((SETQ CH (FUNCALL STREAM ':TYI)))
290        (T
291         (FUNCALL-SELF ':FORCE-KBD-INPUT '(:ERROR "Closed by foreign host"))
292         (PROCESS-WAIT "Connection closed" #'FALSE)))))
293
294(DEFUN TYPEOUT-NET-ERROR (IGNORE STRING &REST ARGS)
295  (FUNCALL-SELF ':FORCE-KBD-INPUT (LIST ':ERROR (LEXPR-FUNCALL #'FORMAT NIL STRING ARGS)))
296  (SI:PROCESS-WAIT-FOREVER))
297
298(DEFFLAVOR BASIC-SUPDUP () (BASIC-NVT)
299  (:DOCUMENTATION :SPECIAL-PURPOSE "A SUPDUP NVT"))
300
301(DEFFLAVOR SUPDUP () (BASIC-SUPDUP TV:FULL-SCREEN-HACK-MIXIN TV:WINDOW)
302  (:DEFAULT-INIT-PLIST :SAVE-BITS T)
303  (:DOCUMENTATION :COMBINATION))
304
305(DEFRESOURCE TYPEOUT-PROCESSES
306 (PROCESS-CREATE "NVT-Typeout" ':SPECIAL-PDL-SIZE 2000.))
307
308(DEFVAR *SUPDUP-WINDOWS* NIL)
309(DEFVAR *SUPDUP-DEFAULT-PATH* "AI")
310(DEFVAR *SUPDUP-MODE* T)                        ;NIL => New window default
311
312(DEFUN FIND-SELECTABLE-SUPDUP (CONNECTED-P &OPTIONAL (SUP TV:MOUSE-SHEET))
313  (DOLIST (W *SUPDUP-WINDOWS*)
314    (AND (EQ (FUNCALL W ':CONNECTED-P) CONNECTED-P)
315         (OR (NULL SUP) (EQ SUP (TV:SHEET-SUPERIOR W)))
316         (RETURN W))))
317
318(DEFUN SUPDUP (&OPTIONAL PATH (MODE *SUPDUP-MODE*))
319  (IF MODE
320      (SUPDUP-SEPARATE PATH)
321      (SUPDUP-BIND PATH)))
322
323(DEFUN SUPDUP-SEPARATE (&OPTIONAL PATH &AUX SW)
324  "Create a separate supdup"
325  (COND ((AND (NULL PATH) (SETQ SW (FIND-SELECTABLE-SUPDUP T NIL)))
326         (FUNCALL SW ':SELECT)
327         NIL)
328        (T
329         (SETQ SW (OR (FIND-SELECTABLE-SUPDUP NIL) (TV:WINDOW-CREATE 'SUPDUP)))
330         (FUNCALL SW ':SET-CONNECT-TO (OR PATH *SUPDUP-DEFAULT-PATH*))
331         (FUNCALL SW ':EXPOSE NIL ':CLEAN) ;Don't come up with old garbage
332         (FUNCALL SW ':SELECT)
333         T)))
334
335(DEFUN SUPDUP-BIND (&OPTIONAL PATH (WINDOW TERMINAL-IO) &AUX SW)
336  "Run supdup in the current window by window pushing"
337  (COND ((AND (NULL PATH) (SETQ SW (FIND-SELECTABLE-SUPDUP T)))
338         (FUNCALL SW ':SELECT)
339         NIL)
340        (T
341         (OR PATH (SETQ PATH *SUPDUP-DEFAULT-PATH*))
342         (WITH-RESOURCE (TV:BIT-ARRAYS BIT-ARRAY)
343           (WITH-RESOURCE (TYPEOUT-PROCESSES TP)
344             (TV:WINDOW-BIND (WINDOW 'SUPDUP ':TYPEIN-PROCESS CURRENT-PROCESS
345                                     ':BIT-ARRAY BIT-ARRAY
346                                     ':TYPEOUT-PROCESS TP)
347                             (FUNCALL WINDOW ':CONNECT PATH)
348                             (*CATCH 'SI:TOP-LEVEL (FUNCALL WINDOW ':TYPEIN-TOP-LEVEL NIL))
349                             (SETF (TV:SHEET-BIT-ARRAY WINDOW) NIL)
350                             T))))))
351
352(DEFMETHOD (BASIC-SUPDUP :BEFORE :INIT) (INIT-PLIST)
353  (SETQ TV:LABEL "Supdup -- not connected")
354  (PUTPROP INIT-PLIST NIL ':MORE-P))
355
356(DEFMETHOD (BASIC-SUPDUP :BEFORE :SELECT) (&REST IGNORE)
357  ;Move ourselves to the head of the list
358  (WITHOUT-INTERRUPTS
359    (SETQ *SUPDUP-WINDOWS* (DELQ SELF *SUPDUP-WINDOWS*))
360    (PUSH SELF *SUPDUP-WINDOWS*)))
361
362(DEFMETHOD (BASIC-SUPDUP :BEFORE :DEACTIVATE) (&REST IGNORE)
363  (WITHOUT-INTERRUPTS (SETQ *SUPDUP-WINDOWS* (DELQ SELF *SUPDUP-WINDOWS*))))
364
365(DEFMETHOD (BASIC-SUPDUP :AFTER :ACTIVATE) (&REST IGNORE)
366  (WITHOUT-INTERRUPTS
367    (OR (MEMQ SELF *SUPDUP-WINDOWS*)
368        (IF *SUPDUP-WINDOWS*
369            (RPLACD (LAST *SUPDUP-WINDOWS*) (NCONS SELF))
370            (SETQ *SUPDUP-WINDOWS* (NCONS SELF))))))
371
372(DEFMETHOD (BASIC-SUPDUP :VERIFY-NEW-EDGES) (NEW-LEFT NEW-TOP NEW-WIDTH NEW-HEIGHT)
373  NEW-LEFT NEW-TOP                              ;Unused
374  (AND CONNECTION
375       (OR ( NEW-WIDTH TV:WIDTH) ( NEW-HEIGHT TV:HEIGHT))
376       "Attempt to change size while connected"))
377
378(DEFMETHOD (BASIC-SUPDUP :CONNECT) (&OPTIONAL PATH (NET-WINDOW 3))
379  (AND (NUMBERP PATH) (SETQ PATH (CHAOS:HOST-DATA PATH)))
380  (LET ((SUPDUP-%TOCID (IF (STRING-SEARCH PATH "SAIL") T
381                           SUPDUP-%TOCID)))
382    (FUNCALL-SELF ':NEW-CONNECTION PATH NET-WINDOW "SUPDUP" 137)))
383
384(DEFMETHOD (BASIC-SUPDUP :GOBBLE-GREETING) ()
385  (SEND-TTY-VARIABLES STREAM SELF)
386  (SEND-FINGER-STRING STREAM)
387  ;;Print out the greeting message ITS sends in ASCII.
388  (DO ((CH #\CR (FUNCALL STREAM ':TYI)))
389      ((OR (NULL CH) (= CH 210)))       ;The end is marked with a %TDNOP, NIL is eof
390    (AND (< CH 40) (SETQ CH (+ 200 CH)))
391    (OR (= CH 212)                      ;Don't type linefeeds (ITS sends CRLFs).
392        (TYO CH SELF))))
393
394;;;Send the initial information describing the Lisp Machine as an
395;;;intelligent terminal.  The TTYOPT word contains the following:
396;;;%TOERS+%TOMVB+%TOSAI+%TOOVR+%TOMVU+%TOLWR+%TOFCI+%TOMOR+%TOLID,,%TPCBS+%TPORS+%TPRSC
397(DEFVAR SUPDUP-%TOCID NIL)
398
399(DEFUN SEND-TTY-VARIABLES (STREAM SHEET)
400    (18BIT-OUT STREAM -5)               ;First word is -5,,0
401    (18BIT-OUT STREAM 0)
402    (18BIT-OUT STREAM 0)                ;TCTYP word must be %TNSFW: 0,,7
403    (18BIT-OUT STREAM 7)
404    (18BIT-OUT STREAM (IF SUPDUP-%TOCID 55633 55632))   ;TTYOPT word explained above.
405    (18BIT-OUT STREAM 54)
406    (18BIT-OUT STREAM 0)                ;TCMXV
407    (18BIT-OUT STREAM (1- (// (TV:SHEET-INSIDE-HEIGHT SHEET) (TV:SHEET-LINE-HEIGHT SHEET))))
408    (18BIT-OUT STREAM 0)                ;TCMXH
409    (18BIT-OUT STREAM (1- (// (TV:SHEET-INSIDE-WIDTH SHEET) (TV:SHEET-CHAR-WIDTH SHEET))))
410    (18BIT-OUT STREAM 0)                ;TTYROL
411    (18BIT-OUT STREAM 0)                ;No scrolling
412    (FUNCALL STREAM ':FORCE-OUTPUT))
413
414(DEFUN 18BIT-OUT (STREAM N)
415    (FUNCALL STREAM ':TYO (LDB 1406 N))
416    (FUNCALL STREAM ':TYO (LDB 0606 N))
417    (FUNCALL STREAM ':TYO (LDB 0006 N)))
418
419;;;Send the string to TELSER saying where we are, so that NAME can find it inside
420;;;the TELSER and print it.  Boy, what a kludge.
421(DEFUN SEND-FINGER-STRING (STREAM &AUX ID)
422  (SETQ ID (OR (CDR (ASSQ CHAOS:MY-ADDRESS CHAOS:FINGER-ALIST))
423               (CHAOS:HOST-DATA CHAOS:MY-ADDRESS)))
424  (FUNCALL STREAM ':TYO 300)            ;SUPDUP escape string meaning that the FINGER
425  (FUNCALL STREAM ':TYO 302)            ;identification string follows.
426  (FUNCALL STREAM ':STRING-OUT ID)
427  (FUNCALL STREAM ':TYO 0)              ; End with a 0.
428  (FUNCALL STREAM ':FORCE-OUTPUT))
429
430(DEFMETHOD (BASIC-SUPDUP :AFTER :DISCONNECT) ()
431  (FUNCALL-SELF ':SET-LABEL "Supdup -- not connected"))
432
433(DEFVAR SUPDUP-KEYS (MAKE-ARRAY NIL 'ART-16B 200))
434(FILLARRAY SUPDUP-KEYS '(0 4102 4103 32         ;null, break, clear, call
435                         4101 37 4110 177       ;esc, backnext, help, rubout
436                         10 11 12 13            ;bs, tab, lf, vt
437                         14 15 4102 323         ;form, cr, quote, hold-output
438                         37 4103 310 0          ;stop-output, abort, resume, status
439                         233 0 0 0 0            ;end, I, II, III, IV
440                         0 0 0 0 0 4102))       ;up, down, left, right, system, network
441
442
443(DEFMETHOD (BASIC-SUPDUP :TRANSLATE-INPUT-CHAR) (CH)
444  (COND ((LISTP CH) CH)
445        ((= CH #\ESC)   ;I don't think this clause can go off --Moon
446         (TV:KBD-ESC)
447         NIL)
448        (T
449         (LET ((CHAR (LDB %%KBD-CHAR CH)))
450           (LOGIOR (LSH (LDB %%KBD-CONTROL-META CH) 7)
451                   (COND ((= CHAR 33) CHAR)    ;(Special case)
452                         ((< CHAR 40) (LOGIOR CHAR 4000))
453                         ((< CHAR 200) CHAR)
454                         (T (AREF SUPDUP-KEYS (- CHAR 200)))))))))
455
456;;;This sends a character of the ITS 12-bit character set to the network,
457;;;using the ITS Intelligent Terminal Protocol to get the extra bits through.
458(DEFMETHOD (BASIC-SUPDUP :NET-OUTPUT) (CH &AUX BITS)
459  (SETQ BITS (LDB 0705 CH))
460  (COND ((NOT (ZEROP BITS))
461         (LOCK-OUTPUT
462           (FUNCALL STREAM ':TYO 34)
463           (FUNCALL STREAM ':TYO (LOGIOR 100 BITS))
464           (FUNCALL STREAM ':TYO (LOGAND 177 CH))))
465        ((= CH 34)
466         (LOCK-OUTPUT
467           (FUNCALL STREAM ':TYO 34)
468           (FUNCALL STREAM ':TYO CH)))
469        (T (FUNCALL STREAM ':TYO CH))))
470
471(DEFMETHOD (BASIC-SUPDUP :LOGOUT) ()
472  (LOCK-OUTPUT
473    (FUNCALL STREAM ':TYO 300)
474    (FUNCALL STREAM ':TYO 301)
475    (FUNCALL STREAM ':FORCE-OUTPUT)))
476
477;;;Dispatch table for the %TD codes.
478(DEFVAR SUPDUP-%TD-DISPATCH (MAKE-ARRAY NIL 'ART-Q 40))
479(FILLARRAY SUPDUP-%TD-DISPATCH
480   '(SUPDUP-TDMOV SUPDUP-TDMV0 TV:SHEET-CLEAR-EOF TV:SHEET-CLEAR-EOL TV:SHEET-CLEAR-CHAR
481;;;  %TDMOV       %TDMV0       %TDEOF             %TDEOL             %TDDLF
482
483     SUPDUP-NOTHING SUPDUP-GT40 TV:SHEET-CRLF SUPDUP-NOTHING SUPDUP-NOTHING SUPDUP-NOTHING
484;;;  %TDMTF         %TDMTN      %TDCRL        %TDNOP         %TDBS          %TDLF
485
486     SUPDUP-NOTHING SUPDUP-TDORS SUPDUP-TDQOT TV:SHEET-SPACE SUPDUP-TDMV0 SUPDUP-CLEAR
487;;;  %TDCR          %TDORS       %TDQOT       %TDFS    %TDMV0       %TDCLR
488
489     SUPDUP-BEEP    SUPDUP-NOTHING SUPDUP-INSERT-LINE SUPDUP-DELETE-LINE
490;;;  %TDBEL         %TDINI         %TDILP             %TDDLP
491
492     SUPDUP-INSERT-CHAR SUPDUP-DELETE-CHAR SUPDUP-NOTHING SUPDUP-NOTHING SUPDUP-NOTHING
493;;;  %TDICP             %TDDCP             %TDBOW         %TDRST         %TDGRF
494     SUPDUP-REGION-UP SUPDUP-REGION-DOWN
495;;;  %TDRSU             %TDRSD
496
497;;; PTV compatibility hacks (ARDS, etc.)
498     SUPDUP-NOTHING SUPDUP-ARDS-SET
499;;;  %TDGXT         %TDLNG
500
501     SUPDUP-ARDS-LONG   SUPDUP-ARDS-SHORT
502;;;  %TDLV              %TDSV
503     ))
504
505(DEFMETHOD (BASIC-SUPDUP :BUFFERED-TYO) (CH)
506    (COND ((< CH 200)
507           (DO () ((ARRAY-PUSH OUTPUT-BUFFER CH))
508             (FUNCALL-SELF ':FORCE-OUTPUT)))
509          (T
510           (FUNCALL-SELF ':FORCE-OUTPUT)
511           (OR (>= (SETQ CH (- CH 200)) (ARRAY-LENGTH SUPDUP-%TD-DISPATCH))
512               (FUNCALL (AREF SUPDUP-%TD-DISPATCH CH) SELF)))))
513
514;;;Handle %TDMOV by ignoring two characters and then acting as if it were a %TDMV0.
515(DEFUN SUPDUP-TDMOV (SHEET)
516  (NVT-NETI)
517  (NVT-NETI)
518  (SUPDUP-TDMV0 SHEET))
519
520;;;Handle %TDMV0 or %TDMV1 by moving the cursor.  This is kludgey because
521;;;ITS sends out positions as VPOS followed by HPOS.
522(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP)
523(DEFUN SUPDUP-TDMV0 (SHEET &AUX YPOS)
524  (SETQ YPOS (* (NVT-NETI) TV:LINE-HEIGHT))
525  (TV:SHEET-SET-CURSORPOS SHEET
526                          (* (NVT-NETI) TV:CHAR-WIDTH)
527                          YPOS)))
528
529;;;This "null function" is used for codes which we should ignore.
530(DEFUN SUPDUP-NOTHING (IGNORE) NIL)
531
532;;;Handle %TDORS.  Just tell ITS where the cursor position is, using the
533;;;Intelligent Terminal Protocol's ^\ ^P command.
534(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP)
535(DEFUN SUPDUP-TDORS (SHEET &AUX VPOS HPOS)
536  (MULTIPLE-VALUE (HPOS VPOS)
537    (TV:SHEET-READ-CURSORPOS SHEET))
538  (LOCK-OUTPUT
539    (FUNCALL STREAM ':TYO 34) ;^\
540    (FUNCALL STREAM ':TYO 20) ;^P
541    (FUNCALL STREAM ':TYO (// VPOS TV:LINE-HEIGHT))
542    (FUNCALL STREAM ':TYO (// HPOS TV:CHAR-WIDTH))
543    (FUNCALL STREAM ':FORCE-OUTPUT))))
544
545;;;%TDQOT means the next character should be quoted.
546(DEFUN SUPDUP-TDQOT (SHEET)
547  (TV:SHEET-TYO SHEET (NVT-NETI)))
548
549;;;%TDBEL means to ring the "bell".
550;;;To avoid gross obnoxosity, we merge multiple consecutive beeps into one
551(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP)
552(DEFUN SUPDUP-BEEP (IGNORE)
553  (TV:BEEP)
554  (DO ((CH (FUNCALL STREAM ':TYI-NO-HANG) (FUNCALL STREAM ':TYI-NO-HANG)))
555      ((OR (NULL CH) ( CH 221))
556       (AND CH (FUNCALL STREAM ':UNTYI CH))))))
557
558;;;%TDCLR
559(DEFUN SUPDUP-CLEAR (SHEET)
560  (TV:SHEET-CLEAR SHEET)
561  (FILLARRAY GT40-DISPLAY-LIST '(NIL)))
562   
563;;;%TDILP means to insert lines, takes one arg from stream which is number of lines to insert
564;;;Lines are inserted at current VPOS.  The current line is affected.
565(DEFUN SUPDUP-INSERT-LINE (SHEET)
566  (TV:SHEET-INSERT-LINE SHEET (NVT-NETI)))
567
568;;;%TDDLP means to delete lines, takes one arg from stream which is the number of lines.
569;;;Affects the current line.
570(DEFUN SUPDUP-DELETE-LINE (SHEET)
571  (TV:SHEET-DELETE-LINE SHEET (NVT-NETI)))
572
573;;;%TDRSU, %TDRSD followed by height, n-lines
574(DEFUN SUPDUP-REGION-UP (SHEET)
575  (LET ((REGION-HEIGHT (NVT-NETI))
576        (SCROLL-AMOUNT (NVT-NETI)))
577    (TV:PREPARE-SHEET (SHEET)
578      (LET ((ARRAY (TV:SHEET-SCREEN-ARRAY SHEET))
579            (WIDTH (TV:SHEET-INSIDE-WIDTH SHEET))
580            (LINE-HEIGHT (TV:SHEET-LINE-HEIGHT SHEET))
581            REGION-BOTTOM
582            DELTA-HEIGHT)
583        (SETQ REGION-HEIGHT (* REGION-HEIGHT LINE-HEIGHT)
584              REGION-BOTTOM (MIN (+ (TV:SHEET-CURSOR-Y SHEET) REGION-HEIGHT)
585                                 (* LINE-HEIGHT
586                                    (// (TV:SHEET-INSIDE-BOTTOM SHEET)
587                                        LINE-HEIGHT)))
588              REGION-HEIGHT (- REGION-BOTTOM (TV:SHEET-CURSOR-Y SHEET))
589              SCROLL-AMOUNT (MIN (* SCROLL-AMOUNT LINE-HEIGHT) REGION-HEIGHT))
590        ;; Get size of region to BLT up
591        (SETQ DELTA-HEIGHT (- REGION-HEIGHT SCROLL-AMOUNT))
592        (OR (<= DELTA-HEIGHT 0)                 ;If some bits to move, move them
593            (BITBLT TV:ALU-SETA
594                    WIDTH DELTA-HEIGHT
595                    ARRAY (TV:SHEET-INSIDE-LEFT SHEET)
596                          (+ (TV:SHEET-CURSOR-Y SHEET) SCROLL-AMOUNT)
597                    ARRAY (TV:SHEET-INSIDE-LEFT SHEET) (TV:SHEET-CURSOR-Y SHEET)))
598        (TV:%DRAW-RECTANGLE WIDTH SCROLL-AMOUNT
599                            (TV:SHEET-INSIDE-LEFT SHEET)
600                            (- REGION-BOTTOM SCROLL-AMOUNT)
601                            (TV:SHEET-ERASE-ALUF SHEET) SHEET)))))
602
603(DEFUN SUPDUP-REGION-DOWN (SHEET)
604  (LET ((REGION-HEIGHT (NVT-NETI))
605        (SCROLL-AMOUNT (NVT-NETI)))
606    (TV:PREPARE-SHEET (SHEET)
607      (LET ((ARRAY (TV:SHEET-SCREEN-ARRAY SHEET))
608            (WIDTH (TV:SHEET-INSIDE-WIDTH SHEET))
609            (LINE-HEIGHT (TV:SHEET-LINE-HEIGHT SHEET))
610            REGION-BOTTOM
611            DELTA-HEIGHT)
612        (SETQ REGION-HEIGHT (* REGION-HEIGHT LINE-HEIGHT)
613              REGION-BOTTOM (MIN (+ (TV:SHEET-CURSOR-Y SHEET) REGION-HEIGHT)
614                                 (* LINE-HEIGHT
615                                    (// (TV:SHEET-INSIDE-BOTTOM SHEET)
616                                        LINE-HEIGHT)))
617              REGION-HEIGHT (- REGION-BOTTOM (TV:SHEET-CURSOR-Y SHEET))
618              SCROLL-AMOUNT (MIN (* SCROLL-AMOUNT LINE-HEIGHT) REGION-HEIGHT))
619        ;; Get negative size of region to BLT down
620        (SETQ DELTA-HEIGHT (- SCROLL-AMOUNT REGION-HEIGHT))
621        (OR (>= DELTA-HEIGHT 0)                 ;If some bits to move, move them
622            (BITBLT TV:ALU-SETA
623                    WIDTH DELTA-HEIGHT
624                    ARRAY (TV:SHEET-INSIDE-LEFT SHEET) (TV:SHEET-CURSOR-Y SHEET)
625                    ARRAY (TV:SHEET-INSIDE-LEFT SHEET)
626                          (+ (TV:SHEET-CURSOR-Y SHEET) SCROLL-AMOUNT)))
627        (TV:%DRAW-RECTANGLE WIDTH SCROLL-AMOUNT
628                            (TV:SHEET-INSIDE-LEFT SHEET) (TV:SHEET-CURSOR-Y SHEET)
629                            (TV:SHEET-ERASE-ALUF SHEET) SHEET)))))
630
631;;;%TDICP insert character positions, takes an arg.
632(DEFUN SUPDUP-INSERT-CHAR (SHEET)
633  (TV:SHEET-INSERT-CHAR SHEET (NVT-NETI)))
634
635;;;%TDDCP delete character positions, takes an arg.
636(DEFUN SUPDUP-DELETE-CHAR (SHEET)
637  (TV:SHEET-DELETE-CHAR SHEET (NVT-NETI)))
638
639;;; Always have at least one supdup window in the world
640(OR *SUPDUP-WINDOWS*
641    (TV:WITHOUT-SCREEN-MANAGEMENT (FUNCALL (TV:WINDOW-CREATE 'SUPDUP) ':ACTIVATE)))
642
643;;; GT40 Simulator (used with the DEC simulator on I.T.S. for running SUDS)
644
645;;; This crock maintains a display list for writing, erasing, and moving display objects
646;;; consisting of characters, vectors, and points.  This protocol is not documented
647;;; anywhere except in the code for DECUUO.
648
649;; Dispatch table for the GT40 simulator.  These functions take one argument, the pc-ppr.
650(DEFVAR GT40-DISPATCH (MAKE-ARRAY NIL 'ART-Q 17))
651(FILLARRAY GT40-DISPATCH
652           '(GT40-INSERT-OR-DELETE
653             GT40-INSERT
654             GT40-DELETE
655;            GT40-RESET
656;            GT40-TURN-ON
657;            GT40-TURN-OFF
658;            GT40-COPY
659;            GT40-MOVE
660;            GT40-MODE
661;            GT40-APPEND
662;            GT40-SUBROUTINIZE
663;            GT40-UNSUBROUTINIZE
664             SUPDUP-NOTHING))                   ;most are not used by DECUUO
665
666;;; Display list array.
667(DEFVAR GT40-DISPLAY-LIST (MAKE-ARRAY NIL 'ART-Q-LIST 10.))
668(DEFVAR GT40-BLINKER NIL)
669(DEFVAR GT40-CURRENT-ITEM-NUMBER)
670(DEFVAR SUDS-KBD-NEW-TABLE                      ;allows thumb keys to be used
671  (LET ((TBL (SI:KBD-MAKE-NEW-TABLE)))
672    (DOLIST (L '((176 #// #/ #// #/) (106 #/\ #/| #/\ #/|)
673                 (117 #/[ #/{ #/[ #/{) (17 #/] #/} #/] #/})))
674      (LET ((NCH (FIRST L)) (LCH (REST1 L)))
675        (DOTIMES (I 5)
676          (ASET (CAR LCH) TBL I NCH)
677          (IF (REST1 LCH) (SETQ LCH (REST1 LCH))))))
678    TBL))
679
680;; %TDMTN is a crock for simulating GT-40's, used by DECUUO on ITS for Imlacs...
681
682(DEFUN SUPDUP-GT40 (SHEET &AUX (BYTE (- (NVT-NETI) 100)))
683  (IF ( (AREF SUDS-KBD-NEW-TABLE 0 176)        ;crock for thumb keys, only when
684         (AREF SI:KBD-NEW-TABLE 0 176))         ;doing GT40 simulation
685      (SETQ SI:KBD-NEW-TABLE SUDS-KBD-NEW-TABLE))
686  (OR (< BYTE 0)
687      (FUNCALL (AREF GT40-DISPATCH (LOGAND 17 BYTE)) SHEET)))
688
689;;; Macros used below to pack characters into words, decode vector formats, etc.
690
691;;; Make a 16-bit "word" from 3 chars in 6-4-6 format
692(DEFMACRO GT40-WORD ()
693  '(DPB (NVT-NETI) 0006
694        (DPB (NVT-NETI) 0604
695             (DPB (NVT-NETI) 1206 0))))
696
697;;; Get a word count
698(DEFMACRO GT40-COUNT () '(LSH (- (GT40-WORD) 5) -1))
699
700;;; Used in constructing display objects - used only in GT40-INSERT.
701(DEFMACRO APUSH (DOB ITEM) `(ARRAY-PUSH-EXTEND ,DOB ,ITEM 500.))
702
703;;; Compute the index of the last thing pushed
704(DEFMACRO GT40-LAST-INDEX (DOB) `(1- (ARRAY-ACTIVE-LENGTH ,DOB)))
705
706;;; Get the last item pushed onto a display object
707(DEFMACRO GT40-LAST-ITEM (DOB) `(AREF ,DOB (GT40-LAST-INDEX ,DOB)))
708
709;;; Short vector format
710(DEFMACRO GT40-SHORT (DOB WORD)
711  `(PROGN
712     (APUSH ,DOB (* (LDB 0706 ,WORD) (IF (BIT-TEST 20000 ,WORD) -1 1)))
713     (APUSH ,DOB (* (LDB 0006 ,WORD) (IF (BIT-TEST 100 ,WORD) -1 1)))
714     (APUSH ,DOB (BIT-TEST 40000 ,WORD))))
715
716;;; Long vector format
717(DEFMACRO GT40-LONG (DOB WORD1 WORD2)
718   `(LET ((WORD2 ,WORD2))
719      (APUSH ,DOB (* (LOGAND 1777 ,WORD1) (IF (BIT-TEST 20000 ,WORD1) -1 1)))
720      (APUSH ,DOB (* (LOGAND 1777 WORD2) (IF (BIT-TEST 20000 WORD2) -1 1)))
721      (APUSH ,DOB (BIT-TEST 40000 ,WORD1))))
722
723;;; Coordinate scaling macro
724(DEFMACRO GT40-COORD (X) `(MAX 0 (// (* 7 ,X) 10.)))
725
726;;; Draw a string.  Note special end of line hackery.  XPOS and YPOS must be symbols.
727(DEFMACRO GT40-DRAW-STRING (STRING XPOS YPOS SHEET)
728  `(LET ((MAX-Y 750.))
729     (TV:SHEET-STRING-OUT-EXPLICIT ,SHEET ,STRING (GT40-COORD ,XPOS)
730                                   (- MAX-Y (GT40-COORD ,YPOS) 11.)
731                                   (TV:SHEET-INSIDE-RIGHT ,SHEET)
732                                   (TV:SHEET-CURRENT-FONT ,SHEET)
733                                   TV:ALU-XOR)))
734
735;;; Draw a vector.  XPOS and YPOS must be symbols
736(DEFMACRO GT40-DRAW-VECTOR (XPOS YPOS X Y FLAG SHEET)
737  `(LET ((MAX-Y 750.) (OXPOS ,XPOS) (OYPOS ,YPOS))
738     (SETQ ,XPOS (+ ,XPOS ,X) ,YPOS (+ ,YPOS ,Y))
739     (IF ,FLAG
740         (TV:%DRAW-LINE (GT40-COORD OXPOS) (- MAX-Y (GT40-COORD OYPOS))
741                        (GT40-COORD ,XPOS) (- MAX-Y (GT40-COORD ,YPOS))
742                        TV:ALU-XOR NIL ,SHEET))))
743
744;;; Read a vector out of the display list and draw it
745(DEFMACRO GT40-VECTOR (DOB XPOS YPOS SHEET)
746  `(LET ((I (GT40-LAST-INDEX ,DOB)))
747     (GT40-DRAW-VECTOR
748      ,XPOS ,YPOS
749      (AREF ,DOB (- I 2)) (AREF ,DOB (- I 1))   ;new x y
750      (AREF ,DOB I) ,SHEET)))                   ;visibility flag
751
752;;; Display list format:  The display list is an ART-Q array of display objects, each of
753;;; which is, in turn, an ART-Q array.  The format of display objects is a sequence of
754;;; display items.  A display item is either a single string of characters or an in-line
755;;; subsequence consisting of a symbol describing the item-type followed by 2 numbers (x,y)
756;;; and a visibility flag.  Numbers and flags are repeated until a new symbol is encountered
757;;; indicating a type change.
758
759;;; GT40 Command 0 - Insert or delete display items
760(DEFUN GT40-INSERT-OR-DELETE (SHEET)
761  (SELECTQ (LOGAND 3 (GT40-WORD))               ;only 1 and 2 are recognized for now
762    (1 (GT40-INSERT SHEET))                     ;insert a new display item
763    (2 (GT40-DELETE SHEET (1+ (GT40-COUNT)))))) ;delete n items
764
765;;; GT40 Command 1 - Insert a display item into the display list.
766(DEFUN GT40-INSERT (SHEET &AUX (WORD-COUNT (GT40-COUNT)))
767  (GT40-DELETE SHEET 1 NIL)             ;Delete the item we are about to insert
768  (DO ((I 0 (1+ I))                     ;Loop over words, contructing a display list
769       (WORD)(MODE -1)                  ;Mode is initially undefined.
770       (XPOS 0) (YPOS 0) (BLINK-THIS)
771       (DOB                             ;Display OBject
772        (OR (AREF GT40-DISPLAY-LIST GT40-CURRENT-ITEM-NUMBER)   ;Already an array or
773            (ASET (MAKE-ARRAY NIL ART-Q 200. NIL '(NIL 0))      ;cons an array with leader
774                  GT40-DISPLAY-LIST GT40-CURRENT-ITEM-NUMBER))))        ;and install it
775      (( I WORD-COUNT)
776       (IF (= 0 MODE)                   ; was char mode, display the string
777           (GT40-DRAW-STRING (GT40-LAST-ITEM DOB) XPOS YPOS SHEET))
778       (IF BLINK-THIS (STORE-ARRAY-LEADER 'ON DOB 1)))
779    (SETQ WORD (GT40-WORD))
780    (COND ((BIT-TEST 100000 WORD)       ;If command, only look at blink bit and mode
781           (IF (NOT (BIT-TEST 40000 WORD))      ;ignore words with the 40000 bit on
782               (LET ((NMODE (LDB 1303 WORD))
783                     (BLINK-FLAG (AND (BIT-TEST 20 WORD) (BIT-TEST 10 WORD))))
784                  (COND ((NOT (= MODE NMODE))   ;get the new datatype mode
785                         (IF (= 0 MODE) ; was char mode, display the string
786                             (GT40-DRAW-STRING (GT40-LAST-ITEM DOB) XPOS YPOS SHEET))
787                         (SETQ MODE NMODE)
788                         (APUSH DOB (SELECTQ MODE       ;initializings
789                                      (0 (MAKE-ARRAY NIL 'ART-STRING 10. NIL '(0)))
790                                      (1 'VECTOR)
791                                      (2 'VECTOR)
792                                      (3 'POINT)
793                                      (6 'RPOINT)
794                                      ((4 5 7) 'UNKNOWN)))))
795                  (COND (BLINK-FLAG
796                         (OR (MEMQ GT40-BLINKER (TV:SHEET-BLINKER-LIST SHEET))
797                             (SETQ GT40-BLINKER
798                                   (TV:DEFINE-BLINKER SHEET 'GT40-BLINKER)))
799                         (SETQ BLINK-THIS T))))))
800          (T (SELECTQ MODE
801               (0 (DO ((CHAR (LDB 0007 WORD) (LDB 1007 WORD))   ;character mode
802                       (STRING (GT40-LAST-ITEM DOB))
803                       (I 0 (1+ I)))
804                      ((= I 2))
805                      (OR (= 0 CHAR) (= 17 CHAR) (ARRAY-PUSH-EXTEND STRING CHAR))))
806               (1 (GT40-SHORT DOB WORD) ;short vector
807                  (GT40-VECTOR DOB XPOS YPOS SHEET))
808               (2 (SETQ I (1+ I))       ;long vector
809                  (GT40-LONG DOB WORD (GT40-WORD))
810                  (GT40-VECTOR DOB XPOS YPOS SHEET))
811               (3 (SETQ I (1+ I))       ;point data
812                  (GT40-LONG DOB WORD (GT40-WORD))
813                  (LET ((I (GT40-LAST-INDEX DOB)))
814                       (SETQ XPOS (AREF DOB (- I 2))
815                             YPOS (AREF DOB (- I 1)))
816                       (GT40-DRAW-VECTOR XPOS YPOS 0 0 (AREF DOB I) SHEET)))
817               (4)                      ;graphplot x data (not used)
818               (5)                      ;graphplot y data (not used)
819               (6 (GT40-SHORT DOB WORD) ;relative point data
820                  (LET ((I (GT40-LAST-INDEX DOB)))
821                       (SETQ XPOS (+ XPOS (AREF DOB (- I 2)))
822                             YPOS (+ YPOS (AREF DOB (- I 1))))
823                       (GT40-DRAW-VECTOR XPOS YPOS 0 0 (AREF DOB I) SHEET)))
824               (7)))))                  ;not used
825  (GT40-WORD))                          ;gobble the checksum
826
827;;; GT40 Command 2 - Delete a display item from the display list
828(DEFUN GT40-DELETE (SHEET &OPTIONAL (NITEMS 1) (CHECKSUM-FLAG T))
829  (DO ((I 0 (1+ I)) (DOB) (ITEM-NUMBER))
830      (( I NITEMS))
831    (SETQ ITEM-NUMBER (GT40-WORD)
832          GT40-CURRENT-ITEM-NUMBER ITEM-NUMBER  ;record item # being hacked
833          DOB (AREF GT40-DISPLAY-LIST ITEM-NUMBER))
834    (IF DOB (PROGN (OR (EQ 'OFF (ARRAY-LEADER DOB 1))   ;don't erase if its already off
835                       (GT40-DISPLAY-ITEM DOB SHEET))
836                   (FILLARRAY DOB '(NIL))
837                   (STORE-ARRAY-LEADER 0 DOB 0) ;zero the fill pointer
838                   (STORE-ARRAY-LEADER NIL DOB 1))))    ;blinking is off
839  (IF CHECKSUM-FLAG (GT40-WORD)))               ;gobble the checksum
840
841;;; Display a display item.
842(DEFUN GT40-DISPLAY-ITEM (DOB SHEET)
843  (DO ((I 0 (1+ I))
844       (END (ARRAY-ACTIVE-LENGTH DOB))
845       (ITEM) (X) (Y) (FLAG) (XPOS 0) (YPOS 0))
846      ((>= I END))
847    (SETQ ITEM (AREF DOB I))
848    (COND ((STRINGP ITEM) (GT40-DRAW-STRING ITEM XPOS YPOS SHEET))
849          ((EQ 'UNKNOWN ITEM))          ;ignore
850          (T (DO NIL
851                 ((OR (<= (- END I) 3)
852                      (SYMBOLP (AREF DOB (1+ I)))
853                      (STRINGP (AREF DOB (1+ I)))))
854                 (SETQ I (+ 3 I)
855                       X    (AREF DOB (- I 2))
856                       Y    (AREF DOB (- I 1))
857                       FLAG (AREF DOB I))
858                 (SELECTQ ITEM
859                   (VECTOR (GT40-DRAW-VECTOR XPOS YPOS X Y FLAG SHEET))
860                   (POINT (SETQ XPOS X YPOS Y)
861                          (GT40-DRAW-VECTOR XPOS YPOS 0 0 FLAG SHEET))
862                   (RPOINT (SETQ XPOS (+ XPOS X) YPOS (+ YPOS Y))
863                           (GT40-DRAW-VECTOR XPOS YPOS 0 0 FLAG SHEET))))))))
864
865(DEFFLAVOR GT40-BLINKER () (TV:BLINKER))
866
867;;; Blink a display item
868(DEFMETHOD (GT40-BLINKER :BLINK) ()
869  (LET-GLOBALLY ((TV:PHASE NIL))
870    (DO ((ITEM (G-L-P GT40-DISPLAY-LIST) (CDR ITEM))
871         (BLINK-FLAG NIL NIL)
872         (DITEM))
873        ((NULL ITEM))
874      (SETQ DITEM (CAR ITEM))
875      (IF DITEM (SETQ BLINK-FLAG (ARRAY-LEADER DITEM 1)))
876      (IF (MEMQ BLINK-FLAG '(ON OFF))
877          (PROGN (GT40-DISPLAY-ITEM DITEM TV:SHEET)
878                 (STORE-ARRAY-LEADER (SELECTQ BLINK-FLAG (ON 'OFF) (OFF 'ON)) DITEM 1))))))
879
880(DEFMETHOD (GT40-BLINKER :SIZE) ()
881  (PROG () (RETURN (TV:SHEET-INSIDE-WIDTH TV:SHEET) (TV:SHEET-INSIDE-HEIGHT TV:SHEET))))
882
883;;; ARDS simulator (for compatibility with PTV's)
884
885;;; Todo: these variables should be instance variables
886;;;       scaling and offset doesn't work right in this version...
887;;;       SHOULD SEND LINE DRAWING MESSAGES RATHER THAN CALLING %DRAW-LINE
888
889(DEFVAR ARDS-XPOS 0)                            ;current pos in ARDS coordinates
890(DEFVAR ARDS-YPOS 0)
891(DEFVAR ARDS-SCALE 1.0)
892(DEFVAR ARDS-SCR-XPOS 0)                        ;current pos in screen coordinates
893(DEFVAR ARDS-SCR-YPOS 0)
894
895;;; Setup scaling and offsets, then loop until exit condition
896(DEFMACRO ARDS-LOOP (&REST BODY)
897  `(LET* ((ARDS-MAX-X (+ TV:X-OFFSET TV:WIDTH))
898          (ARDS-MAX-Y (+ TV:Y-OFFSET TV:HEIGHT))
899          (ARDS-X-OFFSET TV:X-OFFSET)
900          (ARDS-Y-OFFSET TV:Y-OFFSET)
901          (ARDS-SCR-SCALE (* ARDS-SCALE (// (MIN TV:WIDTH TV:HEIGHT) 1023.0)))
902          (ARDS-CENTER-OFFSET (// (1+ (- (MAX TV:WIDTH TV:HEIGHT) (MIN TV:WIDTH TV:HEIGHT)))
903                                  2))
904          (ARDS-FLAG NIL))
905     (IF (< TV:WIDTH TV:HEIGHT) (SETQ ARDS-MAX-Y (- ARDS-MAX-Y ARDS-CENTER-OFFSET))
906         (SETQ ARDS-X-OFFSET (+ ARDS-X-OFFSET ARDS-CENTER-OFFSET)))
907     (*CATCH 'ARDS-RETURN
908             (DO NIL (NIL) ,@BODY))))
909
910;;; Convert -512./511. to 0/1023. and scale if the user wants it.
911(DEFMACRO ARDS-COORD (X)
912  `(MAX 1 (FIX (+ .5 (* ARDS-SCR-SCALE (+ 512. ,X))))))
913
914;;; Get a character and punt out of graphics mode if it is a control char or %TD code
915(DEFMACRO ARDS-GET ()
916  '(LET ((X (NVT-NETI)))
917     (IF (OR (< X 100) (> X 177))
918         (*THROW 'ARDS-RETURN
919                 (PROGN (FUNCALL STREAM ':UNTYI X)
920                        (TV:SHEET-SET-CURSORPOS SHEET
921                                                ARDS-SCR-XPOS
922                                                (- ARDS-SCR-YPOS 11.)))))
923     X))
924
925;;; Unpack long and short format coordinates
926(DEFMACRO ARDS-LONG (F)
927  `(LET ((A (ARDS-GET)) (B (ARDS-GET)))
928     ,(IF F '(SETQ ARDS-FLAG (NOT (BIT-TEST B 40))))
929     (* (IF (BIT-TEST A 1) -1 1)
930        (LOGIOR (LSH (LOGAND 77 A) -1) (LSH (LOGAND 37 B) 5)))))
931
932(DEFMACRO ARDS-SHORT ()
933  `(LET ((A (ARDS-GET)))
934     (SETQ ARDS-FLAG T)
935     (* (IF (BIT-TEST A 1) -1 1)
936        (LSH (LOGAND 77 A) -1))))
937
938;;; Draw a vector
939(DEFMACRO ARDS-VECTOR (DX DY)
940  `(LET ((X0 ARDS-XPOS) (Y0 ARDS-YPOS))
941     (SETQ ARDS-XPOS (+ ARDS-XPOS ,DX)
942           ARDS-YPOS (+ ARDS-YPOS ,DY)
943           ARDS-SCR-XPOS (MIN ARDS-MAX-X (+ ARDS-X-OFFSET (ARDS-COORD ARDS-XPOS)))
944           ARDS-SCR-YPOS (MAX ARDS-Y-OFFSET (- ARDS-MAX-Y (ARDS-COORD ARDS-YPOS))))
945     (IF ARDS-FLAG
946         (TV:%DRAW-LINE (MIN ARDS-MAX-X (+ ARDS-X-OFFSET (ARDS-COORD X0)))
947                        (MAX ARDS-Y-OFFSET (- ARDS-MAX-Y (ARDS-COORD Y0)))
948                        ARDS-SCR-XPOS
949                        ARDS-SCR-YPOS
950                        TV:ALU-IOR
951                        T
952                        SHEET))))
953
954(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SUPDUP)
955
956(DEFUN SUPDUP-ARDS-SET (SHEET)
957  (ARDS-LOOP
958    (SETQ ARDS-XPOS (ARDS-LONG T) ARDS-YPOS (ARDS-LONG NIL))
959    (ARDS-VECTOR 0 0)))         ;for plotting points
960
961(DEFUN SUPDUP-ARDS-LONG (SHEET)
962  (ARDS-LOOP (ARDS-VECTOR (ARDS-LONG T) (ARDS-LONG NIL))))
963
964(DEFUN SUPDUP-ARDS-SHORT (SHEET)
965  (ARDS-LOOP (ARDS-VECTOR (ARDS-SHORT) (ARDS-SHORT))))
966
967)
968
969(DEFFLAVOR BASIC-TELNET
970            ((NEW-TELNET-P NIL)
971             (MORE-FLAG NIL)
972             (ECHO-FLAG NIL)
973             (SIMULATE-IMLAC-FLAG NIL))
974            (BASIC-NVT)
975  (:DOCUMENTATION :SPECIAL-PURPOSE "A TELNET NVT")
976  (:SETTABLE-INSTANCE-VARIABLES SIMULATE-IMLAC-FLAG))
977
978(DEFFLAVOR TELNET () (BASIC-TELNET TV:FULL-SCREEN-HACK-MIXIN TV:WINDOW)
979  (:DEFAULT-INIT-PLIST :SAVE-BITS T)
980  (:DOCUMENTATION :COMBINATION))
981
982(DEFUN TELNET (&OPTIONAL (PATH "AI") SIMULATE-IMLAC-P (WINDOW TERMINAL-IO))
983  (WITH-RESOURCE (TV:BIT-ARRAYS BIT-ARRAY)
984   (WITH-RESOURCE (TYPEOUT-PROCESSES TP)
985    (TV:WINDOW-BIND (WINDOW 'TELNET ':TYPEIN-PROCESS CURRENT-PROCESS
986                            ':BIT-ARRAY BIT-ARRAY
987                            ':TYPEOUT-PROCESS TP
988                            ':SIMULATE-IMLAC-FLAG SIMULATE-IMLAC-P)
989      (FUNCALL WINDOW ':CONNECT PATH)
990      (*CATCH 'SI:TOP-LEVEL (FUNCALL WINDOW ':TYPEIN-TOP-LEVEL NIL))
991      (SETF (TV:SHEET-BIT-ARRAY WINDOW) NIL)
992      T))))
993
994(DEFMETHOD (BASIC-TELNET :BEFORE :INIT) (IGNORE)
995  (SETQ TV:LABEL "Telnet -- not connected"))
996
997(DEFMETHOD (BASIC-TELNET :CONNECT) (&OPTIONAL PATH (NET-WINDOW 3))
998  (IF (STRINGP (SETQ PATH (FUNCALL-SELF ':NEW-CONNECTION PATH NET-WINDOW "TELNET" 27)))
999      PATH
1000      (TELNET-ECHO (NOT ECHO-FLAG))))
1001
1002(DEFMETHOD (BASIC-TELNET :GOBBLE-GREETING) ()
1003  (TERPRI SELF))
1004
1005(DEFMETHOD (BASIC-TELNET :AFTER :DISCONNECT) ()
1006  (SETQ ECHO-FLAG NIL NEW-TELNET-P NIL)
1007  (FUNCALL-SELF ':SET-LABEL "Telnet -- not connected"))
1008
1009(DEFVAR TELNET-KEYS (MAKE-ARRAY NIL 'ART-16B 200))
1010(FILLARRAY TELNET-KEYS '(0 100101 100370 100364 ;null, break, clear, call
1011                         0 37 37 177 10 11 12   ;esc, back-next, help, rubout, bs, tab, lf
1012                         13 14 15 21 0          ;vt, form, return, quote, hold-output
1013                         100365 100363 0 100366 ;stop-output, abort, resume, status
1014                         0 0 0 0 0 0 0 0 0 0    ;end, ...
1015                         100101 0))             ;network
1016
1017;;;Convert to NVT ASCII (except don't convert CR to two characters).
1018(DEFMETHOD (BASIC-TELNET :TRANSLATE-INPUT-CHAR) (CH)
1019  (COND ((LISTP CH) CH)
1020        ((= CH #\ESC)
1021         (TV:KBD-ESC)
1022         NIL)
1023        (T
1024         (LET ((CHAR (LDB %%KBD-CHAR CH)))
1025           (AND ECHO-FLAG (FUNCALL SELF ':TYO CHAR))
1026           (AND (LDB-TEST %%KBD-CONTROL CH) (SETQ CHAR (LDB 0005 CH)))  ;controlify
1027           (AND (> CHAR 200) (SETQ CHAR (AREF TELNET-KEYS (- CHAR 200))))
1028           (AND (LDB-TEST %%KBD-META CH) (SETQ CHAR (+ CHAR 200)))
1029           CHAR))))
1030
1031(DEFVAR NVT-IAC 377)
1032(DEFVAR NVT-DONT 376)
1033(DEFVAR NVT-DO 375)
1034(DEFVAR NVT-WONT 374)
1035(DEFVAR NVT-WILL 373)
1036(DEFVAR NVT-SUBNEGOTIATION-BEGIN 372)
1037(DEFVAR NVT-SUBNEGOTIATION-END 360)
1038
1039(DEFVAR NVT-SUPDUP-OUTPUT 26)
1040(DEFVAR NVT-TIMING-MARK 6)
1041(DEFVAR NVT-SUPPRESS-GO-AHEAD 3)
1042(DEFVAR NVT-ECHO 1)
1043(DEFVAR NVT-TRANSMIT-BINARY 0)
1044(DEFVAR NVT-LOGOUT 22)
1045
1046(DEFMETHOD (BASIC-TELNET :NET-OUTPUT) (CH)
1047  (LOCK-OUTPUT
1048    (COND ((LDB-TEST 1701 CH)
1049           (AND NEW-TELNET-P (FUNCALL STREAM ':TYO NVT-IAC))
1050           (SETQ CH (LDB 0010 CH))))
1051    (FUNCALL STREAM ':TYO CH)
1052    (COND ((= CH 15)
1053           (FUNCALL STREAM ':TYO 12))           ;CR is two chars
1054          ((AND (= CH NVT-IAC) NEW-TELNET-P)
1055           (FUNCALL STREAM ':TYO 377)))))       ;IAC's must be quoted
1056
1057(DEFMETHOD (BASIC-TELNET :BUFFERED-TYO) (CH &AUX CH1)
1058  (COND ((= CH NVT-IAC)
1059         (FUNCALL-SELF ':HANDLE-IAC))           ;Perform new telnet negotiations.
1060        (( CH 200))                            ;Ignore otelnet negotiations
1061        ((= CH 7) (TV:BEEP))                    ;^G rings the bell.
1062        ((AND (= CH 15)
1063              (IF (= (SETQ CH1 (NVT-NETI)) 12)  ;CR LF is NVT newline "character"
1064                  NIL                           ;Output normally
1065                  (FUNCALL-SELF ':FORCE-OUTPUT)
1066                  (MULTIPLE-VALUE-BIND (IGNORE Y) (FUNCALL-SELF ':READ-CURSORPOS)
1067                    (FUNCALL-SELF ':SET-CURSORPOS 0 Y))
1068                  (ZEROP CH1))))                ;CR NUL is bare carriage return
1069        ((AND (= CH 177) SIMULATE-IMLAC-FLAG)   ;Escape character
1070         (FUNCALL-SELF ':HANDLE-IMLAC-ESCAPE))
1071        (T
1072         (AND ( CH 10) ( CH 15) ( CH 13)     ;Convert formatting controls
1073              (SETQ CH (+ CH 200)))             ;to Lisp machine char set.
1074         (DO () ((ARRAY-PUSH OUTPUT-BUFFER CH))
1075           (FUNCALL-SELF ':FORCE-OUTPUT)))))
1076
1077;;;New telnet protocol IAC handler
1078(DEFMETHOD (BASIC-TELNET :HANDLE-IAC) (&AUX COMMAND OPTION)
1079  (COND ((NULL NEW-TELNET-P)
1080         (TELNET-SEND-OPTION NVT-DO NVT-ECHO)
1081         (TELNET-SEND-OPTION NVT-DO NVT-SUPPRESS-GO-AHEAD)
1082         (SETQ NEW-TELNET-P T)))
1083  (SETQ COMMAND (NVT-NETI))
1084  (AND ( COMMAND NVT-WILL) ( COMMAND NVT-DONT)
1085       (SETQ OPTION (NVT-NETI)))
1086  (SELECT COMMAND
1087    (NVT-WILL
1088     (SELECT OPTION
1089       (NVT-ECHO
1090        (TELNET-ECHO NIL))
1091       (NVT-SUPPRESS-GO-AHEAD)          ;ignore things we requested
1092       (NVT-TRANSMIT-BINARY
1093        (TELNET-SEND-OPTION NVT-DO OPTION))
1094       (NVT-SUPDUP-OUTPUT
1095        (TELNET-START-SUPDUP-OUTPUT))
1096       (OTHERWISE
1097        (TELNET-SEND-OPTION NVT-DONT OPTION))))
1098    (NVT-DO
1099     (COND ((= OPTION NVT-ECHO) (TELNET-ECHO T))
1100           ((OR (= OPTION NVT-SUPPRESS-GO-AHEAD) (= OPTION NVT-TIMING-MARK))
1101            (TELNET-SEND-OPTION NVT-WILL OPTION))
1102           (T (TELNET-SEND-OPTION NVT-WONT OPTION))))
1103    (NVT-DONT
1104     (COND ((= OPTION NVT-ECHO) (TELNET-ECHO NIL))
1105           ((= OPTION NVT-TRANSMIT-BINARY)
1106            (TELNET-SEND-OPTION NVT-WONT OPTION))))
1107    (NVT-WONT
1108     (COND ((= OPTION NVT-ECHO) (TELNET-ECHO T))
1109           ((= OPTION NVT-TRANSMIT-BINARY)
1110            (TELNET-SEND-OPTION NVT-DONT OPTION))))
1111    (NVT-SUBNEGOTIATION-BEGIN
1112     (TELNET-HANDLE-SUBNEGOTIATION))))
1113
1114(DEFMETHOD (BASIC-TELNET :HANDLE-IMLAC-ESCAPE) (&AUX CH)
1115  (FUNCALL-SELF ':FORCE-OUTPUT)
1116  (SETQ CH (+ (NVT-NETI) 176))
1117  (COND ((= CH 177)
1118         (LET ((SIMULATE-IMLAC-FLAG NIL))
1119           (FUNCALL-SELF ':BUFFERED-TYO CH)))
1120        ((< (SETQ CH (- CH 200)) (ARRAY-LENGTH SUPDUP-%TD-DISPATCH))
1121         (FUNCALL (AREF SUPDUP-%TD-DISPATCH CH) SELF))))
1122
1123(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
1124(DEFUN TELNET-ECHO (ON-P)
1125  (COND ((NEQ ECHO-FLAG ON-P) ;If not the right way already
1126         (SETQ ECHO-FLAG ON-P)
1127         (TELNET-SEND-OPTION (IF ON-P NVT-DO NVT-WILL) NVT-ECHO)))))
1128
1129(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
1130(DEFUN TELNET-SEND-OPTION (COMMAND OPTION)
1131  (LOCK-OUTPUT
1132    (FUNCALL STREAM ':TYO NVT-IAC)
1133    (FUNCALL STREAM ':TYO COMMAND)
1134    (FUNCALL STREAM ':TYO OPTION)
1135    (FUNCALL STREAM ':FORCE-OUTPUT))))
1136
1137(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
1138(DEFUN TELNET-START-SUPDUP-OUTPUT ()
1139  (LOCK-OUTPUT
1140    (FUNCALL STREAM ':TYO NVT-IAC)
1141    (FUNCALL STREAM ':TYO NVT-SUBNEGOTIATION-BEGIN)
1142    (FUNCALL STREAM ':TYO NVT-SUPDUP-OUTPUT)
1143    (FUNCALL STREAM ':TYO 1)
1144    (SEND-TTY-VARIABLES STREAM SELF)
1145    (FUNCALL STREAM ':TYO NVT-IAC)
1146    (FUNCALL STREAM ':TYO NVT-SUBNEGOTIATION-END)
1147    (FUNCALL STREAM ':FORCE-OUTPUT))))
1148
1149(DEFUN TELNET-HANDLE-SUBNEGOTIATION ()
1150  (IF (AND (= (NVT-NETI) NVT-SUPDUP-OUTPUT) (= (NVT-NETI) 2))
1151      (TELNET-SUPDUP-OUTPUT-SUBNEGOTIATION)
1152      (DO ((CH) (STATE)) (NIL)
1153        (SETQ CH (NVT-NETI))
1154        (COND (STATE
1155               (AND (= CH NVT-SUBNEGOTIATION-END)
1156                    (RETURN NIL))
1157               (SETQ STATE NIL))
1158              ((= CH NVT-IAC)
1159               (SETQ STATE T))))))
1160
1161(LOCAL-DECLARE ((SPECIAL SUPDUP-OUTPUT-BYTE-COUNT SUPDUP-OUTPUT-OLD-STREAM))
1162(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-TELNET)
1163(DEFUN TELNET-SUPDUP-OUTPUT-SUBNEGOTIATION ()
1164  (DO ((SUPDUP-OUTPUT-BYTE-COUNT (NVT-NETI))
1165       (SUPDUP-OUTPUT-OLD-STREAM STREAM)
1166       (STREAM 'SUPDUP-OUTPUT-COUNTING-STREAM))
1167      (( SUPDUP-OUTPUT-BYTE-COUNT 0)
1168       (OR (AND (= SUPDUP-OUTPUT-BYTE-COUNT 0)
1169                (NVT-NETI) (NVT-NETI)                   ;We already know the cursor position
1170                (= (NVT-NETI) NVT-IAC) (= (NVT-NETI) NVT-SUBNEGOTIATION-END))
1171           (FERROR NIL "SUPDUP-OUTPUT subnegotiation out of phase")))
1172    (BASIC-SUPDUP-BUFFERED-TYO-METHOD ':BUFFERED-TYO (NVT-NETI)))))
1173
1174(DEFUN SUPDUP-OUTPUT-COUNTING-STREAM (OP &REST ARGS)
1175  (PROG1 (LEXPR-FUNCALL SUPDUP-OUTPUT-OLD-STREAM OP ARGS)
1176         (AND (EQ OP ':TYI)
1177              (SETQ SUPDUP-OUTPUT-BYTE-COUNT (1- SUPDUP-OUTPUT-BYTE-COUNT))))))
1178
1179(DEFMETHOD (BASIC-TELNET :LOGOUT) ()
1180  (TELNET-SEND-OPTION NVT-DO NVT-LOGOUT))
1181
1182(DEFMETHOD (BASIC-TELNET :TOGGLE-IMLAC-SIMULATION) ()
1183  (SETQ SIMULATE-IMLAC-FLAG (NOT SIMULATE-IMLAC-FLAG)))
1184
1185(DEFMETHOD (BASIC-TELNET :MORE-EXCEPTION) ()
1186  (TV:SHEET-MORE-HANDLER ':MORE-TYI))
1187
1188(DEFMETHOD (BASIC-TELNET :MORE-TYI) ()
1189  (SETQ MORE-FLAG T)
1190  (COND ((EQ CURRENT-PROCESS TYPEOUT-PROCESS)
1191         (FUNCALL-SELF ':FORCE-KBD-INPUT '(:MORE))
1192         (PROCESS-WAIT "MORE"
1193                       #'(LAMBDA (LOC) (NOT (CAR LOC)))
1194                       (LOCATE-IN-INSTANCE SELF 'MORE-FLAG)))
1195        (T
1196         (FUNCALL-SELF ':TYI)
1197         (SETQ MORE-FLAG NIL))))
1198
1199(COMPILE-FLAVOR-METHODS SUPDUP TELNET)
Note: See TracBrowser for help on using the browser.