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

Contents of /src/hemlock/bit-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: RELEASE_18a
Branch point for: RELENG_18
Changes since 1.2: +1 -3 lines
Fix headed boilerplate.
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     ;;;
7     (ext:file-comment
8 ram 1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/bit-stream.lisp,v 1.3 1994/10/31 04:50:12 ram Exp $")
9 ram 1.2 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Some stuff to make streams that write out on bitmap hunks.
13     ;;;
14     ;;; Written by Rob MacLachlan.
15     ;;; Modified by Bill Chiles to run under X on the IBM RT.
16     ;;;
17 ram 1.2 (in-package "HEMLOCK-INTERNALS")
18 ram 1.1
19    
20     ;;; These streams have an associated bitmap-hunk that is used for its
21     ;;; font-family, foreground and background color, and X window pointer.
22     ;;; The hunk need not be associated with any Hemlock window, and the low
23     ;;; level painting routines that use hunk dimensions are not used for
24     ;;; output. Only BITMAP-HUNK-WRITE-STRING is used. The hunk is not
25     ;;; registered for any event service, so resizing the associated X window
26     ;;; does not invoke the exposed/changed handler in Bit-Screen.Lisp; also, the
27     ;;; hunk's input and changed handler slots are not set.
28     ;;;
29     (defstruct (bitmap-hunk-output-stream (:include stream
30     (out #'bitmap-hunk-out)
31     (sout #'bitmap-hunk-sout)
32     (misc #'bitmap-hunk-misc))
33     (:constructor
34     make-bitmap-hunk-output-stream (hunk)))
35     hunk ; bitmap-hunk we display on.
36     (cursor-x 0) ; Character position of output cursor.
37     (cursor-y 0)
38     (buffer (make-string hunk-width-limit) :type simple-string)
39     (old-bottom 0)) ; # of lines of scrolling before next "--More--" prompt.
40    
41     ;;; Bitmap-Hunk-Stream-Newline -- Internal
42     ;;;
43     ;;; Flush the stream's output buffer and then move the cursor down
44     ;;; or scroll the window up if there is no room left.
45     ;;;
46     (defun bitmap-hunk-stream-newline (stream)
47     (let* ((hunk (bitmap-hunk-output-stream-hunk stream))
48     (height (bitmap-hunk-char-height hunk))
49     (y (bitmap-hunk-output-stream-cursor-y stream)))
50     (when (zerop (bitmap-hunk-output-stream-old-bottom stream))
51     (hunk-write-string hunk 0 y "--More--" 0 8)
52     (let ((device (device-hunk-device hunk)))
53     (when (device-force-output device)
54     (funcall (device-force-output device))))
55     (wait-for-more)
56     (hunk-clear-lines hunk y 1)
57     (setf (bitmap-hunk-output-stream-old-bottom stream) (1- height)))
58     (hunk-write-string hunk 0 y (bitmap-hunk-output-stream-buffer stream) 0
59     (bitmap-hunk-output-stream-cursor-x stream))
60     (setf (bitmap-hunk-output-stream-cursor-x stream) 0)
61     (decf (bitmap-hunk-output-stream-old-bottom stream))
62     (incf y)
63     (when (= y height)
64     (decf y)
65     (hunk-copy-lines hunk 1 0 y)
66     (hunk-clear-lines hunk y 1))
67     (setf (bitmap-hunk-output-stream-cursor-y stream) y)))
68    
69     ;;; Bitmap-Hunk-Misc -- Internal
70     ;;;
71     ;;; This is the misc method for bitmap-hunk-output-streams. It just
72     ;;; writes out the contents of the buffer, and does the element type.
73     ;;;
74     (defun bitmap-hunk-misc (stream operation &optional arg1 arg2)
75     (declare (ignore arg1 arg2))
76     (case operation
77     (:charpos
78     (values (bitmap-hunk-output-stream-cursor-x stream)
79     (bitmap-hunk-output-stream-cursor-y stream)))
80     ((:finish-output :force-output)
81     (hunk-write-string (bitmap-hunk-output-stream-hunk stream)
82     0 (bitmap-hunk-output-stream-cursor-y stream)
83     (bitmap-hunk-output-stream-buffer stream) 0
84     (bitmap-hunk-output-stream-cursor-x stream))
85     (let ((device (device-hunk-device (bitmap-hunk-output-stream-hunk stream))))
86     (when (device-force-output device)
87     (funcall (device-force-output device)))))
88     (:line-length
89     (bitmap-hunk-char-width (bitmap-hunk-output-stream-hunk stream)))
90 ram 1.2 (:element-type 'base-char)))
91 ram 1.1
92    
93     ;;; Bitmap-Hunk-Out -- Internal
94     ;;;
95     ;;; Throw a character in a bitmap-hunk-stream's buffer. If we wrap or hit a
96     ;;; newline then call bitmap-hunk-stream-newline.
97     ;;;
98     (defun bitmap-hunk-out (stream character)
99     (let ((hunk (bitmap-hunk-output-stream-hunk stream))
100     (x (bitmap-hunk-output-stream-cursor-x stream)))
101     (cond ((char= character #\newline)
102     (bitmap-hunk-stream-newline stream)
103     (return-from bitmap-hunk-out nil))
104     ((= x (bitmap-hunk-char-width hunk))
105     (setq x 0)
106     (bitmap-hunk-stream-newline stream)))
107     (setf (schar (bitmap-hunk-output-stream-buffer stream) x) character)
108     (setf (bitmap-hunk-output-stream-cursor-x stream) (1+ x))))
109    
110    
111     ;;; Bitmap-Hunk-Sout -- Internal
112     ;;;
113     ;;; Write a string out to a bitmap-hunk, calling ourself recursively if the
114     ;;; string contains newlines.
115     ;;;
116     (defun bitmap-hunk-sout (stream string start end)
117     (let* ((hunk (bitmap-hunk-output-stream-hunk stream))
118     (buffer (bitmap-hunk-output-stream-buffer stream))
119     (x (bitmap-hunk-output-stream-cursor-x stream))
120     (dst-end (+ x (- end start)))
121     (width (bitmap-hunk-char-width hunk)))
122     (cond ((%primitive find-character string start end #\newline)
123     (do ((current (%primitive find-character string start end #\newline)
124     (%primitive find-character string (1+ current)
125     end #\newline))
126     (previous start (1+ current)))
127     ((null current)
128     (bitmap-hunk-sout stream string previous end))
129     (bitmap-hunk-sout stream string previous current)
130     (bitmap-hunk-stream-newline stream)))
131     ((> dst-end width)
132     (let ((new-start (+ start (- width x))))
133     (%primitive byte-blt string start buffer x width)
134     (setf (bitmap-hunk-output-stream-cursor-x stream) width)
135     (bitmap-hunk-stream-newline stream)
136     (do ((idx (+ new-start width) (+ idx width))
137     (prev new-start idx))
138     ((>= idx end)
139     (let ((dst-end (- end prev)))
140     (%primitive byte-blt string prev buffer 0 dst-end)
141     (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end)))
142     (%primitive byte-blt string prev buffer 0 width)
143     (setf (bitmap-hunk-output-stream-cursor-x stream) width)
144     (bitmap-hunk-stream-newline stream))))
145     (t
146     (%primitive byte-blt string start buffer x dst-end)
147     (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end)))))

  ViewVC Help
Powered by ViewVC 1.1.5