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

  ViewVC Help
Powered by ViewVC 1.1.5