/[cmucl]/src/hemlock/tty-screen.lisp
ViewVC logotype

Contents of /src/hemlock/tty-screen.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Thu Mar 14 16:26:46 1991 UTC (23 years, 1 month ago) by ram
Branch: MAIN
Changes since 1.2: +12 -7 lines
Call GET-TERMINAL-ATTRIBUTES to get the terminal size and speed from the OS.
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/tty-screen.lisp,v 1.3 1991/03/14 16:26:46 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Written by Bill Chiles, except for the code that implements random typeout,
15 ;;; which was done by Blaine Burks and Bill Chiles.
16 ;;;
17 ;;; Terminal device screen management functions.
18 ;;;
19
20 (in-package "HEMLOCK-INTERNALS")
21
22
23
24 ;;;; Terminal screen initialization
25
26 (proclaim '(special *parse-starting-mark*))
27
28 (defun init-tty-screen-manager (tty-name)
29 (setf *line-wrap-char* #\!)
30 (setf *window-list* ())
31 (let* ((device (make-tty-device tty-name))
32 (width (tty-device-columns device))
33 (height (tty-device-lines device))
34 (echo-height (value ed::echo-area-height))
35 (main-lines (- height echo-height 1)) ;-1 for echo modeline.
36 (main-text-lines (1- main-lines)) ;also main-modeline-pos.
37 (last-text-line (1- main-text-lines)))
38 (setf (device-bottom-window-base device) last-text-line)
39 ;;
40 ;; Make echo area.
41 (let* ((echo-hunk (make-tty-hunk :position (1- height) :height echo-height
42 :text-position (- height 2)
43 :text-height echo-height :device device))
44 (echo (internal-make-window :hunk echo-hunk)))
45 (setf *echo-area-window* echo)
46 (setf (device-hunk-window echo-hunk) echo)
47 (setup-window-image *parse-starting-mark* echo echo-height width)
48 (setup-modeline-image *echo-area-buffer* echo)
49 (prepare-window-for-redisplay echo))
50 ;;
51 ;; Make the main window.
52 (let* ((main-hunk (make-tty-hunk :position main-text-lines
53 :height main-lines
54 :text-position last-text-line
55 :text-height main-text-lines
56 :device device))
57 (main (internal-make-window :hunk main-hunk)))
58 (setf (device-hunk-window main-hunk) main)
59 (setf *current-window* main)
60 (setup-window-image (buffer-point *current-buffer*)
61 main main-text-lines width)
62 (setup-modeline-image *current-buffer* main)
63 (prepare-window-for-redisplay main)
64 (setf (device-hunk-previous main-hunk) main-hunk
65 (device-hunk-next main-hunk) main-hunk)
66 (setf (device-hunks device) main-hunk))
67 (defhvar "Paren Pause Period"
68 "This is how long commands that deal with \"brackets\" shows the cursor at
69 the matching \"bracket\" for this number of seconds."
70 :value 0.5
71 :mode "Lisp")
72 (defhvar "Highlight Open Parens"
73 "When non-nil, causes open parens to be displayed in a different font when
74 the cursor is directly to the right of the corresponding close paren."
75 :value nil
76 :mode "Lisp")))
77
78
79
80 ;;;; Building devices from termcaps.
81
82 ;;; MAKE-TTY-DEVICE returns a device built from a termcap. Some function
83 ;;; slots are set to the appropriate function even though the capability
84 ;;; might not exist; in this case, we simply set the control string value
85 ;;; to the empty string. Some function slots are set differently depending
86 ;;; on available capability.
87 ;;;
88 (defun make-tty-device (name)
89 (let ((termcap (get-termcap name))
90 (device (%make-tty-device :name name)))
91 (when (termcap :overstrikes termcap)
92 (error "Terminal sufficiently irritating -- not currently supported."))
93 ;;
94 ;; Similar device slots.
95 (setf (device-init device) #'init-tty-device)
96 (setf (device-exit device) #'exit-tty-device)
97 (setf (device-smart-redisplay device)
98 (if (and (termcap :open-line termcap) (termcap :delete-line termcap))
99 #'tty-smart-window-redisplay
100 #'tty-semi-dumb-window-redisplay))
101 (setf (device-dumb-redisplay device) #'tty-dumb-window-redisplay)
102 (setf (device-clear device) #'clear-device)
103 (setf (device-put-cursor device) #'tty-put-cursor)
104 (setf (device-show-mark device) #'tty-show-mark)
105 (setf (device-next-window device) #'tty-next-window)
106 (setf (device-previous-window device) #'tty-previous-window)
107 (setf (device-make-window device) #'tty-make-window)
108 (setf (device-delete-window device) #'tty-delete-window)
109 (setf (device-random-typeout-setup device) #'tty-random-typeout-setup)
110 (setf (device-random-typeout-cleanup device) #'tty-random-typeout-cleanup)
111 (setf (device-random-typeout-full-more device) #'do-tty-full-more)
112 (setf (device-random-typeout-line-more device)
113 #'update-tty-line-buffered-stream)
114 (setf (device-force-output device) #'tty-force-output)
115 (setf (device-finish-output device) #'tty-finish-output)
116 (setf (device-beep device) #'tty-beep)
117 ;;
118 ;; Do we have insert/delete line?
119 (setf (tty-device-dumbp device)
120 (not (and (termcap :open-line termcap)
121 (termcap :delete-line termcap))))
122 ;;
123 ;; Get size and speed.
124 (multiple-value-bind (lines cols speed)
125 (get-terminal-attributes)
126 (setf (tty-device-lines device) (or lines (termcap :lines termcap)))
127 (let ((cols (or cols (termcap :columns termcap))))
128 (setf (tty-device-columns device)
129 (if (termcap :auto-margins-p termcap)
130 (1- cols) cols)))
131 (setf (tty-device-speed device) speed))
132 ;;
133 ;; Some function slots.
134 (setf (tty-device-display-string device)
135 (if (termcap :underlines termcap)
136 #'display-string-checking-underlines
137 #'display-string))
138 (setf (tty-device-standout-init device) #'standout-init)
139 (setf (tty-device-standout-end device) #'standout-end)
140 (setf (tty-device-open-line device)
141 (if (termcap :open-line termcap)
142 #'open-tty-line
143 ;; look for scrolling region stuff
144 ))
145 (setf (tty-device-delete-line device)
146 (if (termcap :delete-line termcap)
147 #'delete-tty-line
148 ;; look for reverse scrolling stuff
149 ))
150 (setf (tty-device-clear-to-eol device)
151 (if (termcap :clear-to-eol termcap)
152 #'clear-to-eol
153 #'space-to-eol))
154 (setf (tty-device-clear-lines device) #'clear-lines)
155 (setf (tty-device-clear-to-eow device) #'clear-to-eow)
156 ;;
157 ;; Insert and delete modes.
158 (let ((init-insert-mode (termcap :init-insert-mode termcap))
159 (init-insert-char (termcap :init-insert-char termcap))
160 (end-insert-char (termcap :end-insert-char termcap)))
161 (when (and init-insert-mode (string/= init-insert-mode ""))
162 (setf (tty-device-insert-string device) #'tty-insert-string)
163 (setf (tty-device-insert-init-string device) init-insert-mode)
164 (setf (tty-device-insert-end-string device)
165 (termcap :end-insert-mode termcap)))
166 (when init-insert-char
167 (setf (tty-device-insert-string device) #'tty-insert-string)
168 (setf (tty-device-insert-char-init-string device) init-insert-char))
169 (when (and end-insert-char (string/= end-insert-char ""))
170 (setf (tty-device-insert-char-end-string device) end-insert-char)))
171 (let ((delete-char (termcap :delete-char termcap)))
172 (when delete-char
173 (setf (tty-device-delete-char device) #'delete-char)
174 (setf (tty-device-delete-char-string device) delete-char)
175 (setf (tty-device-delete-init-string device)
176 (termcap :init-delete-mode termcap))
177 (setf (tty-device-delete-end-string device)
178 (termcap :end-delete-mode termcap))))
179 ;;
180 ;; Some string slots.
181 (setf (tty-device-standout-init-string device)
182 (or (termcap :init-standout-mode termcap) ""))
183 (setf (tty-device-standout-end-string device)
184 (or (termcap :end-standout-mode termcap) ""))
185 (setf (tty-device-clear-to-eol-string device)
186 (termcap :clear-to-eol termcap))
187 (let ((clear-string (termcap :clear-display termcap)))
188 (unless clear-string
189 (error "Terminal not sufficiently powerful enough to run Hemlock."))
190 (setf (tty-device-clear-string device) clear-string))
191 (setf (tty-device-open-line-string device)
192 (termcap :open-line termcap))
193 (setf (tty-device-delete-line-string device)
194 (termcap :delete-line termcap))
195 (let* ((init-string (termcap :init-string termcap))
196 (init-file (termcap :init-file termcap))
197 (init-file-string (if init-file (get-init-file-string init-file)))
198 (init-cm-string (termcap :init-cursor-motion termcap)))
199 (setf (tty-device-init-string device)
200 (concatenate 'simple-string (or init-string "")
201 (or init-file-string "") (or init-cm-string ""))))
202 (setf (tty-device-cm-end-string device)
203 (or (termcap :end-cursor-motion termcap) ""))
204 ;;
205 ;; Cursor motion slots.
206 (let ((cursor-motion (termcap :cursor-motion termcap)))
207 (unless cursor-motion
208 (error "Terminal not sufficiently powerful enough to run Hemlock."))
209 (let ((x-add-char (getf cursor-motion :x-add-char))
210 (y-add-char (getf cursor-motion :y-add-char))
211 (x-condx-char (getf cursor-motion :x-condx-char))
212 (y-condx-char (getf cursor-motion :y-condx-char)))
213 (when x-add-char
214 (setf (tty-device-cm-x-add-char device) (char-code x-add-char)))
215 (when y-add-char
216 (setf (tty-device-cm-y-add-char device) (char-code y-add-char)))
217 (when x-condx-char
218 (setf (tty-device-cm-x-condx-char device) (char-code x-condx-char))
219 (setf (tty-device-cm-x-condx-add-char device)
220 (char-code (getf cursor-motion :x-condx-add-char))))
221 (when y-condx-char
222 (setf (tty-device-cm-y-condx-char device) (char-code y-condx-char))
223 (setf (tty-device-cm-y-condx-add-char device)
224 (char-code (getf cursor-motion :y-condx-add-char)))))
225 (setf (tty-device-cm-string1 device) (getf cursor-motion :string1))
226 (setf (tty-device-cm-string2 device) (getf cursor-motion :string2))
227 (setf (tty-device-cm-string3 device) (getf cursor-motion :string3))
228 (setf (tty-device-cm-one-origin device) (getf cursor-motion :one-origin))
229 (setf (tty-device-cm-reversep device) (getf cursor-motion :reversep))
230 (setf (tty-device-cm-x-pad device) (getf cursor-motion :x-pad))
231 (setf (tty-device-cm-y-pad device) (getf cursor-motion :y-pad)))
232 ;;
233 ;; Screen image initialization.
234 (let* ((lines (tty-device-lines device))
235 (columns (tty-device-columns device))
236 (screen-image (make-array lines)))
237 (dotimes (i lines)
238 (setf (svref screen-image i) (make-si-line columns)))
239 (setf (tty-device-screen-image device) screen-image))
240 device))
241
242
243
244 ;;;; Making a window
245
246 (defun tty-make-window (device start modelinep window font-family
247 ask-user x y width height)
248 (declare (ignore window font-family ask-user x y width height))
249 (let* ((victim (tty-find-biggest-hunk device))
250 (text-height (tty-hunk-text-height victim))
251 (availability (if modelinep (1- text-height) text-height)))
252 (when (> availability 1)
253 (let* ((new-lines (truncate availability 2))
254 (old-lines (- availability new-lines))
255 (pos (device-hunk-position victim))
256 (new-height (if modelinep (1+ new-lines) new-lines))
257 (new-text-pos (if modelinep (1- pos) pos))
258 (new-hunk (make-tty-hunk :position pos
259 :height new-height
260 :text-position new-text-pos
261 :text-height new-lines
262 :device device))
263 (new-window (internal-make-window :hunk new-hunk))
264 (old-window (device-hunk-window victim)))
265 (declare (fixnum new-lines old-lines pos new-height new-text-pos))
266 (setf (device-hunk-window new-hunk) new-window)
267 (let* ((old-text-pos-diff (- pos (tty-hunk-text-position victim)))
268 (old-win-new-pos (- pos new-height)))
269 (declare (fixnum old-text-pos-diff old-win-new-pos))
270 (setf (device-hunk-height victim)
271 (- (device-hunk-height victim) new-height))
272 (setf (tty-hunk-text-height victim) old-lines)
273 (setf (device-hunk-position victim) old-win-new-pos)
274 (setf (tty-hunk-text-position victim)
275 (- old-win-new-pos old-text-pos-diff)))
276 (setup-window-image start new-window new-lines
277 (window-width old-window))
278 (prepare-window-for-redisplay new-window)
279 (when modelinep
280 (setup-modeline-image (line-buffer (mark-line start)) new-window))
281 (change-window-image-height old-window old-lines)
282 (shiftf (device-hunk-previous new-hunk)
283 (device-hunk-previous (device-hunk-next victim))
284 new-hunk)
285 (shiftf (device-hunk-next new-hunk) (device-hunk-next victim) new-hunk)
286 (setf *currently-selected-hunk* nil)
287 (setf *screen-image-trashed* t)
288 new-window))))
289
290 (defun tty-find-biggest-hunk (device)
291 (let* ((top-hunk (device-hunks device))
292 (hunk (device-hunk-next top-hunk))
293 (max-size 0)
294 biggest)
295 (declare (fixnum max-size))
296 (loop
297 (when (> (the fixnum (device-hunk-height hunk)) max-size)
298 (setf max-size (device-hunk-height hunk))
299 (setf biggest hunk))
300 (when (eq hunk top-hunk) (return biggest))
301 (setf hunk (device-hunk-next hunk)))))
302
303
304
305 ;;;; Deleting a window
306
307 (defun tty-delete-window (window)
308 (let* ((hunk (window-hunk window))
309 (prev (device-hunk-previous hunk))
310 (next (device-hunk-next hunk))
311 (device (device-hunk-device hunk)))
312 (setf (device-hunk-next prev) next)
313 (setf (device-hunk-previous next) prev)
314 (let ((buffer (window-buffer window)))
315 (setf (buffer-windows buffer) (delq window (buffer-windows buffer))))
316 (let ((new-lines (device-hunk-height hunk)))
317 (declare (fixnum new-lines))
318 (cond ((eq next (device-hunks (device-hunk-device next)))
319 (incf (device-hunk-height prev) new-lines)
320 (incf (device-hunk-position prev) new-lines)
321 (incf (tty-hunk-text-height prev) new-lines)
322 (incf (tty-hunk-text-position prev) new-lines)
323 (let ((w (device-hunk-window prev)))
324 (change-window-image-height w (+ new-lines (window-height w)))))
325 (t
326 (incf (device-hunk-height next) new-lines)
327 (incf (tty-hunk-text-height next) new-lines)
328 (let ((w (device-hunk-window next)))
329 (change-window-image-height w (+ new-lines (window-height w)))))))
330 (when (eq hunk (device-hunks device))
331 (setf (device-hunks device) next)))
332 (setf *currently-selected-hunk* nil)
333 (setf *screen-image-trashed* t))
334
335
336
337 ;;;; Next and Previous window operations.
338
339 (defun tty-next-window (window)
340 (device-hunk-window (device-hunk-next (window-hunk window))))
341
342 (defun tty-previous-window (window)
343 (device-hunk-window (device-hunk-previous (window-hunk window))))
344
345
346
347 ;;;; Random typeout support
348
349 (defun tty-random-typeout-setup (device stream height)
350 (declare (fixnum height))
351 (let* ((*more-prompt-action* :empty)
352 (height (min (1- (device-bottom-window-base device)) height))
353 (old-hwindow (random-typeout-stream-window stream))
354 (new-hwindow (if old-hwindow
355 (change-tty-random-typeout-window old-hwindow height)
356 (setf (random-typeout-stream-window stream)
357 (make-tty-random-typeout-window
358 device
359 (buffer-start-mark
360 (line-buffer
361 (mark-line
362 (random-typeout-stream-mark stream))))
363 height)))))
364 (funcall (tty-device-clear-to-eow device) (window-hunk new-hwindow) 0 0)))
365
366 (defun change-tty-random-typeout-window (window height)
367 (update-modeline-field (window-buffer window) window :more-prompt)
368 (let* ((height-1 (1- height))
369 (hunk (window-hunk window)))
370 (setf (device-hunk-position hunk) height-1
371 (device-hunk-height hunk) height
372 (tty-hunk-text-position hunk) (1- height-1)
373 (tty-hunk-text-height hunk) height-1)
374 (change-window-image-height window height-1)
375 window))
376
377 (defun make-tty-random-typeout-window (device mark height)
378 (let* ((height-1 (1- height))
379 (hunk (make-tty-hunk :position height-1
380 :height height
381 :text-position (1- height-1)
382 :text-height height-1
383 :device device))
384 (window (internal-make-window :hunk hunk)))
385 (setf (device-hunk-window hunk) window)
386 (setf (device-hunk-device hunk) device)
387 (setup-window-image mark window height-1 (tty-device-columns device))
388 (setf *window-list* (delete window *window-list*))
389 (prepare-window-for-redisplay window)
390 (setup-modeline-image (line-buffer (mark-line mark)) window)
391 (update-modeline-field (window-buffer window) window :more-prompt)
392 window))
393
394 (defun tty-random-typeout-cleanup (stream degree)
395 (declare (ignore degree))
396 (let* ((window (random-typeout-stream-window stream))
397 (stream-hunk (window-hunk window))
398 (last-line-affected (device-hunk-position stream-hunk))
399 (device (device-hunk-device stream-hunk))
400 (*more-prompt-action* :normal))
401 (declare (fixnum last-line-affected))
402 (update-modeline-field (window-buffer window) window :more-prompt)
403 (funcall (tty-device-clear-to-eow device) stream-hunk 0 0)
404 (do* ((hunk (device-hunks device) (device-hunk-next hunk))
405 (window (device-hunk-window hunk) (device-hunk-window hunk))
406 (last (device-hunk-previous hunk)))
407 ((>= (device-hunk-position hunk) last-line-affected)
408 (if (= (device-hunk-position hunk) last-line-affected)
409 (redisplay-window-all window)
410 (tty-redisplay-n-lines window
411 (- (+ last-line-affected
412 (tty-hunk-text-height hunk))
413 (tty-hunk-text-position hunk)))))
414 (redisplay-window-all window)
415 (when (eq hunk last) (return)))))

  ViewVC Help
Powered by ViewVC 1.1.5