Changeset 11653


Ignore:
Timestamp:
Jan 29, 2009, 3:20:03 PM (10 years ago)
Author:
gz
Message:

r11627-r11628 from trunk

Location:
branches/working-0711/ccl/level-1
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-streams.lisp

    r11583 r11653  
    19401940        (incf col))
    19411941      (if (< code limit)
    1942                (%ioblock-write-u8-element ioblock code)
    1943                (funcall encode-function char #'%ioblock-write-u8-element ioblock)))))
     1942        (%ioblock-write-u8-element ioblock code)
     1943        (funcall encode-function char #'%ioblock-write-u8-element ioblock)))))
    19441944
    19451945
     
    26792679  (setf (ioblock-sharing ioblock) sharing)
    26802680  (when character-p
    2681     (setf (ioblock-unread-char-function ioblock) '%ioblock-untyi)
     2681    (setf (ioblock-unread-char-function ioblock) (select-stream-untyi-function (ioblock-stream ioblock) :input))
    26822682    (setf (ioblock-decode-literal-code-unit-limit ioblock)
    26832683          (if encoding
     
    59825982
    59835983
     5984(defmethod select-stream-untyi-function ((s symbol) direction)
     5985  (select-stream-untyi-function (find-class s) direction))
     5986
     5987(defmethod select-stream-untyi-function ((c class) direction)
     5988  (select-stream-untyi-function (class-prototype c) direction))
     5989
     5990(defmethod select-stream-untyi-function ((s fd-stream) (direction t))
     5991  '%ioblock-untyi)
     5992
     5993(defmethod select-stream-untyi-function ((s basic-stream) (direction t))
     5994  '%ioblock-untyi)
    59845995
    59855996; end of L1-streams.lisp
  • branches/working-0711/ccl/level-1/l1-sysio.lisp

    r11074 r11653  
    179179         (curpos (+ element-base (io-buffer-idx inbuf))))
    180180    (if (null newpos)
    181       (if (file-ioblock-untyi-char file-ioblock)
    182         (1- curpos)
    183         curpos)
     181      curpos
    184182      (progn
    185         (setf (file-ioblock-untyi-char file-ioblock) nil)
    186183        (if (and (>= newpos element-base)
    187184                 (< newpos (+ element-base (io-buffer-count inbuf))))
     
    246243         (curpos (+ element-base curidx)))
    247244    (if (null newpos)
    248       (if (file-ioblock-untyi-char file-ioblock)
    249         (1- curpos)
    250         curpos)
     245      curpos
    251246      (let* ((incount (io-buffer-count outbuf)))
    252247        (unless (= newpos 0)
    253248          (setf (ioblock-pending-byte-order-mark file-ioblock) nil))       
    254         (when (file-ioblock-untyi-char file-ioblock)
    255           (setf (file-ioblock-untyi-char file-ioblock) nil)
    256           (if (> curidx 0)
    257             (decf curpos)))
    258249        (cond
    259250          ((and (>= newpos element-base)
     
    325316               ;; file, then seek to the new EOF.
    326317               (fd-ftruncate fd new-octet-eof)
    327                (setf (file-ioblock-untyi-char file-ioblock) nil)
    328318               (file-ioblock-seek-and-reset file-ioblock new-octet-eof))
    329319              (t
     
    531521                   
    532522(defun output-file-force-output (stream file-ioblock count finish-p)
    533   (let* ((n (fd-stream-force-output stream file-ioblock count finish-p)))
     523  (let* ((pos (%ioblock-output-file-position file-ioblock nil))
     524         (n (fd-stream-force-output stream file-ioblock count finish-p)))
    534525    (incf (file-ioblock-octet-pos file-ioblock) (or n 0))
     526    (%ioblock-output-file-position file-ioblock pos)
    535527    n))
    536528
    537529;;; Can't be sure where the underlying fd is positioned, so seek first.
    538530(defun io-file-force-output (stream file-ioblock count finish-p)
    539   (file-ioblock-seek file-ioblock (file-ioblock-octet-pos file-ioblock))
    540   (output-file-force-output stream file-ioblock count finish-p))
     531  (let* ((pos (%ioblock-io-file-position file-ioblock nil)))
     532    (file-ioblock-seek file-ioblock (file-ioblock-octet-pos file-ioblock))
     533    (let* ((n (fd-stream-force-output stream file-ioblock count finish-p)))
     534      (incf (file-ioblock-octet-pos file-ioblock) (or n 0))
     535      (%ioblock-io-file-position file-ioblock pos)
     536      n)))
    541537
    542538
     
    547543  (let* ((inbuf (file-ioblock-inbuf file-ioblock))
    548544         (outbuf (file-ioblock-outbuf file-ioblock)))
    549     (setf (file-ioblock-untyi-char file-ioblock) nil)
    550545    (setf (file-ioblock-dirty file-ioblock) nil)
    551546    (when inbuf
     
    718713    (:output 'output-file-force-output)))
    719714
     715(defmethod select-stream-untyi-function ((s file-stream) (direction t))
     716  '%file-ioblock-untyi)
     717
     718;;; Conceptually, decrement the stream's position by the number of octets
     719;;; needed to encode CHAR.
     720;;; Since we don't use IOBLOCK-UNTYI-CHAR, it's hard to detect the error
     721;;; of calling UNREAD-CHAR twice in a row.
     722(defun %file-ioblock-untyi (ioblock char)
     723  (let* ((inbuf (ioblock-inbuf ioblock))
     724         (idx (io-buffer-idx inbuf))
     725         (encoding (ioblock-encoding ioblock))
     726         (noctets (if encoding
     727                    (funcall (character-encoding-character-size-in-octets-function encoding) char)
     728                    1)))
     729    (declare (fixnum idx noctets))
     730    (if (>= idx noctets)
     731      (setf (io-buffer-idx inbuf) (the fixnum (- idx noctets)))
     732      (let* ((stream (ioblock-stream ioblock))
     733             (pos (stream-position stream))
     734             (newpos (- pos noctets)))
     735        (if (< newpos 0)
     736          (error "Invalid attempt to unread ~s on ~s." char (ioblock-stream ioblock))
     737          (stream-position stream newpos))))
     738    char))
    720739
    721740
Note: See TracChangeset for help on using the changeset viewer.