/[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.12 by rtoy, Tue May 12 16:31:48 2009 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 format support
199      ;;
200      ;; @@ I want to use :default here, but keyword pkg isn't set up yet at boot
201      ;; so initialize to NIL and fix it in SET-ROUTINES
202      #+unicode
203      (external-format nil :type (or null keyword cons))
204      #+unicode
205      (oc-state nil)
206      #+unicode
207      (co-state nil)
208      #+unicode
209      (last-char-read-size 0 :type index))
210    
211  (defun %print-fd-stream (fd-stream stream depth)  (defun %print-fd-stream (fd-stream stream depth)
212    (declare (ignore depth) (stream stream))    (declare (ignore depth) (stream stream))
# Line 363  Line 376 
376                            (:none                            (:none
377                             `(flush-output-buffer stream))                             `(flush-output-buffer stream))
378                            (:line                            (:line
379                             `(when (eq (char-code byte) (char-code #\Newline))                             `(when (eql (char-code byte) (char-code #\Newline))
380                                (flush-output-buffer stream)))                                (flush-output-buffer stream)))
381                            (:full                            (:full
382                             ))                             ))
# Line 449  Line 462 
462                             (fd-stream-obuf-tail stream))                             (fd-stream-obuf-tail stream))
463          byte))          byte))
464    
465    (stream::def-ef-macro ef-cout (extfmt lisp stream::+ef-max+ stream::+ef-cout+)
466      `(lambda (stream char)
467         (declare (type fd-stream stream)
468                  (type character char)
469                  (optimize (speed 3) (space 0) (debug 0) (safety 0)))
470         ;; If there is any input read from UNIX but not
471         ;; supplied to the user of the stream, reposition
472         ;; to the real file position as seen from Lisp.
473         (when (> (fd-stream-ibuf-tail stream)
474                  (fd-stream-ibuf-head stream))
475           (file-position stream (file-position stream)))
476         (let* ((sap (fd-stream-obuf-sap stream))
477                (len (fd-stream-obuf-length stream))
478                (tail (fd-stream-obuf-tail stream)))
479           (declare (type sys:system-area-pointer sap) (type index len tail))
480           (stream::char-to-octets ,extfmt
481                                   char
482                                   (fd-stream-co-state stream)
483                                   (lambda (byte)
484                                     (when (= tail len)
485                                       (do-output stream sap 0 tail t)
486                                       (setq sap (fd-stream-obuf-sap stream)
487                                             tail 0))
488                                     (setf (bref sap (1- (incf tail))) byte)))
489           (setf (fd-stream-obuf-tail stream) tail))))
490    
491    
492  ;;; OUTPUT-RAW-BYTES -- public  ;;; OUTPUT-RAW-BYTES -- public
493  ;;;  ;;;
# Line 524  Line 563 
563  ;;;   Note: some bozos (the FASL dumper) call write-string with things other  ;;;   Note: some bozos (the FASL dumper) call write-string with things other
564  ;;; 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
565  ;;; position on it.  ;;; position on it.
566  ;;;  ;;;
567    
568    (stream::def-ef-macro ef-sout (extfmt lisp stream::+ef-max+ stream::+ef-sout+)
569      `(lambda (stream string start end)
570         (declare (type fd-stream stream)
571                  (type simple-string string)
572                  (type index start end)
573                  (optimize (speed 3) (space 0) (safety 0) (debug 0)))
574         ;; If there is any input read from UNIX but not
575         ;; supplied to the user of the stream, reposition
576         ;; to the real file position as seen from Lisp.
577         ;; (maybe the caller should do this?)
578         (when (> (fd-stream-ibuf-tail stream)
579                  (fd-stream-ibuf-head stream))
580           (file-position stream (file-position stream)))
581         (let* ((sap (fd-stream-obuf-sap stream))
582                (len (fd-stream-obuf-length stream))
583                (tail (fd-stream-obuf-tail stream)))
584           (declare (type sys:system-area-pointer sap) (type index len tail))
585           (do ((i start))
586               ((>= i end))
587             (declare (type index i))
588             (multiple-value-bind (code widep)
589                 (codepoint string i end)
590               (stream::codepoint-to-octets ,extfmt
591                                            code
592                                            (fd-stream-co-state stream)
593                                            (lambda (byte)
594                                              (when (= tail len)
595                                                (do-output stream sap 0 tail t)
596                                                (setq sap (fd-stream-obuf-sap stream)
597                                                      tail 0))
598                                              (setf (bref sap (1- (incf tail))) byte)))
599               (incf i (if widep 2 1))))
600           (setf (fd-stream-obuf-tail stream) tail))))
601    
602    
603  #-unicode  #-unicode
604  (defun fd-sout (stream thing start end)  (defun fd-sout (stream thing start end)
605    (let ((start (or start 0))    (let ((start (or start 0))
# Line 570  Line 645 
645               ((>= index end))               ((>= index end))
646             (funcall out stream (elt thing index))))))))             (funcall out stream (elt thing index))))))))
647    
 #+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))))))  
   
648  (defmacro output-wrapper ((stream size buffering) &body body)  (defmacro output-wrapper ((stream size buffering) &body body)
649    (let ((stream-var (gensym)))    (let ((stream-var (gensym)))
650      `(let ((,stream-var ,stream))      `(let ((,stream-var ,stream))
# Line 684  Line 748 
748          (ibuf-sap (fd-stream-ibuf-sap stream))          (ibuf-sap (fd-stream-ibuf-sap stream))
749          (buflen (fd-stream-ibuf-length stream))          (buflen (fd-stream-ibuf-length stream))
750          (head (fd-stream-ibuf-head stream))          (head (fd-stream-ibuf-head stream))
751            (lcrs #-unicode 0
752                  #+unicode (fd-stream-last-char-read-size stream))
753          (tail (fd-stream-ibuf-tail stream)))          (tail (fd-stream-ibuf-tail stream)))
754      (declare (type index head tail))      (declare (type index head lcrs tail))
755      (unless (zerop head)      (unless (zerop head)
756        (cond ((eql head tail)        (cond ((eql head tail)
757               (setf head 0)               (setf head lcrs)
758               (setf tail 0)               (setf tail lcrs)
759               (setf (fd-stream-ibuf-head stream) 0)               (setf (fd-stream-ibuf-head stream) lcrs)
760               (setf (fd-stream-ibuf-tail stream) 0))               (setf (fd-stream-ibuf-tail stream) lcrs))
761              (t              (t
762               (decf tail head)               (decf tail (- head lcrs))
763               (system-area-copy ibuf-sap (* head vm:byte-bits)               (system-area-copy ibuf-sap (* (- head lcrs) vm:byte-bits)
764                                 ibuf-sap 0 (* tail vm:byte-bits))                                 ibuf-sap 0 (* tail vm:byte-bits))
765               (setf head 0)               (setf head lcrs)
766               (setf (fd-stream-ibuf-head stream) 0)               (setf (fd-stream-ibuf-head stream) lcrs)
767               (setf (fd-stream-ibuf-tail stream) tail))))               (setf (fd-stream-ibuf-tail stream) tail))))
768      (setf (fd-stream-listen stream) nil)      (setf (fd-stream-listen stream) nil)
769      (multiple-value-bind      (multiple-value-bind
# Line 743  Line 809 
809               (throw 'eof-input-catcher nil))               (throw 'eof-input-catcher nil))
810              (t              (t
811               (incf (fd-stream-ibuf-tail stream) count))))))               (incf (fd-stream-ibuf-tail stream) count))))))
812    
813  ;;; INPUT-AT-LEAST -- internal  ;;; INPUT-AT-LEAST -- internal
814  ;;;  ;;;
815  ;;;   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 827 
827             (return))             (return))
828           (do-input ,stream-var)))))           (do-input ,stream-var)))))
829    
830  ;;; INPUT-WRAPPER -- intenal  ;;; INPUT-WRAPPER -- internal
831  ;;;  ;;;
832  ;;;   Macro to wrap around all input routines to handle eof-error noise.  ;;;   Macro to wrap around all input routines to handle eof-error noise.
833  ;;;  ;;;
# Line 769  Line 835 
835    (let ((stream-var (gensym))    (let ((stream-var (gensym))
836          (element-var (gensym)))          (element-var (gensym)))
837      `(let ((,stream-var ,stream))      `(let ((,stream-var ,stream))
838         (if (fd-stream-unread ,stream-var)         (if (fd-stream-unread ,stream-var) ;;@@
839             (prog1             (prog1
840                 ,(if (eq type 'character)                 ,(if (eq type 'character)
841                      `(fd-stream-unread ,stream-var)                      `(fd-stream-unread ,stream-var)
# Line 859  Line 925 
925                     ((signed-byte 32) 4 sap head)                     ((signed-byte 32) 4 sap head)
926    (signed-sap-ref-32 sap head))    (signed-sap-ref-32 sap head))
927    
928    (stream::def-ef-macro ef-cin (extfmt lisp stream::+ef-max+ stream::+ef-cin+)
929      `(lambda (stream)
930         (declare (type fd-stream stream)
931                  (optimize (speed 3) (space 0) (debug 0) (safety 0)))
932         (catch 'eof-input-catcher
933           (let* ((head (fd-stream-ibuf-head stream))
934                  (ch (stream::octets-to-char ,extfmt
935                                              (fd-stream-oc-state stream)
936                                              (fd-stream-last-char-read-size stream)
937                                              ;;@@ Note: need proper EOF handling...
938                                              (progn
939                                                (when (= head
940                                                         (fd-stream-ibuf-tail
941                                                          stream))
942                                                  (let ((sofar (- head (fd-stream-ibuf-head stream))))
943                                                    (do-input stream)
944                                                    (setf head
945                                                          (+ (fd-stream-ibuf-head stream)
946                                                             sofar))))
947                                                (bref (fd-stream-ibuf-sap stream)
948                                                      (1- (incf head))))
949                                              (lambda (n) (decf head n)))))
950             (declare (type index head))
951             (when ch
952               (incf (fd-stream-ibuf-head stream)
953                     (fd-stream-last-char-read-size stream))
954               ch)))))
955    
956    #+(or)
957    (stream::def-ef-macro ef-sin (extfmt lisp stream::+ef-max+ stream::+ef-sin+)
958      `(lambda (stream string char start end)
959         (declare (type fd-stream stream)
960                  (type simple-string string)
961                  (type (or character null) char)
962                  (type index start end)
963                  (optimize (speed 3) (space 0) (debug 0) (safety 0)))
964         (let ((sap (fd-stream-ibuf-sap stream))
965               (head (fd-stream-ibuf-head stream))
966               (tail (fd-stream-ibuf-tail stream))
967               (curr start))
968           (declare (type sys:system-area-pointer sap)
969                    (type index head tail curr))
970           (loop
971             ;;@@ Fix EOF handling
972             (let* ((sz 0)
973                    (ch (catch 'eof-input-catcher
974                          (stream::octets-to-char ,extfmt
975                                                  (fd-stream-oc-state stream)
976                                                  sz
977                                                  (progn
978                                                    (when (= head tail)
979                                                      (do-input stream)
980                                                      (setq head
981                                                            (fd-stream-ibuf-head
982                                                             stream)
983                                                            tail
984                                                            (fd-stream-ibuf-tail
985                                                             stream)))
986                                                    (bref sap (1- (incf head))))
987                                                  (lambda (n) (decf head n))))))
988               (declare (type index sz)
989                        (type (or null character) ch))
990               (when (null ch)
991                 (return (values (- curr start) :eof)))
992               (setf (fd-stream-last-char-read-size stream) sz)
993               (incf (fd-stream-ibuf-head stream) sz)
994               (when (and char (char= ch char))
995                 (return (values (- curr start) t)))
996               (setf (schar string (1- (incf curr))) ch)
997               (when (= curr end)
998                 (return (values (- curr start) nil))))))))
999    
1000  ;;; PICK-INPUT-ROUTINE -- internal  ;;; PICK-INPUT-ROUTINE -- internal
1001  ;;;  ;;;
1002  ;;;   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 1107 
1107  ;;; FD-STREAM-READ-N-BYTES -- internal  ;;; FD-STREAM-READ-N-BYTES -- internal
1108  ;;;  ;;;
1109  ;;;    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
1110  ;;; 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
1111  ;;; 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
1112  ;;; to be done, so blocking isn't too problematical.  ;;; to be done, so blocking isn't too problematical.
1113  ;;;  ;;;
# Line 996  Line 1134 
1134      ;;      ;;
1135      ;; If something has been unread, put that at buffer + start,      ;; If something has been unread, put that at buffer + start,
1136      ;; and read the rest to start + 1.      ;; and read the rest to start + 1.
1137      (when (fd-stream-unread stream)      (when (fd-stream-unread stream) ;;@@
1138        (etypecase buffer        (etypecase buffer
1139          (system-area-pointer          (system-area-pointer
1140           (assert (= 1 (fd-stream-element-size stream)))           (assert (= 1 (fd-stream-element-size stream)))
# Line 1126  Line 1264 
1264      (when (fd-stream-ibuf-sap stream)      (when (fd-stream-ibuf-sap stream)
1265        (push (fd-stream-ibuf-sap stream) *available-buffers*)        (push (fd-stream-ibuf-sap stream) *available-buffers*)
1266        (setf (fd-stream-ibuf-sap stream) nil))        (setf (fd-stream-ibuf-sap stream) nil))
1267    
1268        #+unicode
1269        (when (null (fd-stream-external-format stream))
1270          (setf (fd-stream-external-format stream) :default))
1271    
1272      (when input-p      (when input-p
1273        (multiple-value-bind        (multiple-value-bind
# Line 1183  Line 1325 
1325                      #'ill-out)                      #'ill-out)
1326                  (fd-stream-bout stream) routine))                  (fd-stream-bout stream) routine))
1327          (setf (fd-stream-sout stream)          (setf (fd-stream-sout stream)
1328                #-unicode                ;;#-unicode
1329                (if (eql size 1) #'fd-sout #'ill-out)                (if (eql size 1) #'fd-sout #'ill-out)
1330                #+unicode                #|#+unicode
1331                (if (eql size 1)                (if (eql size 1)
1332                    #'fd-sout-each-character                    #'fd-sout-each-character
1333                    #'ill-out))                    #'ill-out)|#)
1334          (setf (fd-stream-char-pos stream) 0)          (setf (fd-stream-char-pos stream) 0)
1335          (setf output-size size)          (setf output-size size)
1336          (setf output-type type)))          (setf output-type type)))
1337    
1338      (when (and input-size output-size      (when (and input-size output-size
1339                 (not (eq input-size output-size)))                 (not (eql input-size output-size)))
1340        (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"        (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
1341               input-type input-size               input-type input-size
1342               output-type output-size))               output-type output-size))
# Line 1267  Line 1409 
1409                                               0 0))                                               0 0))
1410                      1))))                      1))))
1411      (:unread      (:unread
1412         #-unicode
1413       (setf (fd-stream-unread stream) arg1)       (setf (fd-stream-unread stream) arg1)
1414         #+unicode
1415         (if (zerop (fd-stream-last-char-read-size stream))
1416             (setf (fd-stream-unread stream) arg1)
1417             (decf (fd-stream-ibuf-head stream)
1418                   (fd-stream-last-char-read-size stream)))
1419         ;; Paul says:
1420         ;;
1421         ;; Not needed for unicode when unreading is implemented by backing up in
1422         ;; the buffer (e.g., with last-char-read-size...)
1423         ;;
1424         ;; (AFAICS there's nothing wrong with setting it there, but it
1425         ;; screws up read-interactive in my toplevel command thing -
1426         ;; leaves it expecting to read arguments when it shouldn't,
1427         ;; because LISTEN returns T when there's no input pending, but I
1428         ;; don't understand why...)
1429         #-unicode
1430       (setf (fd-stream-listen stream) t))       (setf (fd-stream-listen stream) t))
1431      (:close      (:close
1432       (cond (arg1       (cond (arg1
# Line 1294  Line 1453 
1453         (setf (fd-stream-ibuf-sap stream) nil))         (setf (fd-stream-ibuf-sap stream) nil))
1454       (lisp::set-closed-flame stream))       (lisp::set-closed-flame stream))
1455      (:clear-input      (:clear-input
1456       (setf (fd-stream-unread stream) nil)       (setf (fd-stream-unread stream) nil) ;;@@
1457         #+unicode (setf (fd-stream-last-char-read-size stream) 0)
1458       (setf (fd-stream-ibuf-head stream) 0)       (setf (fd-stream-ibuf-head stream) 0)
1459       (setf (fd-stream-ibuf-tail stream) 0)       (setf (fd-stream-ibuf-tail stream) 0)
1460       (catch 'eof-input-catcher       (catch 'eof-input-catcher
# Line 1381  Line 1541 
1541                   ;; unread stuff is still available.                   ;; unread stuff is still available.
1542                   (decf posn (- (fd-stream-ibuf-tail stream)                   (decf posn (- (fd-stream-ibuf-tail stream)
1543                                 (fd-stream-ibuf-head stream)))                                 (fd-stream-ibuf-head stream)))
1544                   (when (fd-stream-unread stream)                   (when (fd-stream-unread stream) ;;@@
1545                     (decf posn))                     (decf posn))
1546                   ;; Divide bytes by element size.                   ;; Divide bytes by element size.
1547                   (truncate posn (fd-stream-element-size stream)))                   (truncate posn (fd-stream-element-size stream)))
# Line 1404  Line 1564 
1564            (system:serve-all-events))            (system:serve-all-events))
1565          ;; 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
1566          ;; disk.          ;; disk.
1567          (setf (fd-stream-unread stream) nil)          (setf (fd-stream-unread stream) nil) ;;@@
1568            #+unicode (setf (fd-stream-last-char-read-size stream) 0)
1569          (setf (fd-stream-ibuf-head stream) 0)          (setf (fd-stream-ibuf-head stream) 0)
1570          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
1571          ;; 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 1618 
1618                                   (format nil "file ~S" file)                                   (format nil "file ~S" file)
1619                                   (format nil "descriptor ~D" fd)))                                   (format nil "descriptor ~D" fd)))
1620                         auto-close                         auto-close
1621                           (external-format :default)
1622                         binary-stream-p)                         binary-stream-p)
1623    (declare (type index fd) (type (or index null) timeout)    (declare (type index fd) (type (or index null) timeout)
1624             (type (member :none :line :full) buffering))             (type (member :none :line :full) buffering))
# Line 1493  Line 1655 
1655                                       :timeout timeout))))                                       :timeout timeout))))
1656      (set-routines stream element-type input output input-buffer-p      (set-routines stream element-type input output input-buffer-p
1657                    :binary-stream-p binary-stream-p)                    :binary-stream-p binary-stream-p)
1658        ;;#-unicode-bootstrap ; fails in stream-reinit otherwise
1659        #+(and unicode (not unicode-bootstrap))
1660        (setf (stream-external-format stream) external-format)
1661      (when (and auto-close (fboundp 'finalize))      (when (and auto-close (fboundp 'finalize))
1662        (finalize stream        (finalize stream
1663                  #'(lambda ()                  #'(lambda ()
# Line 1765  Line 1930 
1930             (type (member :input :output :io :probe) direction)             (type (member :input :output :io :probe) direction)
1931             (type (member :error :new-version :rename :rename-and-delete             (type (member :error :new-version :rename :rename-and-delete
1932                           :overwrite :append :supersede nil) if-exists)                           :overwrite :append :supersede nil) if-exists)
1933             (type (member :error :create nil) if-does-not-exist)             (type (member :error :create nil) if-does-not-exist))
            (ignore external-format))  
1934    (multiple-value-bind (fd namestring original delete-original)    (multiple-value-bind (fd namestring original delete-original)
1935        (fd-open pathname direction if-exists if-exists-given        (fd-open pathname direction if-exists if-exists-given
1936                 if-does-not-exist if-does-not-exist-given)                 if-does-not-exist if-does-not-exist-given)
# Line 1785  Line 1949 
1949                           :pathname pathname                           :pathname pathname
1950                           :input-buffer-p t                           :input-buffer-p t
1951                           :auto-close t                           :auto-close t
1952                             :external-format external-format
1953                           :binary-stream-p class))                           :binary-stream-p class))
1954          (:probe          (:probe
1955           (let ((stream (%make-fd-stream :name namestring :fd fd           (let ((stream (%make-fd-stream :name namestring :fd fd
# Line 1816  Line 1981 
1981     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1982                         :overwrite, :append, :supersede or nil                         :overwrite, :append, :supersede or nil
1983     :if-does-not-exist - one of :error, :create or nil     :if-does-not-exist - one of :error, :create or nil
1984     :external-format - :default     :external-format - an external format name
1985    See the manual for details."    See the manual for details."
1986    (declare (ignore external-format input-handle output-handle))    (declare (ignore element-type external-format input-handle output-handle))
1987    
1988    ;; OPEN signals a file-error if the filename is wild.    ;; OPEN signals a file-error if the filename is wild.
1989    (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.12

  ViewVC Help
Powered by ViewVC 1.1.5