/[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.4.1.2.5 by rtoy, Mon Jul 7 14:46:13 2008 UTC revision 1.85.4.1.2.6 by rtoy, Mon Jul 14 14:01:56 2008 UTC
# Line 403  Line 403 
403    (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))
404          (char-code byte)))          (char-code byte)))
405    
406  #+(and unicode (not extfmts))  #+unicode
407  (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"  (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
408                        1                        1
409                        (:none character)                        (:none character)
# Line 476  Line 476 
476              (len (fd-stream-obuf-length stream))              (len (fd-stream-obuf-length stream))
477              (tail (fd-stream-obuf-tail stream)))              (tail (fd-stream-obuf-tail stream)))
478         (declare (type sys:system-area-pointer sap) (type index len tail))         (declare (type sys:system-area-pointer sap) (type index len tail))
479         ,(stream::char-to-octets extfmt         (stream::char-to-octets ,extfmt
480                                  char                                 char
481                                  (fd-stream-co-state stream)                                 (fd-stream-co-state stream)
482                                  (lambda (byte)                                 (lambda (byte)
483                                    (when (= tail len)                                   (when (= tail len)
484                                      (do-output stream sap 0 tail t)                                     (do-output stream sap 0 tail t)
485                                      (setq sap (fd-stream-obuf-sap stream)                                     (setq sap (fd-stream-obuf-sap stream)
486                                            tail 0))                                           tail 0))
487                                    (setf (bref sap (1- (incf tail))) byte)))                                   (setf (bref sap (1- (incf tail))) byte)))
488         (setf (fd-stream-obuf-tail stream) tail))))         (setf (fd-stream-obuf-tail stream) tail))))
489    
 #+(and unicode extfmts)  
 (defun output-char-none-buffered (stream char)  
   (funcall (ef-cout (stream::find-external-format  
                      (fd-stream-external-format stream)))  
            stream char)  
   (if (char= char #\Newline)  
       (setf (fd-stream-char-pos stream) 0)  
       (incf (fd-stream-char-pos stream)))  
   (flush-output-buffer stream)  
   (values))  
 #+(and unicode extfmts)  
 (setf *output-routines*  
     (nconc *output-routines*  
            ;; check that using 1 here doesn't cause problems if the size  
            ;; of a character is NOT actually 1 octet...  
            (list (list 'character :none 'output-char-none-buffered 1))))  
   
 #+(and unicode extfmts)  
 (defun output-char-line-buffered (stream char)  
   (funcall (ef-cout (stream::find-external-format  
                      (fd-stream-external-format stream)))  
            stream char)  
   (if (char= char #\Newline)  
       (progn (setf (fd-stream-char-pos stream) 0)  
              (flush-output-buffer stream))  
       (incf (fd-stream-char-pos stream)))  
   (values))  
 #+(and unicode extfmts)  
 (setf *output-routines*  
     (nconc *output-routines*  
            ;; check that using 1 here doesn't cause problems if the size  
            ;; of a character is NOT actually 1 octet...  
            (list (list 'character :line 'output-char-line-buffered 1))))  
   
 #+(and unicode extfmts)  
 (defun output-char-full-buffered (stream char)  
   (funcall (ef-cout (stream::find-external-format  
                      (fd-stream-external-format stream)))  
            stream char)  
   (if (char= char #\Newline)  
       (setf (fd-stream-char-pos stream) 0)  
       (incf (fd-stream-char-pos stream)))  
   (values))  
 #+(and unicode extfmts)  
 (setf *output-routines*  
     (nconc *output-routines*  
            ;; check that using 1 here doesn't cause problems if the size  
            ;; of a character is NOT actually 1 octet...  
            (list (list 'character :full 'output-char-full-buffered 1))))  
   
490    
491  ;;; OUTPUT-RAW-BYTES -- public  ;;; OUTPUT-RAW-BYTES -- public
492  ;;;  ;;;
# Line 632  Line 582 
582              (tail (fd-stream-obuf-tail stream)))              (tail (fd-stream-obuf-tail stream)))
583         (declare (type sys:system-area-pointer sap) (type index len tail))         (declare (type sys:system-area-pointer sap) (type index len tail))
584         (dotimes (i (- end start))         (dotimes (i (- end start))
585           ,(stream::char-to-octets extfmt           (stream::char-to-octets ,extfmt
586                                    (schar string (+ i start))                                   (schar string (+ i start))
587                                    (fd-stream-co-state stream)                                   (fd-stream-co-state stream)
588                                    (lambda (byte)                                   (lambda (byte)
589                                      (when (= tail len)                                     (when (= tail len)
590                                        (do-output stream sap 0 tail t)                                       (do-output stream sap 0 tail t)
591                                        (setq sap (fd-stream-obuf-sap stream)                                       (setq sap (fd-stream-obuf-sap stream)
592                                              tail 0))                                             tail 0))
593                                      (setf (bref sap (1- (incf tail))) byte))))                                     (setf (bref sap (1- (incf tail))) byte))))
594         (setf (fd-stream-obuf-tail stream) tail))))         (setf (fd-stream-obuf-tail stream) tail))))
595    
 #+(and unicode extfmts)  
 ;; an fd-sout that works with external-formats; needs slots in fd-stream  
 (defun fd-sout (stream thing start end)  
   (let ((start (or start 0))  
         (end (or end (length (the vector thing)))))  
     (declare (type index start end))  
     (if (stringp thing)  
         (let ((last-newline (and (find #\newline (the simple-string thing)  
                                        :start start :end end)  
                                  (position #\newline (the simple-string thing)  
                                            :from-end t  
                                            :start start  
                                            :end end))))  
           (funcall (ef-sout (stream::find-external-format  
                              (fd-stream-external-format stream)))  
                    stream thing start end)  
           (ecase (fd-stream-buffering stream)  
             (:full #| do nothing |#)  
             (:line  
              (when last-newline  
                (flush-output-buffer stream)))  
             (:none  
              (flush-output-buffer stream)))  
           (if last-newline  
               (setf (fd-stream-char-pos stream)  
                     (- end last-newline 1))  
               (incf (fd-stream-char-pos stream)  
                     (- end start))))  
         (ecase (fd-stream-buffering stream)  
           ((:line :full)  
            (output-raw-bytes stream thing start end))  
           (:none  
            (do-output stream thing start end nil))))))  
596    
597  #-unicode  #-unicode
598  (defun fd-sout (stream thing start end)  (defun fd-sout (stream thing start end)
# Line 709  Line 626 
626            (:none            (:none
627             (do-output stream thing start end nil))))))             (do-output stream thing start end nil))))))
628    
629  #+(and unicode (not extfmts))  #+unicode
630  (defun fd-sout (stream thing start end)  (defun fd-sout (stream thing start end)
631    (declare (type string thing))    (declare (type string thing))
632    (let ((start (or start 0))    (let ((start (or start 0))
# Line 722  Line 639 
639               ((>= index end))               ((>= index end))
640             (funcall out stream (elt thing index))))))))             (funcall out stream (elt thing index))))))))
641    
 #+(or) ; a lame sout hack to make external-format work quickly  
 (defun fd-sout-each-character (stream thing start end)  
   (declare (type string thing))  
   (let ((start (or start 0))  
         (end (or end (length (the vector thing)))))  
     (declare (type index start end))  
     (let ((out (fd-stream-out stream)))  
       (do ((index start (+ index 1)))  
           ((>= index end))  
         (funcall out stream (aref thing index))))))  
   
642  (defmacro output-wrapper ((stream size buffering) &body body)  (defmacro output-wrapper ((stream size buffering) &body body)
643    (let ((stream-var (gensym)))    (let ((stream-var (gensym)))
644      `(let ((,stream-var ,stream))      `(let ((,stream-var ,stream))
# Line 962  Line 868 
868  ;;;  ;;;
869  ;;;   Routine to use in stream-in slot for reading string chars.  ;;;   Routine to use in stream-in slot for reading string chars.
870  ;;;  ;;;
 #-(and unicode extfmts)  
871  (def-input-routine input-character  (def-input-routine input-character
872                     (character 1 sap head)                     (character 1 sap head)
873    (code-char (sap-ref-8 sap head)))    (code-char (sap-ref-8 sap head)))
# Line 1021  Line 926 
926                (optimize (speed 3) (space 0) (debug 0) (safety 0)))                (optimize (speed 3) (space 0) (debug 0) (safety 0)))
927      (catch 'eof-input-catcher      (catch 'eof-input-catcher
928        (let* ((head (fd-stream-ibuf-head stream))        (let* ((head (fd-stream-ibuf-head stream))
929               (ch ,(stream::octets-to-char extfmt               (ch (stream::octets-to-char ,extfmt
930                                            (fd-stream-oc-state stream)                                           (fd-stream-oc-state stream)
931                                            (fd-stream-last-char-read-size stream)                                           (fd-stream-last-char-read-size stream)
932                                            ;;@@ Note: need proper EOF handling...                                           ;;@@ Note: need proper EOF handling...
933                                            (progn                                           (progn
934                                              (when (= head                                             (when (= head
935                                                       (fd-stream-ibuf-tail                                                      (fd-stream-ibuf-tail
936                                                        stream))                                                       stream))
937                                                (do-input stream)                                               (do-input stream)
938                                                (setf head                                               (setf head
939                                                    (fd-stream-ibuf-head stream)))                                                   (fd-stream-ibuf-head stream)))
940                                              (bref (fd-stream-ibuf-sap stream)                                             (bref (fd-stream-ibuf-sap stream)
941                                                    (1- (incf head))))                                                   (1- (incf head))))
942                                            (lambda (n) (decf head n)))))                                           (lambda (n) (decf head n)))))
943          (declare (type index head))          (declare (type index head))
944          (when ch          (when ch
945            (incf (fd-stream-ibuf-head stream)            (incf (fd-stream-ibuf-head stream)
946                  (fd-stream-last-char-read-size stream))                  (fd-stream-last-char-read-size stream))
947            ch)))))            ch)))))
948    
 #+(and unicode extfmts)  
 (defun input-character (stream eof-error eof-value)  
   ;; This needs to go away.  Unreading a character needs to be done by backing  
   ;; up the buffer head pointer, so that the external format will re-build the  
   ;; character - else changing extfmts won't work.  But until we get around  
   ;; to teaching UNREAD-CHAR to DTRT, keep this to maintain compatibility...  
   (if (fd-stream-unread stream)  
       (prog1 (fd-stream-unread stream)  
         (setf (fd-stream-unread stream) nil)  
         (setf (fd-stream-listen stream) nil))  
       (let ((char (funcall (ef-cin (stream::find-external-format  
                                     (fd-stream-external-format stream)))  
                            stream)))  
         (if char  
             char  
             (eof-or-lose stream eof-error eof-value)))))  
 #+(and unicode extfmts)  
 (setf *input-routines*  
     (nconc *input-routines*  
            ;; check that using 1 here doesn't cause problems if the size  
            ;; of a character is NOT actually 1 octet...  
            (list (list 'character 'input-character 1))))  
   
949  #+(or)  #+(or)
950  (stream::def-ef-macro ef-sin (extfmt lisp stream::+ef-max+ stream::+ef-sin+)  (stream::def-ef-macro ef-sin (extfmt lisp stream::+ef-max+ stream::+ef-sin+)
951    `(lambda (stream string char start end)    `(lambda (stream string char start end)
# Line 1082  Line 964 
964           ;;@@ Fix EOF handling           ;;@@ Fix EOF handling
965           (let* ((sz 0)           (let* ((sz 0)
966                  (ch (catch 'eof-input-catcher                  (ch (catch 'eof-input-catcher
967                        ,(stream::octets-to-char extfmt                        (stream::octets-to-char ,extfmt
968                                                 (fd-stream-oc-state stream)                                                (fd-stream-oc-state stream)
969                                                 sz                                                sz
970                                                 (progn                                                (progn
971                                                   (when (= head tail)                                                  (when (= head tail)
972                                                     (do-input stream)                                                    (do-input stream)
973                                                     (setq head                                                    (setq head
974                                                         (fd-stream-ibuf-head                                                          (fd-stream-ibuf-head
975                                                          stream)                                                           stream)
976                                                         tail                                                          tail
977                                                         (fd-stream-ibuf-tail                                                          (fd-stream-ibuf-tail
978                                                          stream)))                                                           stream)))
979                                                   (bref sap (1- (incf head))))                                                  (bref sap (1- (incf head))))
980                                                 (lambda (n) (decf head n))))))                                                (lambda (n) (decf head n))))))
981             (declare (type index sz)             (declare (type index sz)
982                      (type (or null character) ch))                      (type (or null character) ch))
983             (when (null ch)             (when (null ch)

Legend:
Removed from v.1.85.4.1.2.5  
changed lines
  Added in v.1.85.4.1.2.6

  ViewVC Help
Powered by ViewVC 1.1.5