/[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.2 - (hide annotations)
Fri Feb 11 21:52:51 1994 UTC (20 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.1: +10 -7 lines
Copy new_compiler branch to trunk.
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     ;;; 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.2 1994/02/11 21:52:51 ram Exp $")
11     ;;;
12 ram 1.1 ;;; **********************************************************************
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 ram 1.2 (in-package "HEMLOCK-INTERNALS")
20 ram 1.1
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 ram 1.2 (:element-type 'base-char)))
93 ram 1.1
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