new file mode 100644

@@ -0,0 +1 @@

+*.fasl

new file mode 100644

@@ -0,0 +1 @@

+This is the stub README.txt for the "vector-update-stream" project.

new file mode 100644

@@ -0,0 +1,5 @@

+;;;; package.lisp

+

+(defpackage :vector-update-stream

+  (:use :cl :trivial-gray-streams))

+

new file mode 100644

@@ -0,0 +1,129 @@

+(in-package :vector-update-stream)

+

+(defclass vector-update-stream (fundamental-binary-output-stream)

+  ((vector :accessor vector-stream-vector :initarg :vector))

+  (:documentation "A binary output stream that writes its data to an associated vector."))

+

+(deftype octet ()

+  '(unsigned-byte 8))

+

+(defun make-update-stream (array)

+  (unless (and (array-has-fill-pointer-p array)

+	       (adjustable-array-p array))

+    (error "GET-STREAM-FOR-ARRAY requires an adjustable array with a fill pointer"))

+  (make-instance 'vector-update-stream

+		 :vector array))

+

+(defun check-if-open (stream)

+  "Checks if STREAM is open and signals an error otherwise."

+  (unless (open-stream-p stream)

+    (error 'flexi-streams:in-memory-stream-closed-error

+	   :stream stream)))

+

+(defmethod stream-write-byte ((stream vector-update-stream) byte)

+  "Writes a byte \(octet) by extending the underlying vector."

+  (check-if-open stream)

+  (with-accessors ((vector vector-stream-vector)) stream

+    (let ((orig-fill-pointer (fill-pointer vector)))

+      (handler-bind ((error (lambda (c)

+			      (declare (ignore c))

+			      (setf (fill-pointer vector) orig-fill-pointer))))

+	(vector-push-extend byte vector)))))

+

+(defmethod stream-write-sequence ((stream vector-update-stream) sequence start end &key)

+  "Just calls VECTOR-PUSH-EXTEND repeatedly."

+  (declare (fixnum start end))

+  (with-accessors ((vector vector-stream-vector)) stream

+    (let ((orig-fill-pointer (fill-pointer vector)))

+      (handler-bind ((error (lambda (c)

+			      (declare (ignore c))

+			      (setf (fill-pointer vector) orig-fill-pointer))))

+	(loop for index of-type fixnum from start below end

+	   do (vector-push-extend (elt sequence index) vector))))

+    sequence))

+

+(defmethod stream-file-position ((stream vector-update-stream))

+  "Simply returns the fill pointer of the underlying vector."

+  (with-accessors ((vector vector-stream-vector)) stream

+    (fill-pointer vector)))

+

+(defmethod (setf stream-file-position) (position-spec (stream vector-update-stream))

+  "Sets the fill pointer underlying vector if POSITION-SPEC is

+acceptable.  Adjusts the vector if necessary."

+  (with-accessors ((vector vector-stream-vector))

+      stream

+    (let* ((total-size (array-total-size vector))

+           (new-fill-pointer

+            (case position-spec

+              (:start 0)

+              (:end

+               (warn "File position designator :END doesn't really make sense for an output stream.")

+               total-size)

+              (otherwise

+               (unless (integerp position-spec)

+                 (error 'flexi-streams:in-memory-stream-position-spec-error

+                        :format-control "Unknown file position designator: ~S."

+                        :format-arguments (list position-spec)

+                        :stream stream

+                        :position-spec position-spec))

+               (unless (<= 0 position-spec array-total-size-limit)

+                 (error 'flexi-streams:in-memory-stream-position-spec-error

+                        :format-control "File position designator ~S is out of bounds."

+                        :format-arguments (list position-spec)

+                        :stream stream

+                        :position-spec position-spec))

+               position-spec))))

+      (declare (fixnum total-size new-fill-pointer))

+      (when (> new-fill-pointer total-size)

+        (adjust-array vector new-fill-pointer))

+      (setf (fill-pointer vector) new-fill-pointer)

+      position-spec)))

+

+(defmethod get-output-stream-sequence ((stream vector-update-stream) &key)

+  "Returns a vector containing, in order, all the octets that have

+been output to the IN-MEMORY stream STREAM. This operation clears any

+octets on STREAM, so the vector contains only those octets which have

+been output since the last call to GET-OUTPUT-STREAM-SEQUENCE or since

+the creation of the stream, whichever occurred most recently.  If

+AS-LIST is true the return value is coerced to a list."

+  (vector-stream-vector stream))

+

+(defmacro deftest (name (expected actual-init) (&rest bindings) &body actions)

+  (alexandria:with-gensyms (assertion-template)

+    `(let* ((expected ,expected)

+	    (actual ,actual-init)

+	    ,@bindings

+	    (,assertion-template (formatter "~&~a Test: ~:[fail~%~4texpected ~s~%~4tactual ~s~;succeed~]~%")))

+       (declare (ignorable ,assertion-template))

+       (flet ((check (assertion)

+		    (funcall ,assertion-template t ',name (funcall assertion expected actual) expected actual)))

+	 ,@actions)

+       (values))))

+

+(defun test ()

+  (deftest write-sequence

+      (#(1 2 3) (make-array 0 :adjustable t :fill-pointer 0))

+      ((vs (make-update-stream actual)))

+    (write-sequence expected vs)

+    (check 'serapeum:vector=))

+

+  (deftest write-sequence-undo-on-error

+      (#(1 2 3) (make-array 0 :adjustable t :fill-pointer 0 :element-type 'octet))

+      ((vs (make-update-stream actual)))

+    (write-sequence expected vs)

+    (handler-case (write-sequence #(1 2 3 #\a) vs)

+      (type-error (c) c (values)))

+    (check 'serapeum:vector=))

+

+  (deftest write-byte

+      (#(1) (make-array 0 :adjustable t :fill-pointer 0))

+      ((vs (make-update-stream actual)))

+    (write-byte 1 vs)

+    (check 'serapeum:vector=))

+

+  (deftest write-byte-undo-on-error

+      (#() (make-array 0 :adjustable t :fill-pointer 0 :element-type 'octet))

+      ((vs (make-update-stream actual)))

+    (handler-case (stream-write-byte vs #\a)

+      (type-error (c) c (values)))

+    (check 'serapeum:vector=)))

new file mode 100644

@@ -0,0 +1,14 @@

+;;;; vector-update-stream.asd

+

+(asdf:defsystem #:vector-update-stream

+  :description "A stream that updates a user-provided backing vector, based on flexi-streams"

+  :author "Ed Langley <fiddlerwoaroof@gmail.com"

+  :license "BSD-2-CLAUSE"

+  :depends-on (#:trivial-gray-streams

+	       #:flexi-streams

+               #:alexandria

+               #:serapeum)

+  :serial t

+  :components ((:file "package")

+               (:file "stream-to-vector")))

+

new file mode 100644

@@ -0,0 +1,6 @@

+;;;; vector-update-stream.lisp

+

+(in-package #:vector-update-stream)

+

+;;; "vector-update-stream" goes here. Hacks and glory await!

+