/[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.6 - (hide annotations)
Thu Sep 26 09:16:20 1991 UTC (22 years, 6 months ago) by wlott
Branch: MAIN
Changes since 1.5: +1 -6 lines
Don't turn off open paren highlighting, because it works now.
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 wlott 1.6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/tty-screen.lisp,v 1.6 1991/09/26 09:16:20 wlott 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     (defun tty-find-biggest-hunk (device)
289     (let* ((top-hunk (device-hunks device))
290     (hunk (device-hunk-next top-hunk))
291     (max-size 0)
292     biggest)
293     (declare (fixnum max-size))
294     (loop
295     (when (> (the fixnum (device-hunk-height hunk)) max-size)
296     (setf max-size (device-hunk-height hunk))
297     (setf biggest hunk))
298     (when (eq hunk top-hunk) (return biggest))
299     (setf hunk (device-hunk-next hunk)))))
300    
301    
302    
303     ;;;; Deleting a window
304    
305     (defun tty-delete-window (window)
306     (let* ((hunk (window-hunk window))
307     (prev (device-hunk-previous hunk))
308     (next (device-hunk-next hunk))
309     (device (device-hunk-device hunk)))
310     (setf (device-hunk-next prev) next)
311     (setf (device-hunk-previous next) prev)
312     (let ((buffer (window-buffer window)))
313     (setf (buffer-windows buffer) (delq window (buffer-windows buffer))))
314     (let ((new-lines (device-hunk-height hunk)))
315     (declare (fixnum new-lines))
316     (cond ((eq next (device-hunks (device-hunk-device next)))
317     (incf (device-hunk-height prev) new-lines)
318     (incf (device-hunk-position prev) new-lines)
319     (incf (tty-hunk-text-height prev) new-lines)
320     (incf (tty-hunk-text-position prev) new-lines)
321     (let ((w (device-hunk-window prev)))
322     (change-window-image-height w (+ new-lines (window-height w)))))
323     (t
324     (incf (device-hunk-height next) new-lines)
325     (incf (tty-hunk-text-height next) new-lines)
326     (let ((w (device-hunk-window next)))
327     (change-window-image-height w (+ new-lines (window-height w)))))))
328     (when (eq hunk (device-hunks device))
329     (setf (device-hunks device) next)))
330     (setf *currently-selected-hunk* nil)
331     (setf *screen-image-trashed* t))
332    
333    
334    
335     ;;;; Next and Previous window operations.
336    
337     (defun tty-next-window (window)
338     (device-hunk-window (device-hunk-next (window-hunk window))))
339    
340     (defun tty-previous-window (window)
341     (device-hunk-window (device-hunk-previous (window-hunk window))))
342    
343    
344    
345     ;;;; Random typeout support
346    
347     (defun tty-random-typeout-setup (device stream height)
348     (declare (fixnum height))
349     (let* ((*more-prompt-action* :empty)
350     (height (min (1- (device-bottom-window-base device)) height))
351     (old-hwindow (random-typeout-stream-window stream))
352     (new-hwindow (if old-hwindow
353     (change-tty-random-typeout-window old-hwindow height)
354     (setf (random-typeout-stream-window stream)
355     (make-tty-random-typeout-window
356     device
357     (buffer-start-mark
358     (line-buffer
359     (mark-line
360     (random-typeout-stream-mark stream))))
361     height)))))
362     (funcall (tty-device-clear-to-eow device) (window-hunk new-hwindow) 0 0)))
363    
364     (defun change-tty-random-typeout-window (window height)
365     (update-modeline-field (window-buffer window) window :more-prompt)
366     (let* ((height-1 (1- height))
367     (hunk (window-hunk window)))
368     (setf (device-hunk-position hunk) height-1
369     (device-hunk-height hunk) height
370     (tty-hunk-text-position hunk) (1- height-1)
371     (tty-hunk-text-height hunk) height-1)
372     (change-window-image-height window height-1)
373     window))
374    
375     (defun make-tty-random-typeout-window (device mark height)
376     (let* ((height-1 (1- height))
377     (hunk (make-tty-hunk :position height-1
378     :height height
379     :text-position (1- height-1)
380     :text-height height-1
381     :device device))
382     (window (internal-make-window :hunk hunk)))
383     (setf (device-hunk-window hunk) window)
384     (setf (device-hunk-device hunk) device)
385     (setup-window-image mark window height-1 (tty-device-columns device))
386     (setf *window-list* (delete window *window-list*))
387     (prepare-window-for-redisplay window)
388     (setup-modeline-image (line-buffer (mark-line mark)) window)
389     (update-modeline-field (window-buffer window) window :more-prompt)
390     window))
391    
392     (defun tty-random-typeout-cleanup (stream degree)
393     (declare (ignore degree))
394     (let* ((window (random-typeout-stream-window stream))
395     (stream-hunk (window-hunk window))
396     (last-line-affected (device-hunk-position stream-hunk))
397     (device (device-hunk-device stream-hunk))
398     (*more-prompt-action* :normal))
399     (declare (fixnum last-line-affected))
400     (update-modeline-field (window-buffer window) window :more-prompt)
401     (funcall (tty-device-clear-to-eow device) stream-hunk 0 0)
402     (do* ((hunk (device-hunks device) (device-hunk-next hunk))
403     (window (device-hunk-window hunk) (device-hunk-window hunk))
404     (last (device-hunk-previous hunk)))
405     ((>= (device-hunk-position hunk) last-line-affected)
406     (if (= (device-hunk-position hunk) last-line-affected)
407     (redisplay-window-all window)
408     (tty-redisplay-n-lines window
409     (- (+ last-line-affected
410     (tty-hunk-text-height hunk))
411     (tty-hunk-text-position hunk)))))
412     (redisplay-window-all window)
413     (when (eq hunk last) (return)))))

  ViewVC Help
Powered by ViewVC 1.1.5