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 ;;;       VT-100 control package
 12 ;;;       CWH 3/17/79
 13 ;;;       Hacked for 3/31/79 redisplay on that day by BSG.
 14 ;;;       Modified 06/01/79 by GMP to use paddings specified in VT100 manual
 15 ;;;        with modifications as specified by CBF, and to make resetting of
 16 ;;;        terminal attributes work.
 17 ;;;       Modified 06/18/79 by GMP to reduce padding on scrolling.
 18 ;;;       Modified 06/20/79 by GMP to fix minor bugs and use new
 19 ;;;        epilogue/prologue mechanism.
 20 ;;;       Modified 06/30/79 by GMP to fix bug in DCTL-outdec that caused
 21 ;;;        failures when in 132 column mode
 22 ;;;       Modified 08/14/79 by GMP to turn off smooth scroll on entrace
 23 ;;;        and reduce padding requirements accordingly
 24 ;;;       Modified 26 September 1980 by GMP to pad at 4800-baud
 25 ;;;       Modified: 11 March 1981 by G. Palter for new terminal types and to
 26 ;;;                    support flow control
 27 ;;;       Modified August 1982 by C. Hornig for underlining.
 28 ;;;       Modified October 1982 by B. Margolin slight underlining change
 29 
 30 (%include e-macros)
 31 
 32 (declare (*expr Rprinc Rtyo DCTL-standard-set-modes))
 33 (declare (special X Y screenheight screenlinelen ospeed given-tty-type))
 34 (declare (special idel-lines-availablep idel-chars-availablep tty-type))
 35 (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep
 36                   DCTL-underline-mask))
 37 (declare (special region-scroll-availablep scroll-region-top
 38                   scroll-region-bottom))
 39 (declare (special DCTL-oflow-enabled DCTL-have-nonstandard-setmodes))
 40 
 41 (declare (defpl1 not_ascii_ "" (char (*) aligned) (return bit (1) aligned)))
 42 (declare (defpl1 vt1xx_ctl_util_$re_enable_oflow ""))
 43 
 44 
 45 ;;; Macro to output escape sequence
 46 (defun vt100-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, based on n pad characters at 9600-baud
 66 ;;;  (Padding is sent only if flow control is disabled and the line speed is
 67 ;;;   at least 4800 baud)
 68 (defun DCTL-pad (n)
 69        (or DCTL-oflow-enabled                     ;flow control should do it
 70            (< ospeed 480.)                        ;terminal not running hard
 71            (do-times (// (* n ospeed) 960.)
 72                      (Rtyo 0))))
 73 
 74 
 75 ;;; Initialize terminal and terminal control package.
 76 (defun DCTL-init ()
 77        (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t)
 78        (setq DCTL-underline-mask t)
 79        (setq idel-lines-availablep t idel-chars-availablep nil)
 80        (setq region-scroll-availablep t)
 81        (setq screenheight
 82              (or (cdr (assq given-tty-type
 83                             '((vt100 . 24.) (vt100fc . 24.) (vt100ws . 14.)
 84                               (vt100w . 24.) (vt100wfc . 24.))))
 85                  24.))                            ;default to 24 high
 86        (setq screenlinelen
 87              (or (cdr (assq given-tty-type
 88                             '((vt100 . 79.) (vt100fc . 79.) (vt100ws . 131.)
 89                               (vt100w . 131.) (vt100wfc . 131.))))
 90                  79.))                            ;default to 80 wide
 91        (setq DCTL-oflow-enabled (memq given-tty-type '(vt100fc vt100wfc)))
 92        (setq tty-type 'vt100)
 93        (DCTL-prologue)
 94        (DCTL-home-cursor)
 95        (DCTL-clear-rest-of-screen))
 96 
 97 ;;; Initialization that must also be done after a QUIT
 98 (defun DCTL-prologue ()
 99        (Rtyo 33) (Rprinc "<") (DCTL-pad 20.)      ;set ANSI mode from VT52 mode
100        (vt100-escape "?4l")                       ;reset scroll mode (jump)
101        (vt100-escape "?6l")                       ;reset absolute origin mode
102        (vt100-escape "r")                         ;reset scroll region
103        (setq scroll-region-top 0 scroll-region-bottom (1- screenheight))
104        (vt100-escape "20l")                       ;turn off auto-CRLF
105        (cond ((= screenlinelen 131.)              ;set proper screen width
106               (vt100-escape "?3h") (DCTL-pad 122.))
107              (t (vt100-escape "?3l") (DCTL-pad 122.)))
108        (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow)))
109 
110 
111 ;;; Restore terminal to outside state
112 (defun DCTL-epilogue ()
113        (vt100-escape "r"))                        ;reset scroll region
114 
115 
116 ;;; Move terminal's cursor to desired position.
117 ;;; Relative cursor movement commands are confined to the current scrolling
118 ;;; region.  Absolute movement commands can address the entire screen if
119 ;;; if Origin Mode is reset.  Missing arguments in the absolute positioning
120 ;;; command default to one.  Relative commands can be used if the scroll
121 ;;; boundaries are examined.
122 (defun DCTL-position-cursor (x y)
123        (let ((deltax (- x X))
124              (deltay (- y Y)))
125             (cond ((= deltay 0)
126                    (cond ((= deltax 0) nil)
127                          ((> deltax 0)            ;move right
128                           (vt100-escape)
129                           (if (not (= deltax 1)) (DCTL-outdec deltax))
130                           (Rprinc "C"))
131                          (t (cond ((= x 0) (Rtyo 15))  ;move left
132                                   ((< (- deltax) 4)
133                                    (do-times (- deltax) (Rtyo 10)))
134                                   (t (vt100-escape)
135                                      (DCTL-outdec (- deltax))
136                                      (Rprinc "D"))))))
137                   ((= deltax 0)
138                    ;;make sure scroll region doesn't screw us.
139                    (cond ((or (and (> y scroll-region-bottom)
140                                    (not (> Y scroll-region-bottom)))
141                               (and (< y scroll-region-top)
142                                    (not (< Y scroll-region-top))))
143                           (vt100-absolute-position x y))
144                          ((> deltay 0)            ;move down
145                           (cond ((< deltay 4)
146                                  (do-times deltay (Rtyo 12)))
147                                 (t (vt100-escape)
148                                    (DCTL-outdec deltay)
149                                    (Rprinc "B"))))
150                          (t (cond ((= deltay -1)  ;move up
151                                    (Rtyo 33) (Rprinc "M"))
152                                   (t (vt100-escape)
153                                      (DCTL-outdec (- deltay))
154                                      (Rprinc "A"))))))
155                   (t (vt100-absolute-position x y)))
156             (setq X x Y y)))
157 
158 
159 ;;; Perform absolute cursor positioning
160 (defun vt100-absolute-position (x y)
161        (vt100-escape)
162        (if (not (= y 0))
163            (DCTL-outdec (1+ y)))
164        (if (not (= x 0))
165            (Rprinc ";")
166            (DCTL-outdec (1+ x)))
167        (Rprinc "H"))
168 
169 
170 ;;; Output string.
171 (defun DCTL-display-char-string (string)
172        (setq X (+ X (stringlength string)))
173        (cond ((= 0 (not_ascii_ string))           ;optimize normal string
174               (Rprinc string))
175              (t (let ((un nil))
176                      (mapc
177                       '(lambda (ch)
178                                (cond ((< (CtoI ch) 400)
179                                       (and un (vt100-escape "m"))
180                                       (setq un nil)
181                                       (Rprinc ch))
182                                      (t           ;underlined character
183                                        (or un (vt100-escape "4m"))
184                                        (setq un t)
185                                        (Rtyo (- (CtoI ch) 400)))))
186                       (explodec string))
187                     (and un (vt100-escape "m"))))))
188 
189 
190 ;;; Home cursor to upper left corner.
191 (defun DCTL-home-cursor ()
192        (setq X 0 Y 0)
193        (vt100-escape H))
194 
195 ;;; Clear to end of screen.
196 (defun DCTL-clear-rest-of-screen ()
197        (vt100-escape J) (DCTL-pad 45.))
198 
199 
200 ;;; Clear to end of line.
201 (defun DCTL-kill-line ()
202        (vt100-escape K) (DCTL-pad 2))
203 
204 
205 ;;; Define the bounds of the scroll region.  Relative cursor
206 ;;; movement can only be done within this region.
207 (defun DCTL-define-scroll-region (top bottom)
208        (cond ((and (= top scroll-region-top) (= bottom scroll-region-bottom)))
209              (t (setq scroll-region-top top scroll-region-bottom bottom)
210                 (Rtyo 33) (Rprinc "7")            ;push cursor position
211                 (Rtyo 33) (Rprinc "[")            ;redefine scroll region (homes)
212                 (cond ((not (= top 0))
213                        (DCTL-outdec (1+ top))))
214                 (cond ((not (= bottom (1- screenheight)))
215                        (Rprinc ";")
216                        (DCTL-outdec (1+ bottom))))
217                 (Rprinc "r")
218                 (Rtyo 33) (Rprinc "8"))))         ;pop cursor position
219 
220 
221 ;;; Insert n lines at the current cursor position
222 (defun DCTL-insert-lines (n)
223        (DCTL-scroll-down-region n (1- screenheight)))
224 
225 
226 ;;; Delete n lines at the current cursor position
227 (defun DCTL-delete-lines (n)
228        (DCTL-scroll-up-region n (1- screenheight)))
229 
230 
231 ;;; Move text in scroll region up n lines (inserts whitespace at bottom)
232 (defun DCTL-scroll-up-region (nlines bottom)
233        (DCTL-define-scroll-region Y bottom)
234        (let ((oldy Y))
235             (Rtyo 33) (Rprinc "7")                ;save cursor position
236             (DCTL-position-cursor 0 bottom)
237             (do-times nlines
238                       (Rtyo 12) (DCTL-pad 30.))
239             (Rtyo 33) (Rprinc "8")
240             (setq Y oldy)))
241 
242 ;;; Move text in scroll region down n lines (inserts whitespace at top)
243 (defun DCTL-scroll-down-region (nlines bottom)
244        (DCTL-define-scroll-region Y bottom)
245        (do-times nlines
246                  (Rtyo 33) (Rprinc 'M) (DCTL-pad 30.)))
247 
248 
249 ;;; Replacement for e_pl1_$set_emacs_tty_modes that enables oflow if necessary
250 (or (and (boundp 'DCTL-have-nonstandard-setmodes)
251          DCTL-have-nonstandard-setmodes)
252     (progn (putprop 'DCTL-standard-set-modes
253                     (get 'e_pl1_$set_emacs_tty_modes 'subr)
254                     'subr)
255            (setq DCTL-have-nonstandard-setmodes t)))
256 
257 (defun e_pl1_$set_emacs_tty_modes ()
258        (DCTL-standard-set-modes)
259        (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow)))
260 
261 (setq DCTL-oflow-enabled nil)                     ;above gets called once before DCTL-init
262 
263 
264 ;;; Load in special key definitions for VT1XX terminals
265 (cond ((status feature Emacs)                     ;but only in Emacs
266        (load (list (car (namelist (truename infile))) "vt1xx_keys_"))))