X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=105ee6fcafbc1357d435ede1a7fc76eb75318066;hb=b0b168c08b31a748150f404398af754f26fd4813;hp=6df3f9f8de1796cda6442c4b4f4a2e5c7e3502d3;hpb=aa2dc9529460ea0d9c99998dc87283fc1a43e808;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 6df3f9f..105ee6f 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -43,7 +43,7 @@ (defstruct (fd-stream (:constructor %make-fd-stream) - (:include lisp-stream + (:include ansi-stream (misc #'fd-stream-misc-routine)) (:copier nil)) @@ -107,7 +107,7 @@ :format-control "~@<~?: ~2I~_~A~:>" :format-arguments (list note-format (list stream) (strerror errno)))) (defun simple-file-perror (note-format pathname errno) - (error 'simple-stream-error + (error 'simple-file-error :pathname pathname :format-control "~@<~?: ~2I~_~A~:>" :format-arguments @@ -154,9 +154,9 @@ (setf (fd-stream-handler stream) (sb!sys:add-fd-handler (fd-stream-fd stream) :output - #'(lambda (fd) - (declare (ignore fd)) - (do-output-later stream))))) + (lambda (fd) + (declare (ignore fd)) + (do-output-later stream))))) (t (nconc (fd-stream-output-later stream) (list (list base start end reuse-sap))))) @@ -203,38 +203,38 @@ (declare (optimize (speed 1))) (cons 'progn (mapcar - #'(lambda (buffering) - (let ((function - (intern (let ((*print-case* :upcase)) - (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)) - (setf *output-routines* - (nconc *output-routines* - ',(mapcar - #'(lambda (type) - (list type - (car buffering) - function - size)) - (cdr buffering))))))) - bufferings))) + (lambda (buffering) + (let ((function + (intern (let ((*print-case* :upcase)) + (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)) + (setf *output-routines* + (nconc *output-routines* + ',(mapcar + (lambda (type) + (list type + (car buffering) + function + size)) + (cdr buffering))))))) + bufferings))) (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED" 1 @@ -316,37 +316,37 @@ ((<= bytes space) (if (system-area-pointer-p thing) (system-area-copy thing - (* start sb!vm:byte-bits) + (* start sb!vm:n-byte-bits) (fd-stream-obuf-sap fd-stream) - (* tail sb!vm:byte-bits) - (* bytes sb!vm:byte-bits)) + (* tail sb!vm:n-byte-bits) + (* bytes sb!vm:n-byte-bits)) ;; FIXME: There should be some type checking somewhere to ;; verify that THING here is a vector, not just . (copy-to-system-area thing - (+ (* start sb!vm:byte-bits) + (+ (* start sb!vm:n-byte-bits) (* sb!vm:vector-data-offset - sb!vm:word-bits)) + sb!vm:n-word-bits)) (fd-stream-obuf-sap fd-stream) - (* tail sb!vm:byte-bits) - (* bytes sb!vm:byte-bits))) + (* tail sb!vm:n-byte-bits) + (* bytes sb!vm:n-byte-bits))) (setf (fd-stream-obuf-tail fd-stream) newtail)) ((<= bytes len) (flush-output-buffer fd-stream) (if (system-area-pointer-p thing) (system-area-copy thing - (* start sb!vm:byte-bits) + (* start sb!vm:n-byte-bits) (fd-stream-obuf-sap fd-stream) 0 - (* bytes sb!vm:byte-bits)) + (* bytes sb!vm:n-byte-bits)) ;; FIXME: There should be some type checking somewhere to ;; verify that THING here is a vector, not just . (copy-to-system-area thing - (+ (* start sb!vm:byte-bits) + (+ (* start sb!vm:n-byte-bits) (* sb!vm:vector-data-offset - sb!vm:word-bits)) + sb!vm:n-word-bits)) (fd-stream-obuf-sap fd-stream) 0 - (* bytes sb!vm:byte-bits))) + (* bytes sb!vm:n-byte-bits))) (setf (fd-stream-obuf-tail fd-stream) bytes)) (t (flush-output-buffer fd-stream) @@ -429,8 +429,8 @@ (setf (fd-stream-ibuf-tail stream) 0)) (t (decf tail head) - (system-area-copy ibuf-sap (* head sb!vm:byte-bits) - ibuf-sap 0 (* tail sb!vm:byte-bits)) + (system-area-copy ibuf-sap (* head sb!vm:n-byte-bits) + ibuf-sap 0 (* tail sb!vm:n-byte-bits)) (setf head 0) (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) tail)))) @@ -479,6 +479,7 @@ (simple-stream-perror "couldn't read from ~S" stream errno))) ((zerop count) (setf (fd-stream-listen stream) :eof) + (/show0 "THROWing EOF-INPUT-CATCHER") (throw 'eof-input-catcher nil)) (t (incf (fd-stream-ibuf-tail stream) count)))))) @@ -575,19 +576,22 @@ (car entry) (caddr entry)))))) -;;; Returns a string constructed from the sap, start, and end. +;;; Return a string constructed from SAP, START, and END. (defun string-from-sap (sap start end) (declare (type index start end)) (let* ((length (- end start)) (string (make-string length))) - (copy-from-system-area sap (* start sb!vm:byte-bits) - string (* sb!vm:vector-data-offset sb!vm:word-bits) - (* length sb!vm:byte-bits)) + (copy-from-system-area sap (* start sb!vm:n-byte-bits) + string (* sb!vm:vector-data-offset + sb!vm:n-word-bits) + (* length sb!vm:n-byte-bits)) string)) -;;; the N-BIN method for FD-STREAMs. 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. +;;; the N-BIN method for FD-STREAMs +;;; +;;; 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) (declare (type fd-stream stream)) (declare (type index start requested)) @@ -598,23 +602,16 @@ (head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream)) (available (- tail head)) - (this-copy (min remaining-request available)) + (n-this-copy (min remaining-request available)) (this-start (+ start total-copied)) + (this-end (+ this-start n-this-copy)) (sap (fd-stream-ibuf-sap stream))) (declare (type index remaining-request head tail available)) - (declare (type index this-copy)) + (declare (type index n-this-copy)) ;; Copy data from stream buffer into user's buffer. - (if (typep buffer 'system-area-pointer) - (system-area-copy sap (* head sb!vm:byte-bits) - buffer (* this-start sb!vm:byte-bits) - (* this-copy sb!vm:byte-bits)) - (copy-from-system-area sap (* head sb!vm:byte-bits) - buffer (+ (* this-start sb!vm:byte-bits) - (* sb!vm:vector-data-offset - sb!vm:word-bits)) - (* this-copy sb!vm:byte-bits))) - (incf (fd-stream-ibuf-head stream) this-copy) - (incf total-copied this-copy) + (%byte-blt sap head buffer this-start this-end) + (incf (fd-stream-ibuf-head stream) n-this-copy) + (incf total-copied n-this-copy) ;; Maybe we need to refill the stream buffer. (cond (;; If there were enough data in the stream buffer, we're done. (= total-copied requested) @@ -687,8 +684,8 @@ (when (eql size 1) (setf (fd-stream-n-bin fd-stream) #'fd-stream-read-n-bytes) (when buffer-p - (setf (lisp-stream-in-buffer fd-stream) - (make-array +in-buffer-length+ + (setf (ansi-stream-in-buffer fd-stream) + (make-array +ansi-stream-in-buffer-length+ :element-type '(unsigned-byte 8))))) (setf input-size size) (setf input-type type))) @@ -858,6 +855,16 @@ (:charpos (fd-stream-char-pos fd-stream)) (:file-length + (unless (fd-stream-file fd-stream) + ;; This is a TYPE-ERROR because ANSI's species FILE-LENGTH + ;; "should signal an error of type TYPE-ERROR if stream is not + ;; a stream associated with a file". Too bad there's no very + ;; appropriate value for the EXPECTED-TYPE slot.. + (error 'simple-type-error + :datum fd-stream + :expected-type 'file-stream + :format-control "~S is not a stream associated with a file." + :format-arguments (list fd-stream))) (multiple-value-bind (okay dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks) (sb!unix:unix-fstat (fd-stream-fd fd-stream)) @@ -978,7 +985,7 @@ input-buffer-p (name (if file (format nil "file ~S" file) - (format nil "descriptor ~D" fd))) + (format nil "descriptor ~W" fd))) auto-close) (declare (type index fd) (type (or index null) timeout) (type (member :none :line :full) buffering)) @@ -1000,7 +1007,7 @@ (lambda () (sb!unix:unix-close fd) #!+sb-show - (format *terminal-io* "** closed file descriptor ~D **~%" + (format *terminal-io* "** closed file descriptor ~W **~%" fd)))) stream))