1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22 (declare (eval (read)))
23 (do x (read)(read)(eq x 'applesauce)(eval x))
24
25 (setsyntax '% 'macro 'DCTL-tdcode-macro)
26
27 (setq DCTL-tdcode-list '(
28
29 TDEOF 202
30 TDEOL 203
31 TDNOP 210
32 TDMV0 217
33 TDMOV 200
34 TDCLR 220
35 TDBEL 221
36 TDILP 223
37 TDDLP 224
38 TDICP 225
39 TDDCP 226
40 ))
41
42 (do x DCTL-tdcode-list (cddr x)(null x)(putprop (car x)(cadr x) 'tdcode))
43 (defun cana macro (x)
44 (list 'not (list 'zerop (list 'boole 1 (cadr x)(caddr x)))))
45
46 (defun DCTL-tdcode-macro ()
47 (or (get (read) 'tdcode)
48 (error "Undefined tdcode")))
49
50 applesauce
51
52
53 (declare (special X Y screenheight tty-no-upmotionp screenlinelen tty-type overstrike-availablep e-quit-transparency))
54 (declare (special DCTL-ttyopt-word DCTL-aobjn-count))
55 (declare (special idel-lines-availablep idel-chars-availablep))
56
57
58
59
60 (defun DCTL-init ()
61 (Rprinc "Multics EMACS Supdup Server")
62 (Rtyo 15)(Rtyo 12)
63 (e_pl1_$dump_output_buffer)
64 (setq DCTL-aobjn-count (lsh (- (DCTL-get-supdup-36-word)) -18.))
65 (DCTL-get-supdup-36-word)
66 (setq DCTL-ttyopt-word (DCTL-get-supdup-36-word))
67 (setq screenheight (DCTL-get-supdup-36-word))
68 (setq screenheight (min 64. screenheight))
69 (setq screenlinelen (DCTL-get-supdup-36-word))
70 (DCTL-get-supdup-36-word)
71 (setq DCTL-aobjn-count (- DCTL-aobjn-count 5))
72 (do ()((= DCTL-aobjn-count 0))
73 (setq DCTL-aobjn-count (1- DCTL-aobjn-count))
74 (DCTL-get-supdup-36-word))
75 (setq idel-chars-availablep (cana DCTL-ttyopt-word 000001000000))
76 (setq idel-lines-availablep (cana DCTL-ttyopt-word 000002000000))
77 (setq overstrike-availablep (cana DCTL-ttyopt-word 001000000000))
78 (setq tty-no-upmotionp (not (cana DCTL-ttyopt-word 000400000000)))
79 (setq tty-type 'supdup)
80 (Rtyo %TDNOP)
81 (set-permanent-key '^\ 'supdup-ITP-escape)
82 (set-permanent-key 'esc-@ 'supdup-300-escape)
83 (setq X -777 Y -777)
84 (DCTL-position-cursor 0 0)
85 (DCTL-clear-rest-of-screen))
86
87 (defun DCTL-get-supdup-36-word ()
88 (do ((w 0 (+ (lsh w 6) b))
89 (b)
90 (i 1 (1+ i)))
91 ((> i 6) w)
92
93 (setq b (DCTL-gnz-char)))))))
94
95
96 (defun DCTL-assert-scpos (x y)
97 (and x (setq X x))
98 (and y (setq Y y))
99 (DCTL-tdmov X Y X Y))
100
101 (defun DCTL-nextline ()
102 (cond ((or (< X 0)(< Y 0))
103 (DCTL-position-cursor 0 0))
104 ((= Y (1- screenheight))
105 (DCTL-position-cursor X 0))
106 (t (DCTL-position-cursor X (1+ Y))
107 (DCTL-assert-scpos nil (1- Y)))))
108
109
110
111
112
113
114
115
116 (defun DCTL-position-cursor (x y)
117 (cond ((and (= x X)(= y Y)))
118 ((not tty-no-upmotionp)(DCTL-real-position-cursor x y))
119 ((or (< X 0)(< Y 0))
120 (DCTL-tdmov 50 0 0 1)
121 (DCTL-tdmov 0 0 x y))
122 ((= Y y)(DCTL-real-position-cursor x y))
123 ((= y 0)(DCTL-tdmov X 0 X 1)
124 (DCTL-tdmov X y x y))
125 (t (DCTL-tdmov X (1- y) x y))))
126
127
128 (defun DCTL-tdmov (oldx oldy newx newy)
129 (setq X newx Y newy)
130 (Rtyo %TDMOV)
131 (Rtyo oldy)
132 (Rtyo oldx)
133 (Rtyo newy)
134 (Rtyo newx))
135
136
137
138
139 (defun DCTL-real-position-cursor (x y)
140 (Rtyo %TDMV0)
141 (Rtyo y)
142 (Rtyo x)
143 (setq X x Y y))
144
145
146 (defun DCTL-ring-tty-bell ()
147 (Rtyo %TDBEL))
148
149 (defprop supdup t tintinnabulum-ipsum-meum-sono)
150
151
152 (defun DCTL-display-char-string (string)
153 ((lambda (len)
154 (setq X (+ X len))
155 (Rprinc string))
156 (stringlength string)))
157
158
159 (defun DCTL-clear-rest-of-screen ()
160 (cond (tty-no-upmotionp (DCTL-nextline))
161 (t (Rtyo %TDEOF))))
162
163
164 (defun DCTL-nextline ()
165 (cond ((= Y (1- screenheight))
166 (DCTL-position-cursor X 0))
167 (t (DCTL-position-cursor X (1+ Y)))))
168
169
170
171 (defun DCTL-kill-line ()
172 (Rtyo %TDEOL))
173
174
175 (defun DCTL-insert-char-string (str)
176 ((lambda (len)
177 (Rtyo %TDICP)
178 (Rtyo len)
179 (Rprinc str)
180 (setq X (+ X len)))
181 (stringlength str)))
182
183
184 (defun DCTL-delete-chars (n)
185 (Rtyo %TDDCP)
186 (Rtyo n))
187
188
189 (defun DCTL-insert-lines (n)
190 (Rtyo %TDILP)
191 (Rtyo n))
192
193
194
195 (defun DCTL-delete-lines (n)
196 (Rtyo %TDDLP)
197 (Rtyo n))
198
199
200
201 (defun DCTL-gnz-char ()
202 (do x (e_pl1_$get_char)(e_pl1_$get_char) nil
203 (cond ((= x 377)((lambda (e-quit-transparency) (telnet-loser (DCTL-gnz-char))) 'leave-it)(setq x -1)))
204 (or (< x 0)(return x))))
205
206 (defun supdup-300-escape ()
207 ((lambda (c)
208 (cond ((= c 301)(quit))
209 ((= c 302)(do x (DCTL-gnz-char)(DCTL-gnz-char)(= x 0)))
210 (t () )))
211 (DCTL-gnz-char)))
212
213 (defun supdup-ITP-escape ()
214 (real-supdup-ITP-escape (DCTL-gnz-char)))
215
216 (defun real-supdup-ITP-escape (c)
217 (cond ((= c 34))
218 ((= c 003)
219 (do ()(nil)
220 ((lambda (d)
221 (cond ((= d 34)((lambda(e)
222 (cond ((= e 003))
223 (t (real-supdup-ITP-escape e))))
224 (DCTL-gnz-char)))
225 (t (full-redisplay)
226 (process-char d)
227 (return nil))))
228 (DCTL-gnz-char))))
229 ((= c 020)
230 (setq Y (DCTL-gnz-char) X (DCTL-gnz-char)))
231 (t ((lambda (d)
232 (setq c (boole 1 3 c))
233 (and (cana d 1)(setq d (- d 100)))
234 (xec-cmd-triplet (lsh c -1) d nil))
235 (DCTL-gnz-char)))))