Add hurd-output-stream class and implementation.

1 files changed, 91 insertions, 0 deletions

diff --git a/streams/output.lisp b/streams/output.lisp
new file mode 100644
index 000000000..b206e3304
--- /dev/null
+++ b/streams/output.lisp
@@ -0,0 +1,91 @@
+
+(in-package :hurd-streams)
+
+(defclass hurd-output-stream (hurd-stream fundamental-binary-output-stream)
+  ((cache :initform (%create-adjustable-array 0)
+          :accessor cache)))
+
+(defmethod stream-write-byte ((stream hurd-output-stream) byte)
+  (vector-push-extend byte (cache stream)))
+
+(defmethod stream-write-char ((stream hurd-output-stream) char)
+  (stream-write-byte stream (char-code char)))
+
+(defun %hurd-stream-write-warn (stream err)
+  (warn "Error writing to hurd-output-stream ~s: ~s"
+        stream err))
+
+(defmethod %hurd-stream-inner-write ((stream hurd-output-stream))
+  (with-accessors ((cache cache) (port port) (offset offset))
+    stream
+    (let ((total (fill-pointer cache)))
+      (multiple-value-bind (total-written err)
+        (io-write port cache :offset offset)
+        (when err
+          (%hurd-stream-write-warn stream err)
+          (return-from %hurd-stream-inner-write nil))
+        (incf offset total-written)
+        (unless (= total-written total)
+          (replace cache cache
+                   :start2 total-written)
+          (setf (fill-pointer cache) total-written)
+          (%hurd-stream-inner-write stream))))))
+
+(defun %hurd-stream-has-data-p (stream)
+  (plusp (fill-pointer (cache stream))))
+
+(defmethod %hurd-stream-write ((stream hurd-output-stream))
+  (with-accessors ((cache cache)) stream
+    (cond
+      ((%hurd-stream-has-data-p stream)
+       (when (%hurd-stream-inner-write stream)
+         (setf (fill-pointer cache) 0)
+         t))
+      (t t))))
+
+(defmethod stream-finish-output ((stream hurd-output-stream))
+  (%hurd-stream-write stream))
+
+(defmethod stream-force-output ((stream hurd-output-stream))
+  (%hurd-stream-write stream))
+
+(defmethod %hurd-stream-write-seq ((stream hurd-output-stream) seq)
+  (with-accessors ((port port) (offset offset))
+    stream
+    (let ((total (length seq)))
+      (multiple-value-bind (total-written err)
+        (io-write port seq :offset offset)
+        (when err
+          (%hurd-stream-write-warn stream err)
+          (return-from %hurd-stream-write-seq nil))
+        (incf offset total-written)
+        (unless (= total-written total)
+          (%hurd-stream-write-seq
+            stream
+            (subseq seq total-written))))))
+  t)
+
+(defmethod stream-write-sequence ((stream hurd-output-stream)
+                                  sequence start end &key)
+  (when (%hurd-stream-write stream)
+    (%hurd-stream-write-seq stream
+                            (subseq sequence start end))))
+
+(defmethod stream-start-line-p ((stream hurd-output-stream))
+  nil)
+
+(defmethod stream-line-column ((stream hurd-output-stream))
+  nil)
+
+(defmethod make-hurd-output-stream ((file string) &optional (flags '(:write)))
+  (make-hurd-output-stream
+    (file-name-lookup file :flags flags)))
+
+(defmethod make-hurd-output-stream ((port number) &optional flags)
+  (declare (ignore flags))
+  (make-instance 'hurd-output-stream :port port))
+
+(defmacro with-hurd-output-stream ((stream-name file &optional (flags ''(:write))) &body body)
+  `(with-stream (,stream-name (make-hurd-output-stream ,file ,flags))
+     ,@body))
+