/[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.78 by rtoy, Fri Apr 23 03:26:44 2004 UTC revision 1.79 by rtoy, Fri Apr 23 15:08:15 2004 UTC
# Line 43  Line 43 
43  (defconstant bytes-per-buffer (* 4 1024)  (defconstant bytes-per-buffer (* 4 1024)
44    "Number of bytes per buffer.")    "Number of bytes per buffer.")
45    
46    ;; This limit is rather arbitrary
47    (defconstant max-stream-element-size 1024
48      "The maximum supported byte size for a stream element-type.")
49    
50  ;;; NEXT-AVAILABLE-BUFFER -- Internal.  ;;; NEXT-AVAILABLE-BUFFER -- Internal.
51  ;;;  ;;;
52  ;;; Returns the next available buffer, creating one if necessary.  ;;; Returns the next available buffer, creating one if necessary.
# Line 449  Line 453 
453            (:none            (:none
454             (do-output stream thing start end nil))))))             (do-output stream thing start end nil))))))
455    
456    (defmacro output-wrapper ((stream size buffering) &body body)
457      (let ((stream-var (gensym)))
458        `(let ((,stream-var ,stream))
459          ,(unless (eq (car buffering) :none)
460             `(when (< (fd-stream-obuf-length ,stream-var)
461                       (+ (fd-stream-obuf-tail ,stream-var)
462                           ,size))
463                (flush-output-buffer ,stream-var)))
464          ,(unless (eq (car buffering) :none)
465             `(when (> (fd-stream-ibuf-tail ,stream-var)
466                       (fd-stream-ibuf-head ,stream-var))
467                (file-position ,stream-var (file-position ,stream-var))))
468    
469          ,@body
470          (incf (fd-stream-obuf-tail ,stream-var) ,size)
471          ,(ecase (car buffering)
472             (:none
473              `(flush-output-buffer ,stream-var))
474             (:line
475              `(when (eq (char-code byte) (char-code #\Newline))
476                 (flush-output-buffer ,stream-var)))
477             (:full))
478          (values))))
479    
480  ;;; PICK-OUTPUT-ROUTINE -- internal  ;;; PICK-OUTPUT-ROUTINE -- internal
481  ;;;  ;;;
482  ;;;   Find an output routine to use given the type and buffering. Return as  ;;;   Find an output routine to use given the type and buffering. Return as
# Line 459  Line 487 
487    (dolist (entry *output-routines*)    (dolist (entry *output-routines*)
488      (when (and (subtypep type (car entry))      (when (and (subtypep type (car entry))
489                 (eq buffering (cadr entry)))                 (eq buffering (cadr entry)))
490        (return (values (symbol-function (caddr entry))        (return-from pick-output-routine
491                        (car entry)          (values (symbol-function (caddr entry))
492                        (cadddr entry))))))                  (car entry)
493                    (cadddr entry)))))
494      ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
495      (loop for i from 40 by 8 to max-stream-element-size ; ARB (KLUDGE)
496            if (subtypep type `(unsigned-byte ,i))
497            do (return-from pick-output-routine
498                 (values
499                  (ecase buffering
500                    (:none
501                     (lambda (stream byte)
502                       (output-wrapper (stream (/ i 8) (:none))
503                         (loop for j from 0 below (/ i 8)
504                               do (setf (sap-ref-8
505                                         (fd-stream-obuf-sap stream)
506                                         (+ j (fd-stream-obuf-tail stream)))
507                                        (ldb (byte 8 (- i 8 (* j 8))) byte))))))
508                    (:full
509                     (lambda (stream byte)
510                       (output-wrapper (stream (/ i 8) (:full))
511                         (loop for j from 0 below (/ i 8)
512                               do (setf (sap-ref-8
513                                         (fd-stream-obuf-sap stream)
514                                         (+ j (fd-stream-obuf-tail stream)))
515                                        (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
516                  `(unsigned-byte ,i)
517                  (/ i 8))))
518      (loop for i from 40 by 8 to max-stream-element-size ; ARB (KLUDGE)
519            if (subtypep type `(signed-byte ,i))
520            do (return-from pick-output-routine
521                 (values
522                  (ecase buffering
523                    (:none
524                     (lambda (stream byte)
525                       (output-wrapper (stream (/ i 8) (:none))
526                         (loop for j from 0 below (/ i 8)
527                               do (setf (sap-ref-8
528                                         (fd-stream-obuf-sap stream)
529                                         (+ j (fd-stream-obuf-tail stream)))
530                                        (ldb (byte 8 (- i 8 (* j 8))) byte))))))
531                    (:full
532                     (lambda (stream byte)
533                       (output-wrapper (stream (/ i 8) (:full))
534                         (loop for j from 0 below (/ i 8)
535                               do (setf (sap-ref-8
536                                         (fd-stream-obuf-sap stream)
537                                         (+ j (fd-stream-obuf-tail stream)))
538                                        (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
539                  `(signed-byte ,i)
540                  (/ i 8)))))
541    
542  ;;;; Input routines and related noise.  ;;;; Input routines and related noise.
543    
# Line 655  Line 730 
730  (defun pick-input-routine (type)  (defun pick-input-routine (type)
731    (dolist (entry *input-routines*)    (dolist (entry *input-routines*)
732      (when (subtypep type (car entry))      (when (subtypep type (car entry))
733        (return (values (symbol-function (cadr entry))        (return-from pick-input-routine
734                        (car entry)          (values (symbol-function (cadr entry))
735                        (caddr entry))))))                  (car entry)
736                    (caddr entry)))))
737      ;; FIXME: let's do it the hard way, then (but ignore things like
738      ;; endianness, efficiency, and the necessary coupling between these
739      ;; and the output routines).  -- CSR, 2004-02-09
740      (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
741            if (subtypep type `(unsigned-byte ,i))
742            do (return-from pick-input-routine
743                 (values
744                  (lambda (stream eof-error eof-value)
745                    (input-wrapper (stream (/ i 8) eof-error eof-value)
746                      (let ((sap (fd-stream-ibuf-sap stream))
747                            (head (fd-stream-ibuf-head stream)))
748                        (loop for j from 0 below (/ i 8)
749                              with result = 0
750                              do (setf result
751                                       (+ (* 256 result)
752                                          (sap-ref-8 sap (+ head j))))
753                              finally (return result)))))
754                  `(unsigned-byte ,i)
755                  (/ i 8))))
756      (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
757            if (subtypep type `(signed-byte ,i))
758            do (return-from pick-input-routine
759                 (values
760                  (lambda (stream eof-error eof-value)
761                    (input-wrapper (stream (/ i 8) eof-error eof-value)
762                      (let ((sap (fd-stream-ibuf-sap stream))
763                            (head (fd-stream-ibuf-head stream)))
764                        (loop for j from 0 below (/ i 8)
765                              with result = 0
766                              do (setf result
767                                       (+ (* 256 result)
768                                          (sap-ref-8 sap (+ head j))))
769                              finally (return (dpb result (byte i 0) -1))))))
770                  `(signed-byte ,i)
771                  (/ i 8)))))
772    
773  ;;; STRING-FROM-SAP -- internal  ;;; STRING-FROM-SAP -- internal
774  ;;;  ;;;

Legend:
Removed from v.1.78  
changed lines
  Added in v.1.79

  ViewVC Help
Powered by ViewVC 1.1.5