Context Navigation

supdup.lisp @ 222

Revision 222, 44.3 KB (checked in by rjs, 22 months 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,
237	you can type these commands:~%" ESCAPE-CHAR)
238	(FORMAT SELF "
239	CALL -- Do a local CALL (return to top window).
240	B -- Enter a breakpoint.
241	C -- Change the SUPDUP escape character.
242	D -- Disconnect and connect to new host.
243	L -- Log out of remote host, and break the connection.
244	P -- Return to top window, but don't break connection.
245	Q -- Disconnect and return to top window.
246	~:[~;M -- Toggle more processing.
247	I -- 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.

Download in other formats:

Original Format