/[cmucl]/src/hemlock/pop-up-stream.lisp
ViewVC logotype

Contents of /src/hemlock/pop-up-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Tue Mar 13 15:49:57 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.3: +2 -2 lines
Change toplevel PROCLAIMs to DECLAIMs.
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 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/pop-up-stream.lisp,v 1.4 2001/03/13 15:49:57 pw Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contatins the stream operations for pop-up-displays.
13 ;;;
14 ;;; Written by Blaine Burks.
15 ;;;
16
17 (in-package "HEMLOCK-INTERNALS")
18
19
20
21 ;;;; Line-buffered Stream Methods.
22
23 (defun random-typeout-line-out (stream char)
24 (insert-character (random-typeout-stream-mark stream) char)
25 (when (and (char= char #\newline)
26 (not (random-typeout-stream-no-prompt stream)))
27 (funcall (device-random-typeout-line-more
28 (device-hunk-device
29 (window-hunk (random-typeout-stream-window stream))))
30 stream 1)))
31
32 (defun random-typeout-line-sout (stream string start end)
33 (insert-string (random-typeout-stream-mark stream) string start end)
34 (unless (random-typeout-stream-no-prompt stream)
35 (let ((count (count #\newline string)))
36 (when count
37 (funcall (device-random-typeout-line-more
38 (device-hunk-device
39 (window-hunk (random-typeout-stream-window stream))))
40 stream count)))))
41
42 (defun random-typeout-line-misc (stream operation &optional arg1 arg2)
43 (declare (ignore arg1 arg2))
44 (case operation
45 ((:force-output :finish-output)
46 (random-typeout-redisplay (random-typeout-stream-window stream)))
47 (:charpos
48 (mark-charpos (random-typeout-stream-mark stream)))))
49
50
51 ;;; Bitmap line-buffered support.
52
53 ;;; UPDATE-BITMAP-LINE-BUFFERED-STREAM is called when anything is written to
54 ;;; a line-buffered-random-typeout-stream on the bitmap. It does a lot of
55 ;;; checking to make sure that strings of characters longer than the width of
56 ;;; the window don't screw us. The code is a little wierd, so a brief
57 ;;; explanation is below.
58 ;;;
59 ;;; The more-mark is how we tell when we will next need to more. Each time
60 ;;; we do a more-prompt, we point the mark at the last visible character in
61 ;;; the random typeout window. That way, when the mark is no longer
62 ;;; DISPLAYED-P, we know it's time to do another more prompt.
63 ;;;
64 ;;; If the buffer-end-mark is DISPLAYED-P, then we return, only redisplaying
65 ;;; if there was at least one newline in the last batch of output. If we
66 ;;; haven't done a more prompt yet (indicated by a value of T for
67 ;;; first-more-p), then since we know the end of the buffer isn't visible, we
68 ;;; need to do a more-prompt. If neither of the first two tests returns T,
69 ;;; then we can only need to do a more-prompt if our more-mark has scrolled
70 ;;; off the top of the screen. If it hasn't, everything is peechy-keen, so
71 ;;; we scroll the screen one line and redisplay.
72 ;;;
73 (defun update-bitmap-line-buffered-stream (stream newline-count)
74 (let* ((window (random-typeout-stream-window stream))
75 (count 0))
76 (when (plusp newline-count) (random-typeout-redisplay window))
77 (loop
78 (cond ((no-text-past-bottom-p window)
79 (return))
80 ((or (random-typeout-stream-first-more-p stream)
81 (not (displayed-p (random-typeout-stream-more-mark stream)
82 window)))
83 (do-bitmap-more-prompt stream)
84 (return))
85 (t
86 (scroll-window window 1)
87 (random-typeout-redisplay window)))
88 (when (= (incf count) newline-count) (return)))))
89
90 ;;; NO-TEXT-PAST-BOTTOM-P determines whether there is text left to be displayed
91 ;;; in the random-typeout window. It does this by first making sure there is a
92 ;;; line past the WINDOW-DISPLAY-END of the window. If there is, this line
93 ;;; must be empty, and BUFFER-END-MARK must be on this line. The final test is
94 ;;; that the window-end is displayed within the window. If it is not, then the
95 ;;; last line wraps past the end of the window, and there is text past the
96 ;;; bottom.
97 ;;;
98 ;;; Win-end is bound after the call to DISPLAYED-P because it updates the
99 ;;; window's image moving WINDOW-DISPLAY-END. We want this updated value for
100 ;;; the display end.
101 ;;;
102 (defun no-text-past-bottom-p (window)
103 (let* ((window-end (window-display-end window))
104 (window-end-displayed-p (displayed-p window-end window)))
105 (with-mark ((win-end window-end))
106 (let ((one-after-end (line-offset win-end 1)))
107 (if one-after-end
108 (and (empty-line-p win-end)
109 (same-line-p win-end (buffer-end-mark (window-buffer window)))
110 window-end-displayed-p)
111 window-end-displayed-p)))))
112
113 (defun reset-more-mark (stream)
114 (let* ((window (random-typeout-stream-window stream))
115 (more-mark (random-typeout-stream-more-mark stream))
116 (end (window-display-end window)))
117 (move-mark more-mark end)
118 (unless (displayed-p end window) (character-offset more-mark -1))))
119
120 ;;; DO-BITMAP-MORE-PROMPT is the function that atually displays the more prompt
121 ;;; and reacts to it. Things are pretty clear. The loop is neccessary because
122 ;;; someone could screw us by never outputting newlines. Improbable, but
123 ;;; possible.
124 ;;;
125 (defun do-bitmap-more-prompt (stream)
126 (let* ((window (random-typeout-stream-window stream))
127 (height (window-height window)))
128 (setf (random-typeout-stream-first-more-p stream) nil)
129 (reset-more-mark stream)
130 (loop
131 (when (no-text-past-bottom-p window) (return))
132 (display-more-prompt stream)
133 (do ((i 0 (1+ i)))
134 ((or (= i height) (no-text-past-bottom-p window)))
135 (scroll-window window 1)
136 (random-typeout-redisplay window)))
137 (unless (displayed-p (random-typeout-stream-more-mark stream) window)
138 (reset-more-mark stream))))
139
140
141 ;;; Tty line-buffered support.
142
143 ;;; UPDATE-TTY-LINE-BUFFERED-STREAM is called when anything is written to
144 ;;; a line-buffered-random-typeout-stream on the tty. It just makes sure
145 ;;; hemlock doesn't choke on extra-long strings.
146 ;;;
147 (defun update-tty-line-buffered-stream (stream newline-count)
148 (let ((window (random-typeout-stream-window stream)))
149 (when (plusp newline-count) (random-typeout-redisplay window))
150 (loop
151 (when (no-text-past-bottom-p window) (return))
152 (display-more-prompt stream)
153 (scroll-window window (window-height window))
154 (random-typeout-redisplay window))))
155
156
157 ;;;; Full-buffered Stream Methods.
158
159 (defun random-typeout-full-out (stream char)
160 (insert-character (random-typeout-stream-mark stream) char))
161
162 (defun random-typeout-full-sout (stream string start end)
163 (insert-string (random-typeout-stream-mark stream) string start end))
164
165 (defun random-typeout-full-misc (stream operation &optional arg1 arg2)
166 (declare (ignore arg1 arg2))
167 (case operation
168 (:charpos
169 (mark-charpos (random-typeout-stream-mark stream)))))
170
171
172 ;;; Bitmap full-buffered support.
173
174 ;;; DO-BITMAP-FULL-MORE and DO-TTY-FULL-MORE scroll through the fresh text in
175 ;;; random typeout buffer. The bitmap function does some checking so that
176 ;;; we don't overshoot the end of the buffer.
177 ;;;
178 (defun do-bitmap-full-more (stream)
179 (let* ((window (random-typeout-stream-window stream))
180 (buffer (window-buffer window))
181 (height (window-height window)))
182 (with-mark ((end-check (buffer-end-mark buffer)))
183 (when (and (mark/= (buffer-start-mark buffer) end-check)
184 (empty-line-p end-check))
185 (line-end (line-offset end-check -1)))
186 (loop
187 (when (displayed-p end-check window)
188 (return))
189 (display-more-prompt stream)
190 (do ((i 0 (1+ i)))
191 ((or (= i height) (displayed-p end-check window)))
192 (scroll-window window 1)
193 (random-typeout-redisplay window))))))
194
195
196 ;;; Tty full-buffered support.
197
198 (defun do-tty-full-more (stream)
199 (let* ((window (random-typeout-stream-window stream))
200 (buffer (window-buffer window)))
201 (with-mark ((end-check (buffer-end-mark buffer)))
202 (when (and (mark/= (buffer-start-mark buffer) end-check)
203 (empty-line-p end-check))
204 (line-end (line-offset end-check -1)))
205 (loop
206 (when (displayed-p end-check window)
207 (return))
208 (display-more-prompt stream)
209 (scroll-window window (window-height window))))))
210
211
212 ;;; Proclaim this special so the compiler doesn't warn me. I hate that.
213 ;;;
214 (declaim (special *more-prompt-action*))
215
216 (defun display-more-prompt (stream)
217 (unless (random-typeout-stream-no-prompt stream)
218 (let ((window (random-typeout-stream-window stream))
219 (*more-prompt-action* :more))
220 (update-modeline-field (window-buffer window) window :more-prompt)
221 (random-typeout-redisplay window)
222 (wait-for-more stream)
223 (let ((*more-prompt-action* :empty))
224 (update-modeline-field (window-buffer window) window :more-prompt)))))

  ViewVC Help
Powered by ViewVC 1.1.5