From d0e880a10c0fc4e983a7127003fff561fad647c6 Mon Sep 17 00:00:00 2001 From: Stelian Ionescu Date: Sun, 25 Jan 2009 20:27:18 +0100 Subject: [PATCH] Add *stream-instance-flags stuff from cmucl's simple-streams. --- io.streams/zeta/file-unix.lisp | 62 +++++++--------- io.streams/zeta/stream.lisp | 159 ++++++++++++++++++++++++++++++----------- io.streams/zeta/types.lisp | 2 +- 3 files changed, 145 insertions(+), 78 deletions(-) diff --git a/io.streams/zeta/file-unix.lisp b/io.streams/zeta/file-unix.lisp index 2275e32..2c7cc1b 100644 --- a/io.streams/zeta/file-unix.lisp +++ b/io.streams/zeta/file-unix.lisp @@ -23,7 +23,7 @@ (defvar *default-open-mode* #o666) -(defclass file-zstream (single-channel-zstream) ()) +(defclass file-zstream (file-device single-channel-zstream) ()) ;;;------------------------------------------------------------------------- @@ -40,26 +40,22 @@ ;;;------------------------------------------------------------------------- (defmethod shared-initialize :after - ((device file-device) slot-names &rest initargs - &key handle filename flags (mode *default-open-mode*) delete-if-exists) - ;; FIXME: use new pathnames - (check-type filename string) - (setf (file-device-filename device) (copy-seq filename)) - (with-device (device) - (device-open device slot-names initargs))) + ((stream file-zstream) slot-names &rest initargs) + (with-device (stream) + (device-open stream slot-names initargs)) + (add-zstream-instance-flags stream :zeta) + (setf (slot-value stream 'base-device) stream + (slot-value stream 'device) stream)) ;;;------------------------------------------------------------------------- ;;; PRINT-OBJECT ;;;------------------------------------------------------------------------- -(defmethod print-object ((file file-device) stream) - (print-unreadable-object (file stream :identity t :type nil) - (format stream "File device for ~S" (file-device-filename file)))) - (defmethod print-object ((file file-zstream) stream) (print-unreadable-object (file stream :identity t :type t) - (format stream "wrapping ~S" (zstream-device file)))) + (format stream "File stream for ~S" + (file-device-filename (zstream-device file))))) ;;;------------------------------------------------------------------------- @@ -67,14 +63,18 @@ ;;;------------------------------------------------------------------------- (defmethod device-open ((device file-device) slot-names initargs) - (destructuring-bind (&key handle filename flags mode delete-if-exists) + (destructuring-bind (&key handle filename flags delete-if-exists + (mode *default-open-mode*)) initargs + ;; FIXME: use new pathnames + (check-type filename string) + (setf (file-device-filename device) (copy-seq filename)) (labels ((handle-error (c) (posix-file-error c filename "opening")) (try-delete () (handler-case (%sys-unlink filename) - (posix-error (c) (handle-error c)))) + (syscall-error (c) (handle-error c)))) (try-open (&optional (retry-on-delete t)) (handler-case (%sys-open filename flags mode) @@ -82,7 +82,7 @@ (cond ((and retry-on-delete delete-if-exists) (try-delete) (try-open nil)) (t (handle-error c)))) - (posix-error (c) + (syscall-error (c) (handle-error c)) (:no-error (fd) fd)))) (let ((fd (or handle (try-open)))) @@ -109,7 +109,7 @@ (defmethod device-position ((device file-device)) (handler-case (%sys-lseek (device-handle device) 0 seek-cur) - (posix-error (err) + (syscall-error (err) (posix-file-error err device "seeking on")))) (defmethod (setf device-position) @@ -120,7 +120,7 @@ (:start seek-set) (:current seek-cur) (:end seek-end))) - (posix-error (err) + (syscall-error (err) (posix-file-error err device "seeking on")))) @@ -131,13 +131,13 @@ (defmethod device-length ((device file-device)) (handler-case (stat-size (%sys-fstat (device-handle device))) - (posix-error (err) + (syscall-error (err) (posix-file-error err device "getting status of")))) (defmethod (setf device-length) (length (device file-device)) (handler-case (%sys-ftruncate (device-handle device) length) - (posix-error (err) + (syscall-error (err) (posix-file-error err device "truncating")))) @@ -200,20 +200,6 @@ (eql :error if-does-not-exist))) (error 'program-error)) ;; FIXME: check for file type TTY and adjust buffering - (let ((file-device - (%open-file filename direction if-exists if-does-not-exist - truncate append extra-flags mode))) - (if (null buffering) - (values file-device) - (make-instance 'file-zeta-stream - :device file-device - :synchronized synchronized - :buffering buffering - :size buffer-size - :external-format external-format)))) - -(defun %open-file (filename direction if-exists if-does-not-exist - truncate append extra-flags mode) (let ((flags 0)) (setf (values flags if-exists if-does-not-exist) (process-file-direction direction flags @@ -222,11 +208,15 @@ (process-file-flags direction flags if-exists if-does-not-exist truncate append extra-flags)) (handler-case - (make-instance 'file-device + (make-instance 'file-zeta-stream :filename (namestring filename) :flags (logior flags extra-flags) :mode mode - :delete-if-exists (eql :delete if-exists)) + :delete-if-exists (eql :delete if-exists) + :synchronized synchronized + :buffering buffering + :size buffer-size + :external-format external-format) (posix-file-error (error) (case (posix-file-error-identifier error) (:enoent diff --git a/io.streams/zeta/stream.lisp b/io.streams/zeta/stream.lisp index 5c66786..9c1e794 100644 --- a/io.streams/zeta/stream.lisp +++ b/io.streams/zeta/stream.lisp @@ -15,6 +15,7 @@ (defclass device-buffer (buffer) ((synchronized :initarg :synchronized) (device :initarg :device) + (base-device :initarg :base-device) (input-iobuf :initarg :input-buffer) (output-iobuf :initarg :output-buffer) (buffering :initarg :buffering)) @@ -32,7 +33,8 @@ :adjust-threshold 1)) (defclass zstream () - (external-format)) + ((%flags :initform 0 :type ub16) + external-format)) (defclass device-zstream (device-buffer zstream) ()) @@ -69,7 +71,7 @@ (defgeneric zstream-device (stream)) -(defgeneric (setf zstream-device) (new-device stream)) +(defgeneric zstream-base-device (stream)) (defgeneric zstream-external-format (stream)) @@ -163,11 +165,11 @@ (declare (ignore stream)) (values nil)) -(defmethod (setf zstream-device) (new-device (stream device-zstream)) - (setf (slot-value stream 'device) new-device)) +(defmethod zstream-base-device ((stream device-zstream)) + (slot-value stream 'base-device)) -(defmethod (setf zstream-device) (new-device (stream memory-zstream)) - (declare (ignore new-device stream)) +(defmethod zstream-base-device ((stream memory-zstream)) + (declare (ignore stream)) (values nil)) (defmethod zstream-external-format ((stream zstream)) @@ -186,6 +188,103 @@ ;;;------------------------------------------------------------------------- +;;; Helper macros +;;;------------------------------------------------------------------------- + +;; FIXME: synchronize memory streams too ? +(defmacro with-synchronized-device-zstream + ((stream &optional direction) &body body) + (with-gensyms (body-fun) + (labels ((make-locks (body direction) + (ecase direction + (:input + `(bt:with-lock-held + ((iobuf-lock (slot-value ,stream 'input-iobuf))) + ,body)) + (:output + `(bt:with-lock-held + ((iobuf-lock (slot-value ,stream 'output-iobuf))) + ,body)) + (:io + (make-locks (make-locks body :output) :input))))) + `(flet ((,body-fun () ,@body)) + (declare (dynamic-extent #',body-fun)) + (if (zstream-synchronized-p ,stream) + ,(make-locks `(,body-fun) direction) + (,body-fun)))))) + +(defconstant (+flag-bits+ :test 'equal) + '(:zeta ; instance is valid + :buffering ; stream is buffered(not raw device) + :eof ; latched EOF + :dirty)) ; output buffer needs write + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun %flags (flags) + (loop :for flag :in flags + :as pos := (position flag +flag-bits+) + :if pos + :sum (ash 1 pos) :into bits + :else + :collect flag :into unused + :finally (when unused + (warn "Invalid stream instance flag~P: ~{~S~^, ~}" + (length unused) unused)) + (return bits)))) + +(defmacro with-zstream-class ((class-name &optional stream) &body body) + (if stream + (with-gensyms ((stm "ZSTREAM")) + `(let* ((,stm ,stream)) + (declare (type ,class-name ,stm)) + (macrolet ((sm (slot-name stream) + (declare (ignore stream)) + `(slot-value ,',stm ',slot-name)) + (add-zstream-instance-flags (stream &rest flags) + (declare (ignore stream)) + `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm) + ,(%flags flags)))) + (remove-zstream-instance-flags (stream &rest flags) + (declare (ignore stream)) + `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm) + ,(%flags flags)))) + (any-zstream-instance-flags (stream &rest flags) + (declare (ignore stream)) + `(not (zerop (logand (sm %flags ,',stm) + ,(%flags flags)))))) + ,@body))) + `(macrolet ((sm (slot-name stream) + `(slot-value ,stream ',slot-name))) + ,@body))) + +(defmacro sm (slot-name stream) + "Access the named slot in Stream." + (warn "Using ~S macro outside ~S." 'sm 'with-zstream-class) + `(slot-value ,stream ',slot-name)) + +(defmacro add-zstream-instance-flags (stream &rest flags) + "Set the given Flags in Stream." + (with-gensyms ((s "STREAM")) + `(let ((,s ,stream)) + (with-zstream-class (zstream ,s) + (add-zstream-instance-flags ,s ,@flags))))) + +(defmacro remove-zstream-instance-flags (stream &rest flags) + "Clear the given Flags in Stream." + (with-gensyms ((s "STREAM")) + `(let ((,s ,stream)) + (with-zstream-class (zstream ,s) + (remove-zstream-instance-flags ,s ,@flags))))) + +(defmacro any-zstream-instance-flags (stream &rest flags) + "Determine whether any one of the Flags is set in Stream." + (with-gensyms ((s "STREAM")) + `(let ((,s ,stream)) + (with-zstream-class (zstream ,s) + (any-zstream-instance-flags ,s ,@flags))))) + + +;;;------------------------------------------------------------------------- ;;; Constructors ;;;------------------------------------------------------------------------- @@ -196,10 +295,12 @@ (with-slots (device input-iobuf output-iobuf) stream (check-type device device) - (check-type data (or null iobuf)) (check-type buffering stream-buffering) - (setf input-iobuf (or data (make-iobuf size)) - output-iobuf input-iobuf))) + (when buffering + (check-type data (or null iobuf)) + (setf input-iobuf (or data (make-iobuf size)) + output-iobuf input-iobuf) + (add-zstream-instance-flags stream :buffering)))) (defmethod shared-initialize :after ((stream dual-channel-zstream) slot-names @@ -208,11 +309,13 @@ (with-slots (device input-iobuf output-iobuf) stream (check-type device device) - (check-type input-data (or null iobuf)) - (check-type output-data (or null iobuf)) (check-type buffering stream-buffering) - (setf input-iobuf (or input-data (make-iobuf input-size))) - (setf output-iobuf (or output-data (make-iobuf output-size))))) + (when buffering + (check-type input-data (or null iobuf)) + (check-type output-data (or null iobuf)) + (setf input-iobuf (or input-data (make-iobuf input-size)) + output-iobuf (or output-data (make-iobuf output-size))) + (add-zstream-instance-flags stream :buffering)))) (defmethod shared-initialize :after ((stream memory-zstream) slot-names &key data (start 0) end) @@ -236,7 +339,8 @@ (setf output-position (- end start)) (replace data-vector data :start2 start :end2 end)) (t - (setf data-vector (make-array 128 :element-type element-type)))))) + (setf data-vector (make-array 128 :element-type element-type)))) + (add-zstream-instance-flags stream :buffering))) (defmethod shared-initialize :after ((stream zstream) slot-names &key (external-format :default)) @@ -271,33 +375,6 @@ ;;;------------------------------------------------------------------------- -;;; Helper macros -;;;------------------------------------------------------------------------- - -;; FIXME: synchronize memory streams too ? -(defmacro with-synchronized-device-zstream - ((stream &optional direction) &body body) - (with-gensyms (body-fun) - (labels ((make-locks (body direction) - (ecase direction - (:input - `(bt:with-lock-held - ((iobuf-lock (slot-value ,stream 'input-iobuf))) - ,body)) - (:output - `(bt:with-lock-held - ((iobuf-lock (slot-value ,stream 'output-iobuf))) - ,body)) - (:io - (make-locks (make-locks body :output) :input))))) - `(flet ((,body-fun () ,@body)) - (declare (dynamic-extent #',body-fun)) - (if (zstream-synchronized-p ,stream) - ,(make-locks `(,body-fun) direction) - (,body-fun)))))) - - -;;;------------------------------------------------------------------------- ;;; RELINQUISH ;;;------------------------------------------------------------------------- diff --git a/io.streams/zeta/types.lisp b/io.streams/zeta/types.lisp index eab779e..c8c50dc 100644 --- a/io.streams/zeta/types.lisp +++ b/io.streams/zeta/types.lisp @@ -60,7 +60,7 @@ ;;;------------------------------------------------------------------------- (deftype stream-buffering () - '(member :line :full)) + '(member nil :line :full)) (deftype file-direction () '(member :input :output :io)) -- 2.11.4.GIT