/[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 - (show annotations)
Wed May 9 13:03:06 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Initial revision
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