/[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 by ram, Wed Feb 17 16:30:39 1993 UTC revision 1.24 by ram, Fri Feb 26 08:25:27 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 626  Line 625 
625                             (* length vm:byte-bits))                             (* length vm:byte-bits))
626      string))      string))
627    
 ;;; FD-STREAM-READ-LINE -- internal  
 ;;;  
 ;;;   Reads a line, returning a simple string. Note: this relies on the fact  
 ;;; that the input buffer does not change during do-input.  
 ;;;  
 (defun fd-stream-read-line (stream eof-error-p eof-value)  
   (let ((eof t))  
     (values  
      (or (let ((sap (fd-stream-ibuf-sap stream))  
                (results (when (fd-stream-unread stream)  
                           (prog1  
                               (list (string (fd-stream-unread stream)))  
                             (setf (fd-stream-unread stream) nil)  
                             (setf (fd-stream-listen stream) nil)))))  
            (catch 'eof-input-catcher  
              (loop  
                (input-at-least stream 1)  
                (let* ((head (fd-stream-ibuf-head stream))  
                       (tail (fd-stream-ibuf-tail stream))  
                       (newline (do ((index head (1+ index)))  
                                    ((= index tail) nil)  
                                  (when (= (sap-ref-8 sap index)  
                                           (char-code #\newline))  
                                    (return index))))  
                       (end (or newline tail)))  
                  (push (string-from-sap sap head end)  
                        results)  
   
                  (when newline  
                    (setf eof nil)  
                    (setf (fd-stream-ibuf-head stream)  
                          (1+ newline))  
                    (return))  
                  (setf (fd-stream-ibuf-head stream) end))))  
            (cond ((null results)  
                   nil)  
                  ((null (cdr results))  
                   (car results))  
                  (t  
                   (apply #'concatenate 'simple-string (nreverse results)))))  
          (if eof-error-p  
              (error "EOF while reading ~S" stream)  
              eof-value))  
      eof)))  
   
628  #|  #|
629  This version waits using server.  I changed to the non-server version because  This version waits using server.  I changed to the non-server version because
630  it allows this method to be used by CLX w/o confusing serve-event.  The  it allows this method to be used by CLX w/o confusing serve-event.  The
# Line 736  non-server method is also significantly Line 690  non-server method is also significantly
690  ;;; out.  ;;; out.
691  ;;;  ;;;
692  ;;;    We loop doing the reads until we either get enough bytes or hit EOF.  We  ;;;    We loop doing the reads until we either get enough bytes or hit EOF.  We
693  ;;; must loop because some streams (like pipes) may return a partial amount  ;;; must loop when eof-errorp is T because some streams (like pipes) may return
694  ;;; without hitting EOF.  ;;; a partial amount without hitting EOF.
695  ;;;  ;;;
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 763  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 786  non-server method is also significantly Line 740  non-server method is also significantly
740                  (unless count                  (unless count
741                    (error "Error reading ~S: ~A" stream                    (error "Error reading ~S: ~A" stream
742                           (unix:get-unix-error-msg err)))                           (unix:get-unix-error-msg err)))
743                  (when (zerop count)                  (when (< count now-needed)
744                    (if eof-error-p                    (if eof-error-p
745                        (error "Unexpected eof on ~S." stream)                        (when (zerop count)
746                        (return (- requested (truncate now-needed elsize)))))                          (error "Unexpected eof on ~S." stream))
747                          (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 803  non-server method is also significantly Line 758  non-server method is also significantly
758                  (error "Error reading ~S: ~A" stream                  (error "Error reading ~S: ~A" stream
759                         (unix:get-unix-error-msg err)))                         (unix:get-unix-error-msg err)))
760                (incf (fd-stream-ibuf-tail stream) count)                (incf (fd-stream-ibuf-tail stream) count)
761                (when (zerop count)                (when (< count now-needed)
762                  (if eof-error-p                  (if eof-error-p
763                      (error "Unexpected eof on ~S." stream)                      (when (zerop count)
764                      (return (- requested (truncate now-needed elsize)))))                        (error "Unexpected eof on ~S." stream))
765                        (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 824  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)
787    
788  ;;; SET-ROUTINES -- internal  ;;; SET-ROUTINES -- internal
789  ;;;  ;;;
790  ;;;   Fill in the various routine slots for the given type. Input-p and output-p  ;;;   Fill in the various routine slots for the given type. Input-p and
791  ;;; indicate what slots to fill. The buffering slot must be set prior to  ;;; output-p indicate what slots to fill. The buffering slot must be set prior
792  ;;; 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 868  non-server method is also significantly Line 822  non-server method is also significantly
822          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
823          (if (subtypep type 'character)          (if (subtypep type 'character)
824              (setf (fd-stream-in stream) routine              (setf (fd-stream-in stream) routine
825                    (fd-stream-bin stream) #'ill-bin                    (fd-stream-bin stream) #'ill-bin)
                   (fd-stream-n-bin stream) #'ill-bin)  
826              (setf (fd-stream-in stream) #'ill-in              (setf (fd-stream-in stream) #'ill-in
827                    (fd-stream-bin stream) routine                    (fd-stream-bin stream) routine))
828                    (fd-stream-n-bin stream) #'fd-stream-read-n-bytes))          (when (eql size 1)
829              (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
830              (when buffer-p
831                (setf (stream-in-buffer stream)
832                      (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 927  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      (:read-line      (:listen
      (fd-stream-read-line stream arg1 arg2))  
     (: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 1141  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 1168  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 1177  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 1373  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
# Line 1473  non-server method is also significantly Line 1433  non-server method is also significantly
1433    (funcall *beep-function* stream))    (funcall *beep-function* stream))
1434    
1435    
 ;;;; File position and file length.  
   
 ;;; File-Position  --  Public  
 ;;;  
 ;;;    Call the misc method with the :file-position operation.  
 ;;;  
 (defun file-position (stream &optional position)  
   "With one argument returns the current position within the file  
   File-Stream is open to.  If the second argument is supplied, then  
   this becomes the new file position.  The second argument may also  
   be :start or :end for the start and end of the file, respectively."  
   (unless (streamp stream)  
     (error "Argument ~S is not a stream." stream))  
   (funcall (stream-misc stream) stream :file-position position))  
   
 ;;; File-Length  --  Public  
 ;;;  
 ;;;    Like File-Position, only use :file-length.  
 ;;;  
 (defun file-length (stream)  
   "This function returns the length of the file that File-Stream is open to."  
   (unless (streamp stream)  
     (error "Argument ~S is not a stream." stream))  
   (funcall (stream-misc stream) stream :file-length))  
   
1436  ;;; File-Name  --  internal interface  ;;; File-Name  --  internal interface
1437  ;;;  ;;;
1438  ;;;    Kind of like File-Position, but is an internal hack used by the filesys  ;;;    Kind of like File-Position, but is an internal hack used by the filesys

Legend:
Removed from v.1.23  
changed lines
  Added in v.1.24

  ViewVC Help
Powered by ViewVC 1.1.5