1 ;;; ******************************************************
  2 ;;; *                                                    *
  3 ;;; * Copyright, (C) Honeywell Bull Inc., 1988           *
  4 ;;; *                                                    *
  5 ;;; * Copyright (c) 1978 by Massachusetts Institute of   *
  6 ;;; * Technology and Honeywell Information Systems, Inc. *
  7 ;;; *                                                    *
  8 ;;; ******************************************************
  9 
 10 ;;; HISTORY COMMENTS:
 11 ;;;  1) change(86-08-15,Coppola), approve(86-08-15,MCR7516),
 12 ;;;     audit(86-09-02,GDixon), install(86-09-04,MR12.0-1146):
 13 ;;;     Add Emacs ctl for Versaterm (Macintosh VT100 Term.)
 14 ;;;  2) change(88-01-16,GDixon), approve(88-09-20,MCR8002),
 15 ;;;     audit(88-10-07,Blair), install(88-10-07,MR12.2-1141):
 16 ;;;      A) Added support for longer versaterm line and page lengths.  The
 17 ;;;         user's current tty_ page and line length modes are used by Emacs.
 18 ;;;      B) Changed DCTL-clear-rest-of-screen to reset scroll mode.  This
 19 ;;;         allows escape via ^X CR to scroll up the Emacs buffers as nonEmacs
 20 ;;;         output appears.
 21 ;;;      C) Changed all places which reset scroll mode to use the proper
 22 ;;;         terminal size (either 80 char lines or 132 char lines).
 23 ;;;      D) Remove all region scrolling functions, as they have never worked
 24 ;;;         and were never enabled.  Emacs does not properly maintain X and Y
 25 ;;;         variables, which the scrolling software depends upon.
 26 ;;;                                                      END HISTORY COMMENTS
 27 
 28 ;;;
 29 ;;;
 30 ;;;       VersaTerm control package (Macintosh VT100/102 Terminal Emulator)
 31 ;;;        Created:  20 May 1983 by B. Margolin from VT132 CTL
 32 ;;;        Modified: 2 November 1984 by B. Margolin to remove unexecuted
 33 ;;;                  forms from DCTL-clear-rest-of-screen and DCTL-kill-line.
 34 ;;;
 35 ;;;                  May, 1986 by R. Coppola for VersaTerm (tm). Works only for
 36 ;;;                  VersaTerm Rev2.20 and higher.
 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 ;;; Macro to output escape sequence
 55 (defun vt102-escape macro (form)
 56        (list 'Rprinc
 57              (apply 'catenate
 58                     (cons (ItoC 33)
 59                           (cons "[" (cdr form))))))
 60 
 61 ;;; Output n to the terminal in decimal.
 62 (defun DCTL-outdec (n)                            ;BSG 3/23/79
 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 ;;; Output padding, based on n pad characters at 9600-baud
 74 (defun DCTL-pad (n)
 75        (or DCTL-oflow-enabled                     ;flow control should do it
 76            (do-times (// (* n ospeed) 960.)
 77                      (Rtyo 0))))
 78 
 79 ;;; Initialize terminal and terminal control package.
 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 ;;; Initialization that must also be done after a QUIT
 97 (defun DCTL-prologue ()
 98        (Rtyo 33) (Rprinc "<")                     ;set ANSI mode from VT52 mode
 99        (vt102-escape "?4l")                       ;reset scroll mode (jump)
100        (vt102-escape "?6l")                       ;reset absolute origin mode
101        (vt102-escape "r")                         ;reset scroll region
102        (vt102-escape "20l")                       ;turn off auto-CRLF
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 ;;; Restore terminal to outside state
112 (defun DCTL-epilogue ()
113        (vt102-escape "?4l")                       ;reset scroll mode (jump)
114        (vt102-escape "?6l")                       ;reset absolute origin mode
115        (vt102-escape "r")                         ;reset scroll region
116        (DCTL-pad 4)
117        (setq DCTL-insert-mode-on nil))
118 
119 
120 ;;; Move terminal's cursor to desired position.
121 (defun DCTL-position-cursor (x y)
122        (vt102-absolute-position x y)
123        (setq X x Y y))
124 
125 
126 ;;; Perform absolute cursor positioning
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 ;;; Output string.
138 (defun DCTL-display-char-string (string)
139        (let ((strx (stringlength string)))
140             (cond ((= strx 0))                    ;bug in redisplay calls with no string
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))         ;optimize standard string
148               (Rprinc string))
149              (t (let ((un nil))
150                      (mapc
151                        '(lambda (ch)
152                                 (cond ((< (CtoI ch) 400)    ;normal char
153                                        (and un
154                                             (vt102-escape "m"))       ;out of underline mode
155                                        (setq un nil)
156                                        (Rprinc ch))
157                                       (t          ;underlined char (400-bit set)
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 ;;; Home cursor to upper left corner.
165 (defun DCTL-home-cursor ()
166        (setq X 0 Y 0)
167        (vt102-escape H))
168 
169 ;;; Clear to end of screen.
170 (defun DCTL-clear-rest-of-screen ()
171        (vt102-escape "?4l")                       ;reset scroll mode (jump)
172        (vt102-escape "?6l")                       ;reset absolute origin mode
173        (vt102-escape "r")                         ;reset scroll region
174        (vt102-escape J)
175        (cond ((> screenlinelen 100.)              ;set proper screen width
176               (vt102-escape "?3h"))
177              (t (vt102-escape "?3l"))))
178 
179 
180 ;;; Clear to end of line.
181 (defun DCTL-kill-line ()
182        (vt102-escape K))
183 
184 ;;; Insert n lines at the current cursor position
185 (defun DCTL-insert-lines (n)
186        (do-times n
187        (vt102-escape "L")))
188 
189 
190 ;;; Delete n lines at the current cursor position
191 (defun DCTL-delete-lines (n)
192        (do-times n
193        (vt102-escape "M")))
194 
195 
196 ;;; Insert given text at the cursor
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 ;;; Delete N characters at the cursor
206 (defun DCTL-delete-chars (n)
207        (vt102-escape)
208        (and (> n 1) (DCTL-outdec n))
209        (Rprinc "P")))
210 
211 
212 ;;; Replacement for e_pl1_$set_emacs_tty_modes that enables oflow if necessary
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)                     ;above gets called once before DCTL-init
225 
226 
227 ;;; Load in special key definitions for VT1XX terminals
228 (cond ((status feature Emacs)                     ;but only in Emacs
229        (load (list (car (namelist (truename infile))) "vt1xx_keys_"))))
230 
231 
232 ;;; REGION SCROLLING DOESN'T WORK because X and Y variables aren't maintained properly by emacs.
233 ;;; Define the bounds of the scroll region.  Relative cursor
234 ;;; movement can only be done within this region.
235 ;;;(defun DCTL-define-scroll-region (top bottom)
236 ;;;       (cond ((and (= top scroll-region-top) (= bottom scroll-region-bottom)))
237 ;;;          (t (setq scroll-region-top top scroll-region-bottom bottom)
238 ;;;             (Rtyo 33) (Rprinc "7")            ;push cursor position
239 ;;;             (Rtyo 33) (Rprinc "[")            ;redefine scroll region (homes)
240 ;;;             (cond ((not (= top 0))
241 ;;;                    (DCTL-outdec (1+ top))))
242 ;;;             (cond ((not (= bottom (1- screenheight)))
243 ;;;                    (Rprinc ";")
244 ;;;                    (DCTL-outdec (1+ bottom))))
245 ;;;             (Rprinc "r")
246 ;;;             (Rtyo 33) (Rprinc "8")  ;pop cursor position
247 ;;;             (DCTL-pad 5.))))
248 
249 ;;; Move text in scroll region up n lines (inserts whitespace at bottom)
250 ;;;(defun DCTL-scroll-up-region (nlines bottom)
251 ;;;       (DCTL-define-scroll-region Y bottom)
252 ;;;       (let ((oldy Y))
253 ;;;         (Rtyo 33) (Rprinc "7")                ;save cursor position
254 ;;;         (DCTL-position-cursor 0 bottom)
255 ;;;         (do-times nlines
256 ;;;                   (Rtyo 12) (DCTL-pad 5.))
257 ;;;         (Rtyo 33) (Rprinc "8")
258 ;;;         (setq Y oldy)))
259 
260 ;;; Move text in scroll region down n lines (inserts whitespace at top)
261 ;;;(defun DCTL-scroll-down-region (nlines bottom)
262 ;;;       (DCTL-define-scroll-region Y bottom)
263 ;;;       (do-times nlines
264 ;;;              (Rtyo 33) (Rprinc "M") (DCTL-pad 5.)))