/[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.20 by wlott, Fri Feb 21 21:59:52 1992 UTC revision 1.20.1.1 by wlott, Sat Mar 7 11:19:20 1992 UTC
# Line 418  Line 418 
418    "List of all available input routines. Each element is a list of the    "List of all available input routines. Each element is a list of the
419    element-type input, the function name, and the number of bytes per element.")    element-type input, the function name, and the number of bytes per element.")
420    
421    
422    (declaim (inline fixup-char-pos-for-input))
423    
424    ;;; FIXUP-CHAR-POS-FOR-INPUT -- internal
425    ;;;
426    ;;;   Try and update char-pos to reflect the presence of input on a duplex
427    ;;; fd-stream.  Since char-pos only matters for output, we only care about
428    ;;; the effect of all input received so far (regardless of how much has been
429    ;;; read by lisp) on the output position, so we just need to look at the
430    ;;; tail of the input.
431    ;;;   Obviously this only works correctly if i/o is properly interspersed,
432    ;;; but that's probably most of the time, and there's nothing we can do if
433    ;;; it's not...
434    ;;;
435    (defun fixup-char-pos-for-input (stream sap pos length)
436      (declare (type fd-stream stream)
437               (type system:system-area-pointer sap)
438               (type index pos length))
439      (when (fd-stream-obuf-sap stream)
440        (do ((offs (+ pos length) (1- offs)))
441            ((= offs pos)
442             (incf (fd-stream-char-pos stream) length))
443          (declare (type index offs))
444          (when (= (system:sap-ref-8 sap (1- offs))
445                   (char-code #\newline))
446            (setf (fd-stream-char-pos stream) (- length (- offs pos)))
447            (return)))))
448    
449    
450  ;;; DO-INPUT -- internal  ;;; DO-INPUT -- internal
451  ;;;  ;;;
452  ;;;   Fills the input buffer, and returns the first character. Throws to  ;;;   Fills the input buffer, and returns the first character. Throws to
# Line 479  Line 508 
508               (setf (fd-stream-listen stream) :eof)               (setf (fd-stream-listen stream) :eof)
509               (throw 'eof-input-catcher nil))               (throw 'eof-input-catcher nil))
510              (t              (t
511               (incf (fd-stream-ibuf-tail stream) count))))))               (fixup-char-pos-for-input stream ibuf-sap tail count)
512                 (setf (fd-stream-ibuf-tail stream) (+ tail count)))))))
513    
514  ;;; INPUT-AT-LEAST -- internal  ;;; INPUT-AT-LEAST -- internal
515  ;;;  ;;;
516  ;;;   Makes sure there are at least ``bytes'' number of bytes in the input  ;;;   Makes sure there are at least ``bytes'' number of bytes in the input
# Line 769  non-server method is also significantly Line 799  non-server method is also significantly
799          (cond          (cond
800           ((> now-needed len)           ((> now-needed len)
801            (system:without-gcing            (system:without-gcing
802              (loop             (let ((buf-sap
803                (multiple-value-bind                    (if (typep buffer 'system-area-pointer)
804                    (count err)                        buffer
805                    (unix:unix-read (fd-stream-fd stream)                        (vector-sap buffer))))
806                                    (sap+ (if (typep buffer 'system-area-pointer)               (incf offset copy)
807                                              buffer               (loop
808                                              (vector-sap buffer))                 (multiple-value-bind
809                                          (+ offset copy))                     (count err)
810                                    now-needed)                     (unix:unix-read (fd-stream-fd stream)
811                  (declare (type (or index null) count))                                     (sap+ buf-sap offset)
812                  (unless count                                     now-needed)
813                    (error "Error reading ~S: ~A" stream                   (declare (type (or index null) count))
814                           (unix:get-unix-error-msg err)))                   (unless count
815                  (when (zerop count)                     (error "Error reading ~S: ~A" stream
816                    (if eof-error-p                            (unix:get-unix-error-msg err)))
817                        (error "Unexpected eof on ~S." stream)                   (when (zerop count)
818                        (return (- requested (truncate now-needed elsize)))))                     (if eof-error-p
819                  (decf now-needed count)                         (error "Unexpected eof on ~S." stream)
820                  (when (zerop now-needed) (return requested))                         (return (- requested (truncate now-needed elsize)))))
821                  (incf offset count)))))                   (decf now-needed count)
822                     (fixup-char-pos-for-input stream buf-sap offset count)
823                     (when (zerop now-needed)
824                       (return requested))
825                     (incf offset count))))))
826           (t           (t
827            (loop            (loop
828              (multiple-value-bind              (multiple-value-bind
# Line 798  non-server method is also significantly Line 832  non-server method is also significantly
832                (unless count                (unless count
833                  (error "Error reading ~S: ~A" stream                  (error "Error reading ~S: ~A" stream
834                         (unix:get-unix-error-msg err)))                         (unix:get-unix-error-msg err)))
835                  (fixup-char-pos-for-input stream sap 0 count)
836                (incf (fd-stream-ibuf-tail stream) count)                (incf (fd-stream-ibuf-tail stream) count)
837                (when (zerop count)                (when (zerop count)
838                  (if eof-error-p                  (if eof-error-p
# Line 1431  non-server method is also significantly Line 1466  non-server method is also significantly
1466    (setf *trace-output* *standard-output*)    (setf *trace-output* *standard-output*)
1467    nil)    nil)
1468    
1469    ;;; Returns non-nil if the unix file-descriptors fd1 and fd2 refer to the
1470    ;;; same object.  This is sort of a hack, I guess...
1471    (defun fd-eq (fd1 fd2)
1472      (or (= fd1 fd2)
1473          (multiple-value-bind (ok1 dev1 inode1 mode1 nlink1 uid1 gid1 rdev1
1474                                    size1 at mt ct block-size1 blocks1)
1475              (unix:unix-fstat fd1)
1476            (declare (ignore at mt ct))
1477            (multiple-value-bind (ok2 dev2 inode2 mode2 nlink2 uid2 gid2 rdev2
1478                                      size2 at mt ct block-size2 blocks2)
1479                (unix:unix-fstat fd2)
1480              (declare (ignore at mt ct))
1481              (and ok1 ok2
1482                   (eql dev1 dev2) (eql inode1 inode2) (eql mode1 mode2)
1483                   (eql nlink1 nlink2) (eql uid1 uid2) (eql gid1 gid2)
1484                   (eql rdev1 rdev2) (eql size1 size2)
1485                   (eql block-size1 block-size2) (eql blocks1 blocks2))))))
1486    
1487  ;;; STREAM-REINIT -- internal interface  ;;; STREAM-REINIT -- internal interface
1488  ;;;  ;;;
1489  ;;; Called whenever a saved core is restarted.  ;;; Called whenever a saved core is restarted.
1490  ;;;  ;;;
1491  (defun stream-reinit ()  (defun stream-reinit ()
1492    (setf *available-buffers* nil)    (setf *available-buffers* nil)
1493    (setf *stdin*    (cond ((fd-eq 0 1)
1494          (make-fd-stream 0 :name "Standard Input" :input t :buffering :line))           (setf *stdin*
1495    (setf *stdout*                 (make-fd-stream 0 :name "Standard I/O" :input t :output t
1496          (make-fd-stream 1 :name "Standard Output" :output t :buffering :line))                                 :buffering :line))
1497    (setf *stderr*           (setf *stdout* *stdin*))
1498          (make-fd-stream 2 :name "Standard Error" :output t :buffering :line))          (t
1499             (setf *stdin*
1500                   (make-fd-stream 0 :name "Standard Input" :input t
1501                                   :buffering :line))
1502             (setf *stdout*
1503                   (make-fd-stream 1 :name "Standard Output" :output t
1504                                   :buffering :line))))
1505    
1506      (cond ((fd-eq 1 2)
1507             (setf *stderr* *stdout*))
1508            (t
1509             (setf *stderr*
1510                   (make-fd-stream 2 :name "Standard Error" :output t
1511                                   :buffering :line))))
1512    
1513    (let ((tty (unix:unix-open "/dev/tty" unix:o_rdwr #o666)))    (let ((tty (unix:unix-open "/dev/tty" unix:o_rdwr #o666)))
1514      (if tty      (cond ((and (eq *stdin* *stdout*)
1515          (setf *tty*                  (or (null tty)
1516                (make-fd-stream tty :name "the Terminal" :input t :output t                      (unix:unix-isatty 1) ; not sure about this
1517                                :buffering :line :auto-close t))                      (fd-eq tty 1)))
1518          (setf *tty* (make-two-way-stream *stdin* *stdout*))))             (setf *tty* *stdout*))
1519              (tty
1520               (setf *tty*
1521                     (make-fd-stream tty :name "the Terminal" :input t :output t
1522                                     :buffering :line)))
1523              (t
1524               (setf *tty* (make-two-way-stream *stdin* *stdout*)))))
1525    nil)    nil)
1526    
1527    

Legend:
Removed from v.1.20  
changed lines
  Added in v.1.20.1.1

  ViewVC Help
Powered by ViewVC 1.1.5