/[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.85 by rtoy, Mon Nov 5 15:25:03 2007 UTC revision 1.85.4.1 by rtoy, Wed May 14 16:12:04 2008 UTC
# Line 379  Line 379 
379                                        (cdr buffering)))))))                                        (cdr buffering)))))))
380            bufferings)))            bufferings)))
381    
382    #-unicode
383  (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"  (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
384                        1                        1
385                        (:none character)                        (:none character)
# Line 390  Line 391 
391    (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))    (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
392          (char-code byte)))          (char-code byte)))
393    
394    #+unicode
395    (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
396                          1
397                          (:none character)
398                          (:line character)
399                          (:full character))
400      (if (char= byte #\Newline)
401          (setf (fd-stream-char-pos stream) 0)
402          (incf (fd-stream-char-pos stream)))
403      ;; FIXME!  We only use the low 8 bits of a character!
404      (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
405            (logand #xff (char-code byte))))
406    
407  (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"  (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
408                        1                        1
409                        (:none (unsigned-byte 8))                        (:none (unsigned-byte 8))
# Line 511  Line 525 
525  ;;; than strings. Therefore, we must make sure we have a string before calling  ;;; than strings. Therefore, we must make sure we have a string before calling
526  ;;; position on it.  ;;; position on it.
527  ;;;  ;;;
528    #-unicode
529  (defun fd-sout (stream thing start end)  (defun fd-sout (stream thing start end)
530    (let ((start (or start 0))    (let ((start (or start 0))
531          (end (or end (length (the vector thing)))))          (end (or end (length (the vector thing)))))
# Line 542  Line 557 
557            (:none            (:none
558             (do-output stream thing start end nil))))))             (do-output stream thing start end nil))))))
559    
560    #+unicode
561    (defun fd-sout (stream thing start end)
562      (declare (type string thing))
563      (let ((start (or start 0))
564            (end (or end (length (the vector thing)))))
565        (declare (type index start end))
566        (cond
567          ((stringp thing)                  ; FIXME - remove this test
568           (let ((out (fd-stream-out stream)))
569             (do ((index start (+ index 1)))
570                 ((>= index end))
571               (funcall out stream (elt thing index))))))))
572    
573    #+unicode ; a lame sout hack to make external-format work quickly
574    (defun fd-sout-each-character (stream thing start end)
575      (declare (type string thing))
576      (let ((start (or start 0))
577            (end (or end (length (the vector thing)))))
578        (declare (type index start end))
579        (let ((out (fd-stream-out stream)))
580          (do ((index start (+ index 1)))
581              ((>= index end))
582            (funcall out stream (aref thing index))))))
583    
584  (defmacro output-wrapper ((stream size buffering) &body body)  (defmacro output-wrapper ((stream size buffering) &body body)
585    (let ((stream-var (gensym)))    (let ((stream-var (gensym)))
586      `(let ((,stream-var ,stream))      `(let ((,stream-var ,stream))
# Line 1144  Line 1183 
1183                      #'ill-out)                      #'ill-out)
1184                  (fd-stream-bout stream) routine))                  (fd-stream-bout stream) routine))
1185          (setf (fd-stream-sout stream)          (setf (fd-stream-sout stream)
1186                (if (eql size 1) #'fd-sout #'ill-out))                #-unicode
1187                  (if (eql size 1) #'fd-sout #'ill-out)
1188                  #+unicode
1189                  (if (eql size 1)
1190                      #'fd-sout-each-character
1191                      #'ill-out))
1192          (setf (fd-stream-char-pos stream) 0)          (setf (fd-stream-char-pos stream) 0)
1193          (setf output-size size)          (setf output-size size)
1194          (setf output-type type)))          (setf output-type type)))

Legend:
Removed from v.1.85  
changed lines
  Added in v.1.85.4.1

  ViewVC Help
Powered by ViewVC 1.1.5