(pop *available-buffers*)
(allocate-system-memory bytes-per-buffer)))
\f
-;;;; the FILE-STREAM structure
+;;;; the FD-STREAM structure
-(defstruct (file-stream
+(defstruct (fd-stream
(:constructor %make-fd-stream)
- ;; KLUDGE: in an ideal world, maybe we'd rewrite
- ;; everything to use FILE-STREAM rather than simply
- ;; providing this hack for compatibility with the old
- ;; code. However, CVS doesn't deal terribly well with
- ;; file renaming, so for now we use this
- ;; backward-compatibility feature.
(:conc-name fd-stream-)
(:predicate fd-stream-p)
(:include ansi-stream
(pathname nil :type (or pathname null))
(external-format :default)
(output-bytes #'ill-out :type function))
-(def!method print-object ((fd-stream file-stream) stream)
+(def!method print-object ((fd-stream fd-stream) stream)
(declare (type stream stream))
(print-unreadable-object (fd-stream stream :type t :identity t)
(format stream "for ~S" (fd-stream-name fd-stream))))
;;; writes. If so, just queue this one. Otherwise, try to write it. If
;;; this would block, queue it.
(defun frob-output (stream base start end reuse-sap)
- (declare (type file-stream stream)
+ (declare (type fd-stream stream)
(type (or system-area-pointer (simple-array * (*))) base)
(type index start end))
(if (not (null (fd-stream-output-later stream))) ; something buffered.
(frob-output stream (fd-stream-obuf-sap stream) 0 length t)
(setf (fd-stream-obuf-tail stream) 0))))
-(defmacro output-wrapper/variable-width ((stream size buffering)
+(defmacro output-wrapper/variable-width ((stream size buffering restart)
&body body)
(let ((stream-var (gensym)))
`(let ((,stream-var ,stream)
`(when (> (fd-stream-ibuf-tail ,stream-var)
(fd-stream-ibuf-head ,stream-var))
(file-position ,stream-var (file-position ,stream-var))))
- (with-simple-restart (output-nothing
- "~@<Skip output of this character.~@:>")
- ,@body)
- (incf (fd-stream-obuf-tail ,stream-var) size)
+ ,(if restart
+
+ `(with-simple-restart (output-nothing
+ "~@<Skip output of this character.~@:>")
+ ,@body
+ (incf (fd-stream-obuf-tail ,stream-var) size))
+ `(progn
+ ,@body
+ (incf (fd-stream-obuf-tail ,stream-var) size)))
,(ecase (car buffering)
(:none
`(flush-output-buffer ,stream-var))
(:full))
(values))))
-(defmacro output-wrapper ((stream size buffering) &body body)
+(defmacro output-wrapper ((stream size buffering restart) &body body)
(let ((stream-var (gensym)))
`(let ((,stream-var ,stream))
,(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))))
- (with-simple-restart (output-nothing
- "~@<Skip output of this character.~@:>")
- ,@body
- (incf (fd-stream-obuf-tail ,stream-var) ,size))
+ ,(if restart
+ `(with-simple-restart (output-nothing
+ "~@<Skip output of this character.~@:>")
+ ,@body
+ (incf (fd-stream-obuf-tail ,stream-var) ,size))
+ `(progn
+ ,@body
+ (incf (fd-stream-obuf-tail ,stream-var) ,size)))
,(ecase (car buffering)
(:none
`(flush-output-buffer ,stream-var))
(:full))
(values))))
-(defmacro def-output-routines/variable-width ((name-fmt size external-format
- &rest bufferings)
- &body body)
+(defmacro def-output-routines/variable-width
+ ((name-fmt size restart external-format &rest bufferings)
+ &body body)
(declare (optimize (speed 1)))
(cons 'progn
(mapcar
(format nil name-fmt (car buffering))))))
`(progn
(defun ,function (stream byte)
- (output-wrapper/variable-width (stream ,size ,buffering)
+ (output-wrapper/variable-width (stream ,size ,buffering ,restart)
,@body))
(setf *output-routines*
(nconc *output-routines*
;;; 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)
+(defmacro def-output-routines ((name-fmt size restart &rest bufferings)
+ &body body)
(declare (optimize (speed 1)))
(cons 'progn
(mapcar
(format nil name-fmt (car buffering))))))
`(progn
(defun ,function (stream byte)
- (output-wrapper (stream ,size ,buffering)
+ (output-wrapper (stream ,size ,buffering ,restart)
,@body))
(setf *output-routines*
(nconc *output-routines*
(cdr buffering)))))))
bufferings)))
+;;; FIXME: is this used anywhere any more?
(def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
1
+ t
(:none character)
(:line character)
(:full character))
(def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
1
+ nil
(:none (unsigned-byte 8))
(:full (unsigned-byte 8)))
(setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
(def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
1
+ nil
(:none (signed-byte 8))
(:full (signed-byte 8)))
(setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)
(def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
2
+ nil
(:none (unsigned-byte 16))
(:full (unsigned-byte 16)))
(setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
(def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
2
+ nil
(:none (signed-byte 16))
(:full (signed-byte 16)))
(setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)
(def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
4
+ nil
(:none (unsigned-byte 32))
(:full (unsigned-byte 32)))
(setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
(def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
4
+ nil
(:none (signed-byte 32))
(:full (signed-byte 32)))
(setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)
(ecase buffering
(:none
(lambda (stream byte)
- (output-wrapper (stream (/ i 8) (:none))
+ (output-wrapper (stream (/ i 8) (:none) nil)
(loop for j from 0 below (/ i 8)
do (setf (sap-ref-8
(fd-stream-obuf-sap stream)
(ldb (byte 8 (- i 8 (* j 8))) byte))))))
(:full
(lambda (stream byte)
- (output-wrapper (stream (/ i 8) (:full))
+ (output-wrapper (stream (/ i 8) (:full) nil)
(loop for j from 0 below (/ i 8)
do (setf (sap-ref-8
(fd-stream-obuf-sap stream)
(ecase buffering
(:none
(lambda (stream byte)
- (output-wrapper (stream (/ i 8) (:none))
+ (output-wrapper (stream (/ i 8) (:none) nil)
(loop for j from 0 below (/ i 8)
do (setf (sap-ref-8
(fd-stream-obuf-sap stream)
(ldb (byte 8 (- i 8 (* j 8))) byte))))))
(:full
(lambda (stream byte)
- (output-wrapper (stream (/ i 8) (:full))
+ (output-wrapper (stream (/ i 8) (:full) nil)
(loop for j from 0 below (/ i 8)
do (setf (sap-ref-8
(fd-stream-obuf-sap stream)
;;; isn't too problematical.
(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
&aux (total-copied 0))
- (declare (type file-stream stream))
+ (declare (type fd-stream stream))
(declare (type index start requested total-copied))
(let ((unread (fd-stream-unread stream)))
(when unread
(when (null count)
(simple-stream-perror "couldn't read from ~S" stream err))
(setf (fd-stream-listen stream) nil
- (fd-stream-ibuf-head stream) new-head
+ (fd-stream-ibuf-head stream) 0
(fd-stream-ibuf-tail stream) (+ count new-head))
count)))
-(defmacro define-external-format (external-format size out-expr in-expr)
+(defmacro define-external-format (external-format size output-restart
+ out-expr in-expr)
(let* ((name (first external-format))
(out-function (intern (let ((*print-case* :upcase))
(format nil "OUTPUT-BYTES/~A" name))))
(sap (fd-stream-obuf-sap stream))
(tail (fd-stream-obuf-tail stream)))
((or (= start end) (< (- len tail) 4)) tail)
- (with-simple-restart (output-nothing
- "~@<Skip output of this character.~@:>")
- (let* ((byte (aref string start))
- (bits (char-code byte)))
- ,out-expr
- (incf tail ,size)))
+ ,(if output-restart
+ `(with-simple-restart (output-nothing
+ "~@<Skip output of this character.~@:>")
+ (let* ((byte (aref string start))
+ (bits (char-code byte)))
+ ,out-expr
+ (incf tail ,size)))
+ `(let* ((byte (aref string start))
+ (bits (char-code byte)))
+ ,out-expr
+ (incf tail ,size)))
(incf start)))
(when (< start end)
(flush-output-buffer stream)))
(flush-output-buffer stream))))
(def-output-routines (,format
,size
+ ,output-restart
(:none character)
(:line character)
(:full character))
,out-expr))
(defun ,in-function (stream buffer start requested eof-error-p
&aux (total-copied 0))
- (declare (type file-stream stream))
+ (declare (type fd-stream stream))
(declare (type index start requested total-copied))
(let ((unread (fd-stream-unread stream)))
(when unread
'(:none :line :full)))
*external-formats*)))))
-(defmacro define-external-format/variable-width (external-format out-size-expr
- out-expr in-size-expr in-expr)
+(defmacro define-external-format/variable-width
+ (external-format output-restart out-size-expr
+ out-expr in-size-expr in-expr)
(let* ((name (first external-format))
(out-function (intern (let ((*print-case* :upcase))
(format nil "OUTPUT-BYTES/~A" name))))
(flush-output-buffer fd-stream))))
(def-output-routines/variable-width (,format
,out-size-expr
+ ,output-restart
,external-format
(:none character)
(:line character)
,out-expr))
(defun ,in-function (stream buffer start requested eof-error-p
&aux (total-copied 0))
- (declare (type file-stream stream))
+ (declare (type fd-stream stream))
(declare (type index start requested total-copied))
(let ((unread (fd-stream-unread stream)))
(when unread
*external-formats*)))))
(define-external-format (:latin-1 :latin1 :iso-8859-1)
- 1
+ 1 t
(if (>= bits 256)
(stream-encoding-error stream bits)
(setf (sap-ref-8 sap tail) bits))
(code-char byte))
(define-external-format (:ascii :us-ascii :ansi_x3.4-1968)
- 1
+ 1 t
(if (>= bits 128)
(stream-encoding-error stream bits)
(setf (sap-ref-8 sap tail) bits))
(code-char byte))
+(let* ((table (let ((s (make-string 256)))
+ (map-into s #'code-char
+ '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f
+ #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f
+ #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07
+ #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a
+ #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c
+ #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac
+ #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
+ #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22
+ #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1
+ #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4
+ #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae
+ #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7
+ #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5
+ #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
+ #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5
+ #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f))
+ s))
+ (reverse-table (let ((rt (make-array 256 :element-type '(unsigned-byte 8) :initial-element 0)))
+ (loop for char across table for i from 0
+ do (aver (= 0 (aref rt (char-code char))))
+ do (setf (aref rt (char-code char)) i))
+ rt)))
+ (define-external-format (:ebcdic-us :ibm-037 :ibm037)
+ 1 t
+ (if (>= bits 256)
+ (stream-encoding-error stream bits)
+ (setf (sap-ref-8 sap tail) (aref reverse-table bits)))
+ (aref table byte)))
+
+
#!+sb-unicode
(let ((latin-9-table (let ((table (make-string 256)))
(do ((i 0 (1+ i)))
:element-type '(unsigned-byte 8)
:initial-contents '(#xa6 #xa8 #xbc #xbd 0 0 0 0 #xbe 0 0 0 #xa4 #xb4 #xb8 0))))
(define-external-format (:latin-9 :latin9 :iso-8859-15)
- 1
+ 1 t
(setf (sap-ref-8 sap tail)
(if (< bits 256)
(if (= bits (char-code (aref latin-9-table bits)))
(stream-encoding-error stream byte))))
(aref latin-9-table byte)))
-(define-external-format/variable-width (:utf-8 :utf8)
+(define-external-format/variable-width (:utf-8 :utf8) nil
(let ((bits (char-code byte)))
(cond ((< bits #x80) 1)
((< bits #x800) 2)
;; appropriate value for the EXPECTED-TYPE slot..
(error 'simple-type-error
:datum fd-stream
- :expected-type 'file-stream
+ :expected-type 'fd-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
(fd-stream-file-position fd-stream arg1))))
(defun fd-stream-file-position (stream &optional newpos)
- (declare (type file-stream stream)
+ (declare (type fd-stream stream)
(type (or (alien sb!unix:off-t) (member nil :start :end)) newpos))
(if (null newpos)
(sb!sys:without-interrupts
;;;
;;; FIXME: misleading name, screwy interface
(defun file-name (stream &optional new-name)
- (when (typep stream 'file-stream)
+ (when (typep stream 'fd-stream)
(cond (new-name
(setf (fd-stream-pathname stream) new-name)
(setf (fd-stream-file stream)
;;;; COMMON-LISP.)
(defun file-string-length (stream object)
- (declare (type (or string character) object) (type file-stream stream))
+ (declare (type (or string character) object) (type fd-stream stream))
#!+sb-doc
"Return the delta in STREAM's FILE-POSITION that would be caused by writing
OBJECT to STREAM. Non-trivial only in implementations that support
(string (length object))))
(defun stream-external-format (stream)
- (declare (type file-stream stream))
+ (declare (type fd-stream stream))
#!+sb-doc
- "Return the actual external format for file-streams, otherwise :DEFAULT."
- (if (typep stream 'file-stream)
+ "Return the actual external format for fd-streams, otherwise :DEFAULT."
+ (if (typep stream 'fd-stream)
(fd-stream-external-format stream)
:default))
projects / sbcl.git / blobdiff