/[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.7 - (hide annotations)
Tue Oct 8 14:45:37 1991 UTC (22 years, 6 months ago) by chiles
Branch: MAIN
Changes since 1.6: +7 -20 lines
Deleted unused function TTY-FIND-BIGGEST-HUNK.

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

  ViewVC Help
Powered by ViewVC 1.1.5