Changeset 5329


Ignore:
Timestamp:
Oct 9, 2006, 2:19:42 PM (18 years ago)
Author:
Gary Byers
Message:

More stuff about line termination. When will this end ?

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/ccl/level-1/l1-streams.lisp

    r5319 r5329  
    382382  (peek-char-function 'ioblock-no-char-input)
    383383  (native-byte-order t)
    384   (read-char-without-translation-while-locked-function 'ioblock-no-char-input)
    385   (write-char-without-translation-while-locked-function 'iblock-no-char-output)
     384  (read-char-without-translation-when-locked-function 'ioblock-no-char-input)
     385  (write-char-without-translation-when-locked-function 'iblock-no-char-output)
    386386  (sharing nil)
    387387  (reserved0 nil)
    … …  
    406406  (report-bad-arg (ioblock-stream ioblock) '(and character-stream input-stream)))
    407407
    408 (defun ioblock-no-char-output (ioblock &rest other-otters)
    409   (declare (ignore other-otters))
     408(defun ioblock-no-char-output (ioblock &rest others)
     409  (declare (ignore others))
    410410  (report-bad-arg (ioblock-stream ioblock) '(and character-stream output-stream)))
    411411
    … …  
    18331833        (limit (ioblock-literal-char-code-limit ioblock))
    18341834        (encode-function (ioblock-encode-output-function ioblock))
     1835        (wcf (ioblock-write-char-when-locked-function ioblock))
    18351836        (start-char start-char (1+ start-char)))
    18361837       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
    … …  
    18391840           (code (char-code char)))
    18401841      (declare (type (mod #x110000) code))
    1841       (if (eq char #\newline)
    1842         (setq col 0)
    1843         (incf col))
    1844       (if (< code limit)
    1845         (%ioblock-write-u8-element ioblock code)
    1846         (funcall encode-function char #'%ioblock-write-u8-element ioblock)))))
     1842      (cond ((eq char #\newline)
     1843             (setq col 0)
     1844             (funcall wcf ioblock char))
     1845            (t
     1846             (incf col)
     1847             (if (< code limit)
     1848               (%ioblock-write-u8-element ioblock code)
     1849               (funcall encode-function char #'%ioblock-write-u8-element ioblock)))))))
    18471850
    18481851(declaim (inline %ioblock-write-u16-encoded-char))
    … …  
    18891892        (limit (ioblock-literal-char-code-limit ioblock))
    18901893        (encode-function (ioblock-encode-output-function ioblock))
     1894        (wcf (ioblock-write-char-when-locked-function ioblock))
    18911895        (start-char start-char (1+ start-char)))
    18921896       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
    … …  
    18951899           (code (char-code char)))
    18961900      (declare (type (mod #x110000) code))
    1897       (if (eq char #\newline)
    1898         (setq col 0)
    1899         (incf col))
    1900       (if (< code limit)
    1901         (%ioblock-write-u16-code-unit ioblock code)
    1902         (funcall encode-function char #'%ioblock-write-u16-code-unit ioblock)))))
     1901      (cond ((eq char #\newline)
     1902             (setq col 0)
     1903             (funcall wcf ioblock char))
     1904            (t
     1905             (incf col)
     1906             (if (< code limit)
     1907               (%ioblock-write-u16-code-unit ioblock code)
     1908               (funcall encode-function char #'%ioblock-write-u16-code-unit ioblock)))))))
    19031909
    19041910(declaim (inline %ioblock-write-swapped-u16-encoded-char))
    … …  
    19351941        (limit (ioblock-literal-char-code-limit ioblock))
    19361942        (encode-function (ioblock-encode-output-function ioblock))
     1943        (wcf (ioblock-write-char-when-locked-function ioblock))
    19371944        (start-char start-char (1+ start-char)))
    19381945       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
    … …  
    19411948           (code (char-code char)))
    19421949      (declare (type (mod #x110000) code))
    1943       (if (eq char #\newline)
    1944         (setq col 0)
    1945         (incf col))
    1946       (if (< code limit)
    1947         (%ioblock-write-swapped-u16-code-unit ioblock code)
    1948         (funcall encode-function char #'%ioblock-write-swapped-u16-code-unit ioblock)))))
     1950      (cond ((eq char #\newline)
     1951             (setq col 0)
     1952             (funcall wcf ioblock char))
     1953            (t
     1954             (incf col)
     1955             (if (< code limit)
     1956               (%ioblock-write-swapped-u16-code-unit ioblock code)
     1957               (funcall encode-function char #'%ioblock-write-swapped-u16-code-unit ioblock)))))))
    19491958
    19501959
    … …  
    23302339(defun %ioblock-read-char-translating-cr-to-newline (ioblock)
    23312340  (let* ((ch (funcall
    2332               (ioblock-read-char-without-translation-while-locked-function
     2341              (ioblock-read-char-without-translation-when-locked-function
    23332342               ioblock)
    23342343              ioblock)))
    … …  
    23482357(defun %ioblock-read-char-translating-crlf-to-newline (ioblock)
    23492358  (let* ((ch (funcall
    2350               (ioblock-read-char-without-translation-while-locked-function
     2359              (ioblock-read-char-without-translation-when-locked-function
    23512360               ioblock)
    23522361              ioblock)))
    23532362    (if (eql ch #\Return)
    23542363      (let* ((next (funcall
    2355                     (ioblock-read-char-without-translation-while-locked-function
     2364                    (ioblock-read-char-without-translation-when-locked-function
    23562365                     ioblock)
    23572366                    ioblock)))
    … …  
    23752384(defun %ioblock-read-char-translating-line-separator-to-newline (ioblock)
    23762385  (let* ((ch (funcall
    2377               (ioblock-read-char-without-translation-while-locked-function
     2386              (ioblock-read-char-without-translation-when-locked-function
    23782387               ioblock)
    23792388              ioblock)))
    … …  
    23922401(declaim (inline %ioblock-write-char-translating-newline-to-cr))
    23932402(defun %ioblock-write-char-translating-newline-to-cr (ioblock char)
    2394   (funcall (ioblock-write-char-without-translation-while-locked-function
     2403  (funcall (ioblock-write-char-without-translation-when-locked-function
    23952404            ioblock)
    23962405           ioblock
    … …  
    24082417(defun %ioblock-write-char-translating-newline-to-crlf (ioblock char)
    24092418  (when (eql char #\Newline)
    2410     (funcall (ioblock-write-char-without-translation-while-locked-function
     2419    (funcall (ioblock-write-char-without-translation-when-locked-function
    24112420              ioblock)
    24122421             ioblock
    24132422             #\Return))   
    2414   (funcall (ioblock-write-char-without-translation-while-locked-function
     2423  (funcall (ioblock-write-char-without-translation-when-locked-function
    24152424            ioblock)
    24162425           ioblock
    … …  
    24272436(declaim (inline %ioblock-write-char-translating-newline-to-line-separator))
    24282437(defun %ioblock-write-char-translating-newline-to-line-separator (ioblock char)
    2429   (funcall (ioblock-write-char-without-translation-while-locked-function
     2438  (funcall (ioblock-write-char-without-translation-when-locked-function
    24302439            ioblock)
    24312440           ioblock
    … …  
    24442453
    24452454(defun setup-ioblock-input (ioblock character-p element-type sharing encoding line-termination)
     2455  (setf (ioblock-sharing ioblock) sharing)
    24462456  (when character-p
    24472457    (if encoding
    24482458      (let* ((unit-size (character-encoding-code-unit-size encoding)))
    2449         (unless (eql unit-size 8)
    2450           (setq line-termination nil))
    24512459        (setf (ioblock-peek-char-function ioblock) '%encoded-ioblock-peek-char)
    24522460        (setf (ioblock-read-line-function ioblock)
    … …  
    24942502        (setf (ioblock-read-line-function ioblock)
    24952503              '%ioblock-unencoded-read-line)))
    2496     (case line-termination
    2497       ((:cr :crlf)
    2498        (let* ((inbuf (ioblock-inbuf ioblock)))
    2499          (setf (io-buffer-translate inbuf) line-termination)))))
     2504    (when line-termination
     2505      (setf (ioblock-read-char-without-translation-when-locked-function ioblock)
     2506            (ioblock-read-char-when-locked-function ioblock))
     2507      (ecase line-termination
     2508        (:cr (setf (ioblock-read-char-when-locked-function ioblock)
     2509                   '%ioblock-read-char-translating-cr-to-newline
     2510                   (ioblock-read-char-function ioblock)
     2511                   (case sharing
     2512                     (:private
     2513                      '%private-ioblock-read-char-translating-cr-to-newline)
     2514                     (:lock
     2515                      '%locked-ioblock-read-char-translating-cr-to-newline)
     2516                     (t '%ioblock-read-char-translating-cr-to-newline))))
     2517        (:crlf (setf (ioblock-read-char-when-locked-function ioblock)
     2518                     '%ioblock-read-char-translating-crlf-to-newline
     2519                   (ioblock-read-char-function ioblock)
     2520                   (case sharing
     2521                     (:private
     2522                      '%private-ioblock-read-char-translating-crlf-to-newline)
     2523                     (:lock
     2524                      '%locked-ioblock-read-char-translating-crlf-to-newline)
     2525                     (t '%ioblock-read-char-translating-crlf-to-newline))))
     2526        (:unicode (setf (ioblock-read-char-when-locked-function ioblock)
     2527                     '%ioblock-read-char-translating-line-separator-to-newline
     2528                   (ioblock-read-char-function ioblock)
     2529                   (case sharing
     2530                     (:private
     2531                      '%private-ioblock-read-char-translating-line-separator-to-newline)
     2532                     (:lock
     2533                      '%locked-ioblock-read-char-translating-line-separator-to-newline)
     2534                     (t '%ioblock-read-char-translating-line-separator-to-newline)))))))
     2535
    25002536  (unless (or (eq element-type 'character)
    25012537              (subtypep element-type 'character))
    … …  
    25782614
    25792615(defun setup-ioblock-output (ioblock character-p element-type sharing encoding line-termination)
     2616  (or (ioblock-sharing ioblock)
     2617      (setf (ioblock-sharing ioblock) sharing))
    25802618  (when character-p
    25812619    (if encoding
    25822620      (let* ((unit-size (character-encoding-code-unit-size encoding)))
    2583         (unless (eq unit-size 8)
    2584           (setq line-termination nil))
    25852621        (setf (ioblock-encode-output-function ioblock)
    25862622              (character-encoding-stream-encode-function encoding))
    … …  
    25892625                (8
    25902626                 (setf (ioblock-write-char-when-locked-function ioblock)
    2591                       '%ioblock-write-u8-encoded-char)
     2627                       '%ioblock-write-u8-encoded-char)
    25922628                 (case sharing
    25932629                   (:private '%private-ioblock-write-u8-encoded-char)
    … …  
    26162652                 (if (character-encoding-native-endianness encoding)
    26172653                   '%ioblock-write-u16-encoded-simple-string
    2618                    '%ioblock-write-swapped-u8-encoded-simple-string))))
     2654                   '%ioblock-write-swapped-u16-encoded-simple-string))))
    26192655        (when (character-encoding-use-byte-order-mark encoding)
    26202656          (setf (ioblock-pending-byte-order-mark ioblock) t)))
    … …  
    26292665                (:lock '%locked-ioblock-write-char)
    26302666                (t '%ioblock-write-char)))))
    2631         (case line-termination
    2632           ((:cr :crlf)
    2633            (let* ((outbuf (ioblock-outbuf ioblock)))
    2634              (setf (io-buffer-translate outbuf) line-termination)))))
     2667    (when line-termination
     2668      (setf (ioblock-write-char-without-translation-when-locked-function ioblock)
     2669            (ioblock-write-char-when-locked-function ioblock))
     2670      (ecase line-termination
     2671        (:cr (setf (ioblock-write-char-when-locked-function ioblock)
     2672                   '%ioblock-write-char-translating-newline-to-cr
     2673                   (ioblock-read-char-function ioblock)
     2674                   (case sharing
     2675                     (:private
     2676                      '%private-ioblock-write-char-translating-newline-to-cr)
     2677                     (:lock
     2678                      '%locked-ioblock-write-char-translating-newline-to-cr)
     2679                     (t '%ioblock-write-char-translating-newline-to-cr))))
     2680        (:crlf (setf (ioblock-write-char-when-locked-function ioblock)
     2681                     '%ioblock-write-char-translating-newline-to-crlf
     2682                     (ioblock-write-char-function ioblock)
     2683                     (case sharing
     2684                       (:private
     2685                        '%private-ioblock-write-char-translating-newline-to-crlf)
     2686                       (:lock
     2687                        '%locked-ioblock-write-char-translating-newline-to-crlf)
     2688                       (t '%ioblock-write-char-translating-newline-to-crlf))))
     2689        (:unicode (setf (ioblock-write-char-when-locked-function ioblock)
     2690                        '%ioblock-write-char-translating-newline-to-line-separator
     2691                        (ioblock-write-char-function ioblock)
     2692                        (case sharing
     2693                          (:private
     2694                           '%private-ioblock-write-char-translating-newline-to-line-separator)
     2695                          (:lock
     2696                           '%locked-ioblock-write-char-translating-newline-to-line-separator)
     2697                          (t '%ioblock-write-char-translating-newline-to-line-separator)))))))
    26352698  (unless (or (eq element-type 'character)
    26362699              (subtypep element-type 'character))
    … …  
    27382801                            &allow-other-keys)
    27392802  (declare (ignorable element-shift))
     2803  (setq line-termination (cdr (assoc line-termination *canonical-line-termination-conventions*)))
    27402804  (when encoding
    27412805    (unless (typep encoding 'character-encoding)
    … …  
    29302994    (:cp/m . :crlf)
    29312995    (:msdos . :crlf)
     2996    (:dos . :crlf)
    29322997    (:windows . :crlf)
    2933     (:inferred . nil)))
     2998    (:inferred . nil)
     2999    (:unicode . :unicode)))
    29343000
    29353001
Note: See TracChangeset for help on using the changeset viewer.