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