/[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.40 by dtc, Tue Mar 25 17:07:31 1997 UTC revision 1.40.2.5 by pw, Thu Aug 24 15:00:19 2000 UTC
# Line 61  Line 61 
61  (defstruct (fd-stream  (defstruct (fd-stream
62              (:print-function %print-fd-stream)              (:print-function %print-fd-stream)
63              (:constructor %make-fd-stream)              (:constructor %make-fd-stream)
64              (:include stream              (:include lisp-stream
65                        (misc #'fd-stream-misc-routine)))                        (misc #'fd-stream-misc-routine)))
66    
67    (name nil)                  ; The name of this stream    (name nil)                  ; The name of this stream
# Line 207  Line 207 
207          )          )
208        (let ((length (- end start)))        (let ((length (- end start)))
209          (multiple-value-bind          (multiple-value-bind
210              (count errno)                (count errno)
211              (unix:unix-write (fd-stream-fd stream) base start length)              (unix:unix-write (fd-stream-fd stream) base start length)
212            (cond ((not count)            (cond ((not count)
213                   (if (= errno unix:ewouldblock)                   (if (= errno unix:ewouldblock)
# Line 399  Line 399 
399  (defun fd-sout (stream thing start end)  (defun fd-sout (stream thing start end)
400    (let ((start (or start 0))    (let ((start (or start 0))
401          (end (or end (length (the vector thing)))))          (end (or end (length (the vector thing)))))
402      (declare (fixnum start end))      (declare (type index start end))
403      (if (stringp thing)      (if (stringp thing)
404          (let ((last-newline (and (find #\newline (the simple-string thing)          (let ((last-newline (and (find #\newline (the simple-string thing)
405                                         :start start :end end)                                         :start start :end end)
# Line 476  Line 476 
476               (setf (fd-stream-ibuf-tail stream) tail))))               (setf (fd-stream-ibuf-tail stream) tail))))
477      (setf (fd-stream-listen stream) nil)      (setf (fd-stream-listen stream) nil)
478      (multiple-value-bind      (multiple-value-bind
479          (count errno)            (count errno)
480          (unix:unix-select (1+ fd) (the (unsigned-byte 32) (ash 1 fd)) 0 0 0)          (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
481        (case count            (unix:fd-zero read-fds)
482          (1)            (unix:fd-set fd read-fds)
483          (0            (unix:unix-fast-select (1+ fd) (alien:addr read-fds) nil nil 0 0))
484           (unless (system:wait-until-fd-usable        ;; Wait if input is not available or if interrupted.
485                    fd :input (fd-stream-timeout stream))        (when (or (eql count 0)
486             (error 'io-timeout :stream stream :direction :read)))                  (and (not count) (eql errno unix:eintr)))
487          (t          (unless #-mp (system:wait-until-fd-usable
488           (error "Problem checking to see if ~S is readable: ~A"                        fd :input (fd-stream-timeout stream))
489                  stream                  #+mp (mp:process-wait-until-fd-usable
490                  (unix:get-unix-error-msg errno)))))                        fd :input (fd-stream-timeout stream))
491              (error 'io-timeout :stream stream :direction :read))))
492      (multiple-value-bind      (multiple-value-bind
493          (count errno)            (count errno)
494          (unix:unix-read fd          (unix:unix-read fd
495                          (system:int-sap (+ (system:sap-int ibuf-sap) tail))                          (system:int-sap (+ (system:sap-int ibuf-sap) tail))
496                          (- buflen tail))                          (- buflen tail))
497        (cond ((null count)        (cond ((null count)
498               (if (eql errno unix:ewouldblock)               (if (eql errno unix:ewouldblock)
499                   (progn                   (progn
500                     (unless (system:wait-until-fd-usable                     (unless #-mp (system:wait-until-fd-usable
501                              fd :input (fd-stream-timeout stream))                                   fd :input (fd-stream-timeout stream))
502                               #+mp (mp:process-wait-until-fd-usable
503                                     fd :input (fd-stream-timeout stream))
504                       (error 'io-timeout :stream stream :direction :read))                       (error 'io-timeout :stream stream :direction :read))
505                     (do-input stream))                     (do-input stream))
506                   (error "Error reading ~S: ~A"                   (error "Error reading ~S: ~A"
# Line 648  Line 651 
651      string))      string))
652    
653  #|  #|
 This version waits using server.  I changed to the non-server version because  
 it allows this method to be used by CLX w/o confusing serve-event.  The  
 non-server method is also significantly more efficient for large reads.  
   -- Ram  
   
654  ;;; FD-STREAM-READ-N-BYTES -- internal  ;;; FD-STREAM-READ-N-BYTES -- internal
655  ;;;  ;;;
656    ;;; This version waits using server.  I changed to the non-server version
657    ;;; because it allows this method to be used by CLX w/o confusing serve-event.
658    ;;; The non-server method is also significantly more efficient for large
659    ;;; reads. -- Ram
660    ;;;
661  ;;; The n-bin routine.  ;;; The n-bin routine.
662  ;;;  ;;;
663  (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)
664      (declare (type stream stream) (type index start requested))
665    (let* ((sap (fd-stream-ibuf-sap stream))    (let* ((sap (fd-stream-ibuf-sap stream))
666           (elsize (fd-stream-element-size stream))           (elsize (fd-stream-element-size stream))
667           (offset (* elsize start))           (offset (* elsize start))
# Line 692  non-server method is also significantly Line 696  non-server method is also significantly
696    
697  ;;; FD-STREAM-READ-N-BYTES -- internal  ;;; FD-STREAM-READ-N-BYTES -- internal
698  ;;;  ;;;
699  ;;;    The N-Bin method for FD-STREAMs.  This doesn't using SERVER; it blocks  ;;;    The N-Bin method for FD-STREAMs.  This doesn't use the SERVER; it blocks
700  ;;; in UNIX-READ.  This allows the method to be used to implementing reading  ;;; in UNIX-READ.  This allows the method to be used to implementing reading
701  ;;; for CLX.  It is generally used where there is a definite amount of reading  ;;; for CLX.  It is generally used where there is a definite amount of reading
702  ;;; to be done, so blocking isn't too problematical.  ;;; to be done, so blocking isn't too problematical.
# Line 760  non-server method is also significantly Line 764  non-server method is also significantly
764                  (unless count                  (unless count
765                    (error "Error reading ~S: ~A" stream                    (error "Error reading ~S: ~A" stream
766                           (unix:get-unix-error-msg err)))                           (unix:get-unix-error-msg err)))
767                    (decf now-needed count)
768                  (if eof-error-p                  (if eof-error-p
769                      (when (zerop count)                      (when (zerop count)
770                        (error 'end-of-file :stream stream))                        (error 'end-of-file :stream stream))
771                      (return (- requested now-needed)))                      (return (- requested now-needed)))
                 (decf now-needed count)  
772                  (when (zerop now-needed) (return requested))                  (when (zerop now-needed) (return requested))
773                  (incf offset count)))))                  (incf offset count)))))
774           (t           (t
# Line 851  non-server method is also significantly Line 855  non-server method is also significantly
855          (when (eql size 1)          (when (eql size 1)
856            (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)            (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
857            (when buffer-p            (when buffer-p
858              (setf (stream-in-buffer stream)              (setf (lisp-stream-in-buffer stream)
859                    (make-array in-buffer-length                    (make-array in-buffer-length
860                                :element-type '(unsigned-byte 8)))))                                :element-type '(unsigned-byte 8)))))
861          (setf input-size size)          (setf input-size size)
# Line 919  non-server method is also significantly Line 923  non-server method is also significantly
923                     (fd-stream-ibuf-tail stream)))                     (fd-stream-ibuf-tail stream)))
924           (fd-stream-listen stream)           (fd-stream-listen stream)
925           (setf (fd-stream-listen stream)           (setf (fd-stream-listen stream)
926                 (eql (unix:unix-select (1+ (fd-stream-fd stream))                 (eql (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
927                                        (the (unsigned-byte 32)                        (unix:fd-zero read-fds)
928                                             (ash 1 (fd-stream-fd stream)))                        (unix:fd-set (fd-stream-fd stream) read-fds)
929                                        0                        (unix:unix-fast-select (1+ (fd-stream-fd stream))
930                                        0                                               (alien:addr read-fds) nil nil
931                                        0)                                               0 0))
932                      1))))                      1))))
933      (:unread      (:unread
934       (setf (fd-stream-unread stream) arg1)       (setf (fd-stream-unread stream) arg1)
# Line 989  non-server method is also significantly Line 993  non-server method is also significantly
993       (setf (fd-stream-ibuf-tail stream) 0)       (setf (fd-stream-ibuf-tail stream) 0)
994       (catch 'eof-input-catcher       (catch 'eof-input-catcher
995         (loop         (loop
996          (let ((count (unix:unix-select (1+ (fd-stream-fd stream))          (multiple-value-bind
997                                         (the (unsigned-byte 32)                (count errno)
998                                              (ash 1 (fd-stream-fd stream)))              (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
999                                         0 0 0)))                (unix:fd-zero read-fds)
1000                  (unix:fd-set (fd-stream-fd stream) read-fds)
1001                  (unix:unix-fast-select (1+ (fd-stream-fd stream))
1002                                         (alien:addr read-fds) nil nil 0 0))
1003            (cond ((eql count 1)            (cond ((eql count 1)
1004                   (do-input stream)                   (do-input stream)
1005                   (setf (fd-stream-ibuf-head stream) 0)                   (setf (fd-stream-ibuf-head stream) 0)
1006                   (setf (fd-stream-ibuf-tail stream) 0))                   (setf (fd-stream-ibuf-tail stream) 0))
1007                    ((and (not count) (eql errno unix:eintr)))
1008                  (t                  (t
1009                   (return t)))))))                   (return t)))))))
1010      (:force-output      (:force-output
# Line 1025  non-server method is also significantly Line 1033  non-server method is also significantly
1033           (error "Error fstating ~S: ~A"           (error "Error fstating ~S: ~A"
1034                  stream                  stream
1035                  (unix:get-unix-error-msg dev)))                  (unix:get-unix-error-msg dev)))
1036         (if (zerop (the index mode))         (if (zerop mode)
1037             nil             nil
1038             (truncate (the index size) (fd-stream-element-size stream)))))             (truncate size (fd-stream-element-size stream)))))
1039      (:file-position      (:file-position
1040       (fd-stream-file-position stream arg1))))       (fd-stream-file-position stream arg1))))
1041    
# Line 1036  non-server method is also significantly Line 1044  non-server method is also significantly
1044  ;;;  ;;;
1045  (defun fd-stream-file-position (stream &optional newpos)  (defun fd-stream-file-position (stream &optional newpos)
1046    (declare (type fd-stream stream)    (declare (type fd-stream stream)
1047             (type (or index (member nil :start :end)) newpos))             (type (or (integer 0) (member nil :start :end)) newpos))
1048    (if (null newpos)    (if (null newpos)
1049        (system:without-interrupts        (system:without-interrupts
1050          ;; First, find the position of the UNIX file descriptor in the          ;; First, find the position of the UNIX file descriptor in the file.
         ;; file.  
1051          (multiple-value-bind          (multiple-value-bind
1052              (posn errno)                (posn errno)
1053              (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)              (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
1054            (declare (type (or index null) posn))            (declare (type (or (integer 0) null) posn))
1055            (cond ((fixnump posn)            (cond (posn
1056                   ;; Adjust for buffered output:                   ;; Adjust for buffered output:
1057                   ;;  If there is any output buffered, the *real* file position                   ;;  If there is any output buffered, the *real* file position
1058                   ;; will be larger than reported by lseek because lseek                   ;; will be larger than reported by lseek because lseek
# Line 1073  non-server method is also significantly Line 1080  non-server method is also significantly
1080                     (error "Error lseek'ing ~S: ~A"                     (error "Error lseek'ing ~S: ~A"
1081                            stream                            stream
1082                            (unix:get-unix-error-msg errno)))))))                            (unix:get-unix-error-msg errno)))))))
1083        (let ((offset 0) origin)        (let ((offset 0)
1084          (declare (type index offset))              origin)
1085            (declare (type (integer 0) offset))
1086          ;; Make sure we don't have any output pending, because if we move the          ;; Make sure we don't have any output pending, because if we move the
1087          ;; file pointer before writing this stuff, it will be written in the          ;; file pointer before writing this stuff, it will be written in the
1088          ;; wrong location.          ;; wrong location.
# Line 1087  non-server method is also significantly Line 1095  non-server method is also significantly
1095          (setf (fd-stream-unread stream) nil)          (setf (fd-stream-unread stream) nil)
1096          (setf (fd-stream-ibuf-head stream) 0)          (setf (fd-stream-ibuf-head stream) 0)
1097          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
1098          ;; Trash cashed value for listen, so that we check next time.          ;; Trash cached value for listen, so that we check next time.
1099          (setf (fd-stream-listen stream) nil)          (setf (fd-stream-listen stream) nil)
1100          ;; Now move it.          ;; Now move it.
1101          (cond ((eq newpos :start)          (cond ((eq newpos :start)
1102                 (setf offset 0 origin unix:l_set))                 (setf offset 0
1103                         origin unix:l_set))
1104                ((eq newpos :end)                ((eq newpos :end)
1105                 (setf offset 0 origin unix:l_xtnd))                 (setf offset 0
1106                ((typep newpos 'index)                       origin unix:l_xtnd))
1107                  ((typep newpos '(integer 0))
1108                 (setf offset (* newpos (fd-stream-element-size stream))                 (setf offset (* newpos (fd-stream-element-size stream))
1109                       origin unix:l_set))                       origin unix:l_set))
1110                (t                (t
# Line 1102  non-server method is also significantly Line 1112  non-server method is also significantly
1112          (multiple-value-bind          (multiple-value-bind
1113              (posn errno)              (posn errno)
1114              (unix:unix-lseek (fd-stream-fd stream) offset origin)              (unix:unix-lseek (fd-stream-fd stream) offset origin)
1115            (cond ((typep posn 'fixnum)            (cond (posn
1116                   t)                   t)
1117                  ((eq errno unix:espipe)                  ((eq errno unix:espipe)
1118                   nil)                   nil)
# Line 1252  non-server method is also significantly Line 1262  non-server method is also significantly
1262     :if-does-not-exist - one of :error, :create or nil     :if-does-not-exist - one of :error, :create or nil
1263    See the manual for details."    See the manual for details."
1264    (declare (ignore external-format))    (declare (ignore external-format))
1265    
1266    ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.    ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
1267    (setf direction    (setf direction
1268          (assure-one-of direction          (assure-one-of direction
# Line 1389  non-server method is also significantly Line 1399  non-server method is also significantly
1399                     (case if-does-not-exist                     (case if-does-not-exist
1400                       (:error                       (:error
1401                        (cerror "Return NIL."                        (cerror "Return NIL."
1402                                "Error opening ~S, ~A."                                'simple-file-error
1403                                pathname                                :pathname pathname
1404                                (unix:get-unix-error-msg errno)))                                :format-control "Error opening ~S, ~A."
1405                                  :format-arguments
1406                                  (list pathname (unix:get-unix-error-msg errno))))
1407                       (:create                       (:create
1408                        (cerror "Return NIL."                        (cerror "Return NIL."
1409                                "Error creating ~S, path does not exist."                                "Error creating ~S, path does not exist."
# Line 1400  non-server method is also significantly Line 1412  non-server method is also significantly
1412                    ((eql errno unix:eexist)                    ((eql errno unix:eexist)
1413                     (unless (eq nil if-exists)                     (unless (eq nil if-exists)
1414                       (cerror "Return NIL."                       (cerror "Return NIL."
1415                               "Error opening ~S, ~A."                               'simple-file-error
1416                               pathname                               :pathname pathname
1417                               (unix:get-unix-error-msg errno)))                               :format-control "Error opening ~S, ~A."
1418                                 :format-arguments
1419                                 (list pathname (unix:get-unix-error-msg errno))))
1420                     (return nil))                     (return nil))
1421                    ((eql errno unix:eacces)                    ((eql errno unix:eacces)
1422                     (cerror "Try again."                     (cerror "Try again."
# Line 1440  non-server method is also significantly Line 1454  non-server method is also significantly
1454                               *standard-output*))                               *standard-output*))
1455    (setf *error-output* (make-synonym-stream '*stderr*))    (setf *error-output* (make-synonym-stream '*stderr*))
1456    (setf *query-io* (make-synonym-stream '*terminal-io*))    (setf *query-io* (make-synonym-stream '*terminal-io*))
1457    (setf *debug-io* *query-io*)    (setf *debug-io* (make-synonym-stream '*tty*))
1458    (setf *trace-output* *standard-output*)    (setf *trace-output* *standard-output*)
1459    nil)    nil)
1460    

Legend:
Removed from v.1.40  
changed lines
  Added in v.1.40.2.5

  ViewVC Help
Powered by ViewVC 1.1.5