;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
-;;; This code is in the public domain.
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
-;;; The cmucl implementation of simple-streams was done by Paul Foley,
-;;; who placed the code in the public domain. Sbcl port by Rudi
-;;; Schlatte.
+;;; Sbcl port by Rudi Schlatte.
(in-package "SB-SIMPLE-STREAMS")
;;;
-;;; HELPER FUNCTIONS
+;;; **********************************************************************
;;;
-
-;; All known stream flags. Note that the position in the constant
-;; list is significant (cf. %flags below).
-(sb-int:defconstant-eqx +flag-bits+
- '(:simple ; instance is valid
- :input :output ; direction
- :dual :string ; type of stream
- :eof ; latched EOF
- :dirty ; output buffer needs write
- :interactive) ; interactive stream
- #'equal)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun %flags (flags)
- (loop for flag in flags
- as pos = (position flag +flag-bits+)
- when (eq flag :gray) do
- (error "Gray streams not supported.")
- 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))))
-
-;;; Setup an environment where sm, funcall-stm-handler and
-;;; funcall-stm-handler-2 are valid and efficient for a stream of type
-;;; class-name or for the stream argument (in which case the
-;;; class-name argument is ignored). In nested with-stream-class
-;;; forms, the inner with-stream-class form must specify a stream
-;;; argument if the outer one specifies one, or the wrong object will
-;;; be accessed.
-
-;;; Commented out in favor of standard class machinery that does not
-;;; depend on implementation internals.
-#+nil
-(defmacro with-stream-class ((class-name &optional stream) &body body)
- (if stream
- (let ((stm (gensym "STREAM"))
- (slt (gensym "SV")))
- `(let* ((,stm ,stream)
- (,slt (sb-pcl::std-instance-slots ,stm)))
- (declare (type ,class-name ,stm) (ignorable ,slt))
- (macrolet ((sm (slot-name stream)
- (declare (ignore stream))
- (let ((slot-access (gethash slot-name
- *slot-access-functions*)))
- (cond ((sb-int:fixnump (cdr slot-access))
- ;; Get value in nth slot
- `(the ,(car slot-access)
- (sb-pcl::clos-slots-ref ,',slt
- ,(cdr slot-access))))
- (slot-access
- ;; Call memorized function
- `(the ,(car slot-access) (,(cdr slot-access)
- ,',stm)))
- (t
- ;; Use slot-value
- `(slot-value ,',stm ',slot-name)))))
- (add-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
- ,(%flags flags))))
- (remove-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
- ,(%flags flags))))
- (any-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(not (zerop (logand (sm %flags ,',stm)
- ,(%flags flags))))))
- ,@body)))
- `(macrolet ((sm (slot-name stream)
- (let ((slot-access (gethash slot-name
- *slot-access-functions*)))
- (cond ((sb-int:fixnump (cdr slot-access))
- `(the ,(car slot-access)
- (sb-pcl::clos-slots-ref
- (sb-pcl::std-instance-slots ,stream)
- ,(cdr slot-access))))
- (slot-access
- `(the ,(car slot-access) (,(cdr slot-access)
- ,stream)))
- (t `(slot-value ,stream ',slot-name))))))
- ,@body)))
-
-
-(defmacro with-stream-class ((class-name &optional stream) &body body)
- (if stream
- (let ((stm (gensym "STREAM"))
- (slt (gensym "SV")))
- `(let* ((,stm ,stream)
- (,slt (sb-kernel:%instance-ref ,stm 1)))
- (declare (type ,class-name ,stm)
- (type simple-vector ,slt)
- (ignorable ,slt))
- (macrolet ((sm (slot-name stream)
- (declare (ignore stream))
- #-count-sm
- `(slot-value ,',stm ',slot-name)
- #+count-sm
- `(%sm ',slot-name ,',stm))
- (add-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
- ,(%flags flags))))
- (remove-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
- ,(%flags flags))))
- (any-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(not (zerop (logand (sm %flags ,',stm)
- ,(%flags flags))))))
- ,@body)))
- `(macrolet ((sm (slot-name stream)
- #-count-sm
- `(slot-value ,stream ',slot-name)
- #+count-sm
- `(%sm ',slot-name ,stream)))
- ,@body)))
-
-;;; Commented out in favor of standard class machinery that does not
-;;; depend on implementation internals.
-#+nil
-(defmacro sm (slot-name stream)
- (let ((slot-access (gethash slot-name *slot-access-functions*)))
- (warn "Using ~S macro outside ~S" 'sm 'with-stream-class)
- (cond ((sb-int:fixnump (cdr slot-access))
- `(the ,(car slot-access) (sb-pcl::clos-slots-ref
- (sb-pcl::std-instance-slots ,stream)
- ,(cdr slot-access))))
- (slot-access
- `(the ,(car slot-access) (,(cdr slot-access) ,stream)))
- (t `(slot-value ,stream ',slot-name)))))
-
-
-(defmacro sm (slot-name stream)
- "Access the named slot in Stream."
- (warn "Using ~S macro outside ~S." 'sm 'with-stream-class)
- `(slot-value ,stream ',slot-name))
-
-(defmacro funcall-stm-handler (slot-name stream &rest args)
- (let ((s (gensym)))
- `(let ((,s ,stream))
- (funcall (sm ,slot-name ,s) ,s ,@args))))
-
-(defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
- (let ((s (gensym)))
- `(let ((,s ,stream))
- (funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))
-
-(defmacro add-stream-instance-flags (stream &rest flags)
- "Set the given flag bits in STREAM."
- (let ((s (gensym "STREAM")))
- `(let ((,s ,stream))
- (with-stream-class (simple-stream ,s)
- (setf (sm %flags ,s) (logior (sm %flags ,s) ,(%flags flags)))))))
-
-(defmacro remove-stream-instance-flags (stream &rest flags)
- "Clear the given flag bits in STREAM."
- (let ((s (gensym "STREAM")))
- `(let ((,s ,stream))
- (with-stream-class (simple-stream ,s)
- (setf (sm %flags ,s) (logandc2 (sm %flags ,s) ,(%flags flags)))))))
-
-(defmacro any-stream-instance-flags (stream &rest flags)
- "Determine whether any one of the FLAGS is set in STREAM."
- (let ((s (gensym "STREAM")))
- `(let ((,s ,stream))
- (with-stream-class (simple-stream ,s)
- (not (zerop (logand (sm %flags ,s) ,(%flags flags))))))))
-
-(defmacro simple-stream-dispatch (stream single dual string)
- (let ((s (gensym "STREAM")))
- `(let ((,s ,stream))
- (with-stream-class (simple-stream ,s)
- (let ((%flags (sm %flags ,s)))
- (cond ((zerop (logand %flags ,(%flags '(:string :dual))))
- ,single)
- ((zerop (logand %flags ,(%flags '(:string))))
- ,dual)
- (t
- ,string)))))))
-
-(declaim (inline buffer-sap bref (setf bref) buffer-copy))
+;;; Various functions needed by simple-streams
+(declaim (inline buffer-sap bref (setf bref) buffer-copy
+ allocate-buffer free-buffer))
(defun buffer-sap (thing &optional offset)
(declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
(defun bref (buffer index)
(declare (type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
- (sb-sys:sap-ref-8 (buffer-sap buffer) index))
+ (if (vectorp buffer)
+ (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index)
+ (sb-sys:sap-ref-8 buffer index)))
(defun (setf bref) (octet buffer index)
(declare (type (unsigned-byte 8) octet)
(type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
- (setf (sb-sys:sap-ref-8 (buffer-sap buffer) index) octet))
+ (if (vectorp buffer)
+ (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet)
+ (setf (sb-sys:sap-ref-8 buffer index) octet)))
(defun buffer-copy (src soff dst doff length)
(declare (type simple-stream-buffer src dst)
(type fixnum soff doff length))
(sb-sys:without-gcing ;; is this necessary??
- (sb-kernel:system-area-copy (buffer-sap src) (* soff 8)
- (buffer-sap dst) (* doff 8)
- (* length 8))))
+ (sb-kernel:system-area-ub8-copy (buffer-sap src) soff
+ (buffer-sap dst) doff
+ length)))
(defun allocate-buffer (size)
(if (= size sb-impl::bytes-per-buffer)
(push buffer sb-impl::*available-buffers*))
t)
+
+(defun make-control-table (&rest inits)
+ (let ((table (make-array 32 :initial-element nil)))
+ (do* ((char (pop inits) (pop inits))
+ (func (pop inits) (pop inits)))
+ ((null char))
+ (when (< (char-code char) 32)
+ (setf (aref table (char-code char)) func)))
+ table))
+
+(defun std-newline-out-handler (stream character)
+ (declare (ignore character))
+ (with-stream-class (simple-stream stream)
+ (setf (sm charpos stream) -1)
+ nil))
+
+(defun std-tab-out-handler (stream character)
+ (declare (ignore character))
+ (with-stream-class (simple-stream stream)
+ (let ((col (sm charpos stream)))
+ (when col
+ (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
+ nil))
+
+(defun std-dc-newline-in-handler (stream character)
+ (with-stream-class (dual-channel-simple-stream stream)
+ ;; FIXME: Currently, -1 is wrong, since callers of CHARPOS expect
+ ;; a result in (or null (and fixnum unsigned-byte)), so they must
+ ;; never see this temporary value. Note that in
+ ;; STD-NEWLINE-OUT-HANDLER it is correct to use -1, since CHARPOS
+ ;; is incremented to zero before WRITE-CHAR returns. Perhaps the
+ ;; same should happen for input?
+ (setf (sm charpos stream) 0) ; was -1
+ character))
+
+(defvar *std-control-out-table*
+ (make-control-table #\Newline #'std-newline-out-handler
+ #\Tab #'std-tab-out-handler))
+
+(defvar *default-external-format* :iso8859-1)
+
+(defvar *external-formats* (make-hash-table))
+(defvar *external-format-aliases* (make-hash-table))
+
+(defstruct (external-format
+ (:conc-name ef-)
+ (:print-function %print-external-format)
+ (:constructor make-external-format (name octets-to-char
+ char-to-octets)))
+ (name (sb-int:missing-arg) :type keyword :read-only t)
+ (octets-to-char (sb-int:missing-arg) :type function :read-only t)
+ (char-to-octets (sb-int:missing-arg) :type function :read-only t))
+
+(defun %print-external-format (ef stream depth)
+ (declare (ignore depth))
+ (print-unreadable-object (ef stream :type t :identity t)
+ (princ (ef-name ef) stream)))
+
+(defmacro define-external-format (name octets-to-char char-to-octets)
+ `(macrolet ((octets-to-char ((state input unput) &body body)
+ `(lambda (,state ,input ,unput)
+ (declare (type (function () (unsigned-byte 8)) ,input)
+ (type (function (sb-int:index) t) ,unput)
+ (ignorable ,state ,input ,unput)
+ (values character sb-int:index t))
+ ,@body))
+ (char-to-octets ((char state output) &body body)
+ `(lambda (,char ,state ,output)
+ (declare (type character ,char)
+ (type (function ((unsigned-byte 8)) t) ,output)
+ (ignorable state ,output)
+ (values t))
+ ,@body)))
+ (setf (gethash ,name *external-formats*)
+ (make-external-format ,name ,octets-to-char ,char-to-octets))))
+
+;;; TODO: make this work
+(defun load-external-format-aliases ()
+ (let ((*package* (find-package "KEYWORD")))
+ (with-open-file (stm "ef:aliases" :if-does-not-exist nil)
+ (when stm
+ (do ((alias (read stm nil stm) (read stm nil stm))
+ (value (read stm nil stm) (read stm nil stm)))
+ ((or (eq alias stm) (eq value stm))
+ (unless (eq alias stm)
+ (warn "External-format aliases file ends early.")))
+ (if (and (keywordp alias) (keywordp value))
+ (setf (gethash alias *external-format-aliases*) value)
+ (warn "Bad entry in external-format aliases file: ~S => ~S."
+ alias value)))))))
+
+(defun find-external-format (name &optional (error-p t))
+ (when (external-format-p name)
+ (return-from find-external-format name))
+
+ (when (eq name :default)
+ (setq name *default-external-format*))
+
+ ;; TODO: make this work
+ #+nil
+ (unless (ext:search-list-defined-p "ef:")
+ (setf (ext:search-list "ef:") '("library:ef/")))
+
+ (when (zerop (hash-table-count *external-format-aliases*))
+ (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
+ (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
+ (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)
+ (load-external-format-aliases))
+
+ (do ((tmp (gethash name *external-format-aliases*)
+ (gethash tmp *external-format-aliases*))
+ (cnt 0 (1+ cnt)))
+ ((or (null tmp) (= cnt 50))
+ (unless (null tmp)
+ (error "External-format aliasing depth exceeded.")))
+ (setq name tmp))
+
+ (or (gethash name *external-formats*)
+ (and (let ((*package* (find-package "SB-SIMPLE-STREAMS")))
+ (load (format nil "ef:~(~A~)" name) :if-does-not-exist nil))
+ (gethash name *external-formats*))
+ (if error-p (error "External format ~S not found." name) nil)))
+
+(define-condition void-external-format (error)
+ ()
+ (:report
+ (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream "Attempting I/O through void external-format."))))
+
+(define-external-format :void
+ (octets-to-char (state input unput)
+ (declare (ignore state input unput))
+ (error 'void-external-format))
+ (char-to-octets (char state output)
+ (declare (ignore char state output))
+ (error 'void-external-format)))
+
+(define-external-format :iso8859-1
+ (octets-to-char (state input unput)
+ (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
+ (values (code-char (funcall input)) 1 state))
+ (char-to-octets (char state output)
+ (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
+ (let ((code (char-code char)))
+ #-(or)
+ (funcall output code)
+ #+(or)
+ (if (< code 256)
+ (funcall output code)
+ (funcall output (char-code #\?))))
+ state))
+
+(defmacro octets-to-char (external-format state count input unput)
+ (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym)))
+ `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3)
+ (funcall (ef-octets-to-char ,external-format) ,state ,input ,unput)
+ (setf ,state ,tmp3 ,count ,tmp2)
+ ,tmp1)))
+
+(defmacro char-to-octets (external-format char state output)
+ `(progn
+ (setf ,state (funcall (ef-char-to-octets ,external-format)
+ ,char ,state ,output))
+ nil))
+
+(defun string-to-octets (string &key (start 0) end (external-format :default))
+ (declare (type string string)
+ (type sb-int:index start)
+ (type (or null sb-int:index) end))
+ (let ((ef (find-external-format external-format))
+ (buffer (make-array (length string) :element-type '(unsigned-byte 8)))
+ (ptr 0)
+ (state nil))
+ (flet ((out (b)
+ (setf (aref buffer ptr) b)
+ (when (= (incf ptr) (length buffer))
+ (setq buffer (adjust-array buffer (* 2 ptr))))))
+ (dotimes (i (- (or end (length string)) start))
+ (declare (type sb-int:index i))
+ (char-to-octets ef (char string (+ start i)) state #'out))
+ (sb-kernel:shrink-vector buffer ptr))))
+
+(defun octets-to-string (octets &key (start 0) end (external-format :default))
+ (declare (type vector octets)
+ (type sb-int:index start)
+ (type (or null sb-int:index) end))
+ (let ((ef (find-external-format external-format))
+ (end (1- (or end (length octets))))
+ (string (make-string (length octets)))
+ (ptr (1- start))
+ (pos -1)
+ (count 0)
+ (state nil))
+ (flet ((input ()
+ (aref octets (incf ptr)))
+ (unput (n)
+ (decf ptr n)))
+ (loop until (>= ptr end)
+ do (setf (schar string (incf pos))
+ (octets-to-char ef state count #'input #'unput))))
+ (sb-kernel:shrink-vector string (1+ pos))))
+
+(defun vector-elt-width (vector)
+ ;; Return octet-width of vector elements
+ (etypecase vector
+ ;; (simple-array fixnum (*)) not supported
+ ;; (simple-array base-char (*)) treated specially; don't call this
+ ((simple-array bit (*)) 1)
+ ((simple-array (unsigned-byte 2) (*)) 1)
+ ((simple-array (unsigned-byte 4) (*)) 1)
+ ((simple-array (signed-byte 8) (*)) 1)
+ ((simple-array (unsigned-byte 8) (*)) 1)
+ ((simple-array (signed-byte 16) (*)) 2)
+ ((simple-array (unsigned-byte 16) (*)) 2)
+ ((simple-array (signed-byte 32) (*)) 4)
+ ((simple-array (unsigned-byte 32) (*)) 4)
+ ((simple-array single-float (*)) 4)
+ ((simple-array double-float (*)) 8)
+ ((simple-array (complex single-float) (*)) 8)
+ ((simple-array (complex double-float) (*)) 16)))
+
+#-(or big-endian little-endian)
+(eval-when (:compile-toplevel)
+ (push sb-c::*backend-byte-order* *features*))
+
+(defun endian-swap-value (vector endian-swap)
+ #+big-endian (declare (ignore vector))
+ (case endian-swap
+ (:network-order #+big-endian 0
+ #+little-endian (1- (vector-elt-width vector)))
+ (:byte-8 0)
+ (:byte-16 1)
+ (:byte-32 3)
+ (:byte-64 7)
+ (:byte-128 15)
+ (otherwise endian-swap)))
+
+#+(or)
+(defun %read-vector (vector stream start end endian-swap blocking)
+ (declare (type (kernel:simple-unboxed-array (*)) vector)
+ (type stream stream))
+ ;; move code from read-vector
+ )
+
+#+(or)
+(defun %write-vector (... blocking)
+ ;; implement me
+ )
+
+(defun read-octets (stream buffer start end blocking)
+ (declare (type simple-stream stream)
+ (type (or null simple-stream-buffer) buffer)
+ (type fixnum start)
+ (type (or null fixnum) end)
+ (type blocking blocking)
+ (optimize (speed 3) (space 2) (safety 0) (debug 0)))
+ (with-stream-class (simple-stream stream)
+ (let ((fd (sm input-handle stream))
+ (end (or end (sm buf-len stream)))
+ (buffer (or buffer (sm buffer stream))))
+ (declare (fixnum end))
+ (typecase fd
+ (fixnum
+ (let ((flag (sb-sys:wait-until-fd-usable fd :input
+ (if blocking nil 0))))
+ (cond
+ ((and (not blocking) (= start end)) (if flag -3 0))
+ ((and (not blocking) (not flag)) 0)
+ (t (block nil
+ (let ((count 0))
+ (declare (type fixnum count))
+ (tagbody
+ again
+ ;; Avoid CMUCL gengc write barrier
+ (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize)))))
+ ((>= i end))
+ (declare (type fixnum i))
+ (setf (bref buffer i) 0))
+ (setf (bref buffer (1- end)) 0)
+ (multiple-value-bind (bytes errno)
+ (sb-unix:unix-read fd (buffer-sap buffer start)
+ (the fixnum (- end start)))
+ (declare (type (or null fixnum) bytes)
+ (type (integer 0 100) errno))
+ (when bytes
+ (incf count bytes)
+ (incf start bytes))
+ (cond ((null bytes)
+ (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
+ (cond ((= errno sb-unix:eintr) (go again))
+ ((and blocking
+ (or (= errno ;;sb-unix:eagain
+ ;; TODO: move
+ ;; eagain into
+ ;; sb-unix
+ 11)
+ (= errno sb-unix:ewouldblock)))
+ (sb-sys:wait-until-fd-usable fd :input nil)
+ (go again))
+ (t (return (- -10 errno)))))
+ ((zerop count) (return -1))
+ (t (return count)))))))))))
+ (t (%read-vector buffer fd start end :byte-8
+ (if blocking :bnb nil)))))))
+
+(defun write-octets (stream buffer start end blocking)
+ (declare (type simple-stream stream)
+ (type simple-stream-buffer buffer)
+ (type fixnum start)
+ (type (or null fixnum) end))
+ (with-stream-class (simple-stream stream)
+ (when (sm handler stream)
+ (do ()
+ ((null (sm pending stream)))
+ (sb-sys:serve-all-events)))
+
+ (let ((fd (sm output-handle stream))
+ (end (or end (length buffer))))
+ (typecase fd
+ (fixnum
+ (let ((flag (sb-sys:wait-until-fd-usable fd :output
+ (if blocking nil 0))))
+ (cond
+ ((and (not blocking) (= start end)) (if flag -3 0))
+ ((and (not blocking) (not flag)) 0)
+ (t
+ (block nil
+ (let ((count 0))
+ (tagbody again
+ (multiple-value-bind (bytes errno)
+ (sb-unix:unix-write fd (buffer-sap buffer) start
+ (- end start))
+ (when bytes
+ (incf count bytes)
+ (incf start bytes))
+ (cond ((null bytes)
+ (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno)
+ (cond ((= errno sb-unix:eintr) (go again))
+ ;; don't block for subsequent chars
+ (t (return (- -10 errno)))))
+ (t (return count)))))))))))
+ (t (error "implement me"))))))
+
+(defun do-some-output (stream)
+ ;; Do some pending output; return T if completed, NIL if more to do
+ (with-stream-class (simple-stream stream)
+ (let ((fd (sm output-handle stream)))
+ (loop
+ (let ((list (pop (sm pending stream))))
+ (unless list
+ (sb-sys:remove-fd-handler (sm handler stream))
+ (setf (sm handler stream) nil)
+ (return t))
+ (let* ((buffer (first list))
+ (start (second list))
+ (end (third list))
+ (len (- end start)))
+ (declare (type simple-stream-buffer buffer)
+ (type sb-int:index start end len))
+ (tagbody again
+ (multiple-value-bind (bytes errno)
+ (sb-unix:unix-write fd (buffer-sap buffer) start len)
+ (cond ((null bytes)
+ (if (= errno sb-unix:eintr)
+ (go again)
+ (progn (push list (sm pending stream))
+ (return nil))))
+ ((< bytes len)
+ (setf (second list) (+ start bytes))
+ (push list (sm pending stream))
+ (return nil))
+ ((= bytes len)
+ (free-buffer buffer)))))))))))
+
+(defun queue-write (stream buffer start end)
+ ;; Queue a write; return T if buffer needs changing, NIL otherwise
+ (declare (type simple-stream stream)
+ (type simple-stream-buffer buffer)
+ (type sb-int:index start end))
+ (with-stream-class (simple-stream stream)
+ (when (sm handler stream)
+ (unless (do-some-output stream)
+ (let ((last (last (sm pending stream))))
+ (setf (cdr last) (list (list buffer start end)))
+ (return-from queue-write t))))
+ (let ((bytes (write-octets stream buffer start end nil)))
+ (unless (or (= bytes (- end start)) ; completed
+ (= bytes -3)) ; empty buffer; shouldn't happen
+ (setf (sm pending stream) (list (list buffer start end)))
+ (setf (sm handler stream)
+ (sb-sys:add-fd-handler (sm output-handle stream) :output
+ (lambda (fd)
+ (declare (ignore fd))
+ (do-some-output stream))))
+ t))))
+
+
+
+
(defun %fd-open (pathname direction if-exists if-exists-given
if-does-not-exist if-does-not-exist-given)
(declare (type pathname pathname)
(declare (type sb-int:index mask))
(let ((name (cond ((sb-int:unix-namestring pathname input))
((and input (eq if-does-not-exist :create))
+ (sb-int:unix-namestring pathname nil))
+ ((and (eq direction :io) (not if-does-not-exist-given))
(sb-int:unix-namestring pathname nil)))))
;; Process if-exists argument if we are doing any output.
(cond (output
:new-version
:error)))
(case if-exists
- ((:error nil)
+ ((:error nil :new-version)
(setf mask (logior mask sb-unix:o_excl)))
((:rename :rename-and-delete)
(setf mask (logior mask sb-unix:o_creat)))
- ((:new-version :supersede)
+ ((:supersede)
(setf mask (logior mask sb-unix:o_trunc)))))
(t
(setf if-exists nil))) ; :ignore-this-arg
projects / sbcl.git / blobdiff