/[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.2 - (show annotations)
Fri Feb 8 16:38:54 1991 UTC (23 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.1: +8 -5 lines
Added new header with RCS FILE-COMMENT.
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.2 1991/02/08 16:38:54 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 ;; A few useful values.
119 (setf (tty-device-dumbp device)
120 (not (and (termcap :open-line termcap)
121 (termcap :delete-line termcap))))
122 (setf (tty-device-lines device) (termcap :lines termcap))
123 (setf (tty-device-columns device)
124 (if (termcap :auto-margins-p termcap)
125 (1- (termcap :columns termcap))
126 (termcap :columns termcap)))
127 ;;
128 ;; Some function slots.
129 (setf (tty-device-display-string device)
130 (if (termcap :underlines termcap)
131 #'display-string-checking-underlines
132 #'display-string))
133 (setf (tty-device-standout-init device) #'standout-init)
134 (setf (tty-device-standout-end device) #'standout-end)
135 (setf (tty-device-open-line device)
136 (if (termcap :open-line termcap)
137 #'open-tty-line
138 ;; look for scrolling region stuff
139 ))
140 (setf (tty-device-delete-line device)
141 (if (termcap :delete-line termcap)
142 #'delete-tty-line
143 ;; look for reverse scrolling stuff
144 ))
145 (setf (tty-device-clear-to-eol device)
146 (if (termcap :clear-to-eol termcap)
147 #'clear-to-eol
148 #'space-to-eol))
149 (setf (tty-device-clear-lines device) #'clear-lines)
150 (setf (tty-device-clear-to-eow device) #'clear-to-eow)
151 ;;
152 ;; Insert and delete modes.
153 (let ((init-insert-mode (termcap :init-insert-mode termcap))
154 (init-insert-char (termcap :init-insert-char termcap))
155 (end-insert-char (termcap :end-insert-char termcap)))
156 (when (and init-insert-mode (string/= init-insert-mode ""))
157 (setf (tty-device-insert-string device) #'tty-insert-string)
158 (setf (tty-device-insert-init-string device) init-insert-mode)
159 (setf (tty-device-insert-end-string device)
160 (termcap :end-insert-mode termcap)))
161 (when init-insert-char
162 (setf (tty-device-insert-string device) #'tty-insert-string)
163 (setf (tty-device-insert-char-init-string device) init-insert-char))
164 (when (and end-insert-char (string/= end-insert-char ""))
165 (setf (tty-device-insert-char-end-string device) end-insert-char)))
166 (let ((delete-char (termcap :delete-char termcap)))
167 (when delete-char
168 (setf (tty-device-delete-char device) #'delete-char)
169 (setf (tty-device-delete-char-string device) delete-char)
170 (setf (tty-device-delete-init-string device)
171 (termcap :init-delete-mode termcap))
172 (setf (tty-device-delete-end-string device)
173 (termcap :end-delete-mode termcap))))
174 ;;
175 ;; Some string slots.
176 (setf (tty-device-standout-init-string device)
177 (or (termcap :init-standout-mode termcap) ""))
178 (setf (tty-device-standout-end-string device)
179 (or (termcap :end-standout-mode termcap) ""))
180 (setf (tty-device-clear-to-eol-string device)
181 (termcap :clear-to-eol termcap))
182 (let ((clear-string (termcap :clear-display termcap)))
183 (unless clear-string
184 (error "Terminal not sufficiently powerful enough to run Hemlock."))
185 (setf (tty-device-clear-string device) clear-string))
186 (setf (tty-device-open-line-string device)
187 (termcap :open-line termcap))
188 (setf (tty-device-delete-line-string device)
189 (termcap :delete-line termcap))
190 (let* ((init-string (termcap :init-string termcap))
191 (init-file (termcap :init-file termcap))
192 (init-file-string (if init-file (get-init-file-string init-file)))
193 (init-cm-string (termcap :init-cursor-motion termcap)))
194 (setf (tty-device-init-string device)
195 (concatenate 'simple-string (or init-string "")
196 (or init-file-string "") (or init-cm-string ""))))
197 (setf (tty-device-cm-end-string device)
198 (or (termcap :end-cursor-motion termcap) ""))
199 ;;
200 ;; Cursor motion slots.
201 (let ((cursor-motion (termcap :cursor-motion termcap)))
202 (unless cursor-motion
203 (error "Terminal not sufficiently powerful enough to run Hemlock."))
204 (let ((x-add-char (getf cursor-motion :x-add-char))
205 (y-add-char (getf cursor-motion :y-add-char))
206 (x-condx-char (getf cursor-motion :x-condx-char))
207 (y-condx-char (getf cursor-motion :y-condx-char)))
208 (when x-add-char
209 (setf (tty-device-cm-x-add-char device) (char-code x-add-char)))
210 (when y-add-char
211 (setf (tty-device-cm-y-add-char device) (char-code y-add-char)))
212 (when x-condx-char
213 (setf (tty-device-cm-x-condx-char device) (char-code x-condx-char))
214 (setf (tty-device-cm-x-condx-add-char device)
215 (char-code (getf cursor-motion :x-condx-add-char))))
216 (when y-condx-char
217 (setf (tty-device-cm-y-condx-char device) (char-code y-condx-char))
218 (setf (tty-device-cm-y-condx-add-char device)
219 (char-code (getf cursor-motion :y-condx-add-char)))))
220 (setf (tty-device-cm-string1 device) (getf cursor-motion :string1))
221 (setf (tty-device-cm-string2 device) (getf cursor-motion :string2))
222 (setf (tty-device-cm-string3 device) (getf cursor-motion :string3))
223 (setf (tty-device-cm-one-origin device) (getf cursor-motion :one-origin))
224 (setf (tty-device-cm-reversep device) (getf cursor-motion :reversep))
225 (setf (tty-device-cm-x-pad device) (getf cursor-motion :x-pad))
226 (setf (tty-device-cm-y-pad device) (getf cursor-motion :y-pad)))
227 ;;
228 ;; Screen image initialization.
229 (let* ((lines (tty-device-lines device))
230 (columns (tty-device-columns device))
231 (screen-image (make-array lines)))
232 (dotimes (i lines)
233 (setf (svref screen-image i) (make-si-line columns)))
234 (setf (tty-device-screen-image device) screen-image))
235 device))
236
237
238
239 ;;;; Making a window
240
241 (defun tty-make-window (device start modelinep window font-family
242 ask-user x y width height)
243 (declare (ignore window font-family ask-user x y width height))
244 (let* ((victim (tty-find-biggest-hunk device))
245 (text-height (tty-hunk-text-height victim))
246 (availability (if modelinep (1- text-height) text-height)))
247 (when (> availability 1)
248 (let* ((new-lines (truncate availability 2))
249 (old-lines (- availability new-lines))
250 (pos (device-hunk-position victim))
251 (new-height (if modelinep (1+ new-lines) new-lines))
252 (new-text-pos (if modelinep (1- pos) pos))
253 (new-hunk (make-tty-hunk :position pos
254 :height new-height
255 :text-position new-text-pos
256 :text-height new-lines
257 :device device))
258 (new-window (internal-make-window :hunk new-hunk))
259 (old-window (device-hunk-window victim)))
260 (declare (fixnum new-lines old-lines pos new-height new-text-pos))
261 (setf (device-hunk-window new-hunk) new-window)
262 (let* ((old-text-pos-diff (- pos (tty-hunk-text-position victim)))
263 (old-win-new-pos (- pos new-height)))
264 (declare (fixnum old-text-pos-diff old-win-new-pos))
265 (setf (device-hunk-height victim)
266 (- (device-hunk-height victim) new-height))
267 (setf (tty-hunk-text-height victim) old-lines)
268 (setf (device-hunk-position victim) old-win-new-pos)
269 (setf (tty-hunk-text-position victim)
270 (- old-win-new-pos old-text-pos-diff)))
271 (setup-window-image start new-window new-lines
272 (window-width old-window))
273 (prepare-window-for-redisplay new-window)
274 (when modelinep
275 (setup-modeline-image (line-buffer (mark-line start)) new-window))
276 (change-window-image-height old-window old-lines)
277 (shiftf (device-hunk-previous new-hunk)
278 (device-hunk-previous (device-hunk-next victim))
279 new-hunk)
280 (shiftf (device-hunk-next new-hunk) (device-hunk-next victim) new-hunk)
281 (setf *currently-selected-hunk* nil)
282 (setf *screen-image-trashed* t)
283 new-window))))
284
285 (defun tty-find-biggest-hunk (device)
286 (let* ((top-hunk (device-hunks device))
287 (hunk (device-hunk-next top-hunk))
288 (max-size 0)
289 biggest)
290 (declare (fixnum max-size))
291 (loop
292 (when (> (the fixnum (device-hunk-height hunk)) max-size)
293 (setf max-size (device-hunk-height hunk))
294 (setf biggest hunk))
295 (when (eq hunk top-hunk) (return biggest))
296 (setf hunk (device-hunk-next hunk)))))
297
298
299
300 ;;;; Deleting a window
301
302 (defun tty-delete-window (window)
303 (let* ((hunk (window-hunk window))
304 (prev (device-hunk-previous hunk))
305 (next (device-hunk-next hunk))
306 (device (device-hunk-device hunk)))
307 (setf (device-hunk-next prev) next)
308 (setf (device-hunk-previous next) prev)
309 (let ((buffer (window-buffer window)))
310 (setf (buffer-windows buffer) (delq window (buffer-windows buffer))))
311 (let ((new-lines (device-hunk-height hunk)))
312 (declare (fixnum new-lines))
313 (cond ((eq next (device-hunks (device-hunk-device next)))
314 (incf (device-hunk-height prev) new-lines)
315 (incf (device-hunk-position prev) new-lines)
316 (incf (tty-hunk-text-height prev) new-lines)
317 (incf (tty-hunk-text-position prev) new-lines)
318 (let ((w (device-hunk-window prev)))
319 (change-window-image-height w (+ new-lines (window-height w)))))
320 (t
321 (incf (device-hunk-height next) new-lines)
322 (incf (tty-hunk-text-height next) new-lines)
323 (let ((w (device-hunk-window next)))
324 (change-window-image-height w (+ new-lines (window-height w)))))))
325 (when (eq hunk (device-hunks device))
326 (setf (device-hunks device) next)))
327 (setf *currently-selected-hunk* nil)
328 (setf *screen-image-trashed* t))
329
330
331
332 ;;;; Next and Previous window operations.
333
334 (defun tty-next-window (window)
335 (device-hunk-window (device-hunk-next (window-hunk window))))
336
337 (defun tty-previous-window (window)
338 (device-hunk-window (device-hunk-previous (window-hunk window))))
339
340
341
342 ;;;; Random typeout support
343
344 (defun tty-random-typeout-setup (device stream height)
345 (declare (fixnum height))
346 (let* ((*more-prompt-action* :empty)
347 (height (min (1- (device-bottom-window-base device)) height))
348 (old-hwindow (random-typeout-stream-window stream))
349 (new-hwindow (if old-hwindow
350 (change-tty-random-typeout-window old-hwindow height)
351 (setf (random-typeout-stream-window stream)
352 (make-tty-random-typeout-window
353 device
354 (buffer-start-mark
355 (line-buffer
356 (mark-line
357 (random-typeout-stream-mark stream))))
358 height)))))
359 (funcall (tty-device-clear-to-eow device) (window-hunk new-hwindow) 0 0)))
360
361 (defun change-tty-random-typeout-window (window height)
362 (update-modeline-field (window-buffer window) window :more-prompt)
363 (let* ((height-1 (1- height))
364 (hunk (window-hunk window)))
365 (setf (device-hunk-position hunk) height-1
366 (device-hunk-height hunk) height
367 (tty-hunk-text-position hunk) (1- height-1)
368 (tty-hunk-text-height hunk) height-1)
369 (change-window-image-height window height-1)
370 window))
371
372 (defun make-tty-random-typeout-window (device mark height)
373 (let* ((height-1 (1- height))
374 (hunk (make-tty-hunk :position height-1
375 :height height
376 :text-position (1- height-1)
377 :text-height height-1
378 :device device))
379 (window (internal-make-window :hunk hunk)))
380 (setf (device-hunk-window hunk) window)
381 (setf (device-hunk-device hunk) device)
382 (setup-window-image mark window height-1 (tty-device-columns device))
383 (setf *window-list* (delete window *window-list*))
384 (prepare-window-for-redisplay window)
385 (setup-modeline-image (line-buffer (mark-line mark)) window)
386 (update-modeline-field (window-buffer window) window :more-prompt)
387 window))
388
389 (defun tty-random-typeout-cleanup (stream degree)
390 (declare (ignore degree))
391 (let* ((window (random-typeout-stream-window stream))
392 (stream-hunk (window-hunk window))
393 (last-line-affected (device-hunk-position stream-hunk))
394 (device (device-hunk-device stream-hunk))
395 (*more-prompt-action* :normal))
396 (declare (fixnum last-line-affected))
397 (update-modeline-field (window-buffer window) window :more-prompt)
398 (funcall (tty-device-clear-to-eow device) stream-hunk 0 0)
399 (do* ((hunk (device-hunks device) (device-hunk-next hunk))
400 (window (device-hunk-window hunk) (device-hunk-window hunk))
401 (last (device-hunk-previous hunk)))
402 ((>= (device-hunk-position hunk) last-line-affected)
403 (if (= (device-hunk-position hunk) last-line-affected)
404 (redisplay-window-all window)
405 (tty-redisplay-n-lines window
406 (- (+ last-line-affected
407 (tty-hunk-text-height hunk))
408 (tty-hunk-text-position hunk)))))
409 (redisplay-window-all window)
410 (when (eq hunk last) (return)))))

  ViewVC Help
Powered by ViewVC 1.1.5