;;; -*- 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)
- (optimize (speed 3) (space 2) (debug 0) (safety 0)
- ;; Suppress the note about having to box up the return:
- (sb-ext:inhibit-warnings 3)))
+ (optimize (speed 3) (space 2) (debug 0) (safety 0)
+ ;; Suppress the note about having to box up the return:
+ (sb-ext:inhibit-warnings 3)))
(let ((sap (if (vectorp thing) (sb-sys:vector-sap thing) thing)))
(if offset (sb-sys:sap+ sap offset) sap)))
(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))
+ (type (integer 0 #.most-positive-fixnum) index))
+ (if (vectorp buffer)
+ (sb-sys:with-pinned-objects (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))
+ (type simple-stream-buffer buffer)
+ (type (integer 0 #.most-positive-fixnum) index))
+ (if (vectorp buffer)
+ (sb-sys:with-pinned-objects (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))))
+ (type fixnum soff doff length))
+ ;; FIXME: Should probably be with-pinned-objects
+ (sb-sys:without-gcing
+ (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)
- (sb-impl::next-available-buffer)
- (make-array size :element-type '(unsigned-byte 8))))
+ (make-array size :element-type '(unsigned-byte 8)))
(defun free-buffer (buffer)
- (when (sb-sys:system-area-pointer-p buffer)
- (push buffer sb-impl::*available-buffers*))
+ (sb-int:aver (typep buffer '(simple-array (unsigned-byte 8) (*))))
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 #.(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-sys:with-pinned-objects (buffer)
+ (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
+ #-win32
+ sb-unix:ewouldblock
+ #+win32
+ sb-unix:eintr)))
+ (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-sys:with-pinned-objects (buffer)
+ (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-sys:with-pinned-objects (buffer)
+ (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)
+ if-does-not-exist if-does-not-exist-given)
(declare (type pathname pathname)
- (type (member :input :output :io :probe) direction)
- (type (member :error :new-version :rename :rename-and-delete
- :overwrite :append :supersede nil) if-exists)
- (type (member :error :create nil) if-does-not-exist))
+ (type (member :input :output :io :probe) direction)
+ (type (member :error :new-version :rename :rename-and-delete
+ :overwrite :append :supersede nil) if-exists)
+ (type (member :error :create nil) if-does-not-exist))
(multiple-value-bind (input output mask)
(ecase direction
- (:input (values t nil sb-unix:o_rdonly))
- (:output (values nil t sb-unix:o_wronly))
- (:io (values t t sb-unix:o_rdwr))
- (:probe (values t nil sb-unix:o_rdonly)))
+ (:input (values t nil sb-unix:o_rdonly))
+ (:output (values nil t sb-unix:o_wronly))
+ (:io (values t t sb-unix:o_rdwr))
+ (:probe (values t nil sb-unix:o_rdonly)))
(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)))))
+ (let* ((phys (sb-int:physicalize-pathname (merge-pathnames pathname)))
+ (true (probe-file phys))
+ (name (cond (true
+ (sb-ext:native-namestring true :as-file t))
+ ((or (not input)
+ (and input (eq if-does-not-exist :create))
+ (and (eq direction :io) (not if-does-not-exist-given)))
+ (sb-ext:native-namestring phys :as-file t)))))
;; Process if-exists argument if we are doing any output.
(cond (output
- (unless if-exists-given
- (setf if-exists
- (if (eq (pathname-version pathname) :newest)
- :new-version
- :error)))
- (case if-exists
- ((:error nil)
- (setf mask (logior mask sb-unix:o_excl)))
- ((:rename :rename-and-delete)
- (setf mask (logior mask sb-unix:o_creat)))
- ((:new-version :supersede)
- (setf mask (logior mask sb-unix:o_trunc)))))
- (t
- (setf if-exists nil))) ; :ignore-this-arg
+ (unless if-exists-given
+ (setf if-exists
+ (if (eq (pathname-version pathname) :newest)
+ :new-version
+ :error)))
+ (case if-exists
+ ((:error nil :new-version)
+ (setf mask (logior mask sb-unix:o_excl)))
+ ((:rename :rename-and-delete)
+ (setf mask (logior mask sb-unix:o_creat)))
+ ((:supersede)
+ (setf mask (logior mask sb-unix:o_trunc)))))
+ (t
+ (setf if-exists nil))) ; :ignore-this-arg
(unless if-does-not-exist-given
- (setf if-does-not-exist
- (cond ((eq direction :input) :error)
- ((and output
- (member if-exists '(:overwrite :append)))
- :error)
- ((eq direction :probe)
- nil)
- (t
- :create))))
+ (setf if-does-not-exist
+ (cond ((eq direction :input) :error)
+ ((and output
+ (member if-exists '(:overwrite :append)))
+ :error)
+ ((eq direction :probe)
+ nil)
+ (t
+ :create))))
(if (eq if-does-not-exist :create)
- (setf mask (logior mask sb-unix:o_creat)))
+ (setf mask (logior mask sb-unix:o_creat)))
(let ((original (if (member if-exists
'(:rename :rename-and-delete))
(sb-impl::pick-backup-name name)
nil))
- (delete-original (eq if-exists :rename-and-delete))
- (mode #o666))
- (when original
- ;; We are doing a :rename or :rename-and-delete.
- ;; Determine if the file already exists, make sure the original
- ;; file is not a directory and keep the mode
- (let ((exists
- (and name
- (multiple-value-bind
- (okay err/dev inode orig-mode)
- (sb-unix:unix-stat name)
- (declare (ignore inode)
- (type (or sb-int:index null) orig-mode))
- (cond
- (okay
- (when (and output (= (logand orig-mode #o170000)
- #o40000))
- (error 'sb-int:simple-file-error
- :pathname pathname
- :format-control
- "Cannot open ~S for output: Is a directory."
- :format-arguments (list name)))
- (setf mode (logand orig-mode #o777))
- t)
- ((eql err/dev sb-unix:enoent)
- nil)
- (t
- (error 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Cannot find ~S: ~A"
- :format-arguments
- (list name
- (sb-int:strerror err/dev)))))))))
- (unless (and exists
- (rename-file name original))
- (setf original nil)
- (setf delete-original nil)
- ;; In order to use SUPERSEDE instead, we have
- ;; to make sure unix:o_creat corresponds to
- ;; if-does-not-exist. unix:o_creat was set
- ;; before because of if-exists being :rename.
- (unless (eq if-does-not-exist :create)
- (setf mask (logior (logandc2 mask sb-unix:o_creat)
- sb-unix:o_trunc)))
- (setf if-exists :supersede))))
-
- ;; Okay, now we can try the actual open.
- (loop
- (multiple-value-bind (fd errno)
- (if name
- (sb-unix:unix-open name mask mode)
- (values nil sb-unix:enoent))
- (cond ((sb-int:fixnump fd)
+ (delete-original (eq if-exists :rename-and-delete))
+ (mode #o666))
+ (when original
+ ;; We are doing a :rename or :rename-and-delete.
+ ;; Determine if the file already exists, make sure the original
+ ;; file is not a directory and keep the mode
+ (let ((exists
+ (and name
+ (multiple-value-bind
+ (okay err/dev inode orig-mode)
+ (sb-unix:unix-stat name)
+ (declare (ignore inode)
+ (type (or sb-int:index null) orig-mode))
+ (cond
+ (okay
+ (when (and output (= (logand orig-mode #o170000)
+ #o40000))
+ (error 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control
+ "Cannot open ~S for output: Is a directory."
+ :format-arguments (list name)))
+ (setf mode (logand orig-mode #o777))
+ t)
+ ((eql err/dev sb-unix:enoent)
+ nil)
+ (t
+ (error 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Cannot find ~S: ~A"
+ :format-arguments
+ (list name
+ (sb-int:strerror err/dev)))))))))
+ (unless (and exists
+ (rename-file name original))
+ (setf original nil)
+ (setf delete-original nil)
+ ;; In order to use SUPERSEDE instead, we have
+ ;; to make sure unix:o_creat corresponds to
+ ;; if-does-not-exist. unix:o_creat was set
+ ;; before because of if-exists being :rename.
+ (unless (eq if-does-not-exist :create)
+ (setf mask (logior (logandc2 mask sb-unix:o_creat)
+ sb-unix:o_trunc)))
+ (setf if-exists :supersede))))
+
+ ;; Okay, now we can try the actual open.
+ (loop
+ (multiple-value-bind (fd errno)
+ (if name
+ #+win32
+ (sb-win32:unixlike-open name mask mode)
+ #-win32
+ (sb-unix:unix-open name mask mode)
+ (values nil sb-unix:enoent))
+ (cond ((integerp fd)
(when (eql if-exists :append)
(sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
- (return (values fd name original delete-original)))
- ((eql errno sb-unix:enoent)
- (case if-does-not-exist
- (:error
- (cerror "Return NIL."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno))))
- (:create
+ (return (values fd name original delete-original)))
+ ((eql errno sb-unix:enoent)
+ (case if-does-not-exist
+ (:error
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (:create
(cerror "Return NIL."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control
- "Error creating ~S, path does not exist."
- :format-arguments (list pathname))))
- (return nil))
- ((eql errno sb-unix:eexist)
- (unless (eq nil if-exists)
- (cerror "Return NIL."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno))))
- (return nil))
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control
+ "Error creating ~S, path does not exist."
+ :format-arguments (list pathname))))
+ (return nil))
+ ((eql errno sb-unix:eexist)
+ (unless (eq nil if-exists)
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (return nil))
#+nil ; FIXME: reinstate this; error reporting is nice.
- ((eql errno sb-unix:eacces)
- (cerror "Try again."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno))))
- (t
- (cerror "Return NIL."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno)))
- (return nil)))))))))
+ ((eql errno sb-unix:eacces)
+ (cerror "Try again."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (t
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno)))
+ (return nil)))))))))
(defun open-fd-stream (pathname &key (direction :input)
- (element-type 'base-char)
- (if-exists nil if-exists-given)
- (if-does-not-exist nil if-does-not-exist-given)
- (external-format :default))
+ (element-type 'base-char)
+ (if-exists nil if-exists-given)
+ (if-does-not-exist nil if-does-not-exist-given)
+ (external-format :default))
(declare (type (or pathname string stream) pathname)
- (type (member :input :output :io :probe) direction)
- (type (member :error :new-version :rename :rename-and-delete
- :overwrite :append :supersede nil) if-exists)
- (type (member :error :create nil) if-does-not-exist)
- (ignore external-format))
+ (type (member :input :output :io :probe) direction)
+ (type (member :error :new-version :rename :rename-and-delete
+ :overwrite :append :supersede nil) if-exists)
+ (type (member :error :create nil) if-does-not-exist))
(let ((filespec (merge-pathnames pathname)))
(multiple-value-bind (fd namestring original delete-original)
(%fd-open filespec direction if-exists if-exists-given
:original original
:delete-original delete-original
:pathname pathname
+ :dual-channel-p nil
:input-buffer-p t
- :auto-close t))
+ :auto-close t
+ :external-format external-format))
(:probe
(let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
:pathname pathname
;; sat: Hooks to parse URIs etc apparently go here
(defstruct (filespec-parser
- (:constructor make-filespec-parser (name priority function)))
+ (:constructor make-filespec-parser (name priority function)))
name
priority
function)
(defun add-filespec (name priority function)
(let ((filespec (make-filespec-parser name priority function)))
(setf *filespec-parsers*
- (stable-sort (cons filespec (delete name *filespec-parsers*
- :key #'filespec-parser-name))
- #'>
- :key #'filespec-parser-priority)))
+ (stable-sort (cons filespec (delete name *filespec-parsers*
+ :key #'filespec-parser-name))
+ #'>
+ :key #'filespec-parser-priority)))
t)
(defmacro define-filespec (name lambda-list &body body)
(let ((truename (if (consp name) (first name) name))
- (priority (if (consp name) (second name) 0)))
+ (priority (if (consp name) (second name) 0)))
`(add-filespec ',truename ,priority (lambda ,lambda-list
- (block ,truename
- ,@body)))))
+ (block ,truename
+ ,@body)))))
(defun parse-filespec (string &optional (errorp t))
(dolist (i *filespec-parsers* (when errorp
- (error "~S not recognised." string)))
+ (error "~S not recognised." string)))
(let ((result (ignore-errors
- (funcall (filespec-parser-function i) string))))
+ (funcall (filespec-parser-function i) string))))
(when result (return result)))))
(define-filespec pathname (string)
projects / sbcl.git / blobdiff