X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=b403ffad183e2124e9eea0e7f9e42b89ea37d153;hb=4ed3f0d08c3a57a6762018d9622f253ab9d0f2b6;hp=ae79940b85c155036593b619a71d14a2ffcddb2a;hpb=b387f6ae447b55e203f47fc40af4a36e756fe345;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index ae79940..b403ffa 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -591,12 +591,28 @@ ;;; 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)) @@ -682,7 +698,15 @@ (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))))) @@ -847,7 +871,6 @@ (: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 @@ -880,22 +903,22 @@ (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 @@ -916,7 +939,7 @@ 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. @@ -936,14 +959,14 @@ (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) @@ -1060,17 +1083,9 @@ :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE, :OVERWRITE, :APPEND, :SUPERSEDE or NIL - :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or nil + :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL See the manual for details." - (unless (eq external-format :default) - (error "Any external format other than :DEFAULT isn't recognized.")) - - ;; First, make sure that DIRECTION is valid. - (ensure-one-of direction - '(:input :output :io :probe) - :direction) - ;; Calculate useful stuff. (multiple-value-bind (input output mask) (case direction @@ -1169,7 +1184,7 @@ (logior (logandc2 mask sb!unix:o_creat) sb!unix:o_trunc))) (setf if-exists :supersede)))) - + ;; Now we can try the actual Unix open(2). (multiple-value-bind (fd errno) (if namestring @@ -1210,7 +1225,7 @@ (open-error "~@" 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)))))))))