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