/[cmucl]/src/code/fd-stream.lisp
ViewVC logotype

Diff of /src/code/fd-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.114 by rtoy, Tue Jul 20 22:53:11 2010 UTC revision 1.114.2.3 by rtoy, Wed Sep 15 15:32:45 2010 UTC
# Line 1450  Line 1450 
1450                  ;; FAST-READ-CHAR.)                  ;; FAST-READ-CHAR.)
1451                  (setf (lisp-stream-string-buffer stream)                  (setf (lisp-stream-string-buffer stream)
1452                        (make-string (1+ in-buffer-length)))                        (make-string (1+ in-buffer-length)))
1453                    (setf (fd-stream-octet-count stream)
1454                          (make-array in-buffer-length :element-type '(unsigned-byte 8)))
1455                  (setf (lisp-stream-string-buffer-len stream) 0)                  (setf (lisp-stream-string-buffer-len stream) 0)
1456                  (setf (lisp-stream-string-index stream) 0)))))                  (setf (lisp-stream-string-index stream) 0)))))
1457          (setf input-size size)          (setf input-size size)
# Line 1693  Line 1695 
1695                     (incf posn (- (the index (caddr later))                     (incf posn (- (the index (caddr later))
1696                                   (the index (cadr later)))))                                   (the index (cadr later)))))
1697                   (incf posn (fd-stream-obuf-tail stream))                   (incf posn (fd-stream-obuf-tail stream))
1698    
1699                   ;; Adjust for unread input:                   ;; Adjust for unread input:
1700                   ;;  If there is any input read from UNIX but not supplied to                   ;;  If there is any input read from UNIX but not supplied to
1701                   ;; the user of the stream, the *real* file position will                   ;; the user of the stream, the *real* file position will
1702                   ;; smaller than reported, because we want to look like the                   ;; smaller than reported, because we want to look like the
1703                   ;; unread stuff is still available.                   ;; unread stuff is still available.
                  #-unicode  
1704                   (decf posn (- (fd-stream-ibuf-tail stream)                   (decf posn (- (fd-stream-ibuf-tail stream)
1705                                 (fd-stream-ibuf-head stream)))                                 (fd-stream-ibuf-head stream)))
1706    
1707                   #+unicode                   #+unicode
1708                   (if (fd-stream-string-buffer stream)                   (if (fd-stream-string-buffer stream)
1709                       ;; The string buffer contains Lisp characters,                       ;; The string buffer contains Lisp characters,
1710                       ;; not octets!  To figure out how many octets                       ;; not octets!  To figure out how many octets
1711                       ;; have not been already supplied, we need to                       ;; have not been already supplied, we need to
1712                       ;; convert them back to the encoded format and                       ;; count how many octets were consumed for all
1713                       ;; count the number of octets.                       ;; the characters in the string bbuffer that have
1714                       (decf posn                       ;; not been supplied.
1715                             (length (string-encode (fd-stream-string-buffer stream)                       (let ((ocount (fd-stream-octet-count stream)))
1716                                                    (fd-stream-external-format stream)                         (when ocount
1717                                                    (fd-stream-string-index stream)                           ;; Note: string-index starts at 1 (because
1718                                                    (fd-stream-string-buffer-len stream))))                           ;; index 0 is for the unread-char), but
1719                       (decf posn (- (fd-stream-ibuf-tail stream)                           ;; octet-count doesn't use that.  Hence,
1720                                     (fd-stream-ibuf-head stream))))                           ;; subtract one from string-index and
1721                             ;; string-buffer-len.
1722                             (loop for k of-type fixnum from (1- (fd-stream-string-index stream))
1723                                below (1- (fd-stream-string-buffer-len stream))
1724                                do (decf posn (aref ocount k)))))
1725                         (when (fd-stream-in-buffer stream)
1726                           ;; When we have an in-buffer (but no
1727                           ;; string-buffer!), we need to adjust for the
1728                           ;; octets that have not yet been supplied.
1729                           ;; This situation (should!) only happens for an
1730                           ;; external-format of ISO-8859-1.  If there's
1731                           ;; no string-buffer and no in-buffer, then the
1732                           ;; ibuf tail and head pointers contain all the
1733                           ;; information needed.
1734                           (decf posn (- in-buffer-length
1735                                         (fd-stream-in-index stream)))))
1736    
1737                   (when (fd-stream-unread stream) ;;@@                   (when (fd-stream-unread stream) ;;@@
1738                     (decf posn))                     (decf posn))
1739                   ;; Divide bytes by element size.                   ;; Divide bytes by element size.
# Line 1841  Line 1860 
1860                            (d (cond ((characterp decoding-error)                            (d (cond ((characterp decoding-error)
1861                                      (constantly (char-code decoding-error)))                                      (constantly (char-code decoding-error)))
1862                                     ((eq t decoding-error)                                     ((eq t decoding-error)
1863                                        #+unicode
1864                                      #'(lambda (&rest args)                                      #'(lambda (&rest args)
1865                                          (apply 'cerror                                          (apply 'cerror
1866                                                 (intl:gettext "Use Unicode replacement character instead")                                                 (intl:gettext "Use Unicode replacement character instead")
1867                                                 args)                                                 args)
1868                                          stream:+replacement-character-code+))                                          stream:+replacement-character-code+)
1869                                        #-unicode
1870                                        #'(lambda (&rest args)
1871                                            (apply 'cerror
1872                                                   (intl:gettext "Use question mark character instead")
1873                                                   args)
1874                                            #\?))
1875                                     (t                                     (t
1876                                      decoding-error))))                                      decoding-error))))
1877                        (%make-fd-stream :fd fd                        (%make-fd-stream :fd fd
# Line 2201  Line 2227 
2227     :if-does-not-exist - one of :error, :create or nil     :if-does-not-exist - one of :error, :create or nil
2228     :external-format - an external format name     :external-format - an external format name
2229     :decoding-error - How to handle decoding errors from the external format.     :decoding-error - How to handle decoding errors from the external format.
2230                         Should be a symbol or function of 3 arguments.  If it                         If a character, then that character is used as
2231                         returns, it should return a code point to use as the                         the replacment character for all errors.  If T,
2232                         replacment.  NIL means use the default replacement scheme                         then a continuable error is signaled.  If
2233                         specified by the external format.  The function arguments                         continued, the Unicode replacement character is
2234                         are a format message string, the offending octet, and the                         used.  Otherwise, it should be a symbol or
2235                         number of octets read in the current encoding.                         function of 3 arguments.  If it returns, it
2236                           should return a code point to use as the
2237                           replacment.  The function arguments are a
2238                           format message string, the offending octet, and
2239                           the number of octets read in the current
2240                           encoding.
2241     :encoding-error - Like :decoding-error, but for errors when encoding the     :encoding-error - Like :decoding-error, but for errors when encoding the
2242                         stream.  The function arguments are a format message                         stream.  If a character, that character is used
2243                         string and the incorrect codepoint.                         as the replacment code point.  Otherwise, it
2244                           should be a symbol or function oof two
2245                           arguments: a format message string and the
2246                           incorrect codepoint.
2247    
2248    See the manual for details."    See the manual for details."
2249    (declare (ignore element-type external-format input-handle output-handle    (declare (ignore element-type external-format input-handle output-handle

Legend:
Removed from v.1.114  
changed lines
  Added in v.1.114.2.3

  ViewVC Help
Powered by ViewVC 1.1.5