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 ;;;       VT132 control package
 12 ;;;        Created:  24 April 1980 by G. Palter from VT132P CTL
 13 ;;;        Modified: 11 March 1981 by G. Palter for new terminal types and to
 14 ;;;                     support flow control
 15 ;;;        Modified: 20 August 1982 by B. Margolin to copy CAH's underlining
 16 ;;;                     code from vt100 CTL
 17 ;;;        Modified: 12 October 1982 by B. Margolin for slight underline change
 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 ;;; Macro to output escape sequence
 35 (defun vt132-escape macro (form)
 36        (list 'Rprinc
 37              (apply 'catenate
 38                     (cons (ItoC 33)
 39                           (cons "[" (cdr form))))))
 40 
 41 ;;; Output n to the terminal in decimal.
 42 (defun DCTL-outdec (n)                            ;BSG 3/23/79
 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 ;;; Output padding, based on n pad characters at 9600-baud
 54 ;;;  (Padding is sent only if flow control is disabled and the line speed is
 55 ;;;   at least 4800 baud)
 56 (defun DCTL-pad (n)
 57        (or DCTL-oflow-enabled                     ;flow control should do it
 58            (< ospeed 480.)                        ;terminal not running hard
 59            (do-times (// (* n ospeed) 960.)
 60                      (Rtyo 0))))
 61 
 62 
 63 ;;; Initialize terminal and terminal control package.
 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.))                           ;default to 132 wide
 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 ;;; Initialization that must also be done after a QUIT
 82 (defun DCTL-prologue ()
 83        (Rtyo 33) (Rprinc "<") (DCTL-pad 20.)      ;set ANSI mode from VT52 mode
 84        (vt132-escape "?4l")                       ;reset scroll mode (jump)
 85        (vt132-escape "?6l")                       ;reset absolute origin mode
 86        (vt132-escape "r")                         ;reset scroll region
 87        (vt132-escape "4l")                        ;reset insert mode
 88        (vt132-escape "20l")                       ;turn off auto-CRLF
 89        (cond ((= screenlinelen 131.)              ;set proper screen width
 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 ;;; Restore terminal to outside state
 98 (defun DCTL-epilogue ()
 99        (vt132-escape "r")                         ;reset scroll region
100        (vt132-escape "4l")                        ;reset insert mode
101        (setq DCTL-insert-mode-on nil))
102 
103 
104 ;;; Move terminal's cursor to desired position.
105 ;;;   Relative cursor movement commands are confined to the current scrolling region.  Absolute movement commands can
106 ;;;   address the entire screen if if Origin Mode is reset.  Missing arguments in the absolute positioning command default
107 ;;;   to one.  Relative commands can be used if the scroll boundaries are examined.
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)            ;move right
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))))  ;move left
118                                   ((< (- deltax) 4)
119                                    (do-times (- deltax) (Rtyo 10)))
120                                   (t (vt132-escape)
121                                      (DCTL-outdec (- deltax))
122                                      (Rprinc "D"))))))
123                   ((= deltax 0)
124                    ;;make sure scroll region doesn't screw us.
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)            ;move down
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)  ;move up
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 ;;; Perform absolute cursor positioning
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 ;;; Output string.
160 (defun DCTL-display-char-string (string)
161        (let ((strx (stringlength string)))
162             (cond ((= strx 0))                    ;bug in redisplay calls with no string
163                   (t (cond (DCTL-insert-mode-on
164                              (setq DCTL-insert-mode-on nil)
165                              (vt132-escape "4l") (DCTL-pad 10.)))     ;reset insert mode
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))         ;optimize standard string
171               (Rprinc string))
172              (t (let ((un nil))
173                      (mapc
174                        '(lambda (ch)
175                                 (cond ((< (CtoI ch) 400)    ;normal char
176                                        (and un
177                                             (vt132-escape "m"))       ;out of underline mode
178                                        (setq un nil)
179                                        (Rprinc ch))
180                                       (t          ;underlined char (400-bit set)
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 ;;; Home cursor to upper left corner.
188 (defun DCTL-home-cursor ()
189        (setq X 0 Y 0)
190        (vt132-escape H) (DCTL-pad 10.))
191 
192 ;;; Clear to end of screen.
193 (defun DCTL-clear-rest-of-screen ()
194        (vt132-escape J) (DCTL-pad 60.))
195 
196 
197 ;;; Clear to end of line.
198 (defun DCTL-kill-line ()
199        (vt132-escape K) (DCTL-pad 5))
200 
201 
202 ;;; Define the bounds of the scroll region.  Relative cursor
203 ;;; movement can only be done within this region.
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")            ;push cursor position
208                 (Rtyo 33) (Rprinc "[")            ;redefine scroll region (homes)
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.))))       ;pop cursor position
217 
218 
219 ;;; Insert n lines at the current cursor position
220 (defun DCTL-insert-lines (n)
221        (DCTL-scroll-down-region n (1- screenheight)))
222 
223 
224 ;;; Delete n lines at the current cursor position
225 (defun DCTL-delete-lines (n)
226        (DCTL-scroll-up-region n (1- screenheight)))
227 
228 
229 ;;; Move text in scroll region up n lines (inserts whitespace at bottom)
230 (defun DCTL-scroll-up-region (nlines bottom)
231        (DCTL-define-scroll-region Y bottom)
232        (let ((oldy Y))
233             (Rtyo 33) (Rprinc "7")                ;save cursor position
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 ;;; Move text in scroll region down n lines (inserts whitespace at top)
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 ;;; Insert the given text at the cursor
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")))              ;turn on insert mode
253        (DCTL-output-underlined-string string)
254        (setq X (+ X (stringlength string)))
255        (DCTL-pad (max (* 2 (stringlength string)) (- screenlinelen X))))
256 
257 
258 ;;; Delete N characters at the cursor
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 ;;; Replacement for e_pl1_$set_emacs_tty_modes that enables oflow if necessary
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)                     ;above gets called once before DCTL-init
279 
280 
281 ;;; Load in special key definitions for VT1XX terminals
282 (cond ((status feature Emacs)                     ;but only in Emacs
283        (load (list (car (namelist (truename infile))) "vt1xx_keys_"))))