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

  ViewVC Help
Powered by ViewVC 1.1.5