/[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.85.4.1 by rtoy, Wed May 14 16:12:04 2008 UTC revision 1.85.4.1.2.7 by rtoy, Mon Jul 14 20:53:43 2008 UTC
# Line 193  Line 193 
193    (timeout nil :type (or index null))    (timeout nil :type (or index null))
194    ;;    ;;
195    ;; Pathname of the file this stream is opened to (returned by PATHNAME.)    ;; Pathname of the file this stream is opened to (returned by PATHNAME.)
196    (pathname nil :type (or pathname null)))    (pathname nil :type (or pathname null))
197      ;;
198      ;; External formats
199      ;; @@ I want to use :default here, but keyword pkg isn't set up yet at boot
200      ;; so initialize to NIL and fix it in SET-ROUTINES
201      #+unicode
202      (external-format nil :type (or null keyword cons))
203      #+unicode
204      (oc-state nil)
205      #+unicode
206      (co-state nil)
207      #+unicode
208      (last-char-read-size 0 :type index))
209    
210  (defun %print-fd-stream (fd-stream stream depth)  (defun %print-fd-stream (fd-stream stream depth)
211    (declare (ignore depth) (stream stream))    (declare (ignore depth) (stream stream))
# Line 363  Line 375 
375                            (:none                            (:none
376                             `(flush-output-buffer stream))                             `(flush-output-buffer stream))
377                            (:line                            (:line
378                             `(when (eq (char-code byte) (char-code #\Newline))                             `(when (eql (char-code byte) (char-code #\Newline))
379                                (flush-output-buffer stream)))                                (flush-output-buffer stream)))
380                            (:full                            (:full
381                             ))                             ))
# Line 449  Line 461 
461                             (fd-stream-obuf-tail stream))                             (fd-stream-obuf-tail stream))
462          byte))          byte))
463    
464    (stream::def-ef-macro ef-cout (extfmt lisp stream::+ef-max+ stream::+ef-cout+)
465      `(lambda (stream char)
466         (declare (type fd-stream stream)
467                  (type character char)
468                  (optimize (speed 3) (space 0) (debug 0) (safety 0)))
469         ;; If there is any input read from UNIX but not
470         ;; supplied to the user of the stream, reposition
471         ;; to the real file position as seen from Lisp.
472         (when (> (fd-stream-ibuf-tail stream)
473                  (fd-stream-ibuf-head stream))
474           (file-position stream (file-position stream)))
475         (let* ((sap (fd-stream-obuf-sap stream))
476                (len (fd-stream-obuf-length stream))
477                (tail (fd-stream-obuf-tail stream)))
478           (declare (type sys:system-area-pointer sap) (type index len tail))
479           (stream::char-to-octets ,extfmt
480                                   char
481                                   (fd-stream-co-state stream)
482                                   (lambda (byte)
483                                     (when (= tail len)
484                                       (do-output stream sap 0 tail t)
485                                       (setq sap (fd-stream-obuf-sap stream)
486                                             tail 0))
487                                     (setf (bref sap (1- (incf tail))) byte)))
488           (setf (fd-stream-obuf-tail stream) tail))))
489    
490    
491  ;;; OUTPUT-RAW-BYTES -- public  ;;; OUTPUT-RAW-BYTES -- public
492  ;;;  ;;;
# Line 524  Line 562 
562  ;;;   Note: some bozos (the FASL dumper) call write-string with things other  ;;;   Note: some bozos (the FASL dumper) call write-string with things other
563  ;;; than strings. Therefore, we must make sure we have a string before calling  ;;; than strings. Therefore, we must make sure we have a string before calling
564  ;;; position on it.  ;;; position on it.
565  ;;;  ;;;
566    
567    (stream::def-ef-macro ef-sout (extfmt lisp stream::+ef-max+ stream::+ef-sout+)
568      `(lambda (stream string start end)
569         (declare (type fd-stream stream)
570                  (type simple-string string)
571                  (type index start end)
572                  (optimize (speed 3) (space 0) (safety 0) (debug 0)))
573         ;; If there is any input read from UNIX but not
574         ;; supplied to the user of the stream, reposition
575         ;; to the real file position as seen from Lisp.
576         ;; (maybe the caller should do this?)
577         (when (> (fd-stream-ibuf-tail stream)
578                  (fd-stream-ibuf-head stream))
579           (file-position stream (file-position stream)))
580         (let* ((sap (fd-stream-obuf-sap stream))
581                (len (fd-stream-obuf-length stream))
582                (tail (fd-stream-obuf-tail stream)))
583           (declare (type sys:system-area-pointer sap) (type index len tail))
584           (dotimes (i (- end start))
585             (stream::char-to-octets ,extfmt
586                                     (schar string (+ i start))
587                                     (fd-stream-co-state stream)
588                                     (lambda (byte)
589                                       (when (= tail len)
590                                         (do-output stream sap 0 tail t)
591                                         (setq sap (fd-stream-obuf-sap stream)
592                                               tail 0))
593                                       (setf (bref sap (1- (incf tail))) byte))))
594           (setf (fd-stream-obuf-tail stream) tail))))
595    
596    
597  #-unicode  #-unicode
598  (defun fd-sout (stream thing start end)  (defun fd-sout (stream thing start end)
599    (let ((start (or start 0))    (let ((start (or start 0))
# Line 570  Line 639 
639               ((>= index end))               ((>= index end))
640             (funcall out stream (elt thing index))))))))             (funcall out stream (elt thing index))))))))
641    
 #+unicode ; a lame sout hack to make external-format work quickly  
 (defun fd-sout-each-character (stream thing start end)  
   (declare (type string thing))  
   (let ((start (or start 0))  
         (end (or end (length (the vector thing)))))  
     (declare (type index start end))  
     (let ((out (fd-stream-out stream)))  
       (do ((index start (+ index 1)))  
           ((>= index end))  
         (funcall out stream (aref thing index))))))  
   
642  (defmacro output-wrapper ((stream size buffering) &body body)  (defmacro output-wrapper ((stream size buffering) &body body)
643    (let ((stream-var (gensym)))    (let ((stream-var (gensym)))
644      `(let ((,stream-var ,stream))      `(let ((,stream-var ,stream))
# Line 684  Line 742 
742          (ibuf-sap (fd-stream-ibuf-sap stream))          (ibuf-sap (fd-stream-ibuf-sap stream))
743          (buflen (fd-stream-ibuf-length stream))          (buflen (fd-stream-ibuf-length stream))
744          (head (fd-stream-ibuf-head stream))          (head (fd-stream-ibuf-head stream))
745            (lcrs #-unicode 0
746                  #+unicode (fd-stream-last-char-read-size stream))
747          (tail (fd-stream-ibuf-tail stream)))          (tail (fd-stream-ibuf-tail stream)))
748      (declare (type index head tail))      (declare (type index head lcrs tail))
749      (unless (zerop head)      (unless (zerop head)
750        (cond ((eql head tail)        (cond ((eql head tail)
751               (setf head 0)               (setf head lcrs)
752               (setf tail 0)               (setf tail lcrs)
753               (setf (fd-stream-ibuf-head stream) 0)               (setf (fd-stream-ibuf-head stream) lcrs)
754               (setf (fd-stream-ibuf-tail stream) 0))               (setf (fd-stream-ibuf-tail stream) lcrs))
755              (t              (t
756               (decf tail head)               (decf tail (- head lcrs))
757               (system-area-copy ibuf-sap (* head vm:byte-bits)               (system-area-copy ibuf-sap (* (- head lcrs) vm:byte-bits)
758                                 ibuf-sap 0 (* tail vm:byte-bits))                                 ibuf-sap 0 (* tail vm:byte-bits))
759               (setf head 0)               (setf head lcrs)
760               (setf (fd-stream-ibuf-head stream) 0)               (setf (fd-stream-ibuf-head stream) lcrs)
761               (setf (fd-stream-ibuf-tail stream) tail))))               (setf (fd-stream-ibuf-tail stream) tail))))
762      (setf (fd-stream-listen stream) nil)      (setf (fd-stream-listen stream) nil)
763      (multiple-value-bind      (multiple-value-bind
# Line 743  Line 803 
803               (throw 'eof-input-catcher nil))               (throw 'eof-input-catcher nil))
804              (t              (t
805               (incf (fd-stream-ibuf-tail stream) count))))))               (incf (fd-stream-ibuf-tail stream) count))))))
806    
807    
808  ;;; INPUT-AT-LEAST -- internal  ;;; INPUT-AT-LEAST -- internal
809  ;;;  ;;;
810  ;;;   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 761  Line 822 
822             (return))             (return))
823           (do-input ,stream-var)))))           (do-input ,stream-var)))))
824    
825  ;;; INPUT-WRAPPER -- intenal  ;;; INPUT-WRAPPER -- internal
826  ;;;  ;;;
827  ;;;   Macro to wrap around all input routines to handle eof-error noise.  ;;;   Macro to wrap around all input routines to handle eof-error noise.
828  ;;;  ;;;
# Line 769  Line 830 
830    (let ((stream-var (gensym))    (let ((stream-var (gensym))
831          (element-var (gensym)))          (element-var (gensym)))
832      `(let ((,stream-var ,stream))      `(let ((,stream-var ,stream))
833         (if (fd-stream-unread ,stream-var)         (if (fd-stream-unread ,stream-var) ;;@@
834             (prog1             (prog1
835                 ,(if (eq type 'character)                 ,(if (eq type 'character)
836                      `(fd-stream-unread ,stream-var)                      `(fd-stream-unread ,stream-var)
# Line 859  Line 920 
920                     ((signed-byte 32) 4 sap head)                     ((signed-byte 32) 4 sap head)
921    (signed-sap-ref-32 sap head))    (signed-sap-ref-32 sap head))
922    
923    (stream::def-ef-macro ef-cin (extfmt lisp stream::+ef-max+ stream::+ef-cin+)
924      `(lambda (stream)
925         (declare (type fd-stream stream)
926                  (optimize (speed 3) (space 0) (debug 0) (safety 0)))
927        (catch 'eof-input-catcher
928          (let* ((head (fd-stream-ibuf-head stream))
929                 (ch (stream::octets-to-char ,extfmt
930                                             (fd-stream-oc-state stream)
931                                             (fd-stream-last-char-read-size stream)
932                                             ;;@@ Note: need proper EOF handling...
933                                             (progn
934                                               (when (= head
935                                                        (fd-stream-ibuf-tail
936                                                         stream))
937                                                 (do-input stream)
938                                                 (setf head
939                                                     (fd-stream-ibuf-head stream)))
940                                               (bref (fd-stream-ibuf-sap stream)
941                                                     (1- (incf head))))
942                                             (lambda (n) (decf head n)))))
943            (declare (type index head))
944            (when ch
945              (incf (fd-stream-ibuf-head stream)
946                    (fd-stream-last-char-read-size stream))
947              ch)))))
948    
949    #+(or)
950    (stream::def-ef-macro ef-sin (extfmt lisp stream::+ef-max+ stream::+ef-sin+)
951      `(lambda (stream string char start end)
952         (declare (type fd-stream stream)
953                  (type simple-string string)
954                  (type (or character null) char)
955                  (type index start end)
956                  (optimize (speed 3) (space 0) (debug 0) (safety 0)))
957         (let ((sap (fd-stream-ibuf-sap stream))
958               (head (fd-stream-ibuf-head stream))
959               (tail (fd-stream-ibuf-tail stream))
960               (curr start))
961           (declare (type sys:system-area-pointer sap)
962                    (type index head tail curr))
963           (loop
964             ;;@@ Fix EOF handling
965             (let* ((sz 0)
966                    (ch (catch 'eof-input-catcher
967                          (stream::octets-to-char ,extfmt
968                                                  (fd-stream-oc-state stream)
969                                                  sz
970                                                  (progn
971                                                    (when (= head tail)
972                                                      (do-input stream)
973                                                      (setq head
974                                                            (fd-stream-ibuf-head
975                                                             stream)
976                                                            tail
977                                                            (fd-stream-ibuf-tail
978                                                             stream)))
979                                                    (bref sap (1- (incf head))))
980                                                  (lambda (n) (decf head n))))))
981               (declare (type index sz)
982                        (type (or null character) ch))
983               (when (null ch)
984                 (return (values (- curr start) :eof)))
985               (setf (fd-stream-last-char-read-size stream) sz)
986               (incf (fd-stream-ibuf-head stream) sz)
987               (when (and char (char= ch char))
988                 (return (values (- curr start) t)))
989               (setf (schar string (1- (incf curr))) ch)
990               (when (= curr end)
991                 (return (values (- curr start) nil))))))))
992    
993  ;;; PICK-INPUT-ROUTINE -- internal  ;;; PICK-INPUT-ROUTINE -- internal
994  ;;;  ;;;
995  ;;;   Find an input routine to use given the type. Return as multiple values  ;;;   Find an input routine to use given the type. Return as multiple values
# Line 969  Line 1100 
1100  ;;; FD-STREAM-READ-N-BYTES -- internal  ;;; FD-STREAM-READ-N-BYTES -- internal
1101  ;;;  ;;;
1102  ;;;    The N-Bin method for FD-STREAMs.  This doesn't use the SERVER; it blocks  ;;;    The N-Bin method for FD-STREAMs.  This doesn't use the SERVER; it blocks
1103  ;;; in UNIX-READ.  This allows the method to be used to implementing reading  ;;; in UNIX-READ.  This allows the method to be used to implement reading
1104  ;;; 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
1105  ;;; to be done, so blocking isn't too problematical.  ;;; to be done, so blocking isn't too problematical.
1106  ;;;  ;;;
# Line 996  Line 1127 
1127      ;;      ;;
1128      ;; If something has been unread, put that at buffer + start,      ;; If something has been unread, put that at buffer + start,
1129      ;; and read the rest to start + 1.      ;; and read the rest to start + 1.
1130      (when (fd-stream-unread stream)      (when (fd-stream-unread stream) ;;@@
1131        (etypecase buffer        (etypecase buffer
1132          (system-area-pointer          (system-area-pointer
1133           (assert (= 1 (fd-stream-element-size stream)))           (assert (= 1 (fd-stream-element-size stream)))
# Line 1126  Line 1257 
1257      (when (fd-stream-ibuf-sap stream)      (when (fd-stream-ibuf-sap stream)
1258        (push (fd-stream-ibuf-sap stream) *available-buffers*)        (push (fd-stream-ibuf-sap stream) *available-buffers*)
1259        (setf (fd-stream-ibuf-sap stream) nil))        (setf (fd-stream-ibuf-sap stream) nil))
1260    
1261        #+unicode
1262        (when (null (fd-stream-external-format stream))
1263          (setf (fd-stream-external-format stream) :default))
1264    
1265      (when input-p      (when input-p
1266        (multiple-value-bind        (multiple-value-bind
# Line 1183  Line 1318 
1318                      #'ill-out)                      #'ill-out)
1319                  (fd-stream-bout stream) routine))                  (fd-stream-bout stream) routine))
1320          (setf (fd-stream-sout stream)          (setf (fd-stream-sout stream)
1321                #-unicode                ;;#-unicode
1322                (if (eql size 1) #'fd-sout #'ill-out)                (if (eql size 1) #'fd-sout #'ill-out)
1323                #+unicode                #|#+unicode
1324                (if (eql size 1)                (if (eql size 1)
1325                    #'fd-sout-each-character                    #'fd-sout-each-character
1326                    #'ill-out))                    #'ill-out)|#)
1327          (setf (fd-stream-char-pos stream) 0)          (setf (fd-stream-char-pos stream) 0)
1328          (setf output-size size)          (setf output-size size)
1329          (setf output-type type)))          (setf output-type type)))
1330    
1331      (when (and input-size output-size      (when (and input-size output-size
1332                 (not (eq input-size output-size)))                 (not (eql input-size output-size)))
1333        (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"        (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
1334               input-type input-size               input-type input-size
1335               output-type output-size))               output-type output-size))
# Line 1267  Line 1402 
1402                                               0 0))                                               0 0))
1403                      1))))                      1))))
1404      (:unread      (:unread
1405         #-unicode
1406       (setf (fd-stream-unread stream) arg1)       (setf (fd-stream-unread stream) arg1)
1407         #+unicode
1408         (if (zerop (fd-stream-last-char-read-size stream))
1409             (setf (fd-stream-unread stream) arg1)
1410             (decf (fd-stream-ibuf-head stream)
1411                   (fd-stream-last-char-read-size stream)))
1412         ;; Paul says:
1413         ;;
1414         ;; Not needed for unicode when unreading is implemented by backing up in
1415         ;; the buffer (e.g., with last-char-read-size...)
1416         ;;
1417         ;; (AFAICS there's nothing wrong with setting it there, but it
1418         ;; screws up read-interactive in my toplevel command thing -
1419         ;; leaves it expecting to read arguments when it shouldn't,
1420         ;; because LISTEN returns T when there's no input pending, but I
1421         ;; don't understand why...)
1422         #-unicode
1423       (setf (fd-stream-listen stream) t))       (setf (fd-stream-listen stream) t))
1424      (:close      (:close
1425       (cond (arg1       (cond (arg1
# Line 1294  Line 1446 
1446         (setf (fd-stream-ibuf-sap stream) nil))         (setf (fd-stream-ibuf-sap stream) nil))
1447       (lisp::set-closed-flame stream))       (lisp::set-closed-flame stream))
1448      (:clear-input      (:clear-input
1449       (setf (fd-stream-unread stream) nil)       (setf (fd-stream-unread stream) nil) ;;@@
1450         #+unicode (setf (fd-stream-last-char-read-size stream) 0)
1451       (setf (fd-stream-ibuf-head stream) 0)       (setf (fd-stream-ibuf-head stream) 0)
1452       (setf (fd-stream-ibuf-tail stream) 0)       (setf (fd-stream-ibuf-tail stream) 0)
1453       (catch 'eof-input-catcher       (catch 'eof-input-catcher
# Line 1381  Line 1534 
1534                   ;; unread stuff is still available.                   ;; unread stuff is still available.
1535                   (decf posn (- (fd-stream-ibuf-tail stream)                   (decf posn (- (fd-stream-ibuf-tail stream)
1536                                 (fd-stream-ibuf-head stream)))                                 (fd-stream-ibuf-head stream)))
1537                   (when (fd-stream-unread stream)                   (when (fd-stream-unread stream) ;;@@
1538                     (decf posn))                     (decf posn))
1539                   ;; Divide bytes by element size.                   ;; Divide bytes by element size.
1540                   (truncate posn (fd-stream-element-size stream)))                   (truncate posn (fd-stream-element-size stream)))
# Line 1404  Line 1557 
1557            (system:serve-all-events))            (system:serve-all-events))
1558          ;; Clear out any pending input to force the next read to go to the          ;; Clear out any pending input to force the next read to go to the
1559          ;; disk.          ;; disk.
1560          (setf (fd-stream-unread stream) nil)          (setf (fd-stream-unread stream) nil) ;;@@
1561            #+unicode (setf (fd-stream-last-char-read-size stream) 0)
1562          (setf (fd-stream-ibuf-head stream) 0)          (setf (fd-stream-ibuf-head stream) 0)
1563          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
1564          ;; Trash cached value for listen, so that we check next time.          ;; Trash cached value for listen, so that we check next time.
# Line 1457  Line 1611 
1611                                   (format nil "file ~S" file)                                   (format nil "file ~S" file)
1612                                   (format nil "descriptor ~D" fd)))                                   (format nil "descriptor ~D" fd)))
1613                         auto-close                         auto-close
1614                           (external-format :default)
1615                         binary-stream-p)                         binary-stream-p)
1616    (declare (type index fd) (type (or index null) timeout)    (declare (type index fd) (type (or index null) timeout)
1617             (type (member :none :line :full) buffering))             (type (member :none :line :full) buffering))
# Line 1493  Line 1648 
1648                                       :timeout timeout))))                                       :timeout timeout))))
1649      (set-routines stream element-type input output input-buffer-p      (set-routines stream element-type input output input-buffer-p
1650                    :binary-stream-p binary-stream-p)                    :binary-stream-p binary-stream-p)
1651        ;;#-unicode-bootstrap ; fails in stream-reinit otherwise
1652        #+(and unicode (not unicode-bootstrap))
1653        (setf (stream-external-format stream) external-format)
1654      (when (and auto-close (fboundp 'finalize))      (when (and auto-close (fboundp 'finalize))
1655        (finalize stream        (finalize stream
1656                  #'(lambda ()                  #'(lambda ()
# Line 1765  Line 1923 
1923             (type (member :input :output :io :probe) direction)             (type (member :input :output :io :probe) direction)
1924             (type (member :error :new-version :rename :rename-and-delete             (type (member :error :new-version :rename :rename-and-delete
1925                           :overwrite :append :supersede nil) if-exists)                           :overwrite :append :supersede nil) if-exists)
1926             (type (member :error :create nil) if-does-not-exist)             (type (member :error :create nil) if-does-not-exist))
            (ignore external-format))  
1927    (multiple-value-bind (fd namestring original delete-original)    (multiple-value-bind (fd namestring original delete-original)
1928        (fd-open pathname direction if-exists if-exists-given        (fd-open pathname direction if-exists if-exists-given
1929                 if-does-not-exist if-does-not-exist-given)                 if-does-not-exist if-does-not-exist-given)
# Line 1785  Line 1942 
1942                           :pathname pathname                           :pathname pathname
1943                           :input-buffer-p t                           :input-buffer-p t
1944                           :auto-close t                           :auto-close t
1945                             :external-format external-format
1946                           :binary-stream-p class))                           :binary-stream-p class))
1947          (:probe          (:probe
1948           (let ((stream (%make-fd-stream :name namestring :fd fd           (let ((stream (%make-fd-stream :name namestring :fd fd
# Line 1816  Line 1974 
1974     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1975                         :overwrite, :append, :supersede or nil                         :overwrite, :append, :supersede or nil
1976     :if-does-not-exist - one of :error, :create or nil     :if-does-not-exist - one of :error, :create or nil
1977     :external-format - :default     :external-format - an external format name
1978    See the manual for details."    See the manual for details."
1979    (declare (ignore external-format input-handle output-handle))    (declare (ignore element-type external-format input-handle output-handle))
1980    
1981    ;; OPEN signals a file-error if the filename is wild.    ;; OPEN signals a file-error if the filename is wild.
1982    (when (wild-pathname-p filename)    (when (wild-pathname-p filename)

Legend:
Removed from v.1.85.4.1  
changed lines
  Added in v.1.85.4.1.2.7

  ViewVC Help
Powered by ViewVC 1.1.5