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