(frob-output stream (fd-stream-obuf-sap stream) 0 length t)
(setf (fd-stream-obuf-tail stream) 0))))
+(defmacro output-wrapper ((stream size buffering) &body body)
+ (let ((stream-var (gensym)))
+ `(let ((,stream-var ,stream))
+ ,(unless (eq (car buffering) :none)
+ `(when (< (fd-stream-obuf-length ,stream-var)
+ (+ (fd-stream-obuf-tail ,stream-var)
+ ,size))
+ (flush-output-buffer ,stream-var)))
+ ,(unless (eq (car buffering) :none)
+ `(when (> (fd-stream-ibuf-tail ,stream-var)
+ (fd-stream-ibuf-head ,stream-var))
+ (file-position ,stream-var (file-position ,stream-var))))
+
+ ,@body
+ (incf (fd-stream-obuf-tail ,stream-var) ,size)
+ ,(ecase (car buffering)
+ (:none
+ `(flush-output-buffer ,stream-var))
+ (:line
+ `(when (eq (char-code byte) (char-code #\Newline))
+ (flush-output-buffer ,stream-var)))
+ (:full))
+ (values))))
+
;;; Define output routines that output numbers SIZE bytes long for the
;;; given bufferings. Use BODY to do the actual output.
(defmacro def-output-routines ((name-fmt size &rest bufferings) &body body)
(format nil name-fmt (car buffering))))))
`(progn
(defun ,function (stream byte)
- ,(unless (eq (car buffering) :none)
- `(when (< (fd-stream-obuf-length stream)
- (+ (fd-stream-obuf-tail stream)
- ,size))
- (flush-output-buffer stream)))
- ,@body
- (incf (fd-stream-obuf-tail stream) ,size)
- ,(ecase (car buffering)
- (:none
- `(flush-output-buffer stream))
- (:line
- `(when (eq (char-code byte) (char-code #\Newline))
- (flush-output-buffer stream)))
- (:full
- ))
- (values))
+ (output-wrapper (stream ,size ,buffering)
+ ,@body))
(setf *output-routines*
(nconc *output-routines*
',(mapcar
(let ((start (or start 0))
(end (or end (length (the (simple-array * (*)) thing)))))
(declare (type index start end))
+ (when (> (fd-stream-ibuf-tail fd-stream)
+ (fd-stream-ibuf-head fd-stream))
+ (file-position fd-stream (file-position fd-stream)))
(let* ((len (fd-stream-obuf-length fd-stream))
(tail (fd-stream-obuf-tail fd-stream))
(space (- len tail))
(dolist (entry *output-routines*)
(when (and (subtypep type (car entry))
(eq buffering (cadr entry)))
- (return (values (symbol-function (caddr entry))
- (car entry)
- (cadddr entry))))))
+ (return-from pick-output-routine
+ (values (symbol-function (caddr entry))
+ (car entry)
+ (cadddr entry)))))
+ ;; KLUDGE: dealing with the buffering here leads to excessive code
+ ;; explosion.
+ ;;
+ ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
+ (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
+ if (subtypep type `(unsigned-byte ,i))
+ do (return-from pick-output-routine
+ (values
+ (ecase buffering
+ (:none
+ (lambda (stream byte)
+ (output-wrapper (stream (/ i 8) (:none))
+ (loop for j from 0 below (/ i 8)
+ do (setf (sap-ref-8
+ (fd-stream-obuf-sap stream)
+ (+ j (fd-stream-obuf-tail stream)))
+ (ldb (byte 8 (- i 8 (* j 8))) byte))))))
+ (:full
+ (lambda (stream byte)
+ (output-wrapper (stream (/ i 8) (:full))
+ (loop for j from 0 below (/ i 8)
+ do (setf (sap-ref-8
+ (fd-stream-obuf-sap stream)
+ (+ j (fd-stream-obuf-tail stream)))
+ (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
+ `(unsigned-byte ,i)
+ (/ i 8))))
+ (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
+ if (subtypep type `(signed-byte ,i))
+ do (return-from pick-output-routine
+ (values
+ (ecase buffering
+ (:none
+ (lambda (stream byte)
+ (output-wrapper (stream (/ i 8) (:none))
+ (loop for j from 0 below (/ i 8)
+ do (setf (sap-ref-8
+ (fd-stream-obuf-sap stream)
+ (+ j (fd-stream-obuf-tail stream)))
+ (ldb (byte 8 (- i 8 (* j 8))) byte))))))
+ (:full
+ (lambda (stream byte)
+ (output-wrapper (stream (/ i 8) (:full))
+ (loop for j from 0 below (/ i 8)
+ do (setf (sap-ref-8
+ (fd-stream-obuf-sap stream)
+ (+ j (fd-stream-obuf-tail stream)))
+ (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
+ `(signed-byte ,i)
+ (/ i 8)))))
\f
;;;; input routines and related noise
(let ((,element-var
(catch 'eof-input-catcher
(input-at-least ,stream-var ,bytes)
- ,@read-forms)))
+ (locally ,@read-forms))))
(cond (,element-var
(incf (fd-stream-ibuf-head ,stream-var) ,bytes)
,element-var)
(defun pick-input-routine (type)
(dolist (entry *input-routines*)
(when (subtypep type (car entry))
- (return (values (symbol-function (cadr entry))
- (car entry)
- (caddr entry))))))
+ (return-from pick-input-routine
+ (values (symbol-function (cadr entry))
+ (car entry)
+ (caddr entry)))))
+ ;; FIXME: let's do it the hard way, then (but ignore things like
+ ;; endianness, efficiency, and the necessary coupling between these
+ ;; and the output routines). -- CSR, 2004-02-09
+ (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really)
+ if (subtypep type `(unsigned-byte ,i))
+ do (return-from pick-input-routine
+ (values
+ (lambda (stream eof-error eof-value)
+ (input-wrapper (stream (/ i 8) eof-error eof-value)
+ (let ((sap (fd-stream-ibuf-sap stream))
+ (head (fd-stream-ibuf-head stream)))
+ (loop for j from 0 below (/ i 8)
+ with result = 0
+ do (setf result
+ (+ (* 256 result)
+ (sap-ref-8 sap (+ head j))))
+ finally (return result)))))
+ `(unsigned-byte ,i)
+ (/ i 8))))
+ (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really)
+ if (subtypep type `(signed-byte ,i))
+ do (return-from pick-input-routine
+ (values
+ (lambda (stream eof-error eof-value)
+ (input-wrapper (stream (/ i 8) eof-error eof-value)
+ (let ((sap (fd-stream-ibuf-sap stream))
+ (head (fd-stream-ibuf-head stream)))
+ (loop for j from 0 below (/ i 8)
+ with result = 0
+ do (setf result
+ (+ (* 256 result)
+ (sap-ref-8 sap (+ head j))))
+ finally (return (if (logbitp (1- i) result)
+ (dpb result (byte i 0) -1)
+ result))))))
+ `(signed-byte ,i)
+ (/ i 8)))))
;;; Return a string constructed from SAP, START, and END.
(defun string-from-sap (sap start end)
;;; Note that this blocks in UNIX-READ. It is generally used where
;;; there is a definite amount of reading to be done, so blocking
;;; isn't too problematical.
-(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
+(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
+ &aux (total-copied 0))
(declare (type file-stream stream))
- (declare (type index start requested))
- (do ((total-copied 0))
+ (declare (type index start requested total-copied))
+ (let ((unread (fd-stream-unread stream)))
+ (when unread
+ ;; AVERs designed to fail when we have more complicated
+ ;; character representations.
+ (aver (typep unread 'base-char))
+ (aver (= (fd-stream-element-size stream) 1))
+ ;; KLUDGE: this is a slightly-unrolled-and-inlined version of
+ ;; %BYTE-BLT
+ (etypecase buffer
+ (system-area-pointer
+ (setf (sap-ref-8 buffer start) (char-code unread)))
+ ((simple-unboxed-array (*))
+ (setf (aref buffer start) unread)))
+ (setf (fd-stream-unread stream) nil)
+ (setf (fd-stream-listen stream) nil)
+ (incf total-copied)))
+ (do ()
(nil)
- (declare (type index total-copied))
(let* ((remaining-request (- requested total-copied))
(head (fd-stream-ibuf-head stream))
(tail (fd-stream-ibuf-tail stream))
(fd-stream-bin fd-stream) routine))
(when (eql size 1)
(setf (fd-stream-n-bin fd-stream) #'fd-stream-read-n-bytes)
- (when buffer-p
+ (when (and buffer-p
+ ;; We only create this buffer for streams of type
+ ;; (unsigned-byte 8). Because there's no buffer, the
+ ;; other element-types will dispatch to the appropriate
+ ;; input (output) routine in fast-read-byte.
+ (equal target-type '(unsigned-byte 8))
+ #+nil
+ (or (eq type 'unsigned-byte)
+ (eq type :default)))
(setf (ansi-stream-in-buffer fd-stream)
(make-array +ansi-stream-in-buffer-length+
:element-type '(unsigned-byte 8)))))
(setf (fd-stream-unread fd-stream) arg1)
(setf (fd-stream-listen fd-stream) t))
(:close
- (cond (arg1
- ;; We got us an abort on our hands.
+ (cond (arg1 ; We got us an abort on our hands.
(when (fd-stream-handler fd-stream)
- (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
- (setf (fd-stream-handler fd-stream) nil))
+ (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
+ (setf (fd-stream-handler fd-stream) nil))
+ ;; We can't do anything unless we know what file were
+ ;; dealing with, and we don't want to do anything
+ ;; strange unless we were writing to the file.
(when (and (fd-stream-file fd-stream)
(fd-stream-obuf-sap fd-stream))
- ;; We can't do anything unless we know what file were
- ;; dealing with, and we don't want to do anything
- ;; strange unless we were writing to the file.
(if (fd-stream-original fd-stream)
- ;; We have a handle on the original, just revert.
- (multiple-value-bind (okay err)
- (sb!unix:unix-rename (fd-stream-original fd-stream)
- (fd-stream-file fd-stream))
- (unless okay
- (simple-stream-perror
- "couldn't restore ~S to its original contents"
- fd-stream
- err)))
- ;; We can't restore the original, so nuke that puppy.
+ ;; If the original is EQ to file we are appending
+ ;; and can just close the file without renaming.
+ (unless (eq (fd-stream-original fd-stream)
+ (fd-stream-file fd-stream))
+ ;; We have a handle on the original, just revert.
+ (multiple-value-bind (okay err)
+ (sb!unix:unix-rename (fd-stream-original fd-stream)
+ (fd-stream-file fd-stream))
+ (unless okay
+ (simple-stream-perror
+ "couldn't restore ~S to its original contents"
+ fd-stream
+ err))))
+ ;; We can't restore the original, and aren't
+ ;; appending, so nuke that puppy.
+ ;;
+ ;; FIXME: This is currently the fate of superseded
+ ;; files, and according to the CLOSE spec this is
+ ;; wrong. However, there seems to be no clean way to
+ ;; do that that doesn't involve either copying the
+ ;; data (bad if the :abort resulted from a full
+ ;; disk), or renaming the old file temporarily
+ ;; (probably bad because stream opening becomes more
+ ;; racy).
(multiple-value-bind (okay err)
(sb!unix:unix-unlink (fd-stream-file fd-stream))
(unless okay
(:element-type
(fd-stream-element-type fd-stream))
(:interactive-p
- ;; FIXME: sb!unix:unix-isatty is undefined.
(= 1 (the (member 0 1)
(sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
(:line-length
(defun fd-stream-file-position (stream &optional newpos)
(declare (type file-stream stream)
- (type (or index (member nil :start :end)) newpos))
+ (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos))
(if (null newpos)
(sb!sys:without-interrupts
;; First, find the position of the UNIX file descriptor in the file.
(multiple-value-bind (posn errno)
(sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)
- (declare (type (or index null) posn))
- (cond ((fixnump posn)
+ (declare (type (or (alien sb!unix:off-t) null) posn))
+ (cond ((integerp posn)
;; Adjust for buffered output: If there is any output
;; buffered, the *real* file position will be larger
;; than reported by lseek() because lseek() obviously
;; cannot take into account output we have not sent
;; yet.
(dolist (later (fd-stream-output-later stream))
- (incf posn (- (the index (caddr later))
- (the index (cadr later)))))
+ (incf posn (- (caddr later)
+ (cadr later))))
(incf posn (fd-stream-obuf-tail stream))
;; Adjust for unread input: If there is any input
;; read from UNIX but not supplied to the user of the
stream
errno))))))
(let ((offset 0) origin)
- (declare (type index offset))
+ (declare (type (alien sb!unix:off-t) offset))
;; Make sure we don't have any output pending, because if we
;; move the file pointer before writing this stuff, it will be
;; written in the wrong location.
(setf offset 0 origin sb!unix:l_set))
((eq newpos :end)
(setf offset 0 origin sb!unix:l_xtnd))
- ((typep newpos 'index)
+ ((typep newpos '(alien sb!unix:off-t))
(setf offset (* newpos (fd-stream-element-size stream))
origin sb!unix:l_set))
(t
(error "invalid position given to FILE-POSITION: ~S" newpos)))
(multiple-value-bind (posn errno)
(sb!unix:unix-lseek (fd-stream-fd stream) offset origin)
- (cond ((typep posn 'fixnum)
+ (cond ((typep posn '(alien sb!unix:off-t))
t)
((eq errno sb!unix:espipe)
nil)
:IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
See the manual for details."
+ (declare (ignore external-format)) ; FIXME: CHECK-TYPE? WARN-if-not?
+
;; Calculate useful stuff.
(multiple-value-bind (input output mask)
(case direction
(namestring
(cond ((unix-namestring pathname input))
((and input (eq if-does-not-exist :create))
+ (unix-namestring pathname nil))
+ ((and (eq direction :io) (not if-does-not-exist-given))
(unix-namestring pathname nil)))))
;; Process if-exists argument if we are doing any output.
(cond (output
:append :supersede nil)
:if-exists)
(case if-exists
- ((:error nil)
+ ((:new-version :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)
+ ((:supersede)
(setf mask (logior mask sb!unix:o_trunc)))
(:append
(setf mask (logior mask sb!unix:o_append)))))
(if (eq if-does-not-exist :create)
(setf mask (logior mask sb!unix:o_creat)))
- (let ((original (if (member if-exists
- '(:rename :rename-and-delete))
- (pick-backup-name namestring)))
+ (let ((original (case if-exists
+ ((:rename :rename-and-delete)
+ (pick-backup-name namestring))
+ ((:append)
+ ;; KLUDGE: Provent CLOSE from deleting
+ ;; appending streams when called with :ABORT T
+ namestring)))
(delete-original (eq if-exists :rename-and-delete))
(mode #o666))
- (when original
+ (when (and original (not (eq original namestring)))
;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
;; whether the file already exists, make sure the original
;; file is not a directory, and keep the mode.
(open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
pathname))
(t nil)))
- ((and (eql errno sb!unix:eexist) if-exists)
+ ((and (eql errno sb!unix:eexist) (null if-exists))
nil)
(t
(vanilla-open-error)))))))))
projects / sbcl.git / blobdiff