/[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.4 - (show annotations)
Mon May 4 01:27:18 1998 UTC (15 years, 11 months ago) by dtc
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
Gray streams support:
* Rename the 'stream structure class to sys:lisp-stream.
* Add a new none hierarchical 'stream built-in class which inherits
  from: instance, t.
* Hack in the new stream class as a mixin for the structure base
  lisp-stream class which now inherits from: stream, structure-object,
  instance, t.
* Add a new 'fundamental-stream standard-class which includes 'stream
  as a mixin, and add PCL hacks to allow this to be redefined after PCL is
  loaded to be (defclass fundamental-stream (standard-object stream) ...).
* Add appropriate support to the base stream functions to dispatch to
  the Gray stream functions for the handling of fundamental-streams.
  Some of the lisp-streams encapsulating CLOS streams still need
  a little work.
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/bit-stream.lisp,v 1.4 1998/05/04 01:27:18 dtc Rel $")
9 ;;;
10 ;;; **********************************************************************
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 (in-package "HEMLOCK-INTERNALS")
18
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 sys:lisp-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 (:element-type 'base-char)))
91
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