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

  ViewVC Help
Powered by ViewVC 1.1.5