1 ;;; ******************************************************
  2 ;;; *                                                    *
  3 ;;; *                                                    *
  4 ;;; * Copyright (c) 1978 by Massachusetts Institute of   *
  5 ;;; * Technology and Honeywell Information Systems, Inc. *
  6 ;;; *                                                    *
  7 ;;; *                                                    *
  8 ;;; ******************************************************
  9 ;;;
 10 ;;;
 11 ;;;       VT102 control package
 12 ;;;        Created:  20 May 1983 by B. Margolin from VT132 CTL
 13 ;;;        Modified: 2 November 1984 by B. Margolin to remove unexecuted
 14 ;;;                  forms from DCTL-clear-rest-of-screen and DCTL-kill-line.
 15 ;;;
 16 
 17 (%include e-macros)
 18 
 19 (declare (*expr Rprinc Rtyo DCTL-standard-set-modes))
 20 (declare (special X Y screenheight screenlinelen ospeed given-tty-type))
 21 (declare (special idel-lines-availablep idel-chars-availablep tty-type))
 22 (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep
 23                   DCTL-underline-mask))
 24 (declare (special region-scroll-availablep scroll-region-top scroll-region-bottom DCTL-insert-mode-on))
 25 (declare (special DCTL-oflow-enabled DCTL-have-nonstandard-setmodes))
 26 
 27 (declare (defpl1 not_ascii_ "" (char (*) aligned) (return bit (1) aligned)))
 28 (declare (defpl1 vt1xx_ctl_util_$re_enable_oflow ""))
 29 
 30 
 31 ;;; Macro to output escape sequence
 32 (defun vt102-escape macro (form)
 33        (list 'Rprinc
 34              (apply 'catenate
 35                     (cons (ItoC 33)
 36                           (cons "[" (cdr form))))))
 37 
 38 ;;; Output n to the terminal in decimal.
 39 (defun DCTL-outdec (n)                            ;BSG 3/23/79
 40        (let ((have-output))
 41             (do digi '(1000. 100. 10. 1) (cdr digi) (null digi)
 42                 ((lambda (rem)
 43                          (cond ((or have-output (> rem 0) (= (car digi) 1))
 44                                 (Rtyo (+ 60 rem))
 45                                 (setq have-output t)))
 46                          (setq n (\ n (car digi))))
 47                  (// n (car digi))))))
 48 
 49 
 50 ;;; Output padding, based on n pad characters at 9600-baud
 51 (defun DCTL-pad (n)
 52        (or DCTL-oflow-enabled                     ;flow control should do it
 53            (do-times (// (* n ospeed) 960.)
 54                      (Rtyo 0))))
 55 
 56 
 57 ;;; Initialize terminal and terminal control package.
 58 (defun DCTL-init ()
 59        (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t)
 60        (setq DCTL-underline-mask t)
 61        (setq idel-lines-availablep t idel-chars-availablep t)
 62        (setq region-scroll-availablep t)
 63        (setq screenheight 24.)
 64        (setq screenlinelen
 65              (or (cdr (assq given-tty-type
 66                             '((vt102 . 79.) (vt102_oflow . 79.)
 67                               (vt102_80c . 79.) (vt102_80c_oflow . 79.)
 68                               (vt102_132c . 131.) (vt102_132c_oflow . 131.))))
 69                  131.))                           ;default to 132 wide
 70        (setq DCTL-oflow-enabled
 71              (memq given-tty-type
 72                    '(vt102_oflow vt102_80c_oflow vt102_132c_oflow)))
 73        (setq tty-type 'vt102)
 74        (DCTL-prologue)
 75        (DCTL-home-cursor)
 76        (DCTL-clear-rest-of-screen))
 77 
 78 ;;; Initialization that must also be done after a QUIT
 79 (defun DCTL-prologue ()
 80        (Rtyo 33) (Rprinc "<")                     ;set ANSI mode from VT52 mode
 81        (vt102-escape "?4l")                       ;reset scroll mode (jump)
 82        (vt102-escape "?6l")                       ;reset absolute origin mode
 83        (vt102-escape "r")                         ;reset scroll region
 84        (vt102-escape "4l")                        ;reset insert mode
 85        (vt102-escape "20l")                       ;turn off auto-CRLF
 86        (cond ((= screenlinelen 131.)              ;set proper screen width
 87               (vt102-escape "?3h"))
 88              (t (vt102-escape "?3l")))
 89        (DCTL-pad 102.)
 90        (setq scroll-region-top 0 scroll-region-bottom (1- screenheight))
 91        (setq DCTL-insert-mode-on nil)
 92        (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow)))
 93 
 94 
 95 ;;; Restore terminal to outside state
 96 (defun DCTL-epilogue ()
 97        (vt102-escape "r")                         ;reset scroll region
 98        (vt102-escape "4l")                        ;reset insert mode
 99        (DCTL-pad 4)
100        (setq DCTL-insert-mode-on nil))
101 
102 
103 ;;; Move terminal's cursor to desired position.
104 ;;;   Relative cursor movement commands are confined to the current scrolling region.  Absolute movement commands can
105 ;;;   address the entire screen if if Origin Mode is reset.  Missing arguments in the absolute positioning command default
106 ;;;   to one.  Relative commands can be used if the scroll boundaries are examined.
107 (defun DCTL-position-cursor (x y)
108        (let ((deltax (- x X))
109              (deltay (- y Y)))
110             (cond ((= deltay 0)
111                    (cond ((= deltax 0) nil)
112                          ((> deltax 0)            ;move right
113                           (vt102-escape)
114                           (if (not (= deltax 1)) (DCTL-outdec deltax))
115                           (Rprinc "C"))
116                          (t (cond ((= x 0) (Rtyo 15) (DCTL-pad (1+ (// X 4))))  ;move left
117                                   ((< (- deltax) 4)
118                                    (do-times (- deltax) (Rtyo 10)))
119                                   (t (vt102-escape)
120                                      (DCTL-outdec (- deltax))
121                                      (Rprinc "D"))))))
122                   ((= deltax 0)
123                    ;;make sure scroll region doesn't screw us.
124                    (cond ((or (and (> y scroll-region-bottom)
125                                    (not (> Y scroll-region-bottom)))
126                               (and (< y scroll-region-top)
127                                    (not (< Y scroll-region-top))))
128                           (vt102-absolute-position x y))
129                          ((> deltay 0)            ;move down
130                           (cond ((< deltay 4)
131                                  (do-times deltay (Rtyo 12)))
132                                 (t (vt102-escape)
133                                    (DCTL-outdec deltay)
134                                    (Rprinc "B"))))
135                          (t (cond ((= deltay -1)  ;move up
136                                    (Rtyo 33) (Rprinc "M"))
137                                   (t (vt102-escape)
138                                      (DCTL-outdec (- deltay))
139                                      (Rprinc "A"))))))
140                   (t (vt102-absolute-position x y)))
141             (setq X x Y y)))
142 
143 
144 ;;; Perform absolute cursor positioning
145 (defun vt102-absolute-position (x y)
146        (vt102-escape)
147        (if (not (= y 0))
148            (DCTL-outdec (1+ y)))
149        (if (not (= x 0))
150            (Rprinc ";")
151            (DCTL-outdec (1+ x)))
152        (Rprinc "H"))
153 
154 
155 ;;; Output string.
156 (defun DCTL-display-char-string (string)
157        (let ((strx (stringlength string)))
158             (cond ((= strx 0))                    ;bug in redisplay calls with no string
159                   (t (cond (DCTL-insert-mode-on
160                              (setq DCTL-insert-mode-on nil)
161                              (vt102-escape "4l") (DCTL-pad 1.)))      ;reset insert mode
162                      (DCTL-output-underlined-string string)
163                      (setq X (+ X strx))))))
164 
165 (defun DCTL-output-underlined-string (string)
166        (cond ((zerop (not_ascii_ string))         ;optimize standard string
167               (Rprinc string))
168              (t (let ((un nil))
169                      (mapc
170                        '(lambda (ch)
171                                 (cond ((< (CtoI ch) 400)    ;normal char
172                                        (and un
173                                             (vt102-escape "m"))       ;out of underline mode
174                                        (setq un nil)
175                                        (Rprinc ch))
176                                       (t          ;underlined char (400-bit set)
177                                         (or un (vt102-escape "4m"))
178                                         (setq un t)
179                                         (Rtyo (- (CtoI ch) 400)))))
180                        (explodec string))
181                      (and un (vt102-escape "m"))))))
182 
183 ;;; Home cursor to upper left corner.
184 (defun DCTL-home-cursor ()
185        (setq X 0 Y 0)
186        (vt102-escape H))
187 
188 ;;; Clear to end of screen.
189 (defun DCTL-clear-rest-of-screen ()
190        (vt102-escape J))
191 
192 ;;; Clear to end of line.
193 (defun DCTL-kill-line ()
194        (vt102-escape K))
195 
196 ;;; Define the bounds of the scroll region.  Relative cursor
197 ;;; movement can only be done within this region.
198 (defun DCTL-define-scroll-region (top bottom)
199        (cond ((and (= top scroll-region-top) (= bottom scroll-region-bottom)))
200              (t (setq scroll-region-top top scroll-region-bottom bottom)
201                 (Rtyo 33) (Rprinc "7")            ;push cursor position
202                 (Rtyo 33) (Rprinc "[")            ;redefine scroll region (homes)
203                 (cond ((not (= top 0))
204                        (DCTL-outdec (1+ top))))
205                 (cond ((not (= bottom (1- screenheight)))
206                        (Rprinc ";")
207                        (DCTL-outdec (1+ bottom))))
208                 (Rprinc "r")
209                 (Rtyo 33) (Rprinc "8")  ;pop cursor position
210                 (DCTL-pad 5.))))
211 
212 
213 ;;; Insert n lines at the current cursor position
214 (defun DCTL-insert-lines (n)
215        (DCTL-scroll-down-region n (1- screenheight)))
216 
217 
218 ;;; Delete n lines at the current cursor position
219 (defun DCTL-delete-lines (n)
220        (DCTL-scroll-up-region n (1- screenheight)))
221 
222 
223 ;;; Move text in scroll region up n lines (inserts whitespace at bottom)
224 (defun DCTL-scroll-up-region (nlines bottom)
225        (DCTL-define-scroll-region Y bottom)
226        (let ((oldy Y))
227             (Rtyo 33) (Rprinc "7")                ;save cursor position
228             (DCTL-position-cursor 0 bottom)
229             (do-times nlines
230                       (Rtyo 12) (DCTL-pad 100.))
231             (Rtyo 33) (Rprinc "8")
232             (setq Y oldy)))
233 
234 ;;; Move text in scroll region down n lines (inserts whitespace at top)
235 (defun DCTL-scroll-down-region (nlines bottom)
236        (DCTL-define-scroll-region Y bottom)
237        (do-times nlines
238                  (Rtyo 33) (Rprinc 'M) (DCTL-pad 100.)))
239 
240 
241 ;;; Insert the given text at the cursor
242 (defun DCTL-insert-char-string (string)
243        (cond (DCTL-insert-mode-on)
244              (t
245                (setq DCTL-insert-mode-on t)
246                (vt102-escape "4h")))              ;turn on insert mode
247        (DCTL-output-underlined-string string)
248        (setq X (+ X (stringlength string)))
249        (DCTL-pad (stringlength string)))
250 
251 
252 ;;; Delete N characters at the cursor
253 (defun DCTL-delete-chars (n)
254        (vt102-escape)
255        (and (> n 1) (DCTL-outdec n))
256        (Rprinc "P")
257        (DCTL-pad n))
258 
259 
260 ;;; Replacement for e_pl1_$set_emacs_tty_modes that enables oflow if necessary
261 (or (and (boundp 'DCTL-have-nonstandard-setmodes)
262          DCTL-have-nonstandard-setmodes)
263     (progn (putprop 'DCTL-standard-set-modes
264                     (get 'e_pl1_$set_emacs_tty_modes 'subr)
265                     'subr)
266            (setq DCTL-have-nonstandard-setmodes t)))
267 
268 (defun e_pl1_$set_emacs_tty_modes ()
269        (DCTL-standard-set-modes)
270        (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow)))
271 
272 (setq DCTL-oflow-enabled nil)                     ;above gets called once before DCTL-init
273 
274 
275 ;;; Load in special key definitions for VT1XX terminals
276 (cond ((status feature Emacs)                     ;but only in Emacs
277        (load (list (car (namelist (truename infile))) "vt1xx_keys_"))))