source: trunk/ccl/hemlock/src/pop-up-stream.lisp @ 781

Last change on this file since 781 was 781, checked in by gb, 16 years ago

Remove some CLXisms.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.5 KB
Line 
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#+CMU (ext:file-comment
8  "$Header$")
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;; ###GB we want a more optimized interface
24
25(defmethod stream-write-char ((stream random-typeout-stream) char)
26  (with-slots (line-buffered-p) stream
27    (cond (line-buffered-p
28           (insert-character (random-typeout-stream-mark stream) char)
29           (when (and (char= char #\newline)
30                      (not (random-typeout-stream-no-prompt stream)))
31             (funcall (device-random-typeout-line-more
32                       (device-hunk-device
33                        (window-hunk (random-typeout-stream-window stream))))
34                      stream 1)))
35          (t
36           (insert-character (random-typeout-stream-mark stream) char)))))             
37
38(defmethod stream-write-string ((stream random-typeout-stream) string &optional start end)
39  (setf start (or start 0))
40  (setf end (or end (length string)))
41  (with-slots (line-buffered-p) stream
42    (cond (line-buffered-p
43           (insert-string (random-typeout-stream-mark stream) string start end)
44           (unless (random-typeout-stream-no-prompt stream)
45             (let ((count (count #\newline string)))
46               (when count
47                 (funcall (device-random-typeout-line-more
48                           (device-hunk-device
49                            (window-hunk (random-typeout-stream-window stream))))
50                          stream count)))))
51          (t
52           (insert-string (random-typeout-stream-mark stream) string start end)))))
53
54(defmethod stream-finish-output ((stream random-typeout-stream))
55  (with-slots (line-buffered-p) stream
56    (cond (line-buffered-p
57           (random-typeout-redisplay (random-typeout-stream-window stream)))
58          (t
59           nil))))
60
61(defmethod stream-force-output ((stream random-typeout-stream))
62  (stream-finish-output stream))
63
64(defmethod stream-line-column ((stream random-typeout-stream))
65  (mark-charpos (random-typeout-stream-mark stream)))
66
67;;; Bitmap line-buffered support.
68
69;;; UPDATE-BITMAP-LINE-BUFFERED-STREAM is called when anything is written to
70;;; a line-buffered-random-typeout-stream on the bitmap.  It does a lot of
71;;; checking to make sure that strings of characters longer than the width of
72;;; the window don't screw us.  The code is a little wierd, so a brief
73;;; explanation is below.
74;;;
75;;; The more-mark is how we tell when we will next need to more.  Each time
76;;; we do a more-prompt, we point the mark at the last visible character in
77;;; the random typeout window.  That way, when the mark is no longer
78;;; DISPLAYED-P, we know it's time to do another more prompt.
79;;;
80;;; If the buffer-end-mark is DISPLAYED-P, then we return, only redisplaying
81;;; if there was at least one newline in the last batch of output.  If we
82;;; haven't done a more prompt yet (indicated by a value of T for
83;;; first-more-p), then since we know the end of the buffer isn't visible, we
84;;; need to do a more-prompt.  If neither of the first two tests returns T,
85;;; then we can only need to do a more-prompt if our more-mark has scrolled
86;;; off the top of the screen.  If it hasn't, everything is peechy-keen, so
87;;; we scroll the screen one line and redisplay.
88;;;
89(defun update-bitmap-line-buffered-stream (stream newline-count)
90  (let* ((window (random-typeout-stream-window stream))
91         (count 0))
92    (when (plusp newline-count) (random-typeout-redisplay window))
93    (loop
94      (cond ((no-text-past-bottom-p window)
95             (return))
96            ((or (random-typeout-stream-first-more-p stream)
97                 (not (displayed-p (random-typeout-stream-more-mark stream)
98                                   window)))
99             (do-bitmap-more-prompt stream)
100             (return))
101            (t
102             (scroll-window window 1)
103             (random-typeout-redisplay window)))
104      (when (= (incf count) newline-count) (return)))))
105
106;;; NO-TEXT-PAST-BOTTOM-P determines whether there is text left to be displayed
107;;; in the random-typeout window.  It does this by first making sure there is a
108;;; line past the WINDOW-DISPLAY-END of the window.  If there is, this line
109;;; must be empty, and BUFFER-END-MARK must be on this line.  The final test is
110;;; that the window-end is displayed within the window.  If it is not, then the
111;;; last line wraps past the end of the window, and there is text past the
112;;; bottom.
113;;;
114;;; Win-end is bound after the call to DISPLAYED-P because it updates the
115;;; window's image moving WINDOW-DISPLAY-END.  We want this updated value for
116;;; the display end.
117;;;
118(defun no-text-past-bottom-p (window)
119  (let* ((window-end (window-display-end window))
120         (window-end-displayed-p (displayed-p window-end window)))
121    (with-mark ((win-end window-end))
122      (let ((one-after-end (line-offset win-end 1)))
123        (if one-after-end
124            (and (empty-line-p win-end)
125                 (same-line-p win-end (buffer-end-mark (window-buffer window)))
126                 window-end-displayed-p)
127            window-end-displayed-p)))))
128
129(defun reset-more-mark (stream)
130  (let* ((window (random-typeout-stream-window stream))
131         (more-mark (random-typeout-stream-more-mark stream))
132         (end (window-display-end window)))
133    (move-mark more-mark end)
134    (unless (displayed-p end window) (character-offset more-mark -1))))
135
136
137
138
139
Note: See TracBrowser for help on using the repository browser.