/[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.23.1.2 by ram, Tue Feb 23 16:12:10 1993 UTC revision 1.23.1.3 by ram, Tue Feb 23 23:25:12 1993 UTC
# Line 504  Line 504 
504    
505  ;;; INPUT-WRAPPER -- intenal  ;;; INPUT-WRAPPER -- intenal
506  ;;;  ;;;
507  ;;;   Macro to wrap around all input routines to handle eof-error noise. This  ;;;   Macro to wrap around all input routines to handle eof-error noise.
 ;;; should make provisions for filling stream-in-buffer.  
508  ;;;  ;;;
509  (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)  (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
510    (let ((stream-var (gensym))    (let ((stream-var (gensym))
# Line 697  non-server method is also significantly Line 696  non-server method is also significantly
696  (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)  (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
697    (declare (type stream stream) (type index start requested))    (declare (type stream stream) (type index start requested))
698    (let* ((sap (fd-stream-ibuf-sap stream))    (let* ((sap (fd-stream-ibuf-sap stream))
699           (elsize (fd-stream-element-size stream))           (offset start)
          (offset (* elsize start))  
          (requested-bytes (* elsize requested))  
700           (head (fd-stream-ibuf-head stream))           (head (fd-stream-ibuf-head stream))
701           (tail (fd-stream-ibuf-tail stream))           (tail (fd-stream-ibuf-tail stream))
702           (available (- tail head))           (available (- tail head))
703           (copy (min requested-bytes available)))           (copy (min requested available)))
704      (declare (type index elsize offset requested-bytes head tail available      (declare (type index offset head tail available copy))
                    copy))  
705      (unless (zerop copy)      (unless (zerop copy)
706        (if (typep buffer 'system-area-pointer)        (if (typep buffer 'system-area-pointer)
707            (system-area-copy sap (* head vm:byte-bits)            (system-area-copy sap (* head vm:byte-bits)
# Line 718  non-server method is also significantly Line 714  non-server method is also significantly
714                                   (* copy vm:byte-bits)))                                   (* copy vm:byte-bits)))
715        (incf (fd-stream-ibuf-head stream) copy))        (incf (fd-stream-ibuf-head stream) copy))
716      (cond      (cond
717       ((> requested-bytes available)       ((or (= copy requested)
718              (and (not eof-error-p) (/= copy 0)))
719          copy)
720         (t
721        (setf (fd-stream-ibuf-head stream) 0)        (setf (fd-stream-ibuf-head stream) 0)
722        (setf (fd-stream-ibuf-tail stream) 0)        (setf (fd-stream-ibuf-tail stream) 0)
723        (setf (fd-stream-listen stream) nil)        (setf (fd-stream-listen stream) nil)
724        (let ((now-needed (- requested-bytes copy))        (let ((now-needed (- requested copy))
725              (len (fd-stream-ibuf-length stream)))              (len (fd-stream-ibuf-length stream)))
726          (declare (type index now-needed len))          (declare (type index now-needed len))
727          (cond          (cond
# Line 745  non-server method is also significantly Line 744  non-server method is also significantly
744                    (if eof-error-p                    (if eof-error-p
745                        (when (zerop count)                        (when (zerop count)
746                          (error "Unexpected eof on ~S." stream))                          (error "Unexpected eof on ~S." stream))
747                        (return (- requested (truncate now-needed elsize)))))                        (return (- requested now-needed))))
748                  (decf now-needed count)                  (decf now-needed count)
749                  (when (zerop now-needed) (return requested))                  (when (zerop now-needed) (return requested))
750                  (incf offset count)))))                  (incf offset count)))))
# Line 763  non-server method is also significantly Line 762  non-server method is also significantly
762                  (if eof-error-p                  (if eof-error-p
763                      (when (zerop count)                      (when (zerop count)
764                        (error "Unexpected eof on ~S." stream))                        (error "Unexpected eof on ~S." stream))
765                      (return (- requested (truncate now-needed elsize)))))                      (return (- requested now-needed))))
766                (let* ((copy (min now-needed count))                (let* ((copy (min now-needed count))
767                       (copy-bits (* copy vm:byte-bits))                       (copy-bits (* copy vm:byte-bits))
768                       (buffer-start-bits                       (buffer-start-bits
# Line 781  non-server method is also significantly Line 780  non-server method is also significantly
780                  (incf (fd-stream-ibuf-head stream) copy)                  (incf (fd-stream-ibuf-head stream) copy)
781                  (decf now-needed copy)                  (decf now-needed copy)
782                  (when (zerop now-needed) (return requested))                  (when (zerop now-needed) (return requested))
783                  (incf offset copy))))))))                  (incf offset copy)))))))))))
      (t  
       requested))))  
784    
785    
786  ;;;; Utility functions (misc routines, etc)  ;;;; Utility functions (misc routines, etc)
# Line 794  non-server method is also significantly Line 791  non-server method is also significantly
791  ;;; output-p indicate what slots to fill. The buffering slot must be set prior  ;;; output-p indicate what slots to fill. The buffering slot must be set prior
792  ;;; to calling this routine.  ;;; to calling this routine.
793  ;;;  ;;;
794  (defun set-routines (stream type input-p output-p)  (defun set-routines (stream type input-p output-p buffer-p)
795    (let ((target-type (case type    (let ((target-type (case type
796                         ((:default unsigned-byte)                         ((:default unsigned-byte)
797                          '(unsigned-byte 8))                          '(unsigned-byte 8))
# Line 830  non-server method is also significantly Line 827  non-server method is also significantly
827                    (fd-stream-bin stream) routine))                    (fd-stream-bin stream) routine))
828          (when (eql size 1)          (when (eql size 1)
829            (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)            (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
830            (setf (stream-in-buffer stream)            (when buffer-p
831                  (make-array in-buffer-length              (setf (stream-in-buffer stream)
832                              :element-type '(unsigned-byte 8))))                    (make-array in-buffer-length
833                                  :element-type '(unsigned-byte 8)))))
834          (setf input-size size)          (setf input-size size)
835          (setf input-type type)))          (setf input-type type)))
836    
# Line 887  non-server method is also significantly Line 885  non-server method is also significantly
885  ;;;   Handle the various misc operations on fd-stream.  ;;;   Handle the various misc operations on fd-stream.
886  ;;;  ;;;
887  (defun fd-stream-misc-routine (stream operation &optional arg1 arg2)  (defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
888      (declare (ignore arg2))
889    (case operation    (case operation
890      (:listen      (:listen
891       (or (not (eql (fd-stream-ibuf-head stream)       (or (not (eql (fd-stream-ibuf-head stream)
892                     (fd-stream-ibuf-tail stream)))                     (fd-stream-ibuf-tail stream)))
893           (fd-stream-listen stream)           (fd-stream-listen stream)
# Line 1099  non-server method is also significantly Line 1098  non-server method is also significantly
1098                         file                         file
1099                         original                         original
1100                         delete-original                         delete-original
1101                           input-buffer-p
1102                         (name (if file                         (name (if file
1103                                   (format nil "file ~S" file)                                   (format nil "file ~S" file)
1104                                   (format nil "descriptor ~D" fd)))                                   (format nil "descriptor ~D" fd)))
# Line 1126  non-server method is also significantly Line 1126  non-server method is also significantly
1126                                   :delete-original delete-original                                   :delete-original delete-original
1127                                   :buffering buffering                                   :buffering buffering
1128                                   :timeout timeout)))                                   :timeout timeout)))
1129      (set-routines stream element-type input output)      (set-routines stream element-type input output input-buffer-p)
1130      (when (and auto-close (fboundp 'finalize))      (when (and auto-close (fboundp 'finalize))
1131        (finalize stream        (finalize stream
1132                  #'(lambda ()                  #'(lambda ()
# Line 1135  non-server method is also significantly Line 1135  non-server method is also significantly
1135                              fd))))                              fd))))
1136      stream))      stream))
1137    
1138    
1139  ;;; PICK-PACKUP-NAME -- internal  ;;; PICK-PACKUP-NAME -- internal
1140  ;;;  ;;;
1141  ;;; Pick a name to use for the backup file.  ;;; Pick a name to use for the backup file.
# Line 1331  non-server method is also significantly Line 1332  non-server method is also significantly
1332                                         :file namestring                                         :file namestring
1333                                         :original original                                         :original original
1334                                         :delete-original delete-original                                         :delete-original delete-original
1335                                           :input-buffer-p t
1336                                         :auto-close t))                                         :auto-close t))
1337                        (:probe                        (:probe
1338                         (let ((stream                         (let ((stream

Legend:
Removed from v.1.23.1.2  
changed lines
  Added in v.1.23.1.3

  ViewVC Help
Powered by ViewVC 1.1.5