in-memory.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
in-memory.lisp (19444B)
---
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
2 ;;; $Header: /usr/local/cvsrep/flexi-streams/in-memory.lisp,v 1.31 2008/05/19 07:57:07 edi Exp $
3
4 ;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
5
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 (in-package :flexi-streams)
31
32 (defclass in-memory-stream (trivial-gray-stream-mixin)
33 ((transformer :initarg :transformer
34 :accessor in-memory-stream-transformer
35 :documentation "A function used to transform the
36 written/read octet to the value stored/retrieved in/from the
37 underlying vector.")
38 #+:cmu
39 (open-p :initform t
40 :accessor in-memory-stream-open-p
41 :documentation "For CMUCL we have to keep track of this
42 manually."))
43 (:documentation "An IN-MEMORY-STREAM is a binary stream that reads
44 octets from or writes octets to a sequence in RAM."))
45
46 (defclass in-memory-input-stream (in-memory-stream fundamental-binary-input-stream)
47 ()
48 (:documentation "An IN-MEMORY-INPUT-STREAM is a binary stream that
49 reads octets from a sequence in RAM."))
50
51 #+:cmu
52 (defmethod output-stream-p ((stream in-memory-input-stream))
53 "Explicitly states whether this is an output stream."
54 (declare (optimize speed))
55 nil)
56
57 (defclass in-memory-output-stream (in-memory-stream fundamental-binary-output-stream)
58 ()
59 (:documentation "An IN-MEMORY-OUTPUT-STREAM is a binary stream that
60 writes octets to a sequence in RAM."))
61
62 #+:cmu
63 (defmethod input-stream-p ((stream in-memory-output-stream))
64 "Explicitly states whether this is an input stream."
65 (declare (optimize speed))
66 nil)
67
68 (defclass list-stream ()
69 ((list :initarg :list
70 :accessor list-stream-list
71 :documentation "The underlying list of the stream."))
72 (:documentation "A LIST-STREAM is a mixin for IN-MEMORY streams
73 where the underlying sequence is a list."))
74
75 (defclass vector-stream ()
76 ((vector :initarg :vector
77 :accessor vector-stream-vector
78 :documentation "The underlying vector of the stream which
79 \(for output) must always be adjustable and have a fill pointer."))
80 (:documentation "A VECTOR-STREAM is a mixin for IN-MEMORY streams
81 where the underlying sequence is a vector."))
82
83 (defclass list-input-stream (list-stream in-memory-input-stream)
84 ()
85 (:documentation "A binary input stream that gets its data from an
86 associated list of octets."))
87
88 (defclass vector-input-stream (vector-stream in-memory-input-stream)
89 ((index :initarg :index
90 :accessor vector-stream-index
91 :type (integer 0 #.array-dimension-limit)
92 :documentation "An index into the underlying vector denoting
93 the current position.")
94 (end :initarg :end
95 :accessor vector-stream-end
96 :type (integer 0 #.array-dimension-limit)
97 :documentation "An index into the underlying vector denoting
98 the end of the available data."))
99 (:documentation "A binary input stream that gets its data from an
100 associated vector of octets."))
101
102 (defclass vector-output-stream (vector-stream in-memory-output-stream)
103 ()
104 (:documentation "A binary output stream that writes its data to an
105 associated vector."))
106
107 #+:cmu
108 (defmethod open-stream-p ((stream in-memory-stream))
109 "Returns a true value if STREAM is open. See ANSI standard."
110 (declare #.*standard-optimize-settings*)
111 (in-memory-stream-open-p stream))
112
113 #+:cmu
114 (defmethod close ((stream in-memory-stream) &key abort)
115 "Closes the stream STREAM. See ANSI standard."
116 (declare #.*standard-optimize-settings*)
117 (declare (ignore abort))
118 (prog1
119 (in-memory-stream-open-p stream)
120 (setf (in-memory-stream-open-p stream) nil)))
121
122 (defmethod check-if-open ((stream in-memory-stream))
123 "Checks if STREAM is open and signals an error otherwise."
124 (declare #.*standard-optimize-settings*)
125 (unless (open-stream-p stream)
126 (error 'in-memory-stream-closed-error
127 :stream stream)))
128
129 (defmethod stream-element-type ((stream in-memory-stream))
130 "The element type is always OCTET by definition."
131 (declare #.*standard-optimize-settings*)
132 'octet)
133
134 (defgeneric peek-byte (stream &optional peek-type eof-err-p eof-value)
135 (:documentation
136 "PEEK-BYTE is like PEEK-CHAR, i.e. it returns a byte from the stream without
137 actually removing it. If PEEK-TYPE is NIL the next byte is returned, if
138 PEEK-TYPE is T, the next byte which is not 0 is returned, if PEEK-TYPE is an
139 byte, the next byte which equals PEEK-TYPE is returned. EOF-ERROR-P and
140 EOF-VALUE are interpreted as usual."))
141
142 (defmethod peek-byte ((stream vector-input-stream) &optional peek-type (eof-error-p t) eof-value)
143 "Returns a byte from VECTOR-INPUT-STREAM without actually removing it."
144 (declare #.*standard-optimize-settings*)
145 (let ((index (vector-stream-index stream)))
146 (loop :for byte = (read-byte stream eof-error-p :eof)
147 :for new-index :from index
148 :until (cond ((eq byte :eof)
149 (return eof-value))
150 ((null peek-type))
151 ((eq peek-type 't)
152 (plusp byte))
153 ((= byte peek-type)))
154 :finally (setf (slot-value stream 'index) new-index)
155 (return byte))))
156
157 (defmethod peek-byte ((stream list-input-stream) &optional peek-type (eof-error-p t) eof-value)
158 "Returns a byte from VECTOR-INPUT-STREAM without actually removing it."
159 (declare #.*standard-optimize-settings*)
160 (loop
161 :for list-elem = (car (list-stream-list stream))
162 :for byte = (read-byte stream eof-error-p :eof)
163 :until (cond ((eq byte :eof)
164 (return eof-value))
165 ((null peek-type))
166 ((eq peek-type 't)
167 (plusp byte))
168 ((= byte peek-type)))
169 :finally (push list-elem (list-stream-list stream))
170 (return byte)))
171
172 (defmethod transform-octet ((stream in-memory-stream) octet)
173 "Applies the transformer of STREAM to octet and returns the result."
174 (declare #.*standard-optimize-settings*)
175 (funcall (or (in-memory-stream-transformer stream)
176 #'identity) octet))
177
178 (defmethod stream-read-byte ((stream list-input-stream))
179 "Reads one byte by simply popping it off of the top of the list."
180 (declare #.*standard-optimize-settings*)
181 (check-if-open stream)
182 (with-accessors ((list list-stream-list))
183 stream
184 (transform-octet stream (or (pop list) (return-from stream-read-byte :eof)))))
185
186 (defmethod stream-listen ((stream list-input-stream))
187 "Checks whether list is not empty."
188 (declare #.*standard-optimize-settings*)
189 (check-if-open stream)
190 (with-accessors ((list list-stream-list))
191 stream
192 list))
193
194 (defmethod stream-read-sequence ((stream list-input-stream) sequence start end &key)
195 "Repeatedly pops elements from the list until it's empty."
196 (declare #.*standard-optimize-settings*)
197 (declare (fixnum start end))
198 (with-accessors ((list list-stream-list))
199 stream
200 (loop with transformer = (in-memory-stream-transformer stream)
201 for index of-type fixnum from start below end
202 while list
203 do (let ((elt (pop list)))
204 (setf (elt sequence index)
205 (if transformer
206 (funcall transformer elt)
207 elt)))
208 finally (return index))))
209
210 (defmethod stream-read-byte ((stream vector-input-stream))
211 "Reads one byte and increments INDEX pointer unless we're beyond
212 END pointer."
213 (declare #.*standard-optimize-settings*)
214 (check-if-open stream)
215 (with-accessors ((index vector-stream-index)
216 (end vector-stream-end)
217 (vector vector-stream-vector))
218 stream
219 (let ((current-index index))
220 (declare (fixnum current-index))
221 (cond ((< current-index (the fixnum end))
222 (incf (the fixnum index))
223 (transform-octet stream (aref vector current-index)))
224 (t :eof)))))
225
226 (defmethod stream-listen ((stream vector-input-stream))
227 "Checking whether INDEX is beyond END."
228 (declare #.*standard-optimize-settings*)
229 (check-if-open stream)
230 (with-accessors ((index vector-stream-index)
231 (end vector-stream-end))
232 stream
233 (< (the fixnum index) (the fixnum end))))
234
235 (defmethod stream-read-sequence ((stream vector-input-stream) sequence start end &key)
236 "Traverses both sequences in parallel until the end of one of them
237 is reached."
238 (declare #.*standard-optimize-settings*)
239 (declare (fixnum start end))
240 (loop with vector-end of-type fixnum = (vector-stream-end stream)
241 with vector = (vector-stream-vector stream)
242 with transformer = (in-memory-stream-transformer stream)
243 for index of-type fixnum from start below end
244 for vector-index of-type fixnum = (vector-stream-index stream)
245 while (< vector-index vector-end)
246 do (let ((elt (aref vector vector-index)))
247 (setf (elt sequence index)
248 (if transformer
249 (funcall transformer elt)
250 elt)))
251 (incf (the fixnum (vector-stream-index stream)))
252 finally (return index)))
253
254 (defmethod stream-write-byte ((stream vector-output-stream) byte)
255 "Writes a byte \(octet) by extending the underlying vector."
256 (declare #.*standard-optimize-settings*)
257 (check-if-open stream)
258 (with-accessors ((vector vector-stream-vector))
259 stream
260 (vector-push-extend (transform-octet stream byte) vector)))
261
262 (defmethod stream-write-sequence ((stream vector-output-stream) sequence start end &key)
263 "Just calls VECTOR-PUSH-EXTEND repeatedly."
264 (declare #.*standard-optimize-settings*)
265 (declare (fixnum start end))
266 (with-accessors ((vector vector-stream-vector))
267 stream
268 (loop for index of-type fixnum from start below end
269 do (vector-push-extend (transform-octet stream (elt sequence index)) vector))
270 sequence))
271
272 (defmethod stream-file-position ((stream vector-input-stream))
273 "Simply returns the index into the underlying vector."
274 (declare #.*standard-optimize-settings*)
275 (with-accessors ((index vector-stream-index))
276 stream
277 index))
278
279 (defmethod (setf stream-file-position) (position-spec (stream vector-input-stream))
280 "Sets the index into the underlying vector if POSITION-SPEC is acceptable."
281 (declare #.*standard-optimize-settings*)
282 (with-accessors ((index vector-stream-index)
283 (end vector-stream-end))
284 stream
285 (setq index
286 (case position-spec
287 (:start 0)
288 (:end end)
289 (otherwise
290 (unless (integerp position-spec)
291 (error 'in-memory-stream-position-spec-error
292 :format-control "Unknown file position designator: ~S."
293 :format-arguments (list position-spec)
294 :stream stream
295 :position-spec position-spec))
296 (unless (<= 0 position-spec end)
297 (error 'in-memory-stream-position-spec-error
298 :format-control "File position designator ~S is out of bounds."
299 :format-arguments (list position-spec)
300 :stream stream
301 :position-spec position-spec))
302 position-spec)))
303 position-spec))
304
305 (defmethod stream-file-position ((stream vector-output-stream))
306 "Simply returns the fill pointer of the underlying vector."
307 (declare #.*standard-optimize-settings*)
308 (with-accessors ((vector vector-stream-vector))
309 stream
310 (fill-pointer vector)))
311
312 (defmethod (setf stream-file-position) (position-spec (stream vector-output-stream))
313 "Sets the fill pointer underlying vector if POSITION-SPEC is
314 acceptable. Adjusts the vector if necessary."
315 (declare #.*standard-optimize-settings*)
316 (with-accessors ((vector vector-stream-vector))
317 stream
318 (let* ((total-size (array-total-size vector))
319 (new-fill-pointer
320 (case position-spec
321 (:start 0)
322 (:end
323 (warn "File position designator :END doesn't really make sense for an output stream.")
324 total-size)
325 (otherwise
326 (unless (integerp position-spec)
327 (error 'in-memory-stream-position-spec-error
328 :format-control "Unknown file position designator: ~S."
329 :format-arguments (list position-spec)
330 :stream stream
331 :position-spec position-spec))
332 (unless (<= 0 position-spec array-total-size-limit)
333 (error 'in-memory-stream-position-spec-error
334 :format-control "File position designator ~S is out of bounds."
335 :format-arguments (list position-spec)
336 :stream stream
337 :position-spec position-spec))
338 position-spec))))
339 (declare (fixnum total-size new-fill-pointer))
340 (when (> new-fill-pointer total-size)
341 (adjust-array vector new-fill-pointer))
342 (setf (fill-pointer vector) new-fill-pointer)
343 position-spec)))
344
345 (defmethod make-in-memory-input-stream ((vector vector) &key (start 0)
346 (end (length vector))
347 transformer)
348 "Returns a binary input stream which will supply, in order, the
349 octets in the subsequence of VECTOR bounded by START and END.
350 Each octet returned will be transformed in turn by the optional
351 TRANSFORMER function."
352 (declare #.*standard-optimize-settings*)
353 (make-instance 'vector-input-stream
354 :vector vector
355 :index start
356 :end end
357 :transformer transformer))
358
359 (defmethod make-in-memory-input-stream ((list list) &key (start 0)
360 (end (length list))
361 transformer)
362 "Returns a binary input stream which will supply, in order, the
363 octets in the subsequence of LIST bounded by START and END. Each
364 octet returned will be transformed in turn by the optional
365 TRANSFORMER function."
366 (declare #.*standard-optimize-settings*)
367 (make-instance 'list-input-stream
368 :list (subseq list start end)
369 :transformer transformer))
370
371 (defun make-output-vector (&key (element-type 'octet))
372 "Creates and returns an array which can be used as the underlying
373 vector for a VECTOR-OUTPUT-STREAM."
374 (declare #.*standard-optimize-settings*)
375 (make-array 0 :adjustable t
376 :fill-pointer 0
377 :element-type element-type))
378
379 (defun make-in-memory-output-stream (&key (element-type 'octet) transformer)
380 "Returns a binary output stream which accepts objects of type
381 ELEMENT-TYPE \(a subtype of OCTET) and makes available a sequence
382 that contains the octes that were actually output. The octets
383 stored will each be transformed by the optional TRANSFORMER
384 function."
385 (declare #.*standard-optimize-settings*)
386 (make-instance 'vector-output-stream
387 :vector (make-output-vector :element-type element-type)
388 :transformer transformer))
389
390 (defmethod get-output-stream-sequence ((stream in-memory-output-stream) &key as-list)
391 "Returns a vector containing, in order, all the octets that have
392 been output to the IN-MEMORY stream STREAM. This operation clears any
393 octets on STREAM, so the vector contains only those octets which have
394 been output since the last call to GET-OUTPUT-STREAM-SEQUENCE or since
395 the creation of the stream, whichever occurred most recently. If
396 AS-LIST is true the return value is coerced to a list."
397 (declare #.*standard-optimize-settings*)
398 (with-accessors ((vector vector-stream-vector))
399 stream
400 (prog1
401 (if as-list
402 (coerce vector 'list)
403 vector)
404 (setq vector
405 (make-output-vector)))))
406
407 (defmethod output-stream-sequence-length ((stream in-memory-output-stream))
408 "Returns the current length of the underlying vector of the
409 IN-MEMORY output stream STREAM."
410 (declare (optimize speed))
411 (length (the vector (vector-stream-vector stream))))
412
413 (defmacro with-input-from-sequence ((var sequence &key start end transformer)
414 &body body)
415 "Creates an IN-MEMORY input stream from SEQUENCE using the
416 parameters START and END, binds VAR to this stream and then
417 executes the code in BODY. A function TRANSFORMER may optionally
418 be specified to transform the returned octets. The stream is
419 automatically closed on exit from WITH-INPUT-FROM-SEQUENCE, no
420 matter whether the exit is normal or abnormal. The return value
421 of this macro is the return value of BODY."
422 (with-rebinding (sequence)
423 `(let (,var)
424 (unwind-protect
425 (progn
426 (setq ,var (make-in-memory-input-stream ,sequence
427 :start (or ,start 0)
428 :end (or ,end (length ,sequence))
429 :transformer ,transformer))
430 ,@body)
431 (when ,var (close ,var))))))
432
433 (defmacro with-output-to-sequence ((var &key as-list (element-type ''octet) transformer)
434 &body body)
435 "Creates an IN-MEMORY output stream, binds VAR to this stream
436 and then executes the code in BODY. The stream stores data of
437 type ELEMENT-TYPE \(a subtype of OCTET) which is \(optionally)
438 transformed by the function TRANSFORMER prior to storage. The
439 stream is automatically closed on exit from
440 WITH-OUTPUT-TO-SEQUENCE, no matter whether the exit is normal or
441 abnormal. The return value of this macro is a vector \(or a list
442 if AS-LIST is true) containing the octets that were sent to the
443 stream within BODY."
444 `(let (,var)
445 (unwind-protect
446 (progn
447 (setq ,var (make-in-memory-output-stream :element-type ,element-type
448 :transformer ,transformer))
449 ,@body
450 (get-output-stream-sequence ,var :as-list ,as-list))
451 (when ,var (close ,var)))))