1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20 (%include e-macros)
21
22 (declare (*expr Rprinc Rtyo DCTL-standard-set-modes))
23 (declare (special X Y screenheight screenlinelen ospeed given-tty-type))
24 (declare (special idel-lines-availablep idel-chars-availablep tty-type))
25 (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep
26 DCTL-underline-mask))
27 (declare (special region-scroll-availablep scroll-region-top scroll-region-bottom DCTL-insert-mode-on))
28 (declare (special DCTL-oflow-enabled DCTL-have-nonstandard-setmodes))
29
30 (declare (defpl1 not_ascii_ "" (char (*) aligned) (return bit (1) aligned)))
31 (declare (defpl1 vt1xx_ctl_util_$re_enable_oflow ""))
32
33
34
35 (defun vt132-escape macro (form)
36 (list 'Rprinc
37 (apply 'catenate
38 (cons (ItoC 33)
39 (cons "[" (cdr form))))))
40
41
42 (defun DCTL-outdec (n)
43 (let ((have-output))
44 (do digi '(1000. 100. 10. 1) (cdr digi) (null digi)
45 ((lambda (rem)
46 (cond ((or have-output (> rem 0) (= (car digi) 1))
47 (Rtyo (+ 60 rem))
48 (setq have-output t)))
49 (setq n (\ n (car digi))))
50 (// n (car digi))))))
51
52
53
54
55
56 (defun DCTL-pad (n)
57 (or DCTL-oflow-enabled
58 (< ospeed 480.)
59 (do-times (// (* n ospeed) 960.)
60 (Rtyo 0))))
61
62
63
64 (defun DCTL-init ()
65 (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t)
66 (setq DCTL-underline-mask t)
67 (setq idel-lines-availablep t idel-chars-availablep t)
68 (setq region-scroll-availablep t)
69 (setq screenheight 24.)
70 (setq screenlinelen
71 (or (cdr (assq given-tty-type
72 '((vt132 . 131.) (vt132_oflow . 131.)
73 (vt132_80c . 79.) (vt132_80c_oflow . 79.))))
74 131.))
75 (setq DCTL-oflow-enabled (memq given-tty-type '(vt132_oflow vt132_80c_oflow)))
76 (setq tty-type 'vt132)
77 (DCTL-prologue)
78 (DCTL-home-cursor)
79 (DCTL-clear-rest-of-screen))
80
81
82 (defun DCTL-prologue ()
83 (Rtyo 33) (Rprinc "<") (DCTL-pad 20.)
84 (vt132-escape "?4l")
85 (vt132-escape "?6l")
86 (vt132-escape "r")
87 (vt132-escape "4l")
88 (vt132-escape "20l")
89 (cond ((= screenlinelen 131.)
90 (vt132-escape "?3h") (DCTL-pad 122.))
91 (t (vt132-escape "?3l") (DCTL-pad 122.)))
92 (setq scroll-region-top 0 scroll-region-bottom (1- screenheight))
93 (setq DCTL-insert-mode-on nil)
94 (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow)))
95
96
97
98 (defun DCTL-epilogue ()
99 (vt132-escape "r")
100 (vt132-escape "4l")
101 (setq DCTL-insert-mode-on nil))
102
103
104
105
106
107
108 (defun DCTL-position-cursor (x y)
109 (let ((deltax (- x X))
110 (deltay (- y Y)))
111 (cond ((= deltay 0)
112 (cond ((= deltax 0) nil)
113 ((> deltax 0)
114 (vt132-escape)
115 (if (not (= deltax 1)) (DCTL-outdec deltax))
116 (Rprinc "C"))
117 (t (cond ((= x 0) (Rtyo 15) (DCTL-pad (1+ (// X 4))))
118 ((< (- deltax) 4)
119 (do-times (- deltax) (Rtyo 10)))
120 (t (vt132-escape)
121 (DCTL-outdec (- deltax))
122 (Rprinc "D"))))))
123 ((= deltax 0)
124
125 (cond ((or (and (> y scroll-region-bottom)
126 (not (> Y scroll-region-bottom)))
127 (and (< y scroll-region-top)
128 (not (< Y scroll-region-top))))
129 (vt132-absolute-position x y))
130 ((> deltay 0)
131 (cond ((< deltay 4)
132 (do-times deltay (Rtyo 12)))
133 (t (vt132-escape)
134 (DCTL-outdec deltay)
135 (Rprinc "B")))
136 (DCTL-pad (* 2 deltay)))
137 (t (cond ((= deltay -1)
138 (Rtyo 33) (Rprinc "M"))
139 (t (vt132-escape)
140 (DCTL-outdec (- deltay))
141 (Rprinc "A")))
142 (DCTL-pad (* 2 (1+ (- deltay)))))))
143 (t (vt132-absolute-position x y)))
144 (setq X x Y y)))
145
146
147
148 (defun vt132-absolute-position (x y)
149 (vt132-escape)
150 (if (not (= y 0))
151 (DCTL-outdec (1+ y)))
152 (if (not (= x 0))
153 (Rprinc ";")
154 (DCTL-outdec (1+ x)))
155 (Rprinc "H")
156 (DCTL-pad (* 2 (+ (abs (- Y y)) (// (abs (- X x)) 4) 1))))
157
158
159
160 (defun DCTL-display-char-string (string)
161 (let ((strx (stringlength string)))
162 (cond ((= strx 0))
163 (t (cond (DCTL-insert-mode-on
164 (setq DCTL-insert-mode-on nil)
165 (vt132-escape "4l") (DCTL-pad 10.)))
166 (DCTL-output-underlined-string string)
167 (setq X (+ X strx))))))
168
169 (defun DCTL-output-underlined-string (string)
170 (cond ((zerop (not_ascii_ string))
171 (Rprinc string))
172 (t (let ((un nil))
173 (mapc
174 '(lambda (ch)
175 (cond ((< (CtoI ch) 400)
176 (and un
177 (vt132-escape "m"))
178 (setq un nil)
179 (Rprinc ch))
180 (t
181 (or un (vt132-escape "4m"))
182 (setq un t)
183 (Rtyo (- (CtoI ch) 400)))))
184 (explodec string))
185 (and un (vt132-escape "m"))))))
186
187
188 (defun DCTL-home-cursor ()
189 (setq X 0 Y 0)
190 (vt132-escape H) (DCTL-pad 10.))
191
192
193 (defun DCTL-clear-rest-of-screen ()
194 (vt132-escape J) (DCTL-pad 60.))
195
196
197
198 (defun DCTL-kill-line ()
199 (vt132-escape K) (DCTL-pad 5))
200
201
202
203
204 (defun DCTL-define-scroll-region (top bottom)
205 (cond ((and (= top scroll-region-top) (= bottom scroll-region-bottom)))
206 (t (setq scroll-region-top top scroll-region-bottom bottom)
207 (Rtyo 33) (Rprinc "7")
208 (Rtyo 33) (Rprinc "[")
209 (cond ((not (= top 0))
210 (DCTL-outdec (1+ top))))
211 (cond ((not (= bottom (1- screenheight)))
212 (Rprinc ";")
213 (DCTL-outdec (1+ bottom))))
214 (Rprinc "r")
215 (Rtyo 33) (Rprinc "8")
216 (DCTL-pad 25.))))
217
218
219
220 (defun DCTL-insert-lines (n)
221 (DCTL-scroll-down-region n (1- screenheight)))
222
223
224
225 (defun DCTL-delete-lines (n)
226 (DCTL-scroll-up-region n (1- screenheight)))
227
228
229
230 (defun DCTL-scroll-up-region (nlines bottom)
231 (DCTL-define-scroll-region Y bottom)
232 (let ((oldy Y))
233 (Rtyo 33) (Rprinc "7")
234 (DCTL-position-cursor 0 bottom)
235 (do-times nlines
236 (Rtyo 12) (DCTL-pad 45.))
237 (Rtyo 33) (Rprinc "8")
238 (setq Y oldy)))
239
240
241 (defun DCTL-scroll-down-region (nlines bottom)
242 (DCTL-define-scroll-region Y bottom)
243 (do-times nlines
244 (Rtyo 33) (Rprinc 'M) (DCTL-pad 45.)))
245
246
247
248 (defun DCTL-insert-char-string (string)
249 (cond (DCTL-insert-mode-on)
250 (t
251 (setq DCTL-insert-mode-on t)
252 (vt132-escape "4h")))
253 (DCTL-output-underlined-string string)
254 (setq X (+ X (stringlength string)))
255 (DCTL-pad (max (* 2 (stringlength string)) (- screenlinelen X))))
256
257
258
259 (defun DCTL-delete-chars (n)
260 (vt132-escape)
261 (and (> n 1) (DCTL-outdec n))
262 (Rprinc "P")
263 (DCTL-pad (* 7 n)))
264
265
266
267 (or (and (boundp 'DCTL-have-nonstandard-setmodes)
268 DCTL-have-nonstandard-setmodes)
269 (progn (putprop 'DCTL-standard-set-modes
270 (get 'e_pl1_$set_emacs_tty_modes 'subr)
271 'subr)
272 (setq DCTL-have-nonstandard-setmodes t)))
273
274 (defun e_pl1_$set_emacs_tty_modes ()
275 (DCTL-standard-set-modes)
276 (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow)))
277
278 (setq DCTL-oflow-enabled nil)
279
280
281
282 (cond ((status feature Emacs)
283 (load (list (car (namelist (truename infile))) "vt1xx_keys_"))))