tin-memory.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP (HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/ (DIR) Log (DIR) Files (DIR) Refs (DIR) Tags (DIR) LICENSE --- tin-memory.lisp (19043B) --- 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 for index of-type fixnum from start below end 201 while list 202 do (setf (elt sequence index) (pop list)) 203 finally (return index)))) 204 205 (defmethod stream-read-byte ((stream vector-input-stream)) 206 "Reads one byte and increments INDEX pointer unless we're beyond 207 END pointer." 208 (declare #.*standard-optimize-settings*) 209 (check-if-open stream) 210 (with-accessors ((index vector-stream-index) 211 (end vector-stream-end) 212 (vector vector-stream-vector)) 213 stream 214 (let ((current-index index)) 215 (declare (fixnum current-index)) 216 (cond ((< current-index (the fixnum end)) 217 (incf (the fixnum index)) 218 (transform-octet stream (aref vector current-index))) 219 (t :eof))))) 220 221 (defmethod stream-listen ((stream vector-input-stream)) 222 "Checking whether INDEX is beyond END." 223 (declare #.*standard-optimize-settings*) 224 (check-if-open stream) 225 (with-accessors ((index vector-stream-index) 226 (end vector-stream-end)) 227 stream 228 (< (the fixnum index) (the fixnum end)))) 229 230 (defmethod stream-read-sequence ((stream vector-input-stream) sequence start end &key) 231 "Traverses both sequences in parallel until the end of one of them 232 is reached." 233 (declare #.*standard-optimize-settings*) 234 (declare (fixnum start end)) 235 (loop with vector-end of-type fixnum = (vector-stream-end stream) 236 with vector = (vector-stream-vector stream) 237 for index of-type fixnum from start below end 238 for vector-index of-type fixnum = (vector-stream-index stream) 239 while (< vector-index vector-end) 240 do (setf (elt sequence index) 241 (aref vector vector-index)) 242 (incf (the fixnum (vector-stream-index stream))) 243 finally (return index))) 244 245 (defmethod stream-write-byte ((stream vector-output-stream) byte) 246 "Writes a byte \(octet) by extending the underlying vector." 247 (declare #.*standard-optimize-settings*) 248 (check-if-open stream) 249 (with-accessors ((vector vector-stream-vector)) 250 stream 251 (vector-push-extend (transform-octet stream byte) vector))) 252 253 (defmethod stream-write-sequence ((stream vector-output-stream) sequence start end &key) 254 "Just calls VECTOR-PUSH-EXTEND repeatedly." 255 (declare #.*standard-optimize-settings*) 256 (declare (fixnum start end)) 257 (with-accessors ((vector vector-stream-vector)) 258 stream 259 (loop for index of-type fixnum from start below end 260 do (vector-push-extend (transform-octet stream (elt sequence index)) vector)) 261 sequence)) 262 263 (defmethod stream-file-position ((stream vector-input-stream)) 264 "Simply returns the index into the underlying vector." 265 (declare #.*standard-optimize-settings*) 266 (with-accessors ((index vector-stream-index)) 267 stream 268 index)) 269 270 (defmethod (setf stream-file-position) (position-spec (stream vector-input-stream)) 271 "Sets the index into the underlying vector if POSITION-SPEC is acceptable." 272 (declare #.*standard-optimize-settings*) 273 (with-accessors ((index vector-stream-index) 274 (end vector-stream-end)) 275 stream 276 (setq index 277 (case position-spec 278 (:start 0) 279 (:end end) 280 (otherwise 281 (unless (integerp position-spec) 282 (error 'in-memory-stream-position-spec-error 283 :format-control "Unknown file position designator: ~S." 284 :format-arguments (list position-spec) 285 :stream stream 286 :position-spec position-spec)) 287 (unless (<= 0 position-spec end) 288 (error 'in-memory-stream-position-spec-error 289 :format-control "File position designator ~S is out of bounds." 290 :format-arguments (list position-spec) 291 :stream stream 292 :position-spec position-spec)) 293 position-spec))) 294 position-spec)) 295 296 (defmethod stream-file-position ((stream vector-output-stream)) 297 "Simply returns the fill pointer of the underlying vector." 298 (declare #.*standard-optimize-settings*) 299 (with-accessors ((vector vector-stream-vector)) 300 stream 301 (fill-pointer vector))) 302 303 (defmethod (setf stream-file-position) (position-spec (stream vector-output-stream)) 304 "Sets the fill pointer underlying vector if POSITION-SPEC is 305 acceptable. Adjusts the vector if necessary." 306 (declare #.*standard-optimize-settings*) 307 (with-accessors ((vector vector-stream-vector)) 308 stream 309 (let* ((total-size (array-total-size vector)) 310 (new-fill-pointer 311 (case position-spec 312 (:start 0) 313 (:end 314 (warn "File position designator :END doesn't really make sense for an output stream.") 315 total-size) 316 (otherwise 317 (unless (integerp position-spec) 318 (error 'in-memory-stream-position-spec-error 319 :format-control "Unknown file position designator: ~S." 320 :format-arguments (list position-spec) 321 :stream stream 322 :position-spec position-spec)) 323 (unless (<= 0 position-spec array-total-size-limit) 324 (error 'in-memory-stream-position-spec-error 325 :format-control "File position designator ~S is out of bounds." 326 :format-arguments (list position-spec) 327 :stream stream 328 :position-spec position-spec)) 329 position-spec)))) 330 (declare (fixnum total-size new-fill-pointer)) 331 (when (> new-fill-pointer total-size) 332 (adjust-array vector new-fill-pointer)) 333 (setf (fill-pointer vector) new-fill-pointer) 334 position-spec))) 335 336 (defmethod make-in-memory-input-stream ((vector vector) &key (start 0) 337 (end (length vector)) 338 transformer) 339 "Returns a binary input stream which will supply, in order, the 340 octets in the subsequence of VECTOR bounded by START and END. 341 Each octet returned will be transformed in turn by the optional 342 TRANSFORMER function." 343 (declare #.*standard-optimize-settings*) 344 (make-instance 'vector-input-stream 345 :vector vector 346 :index start 347 :end end 348 :transformer transformer)) 349 350 (defmethod make-in-memory-input-stream ((list list) &key (start 0) 351 (end (length list)) 352 transformer) 353 "Returns a binary input stream which will supply, in order, the 354 octets in the subsequence of LIST bounded by START and END. Each 355 octet returned will be transformed in turn by the optional 356 TRANSFORMER function." 357 (declare #.*standard-optimize-settings*) 358 (make-instance 'list-input-stream 359 :list (subseq list start end) 360 :transformer transformer)) 361 362 (defun make-output-vector (&key (element-type 'octet)) 363 "Creates and returns an array which can be used as the underlying 364 vector for a VECTOR-OUTPUT-STREAM." 365 (declare #.*standard-optimize-settings*) 366 (make-array 0 :adjustable t 367 :fill-pointer 0 368 :element-type element-type)) 369 370 (defun make-in-memory-output-stream (&key (element-type 'octet) transformer) 371 "Returns a binary output stream which accepts objects of type 372 ELEMENT-TYPE \(a subtype of OCTET) and makes available a sequence 373 that contains the octes that were actually output. The octets 374 stored will each be transformed by the optional TRANSFORMER 375 function." 376 (declare #.*standard-optimize-settings*) 377 (make-instance 'vector-output-stream 378 :vector (make-output-vector :element-type element-type) 379 :transformer transformer)) 380 381 (defmethod get-output-stream-sequence ((stream in-memory-output-stream) &key as-list) 382 "Returns a vector containing, in order, all the octets that have 383 been output to the IN-MEMORY stream STREAM. This operation clears any 384 octets on STREAM, so the vector contains only those octets which have 385 been output since the last call to GET-OUTPUT-STREAM-SEQUENCE or since 386 the creation of the stream, whichever occurred most recently. If 387 AS-LIST is true the return value is coerced to a list." 388 (declare #.*standard-optimize-settings*) 389 (with-accessors ((vector vector-stream-vector)) 390 stream 391 (prog1 392 (if as-list 393 (coerce vector 'list) 394 vector) 395 (setq vector 396 (make-output-vector))))) 397 398 (defmethod output-stream-sequence-length ((stream in-memory-output-stream)) 399 "Returns the current length of the underlying vector of the 400 IN-MEMORY output stream STREAM." 401 (declare (optimize speed)) 402 (length (the vector (vector-stream-vector stream)))) 403 404 (defmacro with-input-from-sequence ((var sequence &key start end transformer) 405 &body body) 406 "Creates an IN-MEMORY input stream from SEQUENCE using the 407 parameters START and END, binds VAR to this stream and then 408 executes the code in BODY. A function TRANSFORMER may optionally 409 be specified to transform the returned octets. The stream is 410 automatically closed on exit from WITH-INPUT-FROM-SEQUENCE, no 411 matter whether the exit is normal or abnormal. The return value 412 of this macro is the return value of BODY." 413 (with-rebinding (sequence) 414 `(let (,var) 415 (unwind-protect 416 (progn 417 (setq ,var (make-in-memory-input-stream ,sequence 418 :start (or ,start 0) 419 :end (or ,end (length ,sequence)) 420 :transformer ,transformer)) 421 ,@body) 422 (when ,var (close ,var)))))) 423 424 (defmacro with-output-to-sequence ((var &key as-list (element-type ''octet) transformer) 425 &body body) 426 "Creates an IN-MEMORY output stream, binds VAR to this stream 427 and then executes the code in BODY. The stream stores data of 428 type ELEMENT-TYPE \(a subtype of OCTET) which is \(optionally) 429 transformed by the function TRANSFORMER prior to storage. The 430 stream is automatically closed on exit from 431 WITH-OUTPUT-TO-SEQUENCE, no matter whether the exit is normal or 432 abnormal. The return value of this macro is a vector \(or a list 433 if AS-LIST is true) containing the octets that were sent to the 434 stream within BODY." 435 `(let (,var) 436 (unwind-protect 437 (progn 438 (setq ,var (make-in-memory-output-stream :element-type ,element-type 439 :transformer ,transformer)) 440 ,@body 441 (get-output-stream-sequence ,var :as-list ,as-list)) 442 (when ,var (close ,var)))))