1.1.11
by Kevin M. Rosenberg
Import upstream version 1.102 |
1 |
;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp -*-
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
2 |
;;;; *************************************************************************
|
3 |
;;;; FILE IDENTIFICATION
|
|
4 |
;;;;
|
|
5 |
;;;; Name: byte-stream.lisp
|
|
6 |
;;;; Purpose: Byte array input/output streams
|
|
7 |
;;;; Programmer: Kevin M. Rosenberg
|
|
8 |
;;;; Date Started: June 2003
|
|
9 |
;;;;
|
|
10 |
;;;; Works for CMUCL, SBCL, and AllergoCL only
|
|
11 |
;;;;
|
|
12 |
;;;; This file, part of KMRCL, is Copyright (c) 2003 by Kevin M. Rosenberg
|
|
13 |
;;;; and by onShore Development, Inc.
|
|
14 |
;;;;
|
|
15 |
;;;; KMRCL users are granted the rights to distribute and use this software
|
|
16 |
;;;; as governed by the terms of the Lisp Lesser GNU Public License
|
|
17 |
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
|
|
18 |
;;;; *************************************************************************
|
|
19 |
||
20 |
(in-package #:kmrcl) |
|
21 |
||
1.1.11
by Kevin M. Rosenberg
Import upstream version 1.102 |
22 |
;; Intial CMUCL version by OnShored. Ported to AllegroCL, SBCL by Kevin Rosenberg
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
23 |
|
1.2.1
by Kevin M. Rosenberg
Import upstream version 1.82 |
24 |
#+sbcl |
25 |
(eval-when (:compile-toplevel :load-toplevel :execute) |
|
26 |
(when (sb-ext:without-package-locks |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
27 |
(sb-pcl::structure-class-p |
28 |
(find-class (intern "FILE-STREAM" "SB-IMPL")))) |
|
1.2.1
by Kevin M. Rosenberg
Import upstream version 1.82 |
29 |
(push :old-sb-file-stream cl:*features*))) |
30 |
||
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
31 |
#+(or cmu sbcl) |
32 |
(progn |
|
33 |
(defstruct (byte-array-output-stream |
|
34 |
(:include #+cmu system:lisp-stream |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
35 |
#+(and sbcl old-sb-file-stream) sb-impl::file-stream |
36 |
#+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
37 |
(bout #'byte-array-bout) |
38 |
(misc #'byte-array-out-misc)) |
|
39 |
(:print-function %print-byte-array-output-stream) |
|
40 |
(:constructor make-byte-array-output-stream ())) |
|
41 |
;; The buffer we throw stuff in.
|
|
42 |
(buffer (make-array 128 :element-type '(unsigned-byte 8))) |
|
43 |
;; Index of the next location to use.
|
|
44 |
(index 0 :type fixnum)) |
|
45 |
||
46 |
(defun %print-byte-array-output-stream (s stream d) |
|
47 |
(declare (ignore s d)) |
|
48 |
(write-string "#<Byte-Array-Output Stream>" stream)) |
|
49 |
||
50 |
(setf (documentation 'make-binary-output-stream 'function) |
|
51 |
"Returns an Output stream which will accumulate all output given it for
|
|
52 |
the benefit of the function Get-Output-Stream-Data.") |
|
53 |
||
54 |
(defun byte-array-bout (stream byte) |
|
55 |
(let ((current (byte-array-output-stream-index stream)) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
56 |
(workspace (byte-array-output-stream-buffer stream))) |
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
57 |
(if (= current (length workspace)) |
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
58 |
(let ((new-workspace (make-array (* current 2) :element-type '(unsigned-byte 8)))) |
59 |
(replace new-workspace workspace) |
|
60 |
(setf (aref new-workspace current) byte) |
|
61 |
(setf (byte-array-output-stream-buffer stream) new-workspace)) |
|
62 |
(setf (aref workspace current) byte)) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
63 |
(setf (byte-array-output-stream-index stream) (1+ current)))) |
64 |
||
65 |
(defun byte-array-out-misc (stream operation &optional arg1 arg2) |
|
66 |
(declare (ignore arg2)) |
|
67 |
(case operation |
|
68 |
(:file-position |
|
69 |
(if (null arg1) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
70 |
(byte-array-output-stream-index stream))) |
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
71 |
(:element-type '(unsigned-byte 8)))) |
72 |
||
73 |
(defun get-output-stream-data (stream) |
|
74 |
"Returns an array of all data sent to a stream made by
|
|
75 |
Make-Byte-Array-Output-Stream since the last call to this function and
|
|
76 |
clears buffer."
|
|
77 |
(declare (type byte-array-output-stream stream)) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
78 |
(prog1 |
79 |
(dump-output-stream-data stream) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
80 |
(setf (byte-array-output-stream-index stream) 0))) |
81 |
||
82 |
(defun dump-output-stream-data (stream) |
|
83 |
"Returns an array of all data sent to a stream made by
|
|
84 |
Make-Byte-Array-Output-Stream since the last call to this function."
|
|
85 |
(declare (type byte-array-output-stream stream)) |
|
86 |
(let* ((length (byte-array-output-stream-index stream)) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
87 |
(result (make-array length :element-type '(unsigned-byte 8)))) |
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
88 |
(replace result (byte-array-output-stream-buffer stream)) |
89 |
result)) |
|
90 |
||
91 |
) ; progn |
|
92 |
||
93 |
||
1.2.1
by Kevin M. Rosenberg
Import upstream version 1.82 |
94 |
#+sbcl |
95 |
(eval-when (:compile-toplevel :load-toplevel :execute) |
|
96 |
(sb-ext:without-package-locks |
|
97 |
(defvar *system-copy-fn* (if (fboundp (intern "COPY-SYSTEM-AREA" "SB-KERNEL")) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
98 |
(intern "COPY-SYSTEM-AREA" "SB-KERNEL") |
99 |
(intern "COPY-SYSTEM-UB8-AREA" "SB-KERNEL"))) |
|
1.2.1
by Kevin M. Rosenberg
Import upstream version 1.82 |
100 |
(defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) |
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
101 |
sb-vm:n-byte-bits
|
102 |
1)))) |
|
103 |
||
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
104 |
#+(or cmu sbcl) |
105 |
(progn |
|
106 |
(defstruct (byte-array-input-stream |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
107 |
(:include #+cmu system:lisp-stream |
108 |
;;#+sbcl sb-impl::file-stream
|
|
109 |
#+(and sbcl old-sb-file-stream) sb-impl::file-stream |
|
110 |
#+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream |
|
111 |
(in #'byte-array-inch) |
|
112 |
(bin #'byte-array-binch) |
|
113 |
(n-bin #'byte-array-stream-read-n-bytes) |
|
114 |
(misc #'byte-array-in-misc)) |
|
115 |
(:print-function %print-byte-array-input-stream) |
|
116 |
;(:constructor nil)
|
|
117 |
(:constructor internal-make-byte-array-input-stream |
|
118 |
(byte-array current end))) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
119 |
(byte-array nil :type vector) |
120 |
(current nil) |
|
121 |
(end nil)) |
|
122 |
||
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
123 |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
124 |
(defun %print-byte-array-input-stream (s stream d) |
125 |
(declare (ignore s d)) |
|
126 |
(write-string "#<Byte-Array-Input Stream>" stream)) |
|
1.2.1
by Kevin M. Rosenberg
Import upstream version 1.82 |
127 |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
128 |
(defun byte-array-inch (stream eof-errorp eof-value) |
129 |
(let ((byte-array (byte-array-input-stream-byte-array stream)) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
130 |
(index (byte-array-input-stream-current stream))) |
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
131 |
(cond ((= index (byte-array-input-stream-end stream)) |
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
132 |
#+cmu |
133 |
(eof-or-lose stream eof-errorp eof-value) |
|
134 |
#+sbcl |
|
135 |
(sb-impl::eof-or-lose stream eof-errorp eof-value) |
|
136 |
)
|
|
137 |
(t |
|
138 |
(setf (byte-array-input-stream-current stream) (1+ index)) |
|
139 |
(aref byte-array index))))) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
140 |
|
141 |
(defun byte-array-binch (stream eof-errorp eof-value) |
|
142 |
(let ((byte-array (byte-array-input-stream-byte-array stream)) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
143 |
(index (byte-array-input-stream-current stream))) |
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
144 |
(cond ((= index (byte-array-input-stream-end stream)) |
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
145 |
#+cmu |
146 |
(eof-or-lose stream eof-errorp eof-value) |
|
147 |
#+sbcl |
|
148 |
(sb-impl::eof-or-lose stream eof-errorp eof-value) |
|
149 |
)
|
|
150 |
(t |
|
151 |
(setf (byte-array-input-stream-current stream) (1+ index)) |
|
152 |
(aref byte-array index))))) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
153 |
|
154 |
(defun byte-array-stream-read-n-bytes (stream buffer start requested eof-errorp) |
|
155 |
(declare (type byte-array-input-stream stream)) |
|
156 |
(let* ((byte-array (byte-array-input-stream-byte-array stream)) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
157 |
(index (byte-array-input-stream-current stream)) |
158 |
(available (- (byte-array-input-stream-end stream) index)) |
|
159 |
(copy (min available requested))) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
160 |
(when (plusp copy) |
161 |
(setf (byte-array-input-stream-current stream) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
162 |
(+ index copy)) |
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
163 |
#+cmu |
164 |
(system:without-gcing |
|
165 |
(system::system-area-copy (system:vector-sap byte-array) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
166 |
(* index vm:byte-bits) |
167 |
(if (typep buffer 'system::system-area-pointer) |
|
168 |
buffer
|
|
169 |
(system:vector-sap buffer)) |
|
170 |
(* start vm:byte-bits) |
|
171 |
(* copy vm:byte-bits))) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
172 |
#+sbcl |
173 |
(sb-sys:without-gcing |
|
1.2.1
by Kevin M. Rosenberg
Import upstream version 1.82 |
174 |
(funcall *system-copy-fn* (sb-sys:vector-sap byte-array) |
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
175 |
(* index +system-copy-multiplier+) |
176 |
(if (typep buffer 'sb-sys::system-area-pointer) |
|
177 |
buffer
|
|
178 |
(sb-sys:vector-sap buffer)) |
|
179 |
(* start +system-copy-multiplier+) |
|
180 |
(* copy +system-copy-multiplier+)))) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
181 |
(if (and (> requested copy) eof-errorp) |
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
182 |
(error 'end-of-file :stream stream) |
183 |
copy))) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
184 |
|
185 |
(defun byte-array-in-misc (stream operation &optional arg1 arg2) |
|
186 |
(declare (ignore arg2)) |
|
187 |
(case operation |
|
188 |
(:file-position |
|
189 |
(if arg1 |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
190 |
(setf (byte-array-input-stream-current stream) arg1) |
191 |
(byte-array-input-stream-current stream))) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
192 |
(:file-length (length (byte-array-input-stream-byte-array stream))) |
193 |
(:unread (decf (byte-array-input-stream-current stream))) |
|
194 |
(:listen (or (/= (the fixnum (byte-array-input-stream-current stream)) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
195 |
(the fixnum (byte-array-input-stream-end stream))) |
196 |
:eof)) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
197 |
(:element-type 'base-char))) |
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
198 |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
199 |
(defun make-byte-array-input-stream (buffer &optional (start 0) (end (length buffer))) |
200 |
"Returns an input stream which will supply the bytes of BUFFER between
|
|
201 |
Start and End in order."
|
|
202 |
(internal-make-byte-array-input-stream buffer start end)) |
|
203 |
||
204 |
) ;; progn |
|
205 |
||
1.2.1
by Kevin M. Rosenberg
Import upstream version 1.82 |
206 |
(eval-when (:compile-toplevel :load-toplevel :execute) |
207 |
(setq cl:*features* (delete :old-sb-file-stream cl:*features*))) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
208 |
|
209 |
;;; Simple streams implementation by Kevin Rosenberg
|
|
210 |
||
211 |
#+allegro |
|
212 |
(progn |
|
213 |
||
214 |
(defclass extendable-buffer-output-stream (excl:buffer-output-simple-stream) |
|
215 |
()
|
|
216 |
)
|
|
217 |
||
218 |
(defun make-byte-array-output-stream () |
|
219 |
"Returns an Output stream which will accumulate all output given it for
|
|
220 |
the benefit of the function Get-Output-Stream-Data."
|
|
221 |
(make-instance 'extendable-buffer-output-stream |
|
222 |
:buffer (make-array 128 :element-type '(unsigned-byte 8)) |
|
223 |
:external-form :octets)) |
|
224 |
||
225 |
(defun get-output-stream-data (stream) |
|
226 |
"Returns an array of all data sent to a stream made by
|
|
227 |
Make-Byte-Array-Output-Stream since the last call to this function
|
|
228 |
and clears buffer."
|
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
229 |
(prog1 |
230 |
(dump-output-stream-data stream) |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
231 |
(file-position stream 0))) |
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
232 |
|
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
233 |
(defun dump-output-stream-data (stream) |
234 |
"Returns an array of all data sent to a stream made by
|
|
235 |
Make-Byte-Array-Output-Stream since the last call to this function."
|
|
236 |
(force-output stream) |
|
237 |
(let* ((length (file-position stream)) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
238 |
(result (make-array length :element-type '(unsigned-byte 8)))) |
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
239 |
(replace result (slot-value stream 'excl::buffer)) |
240 |
result)) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
241 |
|
242 |
(excl::without-package-locks |
|
243 |
(defmethod excl:device-extend ((stream extendable-buffer-output-stream) |
|
244 |
need action) |
|
245 |
(declare (ignore action)) |
|
246 |
(let* ((len (file-position stream)) |
|
247 |
(new-len (max (+ len need) (* 2 len))) |
|
248 |
(old-buf (slot-value stream 'excl::buffer)) |
|
249 |
(new-buf (make-array new-len :element-type '(unsigned-byte 8)))) |
|
250 |
(declare (fixnum len) |
|
251 |
(optimize (speed 3) (safety 0))) |
|
252 |
(dotimes (i len) |
|
253 |
(setf (aref new-buf i) (aref old-buf i))) |
|
254 |
(setf (slot-value stream 'excl::buffer) new-buf) |
|
255 |
(setf (slot-value stream 'excl::buffer-ptr) new-len) |
|
256 |
)
|
|
257 |
t)) |
|
258 |
||
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
259 |
)
|
260 |
||
261 |
#+allegro |
|
262 |
(progn |
|
263 |
(defun make-byte-array-input-stream (buffer &optional (start 0) |
|
1.1.8
by Kevin M. Rosenberg
Import upstream version 1.97 |
264 |
(end (length buffer))) |
1
by Kevin M. Rosenberg
Import upstream version 1.73 |
265 |
(excl:make-buffer-input-stream buffer start end :octets)) |
266 |
) ;; progn |
|
1.2.1
by Kevin M. Rosenberg
Import upstream version 1.82 |
267 |
|
268 |