/[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 - (hide 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 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     "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/tty-screen.lisp,v 1.2 1991/02/08 16:38:54 ram Exp $")
11     ;;;
12 ram 1.1 ;;; **********************************************************************
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