/[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 by rtoy, Mon Nov 5 15:25:03 2007 UTC revision 1.86 by rtoy, Thu Jun 11 16:03:57 2009 UTC
# Line 97  Line 97 
97    (etypecase vector    (etypecase vector
98      ;; (simple-array fixnum (*)) not supported      ;; (simple-array fixnum (*)) not supported
99      ;; (simple-array base-char (*)) treated specially; don't call this      ;; (simple-array base-char (*)) treated specially; don't call this
100      ((simple-array bit (*)) 1)      ((simple-array bit (*)) 1/8)
101      ((simple-array (unsigned-byte 2) (*)) 1)      ((simple-array (unsigned-byte 2) (*)) 1/4)
102      ((simple-array (unsigned-byte 4) (*)) 1)      ((simple-array (unsigned-byte 4) (*)) 1/2)
103      ((simple-array (signed-byte 8) (*)) 1)      ((simple-array (signed-byte 8) (*)) 1)
104      ((simple-array (unsigned-byte 8) (*)) 1)      ((simple-array (unsigned-byte 8) (*)) 1)
105      ((simple-array (signed-byte 16) (*)) 2)      ((simple-array (signed-byte 16) (*)) 2)
# Line 121  Line 121 
121    
122  (defun endian-swap-value (vector endian-swap)  (defun endian-swap-value (vector endian-swap)
123    (case endian-swap    (case endian-swap
124      (:network-order #+big-endian 0      (:network-order
125                      #+little-endian (1- (vector-elt-width vector)))       #+big-endian 0
126         ;; This is needed because the little-endian (x86) architectures
127         ;; store the lowest indexed element in the least significant part
128         ;; of a byte.  On a big-endian machine (sparc, ppc), the lowest
129         ;; indexed element is at the most significant part of a byte.
130         #+little-endian
131         (typecase vector
132           ((array (unsigned-byte 4) (*))
133            -1)
134           ((array (unsigned-byte 2) (*))
135            -2)
136           ((array (unsigned-byte 1) (*))
137            -8)
138           (t
139            (1- (vector-elt-width vector)))))
140      (:byte-8 0)      (:byte-8 0)
141      (:byte-16 1)      (:byte-16 1)
142      (:byte-32 3)      (:byte-32 3)
# Line 130  Line 144 
144      (:byte-128 15)      (:byte-128 15)
145      ;; additions by Lynn Quam      ;; additions by Lynn Quam
146      (:machine-endian 0)      (:machine-endian 0)
147      (:big-endian #+big-endian 0      (:big-endian
148                   #+little-endian (1- (vector-elt-width vector)))       #+big-endian 0
149      (:little-endian #+big-endian (1- (vector-elt-width vector))       #+little-endian
150                      #+little-endian 0)       (typecase vector
151           ((array (unsigned-byte 4) (*))
152            -1)
153           ((array (unsigned-byte 2) (*))
154            -2)
155           ((array (unsigned-byte 1) (*))
156            -8)
157           (t
158            (1- (vector-elt-width vector)))))
159        (:little-endian
160         #+big-endian
161         (typecase vector
162           ((array (unsigned-byte 4) (*))
163            -1)
164           ((array (unsigned-byte 2) (*))
165            -2)
166           ((array (unsigned-byte 1) (*))
167            -8)
168           (t
169            (1- (vector-elt-width vector))))
170         #+little-endian 0)
171      (otherwise endian-swap)))      (otherwise endian-swap)))
172    
173    
# Line 193  Line 227 
227    (timeout nil :type (or index null))    (timeout nil :type (or index null))
228    ;;    ;;
229    ;; Pathname of the file this stream is opened to (returned by PATHNAME.)    ;; Pathname of the file this stream is opened to (returned by PATHNAME.)
230    (pathname nil :type (or pathname null)))    (pathname nil :type (or pathname null))
231      ;;
232      ;; External format support
233      ;;
234      ;; @@ I want to use :default here, but keyword pkg isn't set up yet at boot
235      ;; so initialize to NIL and fix it in SET-ROUTINES
236      #+unicode
237      (external-format nil :type (or null keyword cons))
238      #+unicode
239      (oc-state nil)
240      #+unicode
241      (co-state nil)
242      #+unicode
243      (last-char-read-size 0 :type index))
244    
245  (defun %print-fd-stream (fd-stream stream depth)  (defun %print-fd-stream (fd-stream stream depth)
246    (declare (ignore depth) (stream stream))    (declare (ignore depth) (stream stream))
# Line 363  Line 410 
410                            (:none                            (:none
411                             `(flush-output-buffer stream))                             `(flush-output-buffer stream))
412                            (:line                            (:line
413                             `(when (eq (char-code byte) (char-code #\Newline))                             `(when (eql (char-code byte) (char-code #\Newline))
414                                (flush-output-buffer stream)))                                (flush-output-buffer stream)))
415                            (:full                            (:full
416                             ))                             ))
# Line 379  Line 426 
426                                        (cdr buffering)))))))                                        (cdr buffering)))))))
427            bufferings)))            bufferings)))
428    
429    #-unicode
430  (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"  (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
431                        1                        1
432                        (:none character)                        (:none character)
# Line 390  Line 438 
438    (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))    (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
439          (char-code byte)))          (char-code byte)))
440    
441    #+unicode
442    (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
443                          1
444                          (:none character)
445                          (:line character)
446                          (:full character))
447      (if (char= byte #\Newline)
448          (setf (fd-stream-char-pos stream) 0)
449          (incf (fd-stream-char-pos stream)))
450      ;; FIXME!  We only use the low 8 bits of a character!
451      (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
452            (logand #xff (char-code byte))))
453    
454  (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"  (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
455                        1                        1
456                        (:none (unsigned-byte 8))                        (:none (unsigned-byte 8))
# Line 435  Line 496 
496                             (fd-stream-obuf-tail stream))                             (fd-stream-obuf-tail stream))
497          byte))          byte))
498    
499    (stream::def-ef-macro ef-cout (extfmt lisp stream::+ef-max+ stream::+ef-cout+)
500      `(lambda (stream char)
501         (declare (type fd-stream stream)
502                  (type character char)
503                  (optimize (speed 3) (space 0) (debug 0) (safety 0)))
504         ;; If there is any input read from UNIX but not
505         ;; supplied to the user of the stream, reposition
506         ;; to the real file position as seen from Lisp.
507         (when (> (fd-stream-ibuf-tail stream)
508                  (fd-stream-ibuf-head stream))
509           (file-position stream (file-position stream)))
510         (let* ((sap (fd-stream-obuf-sap stream))
511                (len (fd-stream-obuf-length stream))
512                (tail (fd-stream-obuf-tail stream)))
513           (declare (type sys:system-area-pointer sap) (type index len tail))
514           (stream::char-to-octets ,extfmt
515                                   char
516                                   (fd-stream-co-state stream)
517                                   (lambda (byte)
518                                     (when (= tail len)
519                                       (do-output stream sap 0 tail t)
520                                       (setq sap (fd-stream-obuf-sap stream)
521                                             tail 0))
522                                     (setf (bref sap (1- (incf tail))) byte)))
523           (setf (fd-stream-obuf-tail stream) tail))))
524    
525    
526  ;;; OUTPUT-RAW-BYTES -- public  ;;; OUTPUT-RAW-BYTES -- public
527  ;;;  ;;;
# Line 510  Line 597 
597  ;;;   Note: some bozos (the FASL dumper) call write-string with things other  ;;;   Note: some bozos (the FASL dumper) call write-string with things other
598  ;;; 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
599  ;;; position on it.  ;;; position on it.
600  ;;;  ;;;
601    
602    (stream::def-ef-macro ef-sout (extfmt lisp stream::+ef-max+ stream::+ef-sout+)
603      `(lambda (stream string start end)
604         (declare (type fd-stream stream)
605                  (type simple-string string)
606                  (type index start end)
607                  (optimize (speed 3) (space 0) (safety 0) (debug 0)))
608         ;; If there is any input read from UNIX but not
609         ;; supplied to the user of the stream, reposition
610         ;; to the real file position as seen from Lisp.
611         ;; (maybe the caller should do this?)
612         (when (> (fd-stream-ibuf-tail stream)
613                  (fd-stream-ibuf-head stream))
614           (file-position stream (file-position stream)))
615         (let* ((sap (fd-stream-obuf-sap stream))
616                (len (fd-stream-obuf-length stream))
617                (tail (fd-stream-obuf-tail stream)))
618           (declare (type sys:system-area-pointer sap) (type index len tail))
619           (do ((i start))
620               ((>= i end))
621             (declare (type index i))
622             (multiple-value-bind (code widep)
623                 (codepoint string i end)
624               (stream::codepoint-to-octets ,extfmt
625                                            code
626                                            (fd-stream-co-state stream)
627                                            (lambda (byte)
628                                              (when (= tail len)
629                                                (do-output stream sap 0 tail t)
630                                                (setq sap (fd-stream-obuf-sap stream)
631                                                      tail 0))
632                                              (setf (bref sap (1- (incf tail))) byte)))
633               (incf i (if widep 2 1))))
634           (setf (fd-stream-obuf-tail stream) tail))))
635    
636    
637    #-unicode
638  (defun fd-sout (stream thing start end)  (defun fd-sout (stream thing start end)
639    (let ((start (or start 0))    (let ((start (or start 0))
640          (end (or end (length (the vector thing)))))          (end (or end (length (the vector thing)))))
# Line 542  Line 666 
666            (:none            (:none
667             (do-output stream thing start end nil))))))             (do-output stream thing start end nil))))))
668    
669    #+unicode
670    (defun fd-sout (stream thing start end)
671      (declare (type string thing))
672      (let ((start (or start 0))
673            (end (or end (length (the vector thing)))))
674        (declare (type index start end))
675        (cond
676          ((stringp thing)                  ; FIXME - remove this test
677           (let ((out (fd-stream-out stream)))
678             (do ((index start (+ index 1)))
679                 ((>= index end))
680               (funcall out stream (elt thing index))))))))
681    
682  (defmacro output-wrapper ((stream size buffering) &body body)  (defmacro output-wrapper ((stream size buffering) &body body)
683    (let ((stream-var (gensym)))    (let ((stream-var (gensym)))
684      `(let ((,stream-var ,stream))      `(let ((,stream-var ,stream))
# Line 645  Line 782 
782          (ibuf-sap (fd-stream-ibuf-sap stream))          (ibuf-sap (fd-stream-ibuf-sap stream))
783          (buflen (fd-stream-ibuf-length stream))          (buflen (fd-stream-ibuf-length stream))
784          (head (fd-stream-ibuf-head stream))          (head (fd-stream-ibuf-head stream))
785            (lcrs #-unicode 0
786                  #+unicode (fd-stream-last-char-read-size stream))
787          (tail (fd-stream-ibuf-tail stream)))          (tail (fd-stream-ibuf-tail stream)))
788      (declare (type index head tail))      (declare (type index head lcrs tail))
789      (unless (zerop head)      (unless (zerop head)
790        (cond ((eql head tail)        (cond ((eql head tail)
791               (setf head 0)               (setf head lcrs)
792               (setf tail 0)               (setf tail lcrs)
793               (setf (fd-stream-ibuf-head stream) 0)               (setf (fd-stream-ibuf-head stream) lcrs)
794               (setf (fd-stream-ibuf-tail stream) 0))               (setf (fd-stream-ibuf-tail stream) lcrs))
795              (t              (t
796               (decf tail head)               (decf tail (- head lcrs))
797               (system-area-copy ibuf-sap (* head vm:byte-bits)               (system-area-copy ibuf-sap (* (- head lcrs) vm:byte-bits)
798                                 ibuf-sap 0 (* tail vm:byte-bits))                                 ibuf-sap 0 (* tail vm:byte-bits))
799               (setf head 0)               (setf head lcrs)
800               (setf (fd-stream-ibuf-head stream) 0)               (setf (fd-stream-ibuf-head stream) lcrs)
801               (setf (fd-stream-ibuf-tail stream) tail))))               (setf (fd-stream-ibuf-tail stream) tail))))
802      (setf (fd-stream-listen stream) nil)      (setf (fd-stream-listen stream) nil)
803      (multiple-value-bind      (multiple-value-bind
# Line 704  Line 843 
843               (throw 'eof-input-catcher nil))               (throw 'eof-input-catcher nil))
844              (t              (t
845               (incf (fd-stream-ibuf-tail stream) count))))))               (incf (fd-stream-ibuf-tail stream) count))))))
846    
847  ;;; INPUT-AT-LEAST -- internal  ;;; INPUT-AT-LEAST -- internal
848  ;;;  ;;;
849  ;;;   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 722  Line 861 
861             (return))             (return))
862           (do-input ,stream-var)))))           (do-input ,stream-var)))))
863    
864  ;;; INPUT-WRAPPER -- intenal  ;;; INPUT-WRAPPER -- internal
865  ;;;  ;;;
866  ;;;   Macro to wrap around all input routines to handle eof-error noise.  ;;;   Macro to wrap around all input routines to handle eof-error noise.
867  ;;;  ;;;
# Line 730  Line 869 
869    (let ((stream-var (gensym))    (let ((stream-var (gensym))
870          (element-var (gensym)))          (element-var (gensym)))
871      `(let ((,stream-var ,stream))      `(let ((,stream-var ,stream))
872         (if (fd-stream-unread ,stream-var)         (if (fd-stream-unread ,stream-var) ;;@@
873             (prog1             (prog1
874                 ,(if (eq type 'character)                 ,(if (eq type 'character)
875                      `(fd-stream-unread ,stream-var)                      `(fd-stream-unread ,stream-var)
# Line 820  Line 959 
959                     ((signed-byte 32) 4 sap head)                     ((signed-byte 32) 4 sap head)
960    (signed-sap-ref-32 sap head))    (signed-sap-ref-32 sap head))
961    
962    (stream::def-ef-macro ef-cin (extfmt lisp stream::+ef-max+ stream::+ef-cin+)
963      `(lambda (stream)
964         (declare (type fd-stream stream)
965                  (optimize (speed 3) (space 0) (debug 0) (safety 0)))
966         (catch 'eof-input-catcher
967           (let* ((head (fd-stream-ibuf-head stream))
968                  (ch (stream::octets-to-char ,extfmt
969                                              (fd-stream-oc-state stream)
970                                              (fd-stream-last-char-read-size stream)
971                                              ;;@@ Note: need proper EOF handling...
972                                              (progn
973                                                (when (= head
974                                                         (fd-stream-ibuf-tail
975                                                          stream))
976                                                  (let ((sofar (- head (fd-stream-ibuf-head stream))))
977                                                    (do-input stream)
978                                                    (setf head
979                                                          (+ (fd-stream-ibuf-head stream)
980                                                             sofar))))
981                                                (bref (fd-stream-ibuf-sap stream)
982                                                      (1- (incf head))))
983                                              (lambda (n) (decf head n)))))
984             (declare (type index head))
985             (when ch
986               (incf (fd-stream-ibuf-head stream)
987                     (fd-stream-last-char-read-size stream))
988               ch)))))
989    
990    #+(or)
991    (stream::def-ef-macro ef-sin (extfmt lisp stream::+ef-max+ stream::+ef-sin+)
992      `(lambda (stream string char start end)
993         (declare (type fd-stream stream)
994                  (type simple-string string)
995                  (type (or character null) char)
996                  (type index start end)
997                  (optimize (speed 3) (space 0) (debug 0) (safety 0)))
998         (let ((sap (fd-stream-ibuf-sap stream))
999               (head (fd-stream-ibuf-head stream))
1000               (tail (fd-stream-ibuf-tail stream))
1001               (curr start))
1002           (declare (type sys:system-area-pointer sap)
1003                    (type index head tail curr))
1004           (loop
1005             ;;@@ Fix EOF handling
1006             (let* ((sz 0)
1007                    (ch (catch 'eof-input-catcher
1008                          (stream::octets-to-char ,extfmt
1009                                                  (fd-stream-oc-state stream)
1010                                                  sz
1011                                                  (progn
1012                                                    (when (= head tail)
1013                                                      (do-input stream)
1014                                                      (setq head
1015                                                            (fd-stream-ibuf-head
1016                                                             stream)
1017                                                            tail
1018                                                            (fd-stream-ibuf-tail
1019                                                             stream)))
1020                                                    (bref sap (1- (incf head))))
1021                                                  (lambda (n) (decf head n))))))
1022               (declare (type index sz)
1023                        (type (or null character) ch))
1024               (when (null ch)
1025                 (return (values (- curr start) :eof)))
1026               (setf (fd-stream-last-char-read-size stream) sz)
1027               (incf (fd-stream-ibuf-head stream) sz)
1028               (when (and char (char= ch char))
1029                 (return (values (- curr start) t)))
1030               (setf (schar string (1- (incf curr))) ch)
1031               (when (= curr end)
1032                 (return (values (- curr start) nil))))))))
1033    
1034  ;;; PICK-INPUT-ROUTINE -- internal  ;;; PICK-INPUT-ROUTINE -- internal
1035  ;;;  ;;;
1036  ;;;   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 930  Line 1141 
1141  ;;; FD-STREAM-READ-N-BYTES -- internal  ;;; FD-STREAM-READ-N-BYTES -- internal
1142  ;;;  ;;;
1143  ;;;    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
1144  ;;; 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
1145  ;;; 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
1146  ;;; to be done, so blocking isn't too problematical.  ;;; to be done, so blocking isn't too problematical.
1147  ;;;  ;;;
# Line 957  Line 1168 
1168      ;;      ;;
1169      ;; If something has been unread, put that at buffer + start,      ;; If something has been unread, put that at buffer + start,
1170      ;; and read the rest to start + 1.      ;; and read the rest to start + 1.
1171      (when (fd-stream-unread stream)      (when (fd-stream-unread stream) ;;@@
1172        (etypecase buffer        (etypecase buffer
1173          (system-area-pointer          (system-area-pointer
1174           (assert (= 1 (fd-stream-element-size stream)))           (assert (= 1 (fd-stream-element-size stream)))
# Line 1087  Line 1298 
1298      (when (fd-stream-ibuf-sap stream)      (when (fd-stream-ibuf-sap stream)
1299        (push (fd-stream-ibuf-sap stream) *available-buffers*)        (push (fd-stream-ibuf-sap stream) *available-buffers*)
1300        (setf (fd-stream-ibuf-sap stream) nil))        (setf (fd-stream-ibuf-sap stream) nil))
1301    
1302        #+unicode
1303        (when (null (fd-stream-external-format stream))
1304          (setf (fd-stream-external-format stream) :default))
1305    
1306      (when input-p      (when input-p
1307        (multiple-value-bind        (multiple-value-bind
# Line 1144  Line 1359 
1359                      #'ill-out)                      #'ill-out)
1360                  (fd-stream-bout stream) routine))                  (fd-stream-bout stream) routine))
1361          (setf (fd-stream-sout stream)          (setf (fd-stream-sout stream)
1362                (if (eql size 1) #'fd-sout #'ill-out))                ;;#-unicode
1363                  (if (eql size 1) #'fd-sout #'ill-out)
1364                  #|#+unicode
1365                  (if (eql size 1)
1366                      #'fd-sout-each-character
1367                      #'ill-out)|#)
1368          (setf (fd-stream-char-pos stream) 0)          (setf (fd-stream-char-pos stream) 0)
1369          (setf output-size size)          (setf output-size size)
1370          (setf output-type type)))          (setf output-type type)))
1371    
1372      (when (and input-size output-size      (when (and input-size output-size
1373                 (not (eq input-size output-size)))                 (not (eql input-size output-size)))
1374        (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"        (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
1375               input-type input-size               input-type input-size
1376               output-type output-size))               output-type output-size))
# Line 1223  Line 1443 
1443                                               0 0))                                               0 0))
1444                      1))))                      1))))
1445      (:unread      (:unread
1446         #-unicode
1447       (setf (fd-stream-unread stream) arg1)       (setf (fd-stream-unread stream) arg1)
1448         #+unicode
1449         (if (zerop (fd-stream-last-char-read-size stream))
1450             (setf (fd-stream-unread stream) arg1)
1451             (decf (fd-stream-ibuf-head stream)
1452                   (fd-stream-last-char-read-size stream)))
1453         ;; Paul says:
1454         ;;
1455         ;; Not needed for unicode when unreading is implemented by backing up in
1456         ;; the buffer (e.g., with last-char-read-size...)
1457         ;;
1458         ;; (AFAICS there's nothing wrong with setting it there, but it
1459         ;; screws up read-interactive in my toplevel command thing -
1460         ;; leaves it expecting to read arguments when it shouldn't,
1461         ;; because LISTEN returns T when there's no input pending, but I
1462         ;; don't understand why...)
1463         #-unicode
1464       (setf (fd-stream-listen stream) t))       (setf (fd-stream-listen stream) t))
1465      (:close      (:close
1466       (cond (arg1       (cond (arg1
# Line 1250  Line 1487 
1487         (setf (fd-stream-ibuf-sap stream) nil))         (setf (fd-stream-ibuf-sap stream) nil))
1488       (lisp::set-closed-flame stream))       (lisp::set-closed-flame stream))
1489      (:clear-input      (:clear-input
1490       (setf (fd-stream-unread stream) nil)       (setf (fd-stream-unread stream) nil) ;;@@
1491         #+unicode (setf (fd-stream-last-char-read-size stream) 0)
1492       (setf (fd-stream-ibuf-head stream) 0)       (setf (fd-stream-ibuf-head stream) 0)
1493       (setf (fd-stream-ibuf-tail stream) 0)       (setf (fd-stream-ibuf-tail stream) 0)
1494       (catch 'eof-input-catcher       (catch 'eof-input-catcher
# Line 1337  Line 1575 
1575                   ;; unread stuff is still available.                   ;; unread stuff is still available.
1576                   (decf posn (- (fd-stream-ibuf-tail stream)                   (decf posn (- (fd-stream-ibuf-tail stream)
1577                                 (fd-stream-ibuf-head stream)))                                 (fd-stream-ibuf-head stream)))
1578                   (when (fd-stream-unread stream)                   (when (fd-stream-unread stream) ;;@@
1579                     (decf posn))                     (decf posn))
1580                   ;; Divide bytes by element size.                   ;; Divide bytes by element size.
1581                   (truncate posn (fd-stream-element-size stream)))                   (truncate posn (fd-stream-element-size stream)))
# Line 1360  Line 1598 
1598            (system:serve-all-events))            (system:serve-all-events))
1599          ;; 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
1600          ;; disk.          ;; disk.
1601          (setf (fd-stream-unread stream) nil)          (setf (fd-stream-unread stream) nil) ;;@@
1602            #+unicode (setf (fd-stream-last-char-read-size stream) 0)
1603          (setf (fd-stream-ibuf-head stream) 0)          (setf (fd-stream-ibuf-head stream) 0)
1604          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
1605          ;; Trash cached value for listen, so that we check next time.          ;; Trash cached value for listen, so that we check next time.
# Line 1413  Line 1652 
1652                                   (format nil "file ~S" file)                                   (format nil "file ~S" file)
1653                                   (format nil "descriptor ~D" fd)))                                   (format nil "descriptor ~D" fd)))
1654                         auto-close                         auto-close
1655                           (external-format :default)
1656                         binary-stream-p)                         binary-stream-p)
1657    (declare (type index fd) (type (or index null) timeout)    (declare (type index fd) (type (or index null) timeout)
1658             (type (member :none :line :full) buffering))             (type (member :none :line :full) buffering))
# Line 1449  Line 1689 
1689                                       :timeout timeout))))                                       :timeout timeout))))
1690      (set-routines stream element-type input output input-buffer-p      (set-routines stream element-type input output input-buffer-p
1691                    :binary-stream-p binary-stream-p)                    :binary-stream-p binary-stream-p)
1692        ;;#-unicode-bootstrap ; fails in stream-reinit otherwise
1693        #+(and unicode (not unicode-bootstrap))
1694        (setf (stream-external-format stream) external-format)
1695      (when (and auto-close (fboundp 'finalize))      (when (and auto-close (fboundp 'finalize))
1696        (finalize stream        (finalize stream
1697                  #'(lambda ()                  #'(lambda ()
# Line 1721  Line 1964 
1964             (type (member :input :output :io :probe) direction)             (type (member :input :output :io :probe) direction)
1965             (type (member :error :new-version :rename :rename-and-delete             (type (member :error :new-version :rename :rename-and-delete
1966                           :overwrite :append :supersede nil) if-exists)                           :overwrite :append :supersede nil) if-exists)
1967             (type (member :error :create nil) if-does-not-exist)             (type (member :error :create nil) if-does-not-exist))
            (ignore external-format))  
1968    (multiple-value-bind (fd namestring original delete-original)    (multiple-value-bind (fd namestring original delete-original)
1969        (fd-open pathname direction if-exists if-exists-given        (fd-open pathname direction if-exists if-exists-given
1970                 if-does-not-exist if-does-not-exist-given)                 if-does-not-exist if-does-not-exist-given)
# Line 1741  Line 1983 
1983                           :pathname pathname                           :pathname pathname
1984                           :input-buffer-p t                           :input-buffer-p t
1985                           :auto-close t                           :auto-close t
1986                             :external-format external-format
1987                           :binary-stream-p class))                           :binary-stream-p class))
1988          (:probe          (:probe
1989           (let ((stream (%make-fd-stream :name namestring :fd fd           (let ((stream (%make-fd-stream :name namestring :fd fd
# Line 1772  Line 2015 
2015     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
2016                         :overwrite, :append, :supersede or nil                         :overwrite, :append, :supersede or nil
2017     :if-does-not-exist - one of :error, :create or nil     :if-does-not-exist - one of :error, :create or nil
2018     :external-format - :default     :external-format - an external format name
2019    See the manual for details."    See the manual for details."
2020    (declare (ignore external-format input-handle output-handle))    (declare (ignore element-type external-format input-handle output-handle))
2021    
2022    ;; OPEN signals a file-error if the filename is wild.    ;; OPEN signals a file-error if the filename is wild.
2023    (when (wild-pathname-p filename)    (when (wild-pathname-p filename)

Legend:
Removed from v.1.85  
changed lines
  Added in v.1.86

  ViewVC Help
Powered by ViewVC 1.1.5