/[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.8 by pw, Sat Mar 23 18:49:58 2002 UTC
# Line 48  Line 48 
48  ;;;  ;;;
49  ;;; Returns the next available buffer, creating one if necessary.  ;;; Returns the next available buffer, creating one if necessary.
50  ;;;  ;;;
51  (proclaim '(inline next-available-buffer))  (declaim (inline next-available-buffer))
52  ;;;  ;;;
53  (defun next-available-buffer ()  (defun next-available-buffer ()
54    (if *available-buffers*    (if *available-buffers*
# 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 848  non-server method is also significantly Line 852  non-server method is also significantly
852                    (fd-stream-bin stream) #'ill-bin)                    (fd-stream-bin stream) #'ill-bin)
853              (setf (fd-stream-in stream) #'ill-in              (setf (fd-stream-in stream) #'ill-in
854                    (fd-stream-bin stream) routine))                    (fd-stream-bin stream) routine))
855          (when (eql size 1)          (when (or (eql size 1)
856                      (eql size 2)
857                      (eql size 4))
858              ;; Support for n-byte operations on 8-, 16-, and 32-bit streams
859            (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)            (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
860            (when buffer-p            (when buffer-p
861              (setf (stream-in-buffer stream)              (setf (lisp-stream-in-buffer stream)
862                    (make-array in-buffer-length                    (make-array in-buffer-length
863                                :element-type '(unsigned-byte 8)))))                                :element-type '(unsigned-byte 8)))))
864          (setf input-size size)          (setf input-size size)
# Line 919  non-server method is also significantly Line 926  non-server method is also significantly
926                     (fd-stream-ibuf-tail stream)))                     (fd-stream-ibuf-tail stream)))
927           (fd-stream-listen stream)           (fd-stream-listen stream)
928           (setf (fd-stream-listen stream)           (setf (fd-stream-listen stream)
929                 (eql (unix:unix-select (1+ (fd-stream-fd stream))                 (eql (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
930                                        (the (unsigned-byte 32)                        (unix:fd-zero read-fds)
931                                             (ash 1 (fd-stream-fd stream)))                        (unix:fd-set (fd-stream-fd stream) read-fds)
932                                        0                        (unix:unix-fast-select (1+ (fd-stream-fd stream))
933                                        0                                               (alien:addr read-fds) nil nil
934                                        0)                                               0 0))
935                      1))))                      1))))
936      (:unread      (:unread
937       (setf (fd-stream-unread stream) arg1)       (setf (fd-stream-unread stream) arg1)
# Line 989  non-server method is also significantly Line 996  non-server method is also significantly
996       (setf (fd-stream-ibuf-tail stream) 0)       (setf (fd-stream-ibuf-tail stream) 0)
997       (catch 'eof-input-catcher       (catch 'eof-input-catcher
998         (loop         (loop
999          (let ((count (unix:unix-select (1+ (fd-stream-fd stream))          (multiple-value-bind
1000                                         (the (unsigned-byte 32)                (count errno)
1001                                              (ash 1 (fd-stream-fd stream)))              (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1002                                         0 0 0)))                (unix:fd-zero read-fds)
1003                  (unix:fd-set (fd-stream-fd stream) read-fds)
1004                  (unix:unix-fast-select (1+ (fd-stream-fd stream))
1005                                         (alien:addr read-fds) nil nil 0 0))
1006            (cond ((eql count 1)            (cond ((eql count 1)
1007                   (do-input stream)                   (do-input stream)
1008                   (setf (fd-stream-ibuf-head stream) 0)                   (setf (fd-stream-ibuf-head stream) 0)
1009                   (setf (fd-stream-ibuf-tail stream) 0))                   (setf (fd-stream-ibuf-tail stream) 0))
1010                    ((and (not count) (eql errno unix:eintr)))
1011                  (t                  (t
1012                   (return t)))))))                   (return t)))))))
1013      (:force-output      (:force-output
# Line 1015  non-server method is also significantly Line 1026  non-server method is also significantly
1026      (:charpos      (:charpos
1027       (fd-stream-char-pos stream))       (fd-stream-char-pos stream))
1028      (:file-length      (:file-length
1029         (unless (fd-stream-file stream)
1030           (error 'simple-type-error
1031                  :datum stream
1032                  :expected-type 'file-stream
1033                  :format-control "~s is not a stream associated with a file."
1034                  :format-arguments (list stream)))
1035       (multiple-value-bind       (multiple-value-bind
1036           (okay dev ino mode nlink uid gid rdev size           (okay dev ino mode nlink uid gid rdev size
1037                 atime mtime ctime blksize blocks)                 atime mtime ctime blksize blocks)
# Line 1025  non-server method is also significantly Line 1042  non-server method is also significantly
1042           (error "Error fstating ~S: ~A"           (error "Error fstating ~S: ~A"
1043                  stream                  stream
1044                  (unix:get-unix-error-msg dev)))                  (unix:get-unix-error-msg dev)))
1045         (if (zerop (the index mode))         (if (zerop mode)
1046             nil             nil
1047             (truncate (the index size) (fd-stream-element-size stream)))))             (truncate size (fd-stream-element-size stream)))))
1048      (:file-position      (:file-position
1049       (fd-stream-file-position stream arg1))))       (fd-stream-file-position stream arg1))))
1050    
# Line 1036  non-server method is also significantly Line 1053  non-server method is also significantly
1053  ;;;  ;;;
1054  (defun fd-stream-file-position (stream &optional newpos)  (defun fd-stream-file-position (stream &optional newpos)
1055    (declare (type fd-stream stream)    (declare (type fd-stream stream)
1056             (type (or index (member nil :start :end)) newpos))             (type (or (integer 0) (member nil :start :end)) newpos))
1057    (if (null newpos)    (if (null newpos)
1058        (system:without-interrupts        (system:without-interrupts
1059          ;; First, find the position of the UNIX file descriptor in the          ;; First, find the position of the UNIX file descriptor in the file.
         ;; file.  
1060          (multiple-value-bind          (multiple-value-bind
1061              (posn errno)                (posn errno)
1062              (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)              (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
1063            (declare (type (or index null) posn))            (declare (type (or (integer 0) null) posn))
1064            (cond ((fixnump posn)            (cond (posn
1065                   ;; Adjust for buffered output:                   ;; Adjust for buffered output:
1066                   ;;  If there is any output buffered, the *real* file position                   ;;  If there is any output buffered, the *real* file position
1067                   ;; 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 1089  non-server method is also significantly
1089                     (error "Error lseek'ing ~S: ~A"                     (error "Error lseek'ing ~S: ~A"
1090                            stream                            stream
1091                            (unix:get-unix-error-msg errno)))))))                            (unix:get-unix-error-msg errno)))))))
1092        (let ((offset 0) origin)        (let ((offset 0)
1093          (declare (type index offset))              origin)
1094            (declare (type (integer 0) offset))
1095          ;; 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
1096          ;; file pointer before writing this stuff, it will be written in the          ;; file pointer before writing this stuff, it will be written in the
1097          ;; wrong location.          ;; wrong location.
# Line 1087  non-server method is also significantly Line 1104  non-server method is also significantly
1104          (setf (fd-stream-unread stream) nil)          (setf (fd-stream-unread stream) nil)
1105          (setf (fd-stream-ibuf-head stream) 0)          (setf (fd-stream-ibuf-head stream) 0)
1106          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
1107          ;; Trash cashed value for listen, so that we check next time.          ;; Trash cached value for listen, so that we check next time.
1108          (setf (fd-stream-listen stream) nil)          (setf (fd-stream-listen stream) nil)
1109          ;; Now move it.          ;; Now move it.
1110          (cond ((eq newpos :start)          (cond ((eq newpos :start)
1111                 (setf offset 0 origin unix:l_set))                 (setf offset 0
1112                         origin unix:l_set))
1113                ((eq newpos :end)                ((eq newpos :end)
1114                 (setf offset 0 origin unix:l_xtnd))                 (setf offset 0
1115                ((typep newpos 'index)                       origin unix:l_xtnd))
1116                  ((typep newpos '(integer 0))
1117                 (setf offset (* newpos (fd-stream-element-size stream))                 (setf offset (* newpos (fd-stream-element-size stream))
1118                       origin unix:l_set))                       origin unix:l_set))
1119                (t                (t
# Line 1102  non-server method is also significantly Line 1121  non-server method is also significantly
1121          (multiple-value-bind          (multiple-value-bind
1122              (posn errno)              (posn errno)
1123              (unix:unix-lseek (fd-stream-fd stream) offset origin)              (unix:unix-lseek (fd-stream-fd stream) offset origin)
1124            (cond ((typep posn 'fixnum)            (cond (posn
1125                   t)                   t)
1126                  ((eq errno unix:espipe)                  ((eq errno unix:espipe)
1127                   nil)                   nil)
# Line 1227  non-server method is also significantly Line 1246  non-server method is also significantly
1246                     (unix:get-unix-error-msg err))                     (unix:get-unix-error-msg err))
1247             nil))))             nil))))
1248    
1249    ;;; RETURN-STREAM -- internal
1250    ;;;
1251    ;;; (this is just to save having to reindent the code in OPEN...move it there)
1252    ;;;
1253    (defmacro return-stream (class &body body)
1254      (let ((stream (gensym)))
1255        `(let ((,stream (progn ,@body)))
1256           (return (if ,class
1257                      (make-instance ,class :lisp-stream ,stream)
1258                      ,stream)))))
1259    
1260  ;;; OPEN -- public  ;;; OPEN -- public
1261  ;;;  ;;;
# Line 1239  non-server method is also significantly Line 1268  non-server method is also significantly
1268               (if-exists nil if-exists-given)               (if-exists nil if-exists-given)
1269               (if-does-not-exist nil if-does-not-exist-given)               (if-does-not-exist nil if-does-not-exist-given)
1270               (external-format :default)               (external-format :default)
1271                 class
1272               &aux ; Squelch assignment warning.               &aux ; Squelch assignment warning.
1273               (direction direction)               (direction direction)
1274               (if-does-not-exist if-does-not-exist)               (if-does-not-exist if-does-not-exist)
# Line 1252  non-server method is also significantly Line 1282  non-server method is also significantly
1282     :if-does-not-exist - one of :error, :create or nil     :if-does-not-exist - one of :error, :create or nil
1283    See the manual for details."    See the manual for details."
1284    (declare (ignore external-format))    (declare (ignore external-format))
1285    
1286    ;; 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.
1287    (setf direction    (setf direction
1288          (assure-one-of direction          (assure-one-of direction
# Line 1365  non-server method is also significantly Line 1395  non-server method is also significantly
1395                    (unix:unix-open namestring mask mode)                    (unix:unix-open namestring mask mode)
1396                    (values nil unix:enoent))                    (values nil unix:enoent))
1397              (cond ((numberp fd)              (cond ((numberp fd)
1398                     (return                     (return-stream class
1399                      (case direction                      (case direction
1400                        ((:input :output :io)                        ((:input :output :io)
1401                         (make-fd-stream fd                         (make-fd-stream fd
# Line 1389  non-server method is also significantly Line 1419  non-server method is also significantly
1419                     (case if-does-not-exist                     (case if-does-not-exist
1420                       (:error                       (:error
1421                        (cerror "Return NIL."                        (cerror "Return NIL."
1422                                "Error opening ~S, ~A."                                'simple-file-error
1423                                pathname                                :pathname pathname
1424                                (unix:get-unix-error-msg errno)))                                :format-control "Error opening ~S, ~A."
1425                                  :format-arguments
1426                                  (list pathname (unix:get-unix-error-msg errno))))
1427                       (:create                       (:create
1428                        (cerror "Return NIL."                        (cerror "Return NIL."
1429                                "Error creating ~S, path does not exist."                                "Error creating ~S, path does not exist."
# Line 1400  non-server method is also significantly Line 1432  non-server method is also significantly
1432                    ((eql errno unix:eexist)                    ((eql errno unix:eexist)
1433                     (unless (eq nil if-exists)                     (unless (eq nil if-exists)
1434                       (cerror "Return NIL."                       (cerror "Return NIL."
1435                               "Error opening ~S, ~A."                               'simple-file-error
1436                               pathname                               :pathname pathname
1437                               (unix:get-unix-error-msg errno)))                               :format-control "Error opening ~S, ~A."
1438                                 :format-arguments
1439                                 (list pathname (unix:get-unix-error-msg errno))))
1440                     (return nil))                     (return nil))
1441                    ((eql errno unix:eacces)                    ((eql errno unix:eacces)
1442                     (cerror "Try again."                     (cerror "Try again."
# Line 1456  non-server method is also significantly Line 1490  non-server method is also significantly
1490          (make-fd-stream 1 :name "Standard Output" :output t :buffering :line))          (make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
1491    (setf *stderr*    (setf *stderr*
1492          (make-fd-stream 2 :name "Standard Error" :output t :buffering :line))          (make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
1493    (let ((tty (unix:unix-open "/dev/tty" unix:o_rdwr #o666)))    (let ((tty (and (not *batch-mode*)
1494      (if tty                    (unix:unix-open "/dev/tty" unix:o_rdwr #o666))))
1495          (setf *tty*      (setf *tty*
1496              (if tty
1497                (make-fd-stream tty :name "the Terminal" :input t :output t                (make-fd-stream tty :name "the Terminal" :input t :output t
1498                                :buffering :line :auto-close t))                                :buffering :line :auto-close t)
1499          (setf *tty* (make-two-way-stream *stdin* *stdout*))))                (make-two-way-stream *stdin* *stdout*))))
1500    nil)    nil)
1501    
1502    

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

  ViewVC Help
Powered by ViewVC 1.1.5