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