/[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.81.2.2 by rtoy, Mon Dec 19 01:09:50 2005 UTC revision 1.125 by rtoy, Wed Jun 29 00:55:04 2011 UTC
# Line 19  Line 19 
19    
20  (in-package "SYSTEM")  (in-package "SYSTEM")
21    
22    (intl:textdomain "cmucl")
23    
24  (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream  (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
25            io-timeout beep *beep-function* output-raw-bytes            io-timeout beep *beep-function* output-raw-bytes
26            *tty* *stdin* *stdout* *stderr*            *tty* *stdin* *stdout* *stderr*
# Line 41  Line 43 
43    "List of available buffers.  Each buffer is an sap pointing to    "List of available buffers.  Each buffer is an sap pointing to
44    bytes-per-buffer of memory.")    bytes-per-buffer of memory.")
45    
46    (defvar lisp::*enable-stream-buffer-p* nil)
47    
48  (defconstant bytes-per-buffer (* 4 1024)  (defconstant bytes-per-buffer (* 4 1024)
49    "Number of bytes per buffer.")    "Number of bytes per buffer.")
50    
# Line 59  Line 63 
63        (pop *available-buffers*)        (pop *available-buffers*)
64        (allocate-system-memory bytes-per-buffer)))        (allocate-system-memory bytes-per-buffer)))
65    
66    (declaim (inline buffer-sap bref (setf bref) buffer-copy))
67    
68    (defun buffer-sap (thing &optional offset)
69      (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
70               (optimize (speed 3) (space 2) (debug 0) (safety 0)
71                         ;; Suppress the note about having to box up the return:
72                         (ext:inhibit-warnings 3)))
73      (let ((sap (if (vectorp thing) (sys:vector-sap thing) thing)))
74        (if offset (sys:sap+ sap offset) sap)))
75    
76    (defun bref (buffer index)
77      (declare (type simple-stream-buffer buffer)
78               (type (integer 0 #.most-positive-fixnum) index))
79      (sys:sap-ref-8 (buffer-sap buffer) index))
80    
81    (defun (setf bref) (octet buffer index)
82      (declare (type (unsigned-byte 8) octet)
83               (type simple-stream-buffer buffer)
84               (type (integer 0 #.most-positive-fixnum) index))
85      (setf (sys:sap-ref-8 (buffer-sap buffer) index) octet))
86    
87    (defun buffer-copy (src soff dst doff length)
88      (declare (type simple-stream-buffer src dst)
89               (type fixnum soff doff length))
90      (sys:without-gcing ;; is this necessary??
91       (kernel:system-area-copy (buffer-sap src) (* soff 8)
92                                (buffer-sap dst) (* doff 8)
93                                (* length 8))))
94    
95    #-(or big-endian little-endian)
96    (eval-when (:compile-toplevel)
97      (push (c::backend-byte-order c::*target-backend*) *features*))
98    
99    (defun vector-elt-width (vector)
100      ;; Return octet-width of vector elements
101      (etypecase vector
102        ;; (simple-array fixnum (*)) not supported
103        ;; (simple-array base-char (*)) treated specially; don't call this
104        ((simple-array bit (*)) 1/8)
105        ((simple-array (unsigned-byte 2) (*)) 1/4)
106        ((simple-array (unsigned-byte 4) (*)) 1/2)
107        ((simple-array (signed-byte 8) (*)) 1)
108        ((simple-array (unsigned-byte 8) (*)) 1)
109        ((simple-array (signed-byte 16) (*)) 2)
110        ((simple-array (unsigned-byte 16) (*)) 2)
111        ((simple-array (signed-byte 32) (*)) 4)
112        ((simple-array (unsigned-byte 32) (*)) 4)
113        ((simple-array single-float (*)) 4)
114        ((simple-array double-float (*)) 8)
115        ((simple-array (complex single-float) (*)) 8)
116        ((simple-array (complex double-float) (*)) 16)
117        #+long-float
118        ((simple-array long-float (*)) 10)
119        #+long-float
120        ((simple-array (complex long-float) (*)) 20)
121        #+double-double
122        ((simple-array double-double-float (*)) 16)
123        #+double-double
124        ((simple-array (complex double-double-float) (*)) 32)))
125    
126    (defun endian-swap-value (vector endian-swap)
127      (case endian-swap
128        (:network-order
129         #+big-endian 0
130         ;; This is needed because the little-endian (x86) architectures
131         ;; store the lowest indexed element in the least significant part
132         ;; of a byte.  On a big-endian machine (sparc, ppc), the lowest
133         ;; indexed element is at the most significant part of a byte.
134         #+little-endian
135         (typecase vector
136           ((array (unsigned-byte 4) (*))
137            -1)
138           ((array (unsigned-byte 2) (*))
139            -2)
140           ((array (unsigned-byte 1) (*))
141            -8)
142           (t
143            (1- (vector-elt-width vector)))))
144        (:byte-8 0)
145        (:byte-16 1)
146        (:byte-32 3)
147        (:byte-64 7)
148        (:byte-128 15)
149        ;; additions by Lynn Quam
150        (:machine-endian 0)
151        (:big-endian
152         #+big-endian 0
153         #+little-endian
154         (typecase vector
155           ((array (unsigned-byte 4) (*))
156            -1)
157           ((array (unsigned-byte 2) (*))
158            -2)
159           ((array (unsigned-byte 1) (*))
160            -8)
161           (t
162            (1- (vector-elt-width vector)))))
163        (:little-endian
164         #+big-endian
165         (typecase vector
166           ((array (unsigned-byte 4) (*))
167            -1)
168           ((array (unsigned-byte 2) (*))
169            -2)
170           ((array (unsigned-byte 1) (*))
171            -8)
172           (t
173            (1- (vector-elt-width vector))))
174         #+little-endian 0)
175        (otherwise endian-swap)))
176    
177    
178  ;;;; The FD-STREAM structure.  ;;;; The FD-STREAM structure.
179    
# Line 116  Line 231 
231    (timeout nil :type (or index null))    (timeout nil :type (or index null))
232    ;;    ;;
233    ;; Pathname of the file this stream is opened to (returned by PATHNAME.)    ;; Pathname of the file this stream is opened to (returned by PATHNAME.)
234    (pathname nil :type (or pathname null)))    (pathname nil :type (or pathname null))
235      ;;
236      ;; External format support
237      ;;
238      ;; @@ I want to use :default here, but keyword pkg isn't set up yet at boot
239      ;; so initialize to NIL and fix it in SET-ROUTINES
240      #+unicode
241      (external-format nil :type (or null keyword cons))
242      ;;
243      ;; State for octets-to-char (for reading from a stream).  The
244      ;; contents of the state can be anything and is defined by the
245      ;; external format.
246      #+unicode
247      (oc-state nil)
248      ;;
249      ;; State for char-to-octets (for writing to a stream).  The contents
250      ;; of the state can be anything and is defined by the external
251      ;; format.  If not NIL, then the CAR is used by char-to-octets to
252      ;; hold some state information, and the CDR is available to the
253      ;; external format to hold whatever state information is needed.
254      #+unicode
255      (co-state nil)
256      #+unicode
257      (last-char-read-size 0 :type index)
258      ;;
259      ;; The number of octets in in-buffer.  Normally equal to
260      ;; in-buffer-length, but could be less if we reached the
261      ;; end-of-file.
262      #+unicode
263      (in-length 0 :type index)
264      ;;
265      ;; Indicates how to handle errors when converting octets to
266      ;; characters.  If NIL, then the external format should handle it
267      ;; itself, doing whatever is deemed appropriate.  If non-NIL, this
268      ;; should be a function (or symbol) that the external format can
269      ;; funcall to deal with the error.  The function should take three
270      ;; arguments: a message string, the offending octet, and the number
271      ;; of octets read so far in decoding; if the function returns it
272      ;; should return the codepoint of the desired replacement character.
273      (octets-to-char-error nil :type (or null symbol function))
274      ;;
275      ;; Like OCTETS-TO-CHAR-ERROR, but for converting characters to
276      ;; octets for output.  The function takes two arguments: a message
277      ;; string and the codepoint that cannot be converted.  The function
278      ;; should return the octet that should be output.
279      (char-to-octets-error nil :type (or null symbol function)))
280    
281  (defun %print-fd-stream (fd-stream stream depth)  (defun %print-fd-stream (fd-stream stream depth)
282    (declare (ignore depth) (stream stream))    (declare (ignore depth) (stream stream))
# Line 140  Line 300 
300    (:report    (:report
301     (lambda (condition stream)     (lambda (condition stream)
302       (declare (stream stream))       (declare (stream stream))
303       (format stream "Timeout ~(~A~)ing ~S."       (format stream (intl:gettext "Timeout ~(~A~)ing ~S.")
304               (io-timeout-direction condition)               (io-timeout-direction condition)
305               (stream-error-stream condition)))))               (stream-error-stream condition)))))
306    
# Line 174  Line 334 
334                           length)                           length)
335        (cond ((not count)        (cond ((not count)
336               (if (= errno unix:ewouldblock)               (if (= errno unix:ewouldblock)
337                   (error "Write would have blocked, but SERVER told us to go.")                   (error (intl:gettext "Write would have blocked, but SERVER told us to go."))
338                   (error "While writing ~S: ~A"                   (error (intl:gettext "While writing ~S: ~A")
339                          stream (unix:get-unix-error-msg errno))))                          stream (unix:get-unix-error-msg errno))))
340              ((eql count length) ; Hot damn, it worked.              ((eql count length) ; Hot damn, it worked.
341               (when reuse-sap               (when reuse-sap
# Line 241  Line 401 
401                   (output-later stream base (the index (+ start count))                   (output-later stream base (the index (+ start count))
402                                 end reuse-sap)))))))                                 end reuse-sap)))))))
403    
404    #+unicode
405    (stream::def-ef-macro ef-flush (extfmt lisp stream::+ef-max+ stream::+ef-flush+)
406      `(lambda (stream)
407         (declare (type fd-stream stream))
408         (let* ((tail (fd-stream-obuf-tail stream)))
409           (declare (type index tail))
410           (cond
411             ((stream::ef-flush-state ,(stream::find-external-format extfmt))
412              (let* ((sap (fd-stream-obuf-sap stream))
413                     (len (fd-stream-obuf-length stream)))
414                (declare (type sys:system-area-pointer sap)
415                         (type index len)
416                         (ignorable sap len))
417                (stream::flush-state ,extfmt
418                                     (fd-stream-co-state stream)
419                                     (lambda (byte)
420                                       (when (= tail len)
421                                         (do-output stream sap 0 tail t)
422                                         (setq sap (fd-stream-obuf-sap stream)
423                                               tail 0))
424                                       (setf (bref sap (1- (incf tail))) byte))
425                                     (fd-stream-char-to-octets-error stream))
426                (setf (fd-stream-obuf-tail stream) tail)))
427             (t
428              ;; No flush-state function, so just output a replacement
429              ;; character (or signal an error).  We hack the co-state to
430              ;; what we need for this to work.  This should be ok because
431              ;; we're closing the file anyway.
432              (let* ((state (fd-stream-co-state stream))
433                     (c (car state)))
434                (when (and state c)
435                  (setf (fd-stream-co-state stream)
436                        (cons nil (cdr state)))
437                  (funcall (ef-cout (fd-stream-external-format stream))
438                           stream
439                           ;; Handle bare surrogates or use the
440                           ;; replacement character.
441                           (if (lisp::surrogatep c)
442                               (if (fd-stream-char-to-octets-error stream)
443                                   (funcall (fd-stream-char-to-octets-error stream)
444                                            "Flushing bare surrogate #x~4,0X is illegal"
445                                            (char-code c))
446                                   (code-char stream:+replacement-character-code+))
447                               c))))))
448           (values))))
449    
450  ;;; FLUSH-OUTPUT-BUFFER -- internal  ;;; FLUSH-OUTPUT-BUFFER -- internal
451  ;;;  ;;;
452  ;;;   Flush any data in the output buffer.  ;;;   Flush any data in the output buffer.
# Line 286  Line 491 
491                            (:none                            (:none
492                             `(flush-output-buffer stream))                             `(flush-output-buffer stream))
493                            (:line                            (:line
494                             `(when (eq (char-code byte) (char-code #\Newline))                             `(when (eql (char-code byte) (char-code #\Newline))
495                                (flush-output-buffer stream)))                                (flush-output-buffer stream)))
496                            (:full                            (:full
497                             ))                             ))
# Line 302  Line 507 
507                                        (cdr buffering)))))))                                        (cdr buffering)))))))
508            bufferings)))            bufferings)))
509    
510    #-unicode
511  (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"  (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
512                        1                        1
513                        (:none character)                        (:none character)
# Line 313  Line 519 
519    (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))
520          (char-code byte)))          (char-code byte)))
521    
522    #+unicode
523    (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
524                          1
525                          (:none character)
526                          (:line character)
527                          (:full character))
528      (if (char= byte #\Newline)
529          (setf (fd-stream-char-pos stream) 0)
530          (incf (fd-stream-char-pos stream)))
531      ;; FIXME!  We only use the low 8 bits of a character!
532      (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
533            (logand #xff (char-code byte))))
534    
535  (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"  (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
536                        1                        1
537                        (:none (unsigned-byte 8))                        (:none (unsigned-byte 8))
# Line 358  Line 577 
577                             (fd-stream-obuf-tail stream))                             (fd-stream-obuf-tail stream))
578          byte))          byte))
579    
580    (stream::def-ef-macro ef-cout (extfmt lisp stream::+ef-max+ stream::+ef-cout+)
581      `(lambda (stream char)
582         (declare (type fd-stream stream)
583                  (type character char)
584                  (optimize (speed 3) (space 0) (debug 0) (safety 0)))
585         ;; If there is any input read from UNIX but not
586         ;; supplied to the user of the stream, reposition
587         ;; to the real file position as seen from Lisp.
588         (when (> (fd-stream-ibuf-tail stream)
589                  (fd-stream-ibuf-head stream))
590           (file-position stream (file-position stream)))
591         (let* ((sap (fd-stream-obuf-sap stream))
592                (len (fd-stream-obuf-length stream))
593                (tail (fd-stream-obuf-tail stream)))
594           (declare (type sys:system-area-pointer sap) (type index len tail))
595           (stream::char-to-octets ,extfmt
596                                   char
597                                   (fd-stream-co-state stream)
598                                   (lambda (byte)
599                                     (when (= tail len)
600                                       (do-output stream sap 0 tail t)
601                                       (setq sap (fd-stream-obuf-sap stream)
602                                             tail 0))
603                                     (setf (bref sap (1- (incf tail))) byte))
604                                   (fd-stream-char-to-octets-error stream))
605           (setf (fd-stream-obuf-tail stream) tail))
606        (if (char= char #\Newline)
607            (setf (fd-stream-char-pos stream) 0)
608            (incf (fd-stream-char-pos stream)))
609        (ecase (fd-stream-buffering stream)
610          (:none (flush-output-buffer stream))
611          (:line (when (char= char #\Newline) (flush-output-buffer stream)))
612          (:full #| do nothing |#))
613        (values)))
614    
615    
616  ;;; OUTPUT-RAW-BYTES -- public  ;;; OUTPUT-RAW-BYTES -- public
617  ;;;  ;;;
# Line 386  Line 640 
640             (bytes (- end start))             (bytes (- end start))
641             (newtail (+ tail bytes)))             (newtail (+ tail bytes)))
642        (cond ((minusp bytes) ; Error case        (cond ((minusp bytes) ; Error case
643               (cerror "Just go on as if nothing happened..."               (cerror (intl:gettext "Just go on as if nothing happened...")
644                       "~S called with :END before :START!"                       (intl:gettext "~S called with :END before :START!")
645                       'output-raw-bytes))                       'output-raw-bytes))
646              ((zerop bytes)) ; Easy case              ((zerop bytes)) ; Easy case
647              ((<= bytes space)              ((<= bytes space)
# Line 433  Line 687 
687  ;;;   Note: some bozos (the FASL dumper) call write-string with things other  ;;;   Note: some bozos (the FASL dumper) call write-string with things other
688  ;;; 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
689  ;;; position on it.  ;;; position on it.
690  ;;;  ;;;
691    
692    (stream::def-ef-macro ef-sout (extfmt lisp stream::+ef-max+ stream::+ef-sout+)
693      `(lambda (stream string start end)
694         (declare (type fd-stream stream)
695                  (type simple-string string)
696                  (type index start end)
697                  (optimize (speed 3) (space 0) (safety 0) (debug 0)))
698         ;; If there is any input read from UNIX but not
699         ;; supplied to the user of the stream, reposition
700         ;; to the real file position as seen from Lisp.
701         ;; (maybe the caller should do this?)
702         (when (> (fd-stream-ibuf-tail stream)
703                  (fd-stream-ibuf-head stream))
704           (file-position stream (file-position stream)))
705         (let* ((sap (fd-stream-obuf-sap stream))
706                (len (fd-stream-obuf-length stream))
707                (tail (fd-stream-obuf-tail stream)))
708           (declare (type sys:system-area-pointer sap) (type index len tail))
709           (dotimes (i (- end start))
710             (stream::char-to-octets ,extfmt
711                                     (schar string (+ i start))
712                                     (fd-stream-co-state stream)
713                                     (lambda (byte)
714                                       (when (= tail len)
715                                         (do-output stream sap 0 tail t)
716                                         (setq sap (fd-stream-obuf-sap stream)
717                                               tail 0))
718                                       (setf (bref sap (1- (incf tail))) byte))
719                                     (fd-stream-char-to-octets-error stream)))
720           (setf (fd-stream-obuf-tail stream) tail))))
721    
722    
723    #-unicode
724  (defun fd-sout (stream thing start end)  (defun fd-sout (stream thing start end)
725    (let ((start (or start 0))    (let ((start (or start 0))
726          (end (or end (length (the vector thing)))))          (end (or end (length (the vector thing)))))
# Line 465  Line 752 
752            (:none            (:none
753             (do-output stream thing start end nil))))))             (do-output stream thing start end nil))))))
754    
755    #+unicode
756    ;; Temporary.  The final version is defined in fd-stream-extfmt.lisp
757    (defun fd-sout (stream thing start end)
758      (declare (type string thing))
759      (let ((start (or start 0))
760            (end (or end (length (the vector thing)))))
761        (declare (type index start end))
762        (cond
763          ((stringp thing)                  ; FIXME - remove this test
764           (let ((out (fd-stream-out stream)))
765             (do ((index start (+ index 1)))
766                 ((>= index end))
767               (funcall out stream (elt thing index))))))))
768    
769  (defmacro output-wrapper ((stream size buffering) &body body)  (defmacro output-wrapper ((stream size buffering) &body body)
770    (let ((stream-var (gensym)))    (let ((stream-var (gensym)))
771      `(let ((,stream-var ,stream))      `(let ((,stream-var ,stream))
# Line 568  Line 869 
869          (ibuf-sap (fd-stream-ibuf-sap stream))          (ibuf-sap (fd-stream-ibuf-sap stream))
870          (buflen (fd-stream-ibuf-length stream))          (buflen (fd-stream-ibuf-length stream))
871          (head (fd-stream-ibuf-head stream))          (head (fd-stream-ibuf-head stream))
872            (lcrs #-unicode 0
873                  #+unicode (fd-stream-last-char-read-size stream))
874          (tail (fd-stream-ibuf-tail stream)))          (tail (fd-stream-ibuf-tail stream)))
875      (declare (type index head tail))      (declare (type index head lcrs tail))
876      (unless (zerop head)      (unless (zerop head)
877        (cond ((eql head tail)        (cond ((eql head tail)
878               (setf head 0)               (setf head lcrs)
879               (setf tail 0)               (setf tail lcrs)
880               (setf (fd-stream-ibuf-head stream) 0)               (setf (fd-stream-ibuf-head stream) lcrs)
881               (setf (fd-stream-ibuf-tail stream) 0))               (setf (fd-stream-ibuf-tail stream) lcrs))
882              (t              (t
883               (decf tail head)               (decf tail (- head lcrs))
884               (system-area-copy ibuf-sap (* head vm:byte-bits)               (system-area-copy ibuf-sap (* (- head lcrs) vm:byte-bits)
885                                 ibuf-sap 0 (* tail vm:byte-bits))                                 ibuf-sap 0 (* tail vm:byte-bits))
886               (setf head 0)               (setf head lcrs)
887               (setf (fd-stream-ibuf-head stream) 0)               (setf (fd-stream-ibuf-head stream) lcrs)
888               (setf (fd-stream-ibuf-tail stream) tail))))               (setf (fd-stream-ibuf-tail stream) tail))))
889      (setf (fd-stream-listen stream) nil)      (setf (fd-stream-listen stream) nil)
890      (multiple-value-bind      (multiple-value-bind
# Line 619  Line 922 
922                             :format-arguments (list (unix:get-unix-error-msg errno))                             :format-arguments (list (unix:get-unix-error-msg errno))
923                             :errno errno))                             :errno errno))
924                     (t                     (t
925                      (error "Error reading ~S: ~A"                      (error (intl:gettext "Error reading ~S: ~A")
926                             stream                             stream
927                             (unix:get-unix-error-msg errno)))))                             (unix:get-unix-error-msg errno)))))
928              ((zerop count)              ((zerop count)
# Line 627  Line 930 
930               (throw 'eof-input-catcher nil))               (throw 'eof-input-catcher nil))
931              (t              (t
932               (incf (fd-stream-ibuf-tail stream) count))))))               (incf (fd-stream-ibuf-tail stream) count))))))
933    
934  ;;; INPUT-AT-LEAST -- internal  ;;; INPUT-AT-LEAST -- internal
935  ;;;  ;;;
936  ;;;   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 645  Line 948 
948             (return))             (return))
949           (do-input ,stream-var)))))           (do-input ,stream-var)))))
950    
951  ;;; INPUT-WRAPPER -- intenal  ;;; INPUT-WRAPPER -- internal
952  ;;;  ;;;
953  ;;;   Macro to wrap around all input routines to handle eof-error noise.  ;;;   Macro to wrap around all input routines to handle eof-error noise.
954  ;;;  ;;;
# Line 653  Line 956 
956    (let ((stream-var (gensym))    (let ((stream-var (gensym))
957          (element-var (gensym)))          (element-var (gensym)))
958      `(let ((,stream-var ,stream))      `(let ((,stream-var ,stream))
959         (if (fd-stream-unread ,stream-var)         (if (fd-stream-unread ,stream-var) ;;@@
960             (prog1             (prog1
961                 ,(if (eq type 'character)                 ,(if (eq type 'character)
962                      `(fd-stream-unread ,stream-var)                      `(fd-stream-unread ,stream-var)
# Line 743  Line 1046 
1046                     ((signed-byte 32) 4 sap head)                     ((signed-byte 32) 4 sap head)
1047    (signed-sap-ref-32 sap head))    (signed-sap-ref-32 sap head))
1048    
1049    (stream::def-ef-macro ef-cin (extfmt lisp stream::+ef-max+ stream::+ef-cin+)
1050      `(lambda (stream eof-error-p eof-value)
1051         (declare (type fd-stream stream)
1052                  #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#)
1053         (let* ((head (fd-stream-ibuf-head stream))
1054                (ch (catch 'eof-input-catcher
1055                      (stream::octets-to-char ,extfmt
1056                                  (fd-stream-oc-state stream)
1057                                  (fd-stream-last-char-read-size stream)
1058                                  ;;@@ Note: need proper EOF handling...
1059                                  (progn
1060                                    (when (= head (fd-stream-ibuf-tail stream))
1061                                      (let ((sofar (- head (fd-stream-ibuf-head
1062                                                            stream))))
1063                                        (do-input stream)
1064                                        (setf head (+ (fd-stream-ibuf-head stream)
1065                                                      sofar))))
1066                                    (bref (fd-stream-ibuf-sap stream)
1067                                          (1- (incf head))))
1068                                  (lambda (n) (decf head n))))))
1069           (declare (type index head))
1070           (if ch
1071               (progn
1072                 (setf (fd-stream-ibuf-head stream) head)
1073                 ch)
1074               (eof-or-lose stream eof-error-p eof-value)))))
1075    
1076    #+(or)
1077    (stream::def-ef-macro ef-sin (extfmt lisp stream::+ef-max+ stream::+ef-sin+)
1078      `(lambda (stream string char start end)
1079         (declare (type fd-stream stream)
1080                  (type simple-string string)
1081                  (type (or character null) char)
1082                  (type index start end)
1083                  (optimize (speed 3) (space 0) (debug 0) (safety 0)))
1084         (let ((sap (fd-stream-ibuf-sap stream))
1085               (head (fd-stream-ibuf-head stream))
1086               (tail (fd-stream-ibuf-tail stream))
1087               (curr start))
1088           (declare (type sys:system-area-pointer sap)
1089                    (type index head tail curr))
1090           (loop
1091             ;;@@ Fix EOF handling
1092             (let* ((sz 0)
1093                    (ch (catch 'eof-input-catcher
1094                          (stream::octets-to-char ,extfmt
1095                                      (fd-stream-oc-state stream)
1096                                      sz
1097                                      (progn
1098                                        (when (= head tail)
1099                                          (let ((sofar (- head
1100                                                          (fd-stream-ibuf-head
1101                                                           stream))))
1102                                            (do-input stream)
1103                                            (setq head
1104                                                  (+ (fd-stream-ibuf-head
1105                                                      stream)
1106                                                     sofar)
1107                                                tail
1108                                                (fd-stream-ibuf-tail
1109                                                 stream))))
1110                                        (bref sap (1- (incf head))))
1111                                      (lambda (n) (decf head n))))))
1112               (declare (type index sz)
1113                        (type (or null character) ch))
1114               (when (null ch)
1115                 (return (values (- curr start) :eof)))
1116               (setf (fd-stream-last-char-read-size stream) sz)
1117               (incf (fd-stream-ibuf-head stream) sz)
1118               (when (and char (char= ch char))
1119                 (return (values (- curr start) t)))
1120               (setf (schar string (1- (incf curr))) ch)
1121               (when (= curr end)
1122                 (return (values (- curr start) nil))))))))
1123    
1124  ;;; PICK-INPUT-ROUTINE -- internal  ;;; PICK-INPUT-ROUTINE -- internal
1125  ;;;  ;;;
1126  ;;;   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 853  Line 1231 
1231  ;;; FD-STREAM-READ-N-BYTES -- internal  ;;; FD-STREAM-READ-N-BYTES -- internal
1232  ;;;  ;;;
1233  ;;;    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
1234  ;;; 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
1235  ;;; 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
1236  ;;; to be done, so blocking isn't too problematical.  ;;; to be done, so blocking isn't too problematical.
1237  ;;;  ;;;
# Line 880  Line 1258 
1258      ;;      ;;
1259      ;; If something has been unread, put that at buffer + start,      ;; If something has been unread, put that at buffer + start,
1260      ;; and read the rest to start + 1.      ;; and read the rest to start + 1.
1261      (when (fd-stream-unread stream)      (when (fd-stream-unread stream) ;;@@
1262        (etypecase buffer        (etypecase buffer
1263          (system-area-pointer          (system-area-pointer
1264           (assert (= 1 (fd-stream-element-size stream)))           (assert (= 1 (fd-stream-element-size stream)))
# Line 934  Line 1312 
1312                                    now-needed)                                    now-needed)
1313                  (declare (type (or index null) count))                  (declare (type (or index null) count))
1314                  (unless count                  (unless count
1315                    (error "Error reading ~S: ~A" stream                    (error (intl:gettext "Error reading ~S: ~A") stream
1316                           (unix:get-unix-error-msg err)))                           (unix:get-unix-error-msg err)))
1317                  (decf now-needed count)                  (decf now-needed count)
1318                  (if eof-error-p                  (if eof-error-p
# Line 954  Line 1332 
1332                  (unix:unix-read (fd-stream-fd stream) sap len)                  (unix:unix-read (fd-stream-fd stream) sap len)
1333                (declare (type (or index null) count))                (declare (type (or index null) count))
1334                (unless count                (unless count
1335                  (error "Error reading ~S: ~A" stream                  (error (intl:gettext "Error reading ~S: ~A") stream
1336                         (unix:get-unix-error-msg err)))                         (unix:get-unix-error-msg err)))
1337                (when (and eof-error-p (zerop count))                (when (and eof-error-p (zerop count))
1338                  (error 'end-of-file :stream stream))                  (error 'end-of-file :stream stream))
# Line 1010  Line 1388 
1388      (when (fd-stream-ibuf-sap stream)      (when (fd-stream-ibuf-sap stream)
1389        (push (fd-stream-ibuf-sap stream) *available-buffers*)        (push (fd-stream-ibuf-sap stream) *available-buffers*)
1390        (setf (fd-stream-ibuf-sap stream) nil))        (setf (fd-stream-ibuf-sap stream) nil))
1391    
1392        #+unicode
1393        (when (null (fd-stream-external-format stream))
1394          (setf (fd-stream-external-format stream) :default))
1395    
1396      (when input-p      (when input-p
1397        (multiple-value-bind        (multiple-value-bind
1398            (routine type size)            (routine type size)
1399            (pick-input-routine target-type)            (pick-input-routine target-type)
1400          (unless routine          (unless routine
1401            (error "Could not find any input routine for ~S" target-type))            (error (intl:gettext "Could not find any input routine for ~S") target-type))
1402          (setf (fd-stream-ibuf-sap stream) (next-available-buffer))          (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
1403          (setf (fd-stream-ibuf-length stream) bytes-per-buffer)          (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
1404          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
1405    
1406            ;; Set the in and bin methods.  Normally put an illegal input
1407            ;; function in, but if we have a binary text stream, pick an
1408            ;; appropriate input routine.
1409          (if (subtypep type 'character)          (if (subtypep type 'character)
1410              (setf (fd-stream-in stream) routine              (setf (fd-stream-in stream) routine
1411                    (fd-stream-bin stream) #'ill-bin)                    (fd-stream-bin stream) (if (and binary-stream-p
1412                                                      (eql size 1))
1413                                                 (pick-input-routine '(unsigned-byte 8))
1414                                                 #'ill-bin))
1415              (setf (fd-stream-in stream) (if (and binary-stream-p              (setf (fd-stream-in stream) (if (and binary-stream-p
1416                                                   (eql size 1))                                                   (eql size 1))
1417                                              (pick-input-routine 'character)                                              (pick-input-routine 'character)
# Line 1034  Line 1423 
1423            ;; Support for n-byte operations on 8-, 16-, and 32-bit streams            ;; Support for n-byte operations on 8-, 16-, and 32-bit streams
1424            (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)            (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
1425            (when (and buffer-p (eql size 1)            (when (and buffer-p (eql size 1)
1426                       (or (eq type 'unsigned-byte)                       (or
1427                           (eq type :default)))                        ;; FIXME: Do this better.  We want to check for
1428              ;; We only create this buffer for streams of type                        ;; (unsigned-byte 8).  The 8 is unnecessary
1429              ;; (unsigned-byte 8).  Because there's no buffer, the                        ;; since we already have size = 1.
1430              ;; other element-types will dispatch to the appropriate                        (or (eq 'unsigned-byte (and (consp type) (car type)))
1431              ;; input (output) routine in fast-read-byte.                            (eq type :default))
1432              (setf (lisp-stream-in-buffer stream)                        (eq type 'character)))
1433                    (make-array in-buffer-length              (when *enable-stream-buffer-p*
1434                                :element-type '(unsigned-byte 8)))))                (when (and (not binary-stream-p)
1435                             (eq type 'character))
1436                    ;; Create the in-buffer for any character (only)
1437                    ;; stream.  Don't want one for binary-text-streams!
1438                    (setf (lisp-stream-in-buffer stream)
1439                          (make-array in-buffer-length
1440                                      :element-type '(unsigned-byte 8))))
1441                  #+unicode
1442                  (when (and (not binary-stream-p)
1443                             (eq type 'character)
1444                             (not (eq :iso8859-1 (fd-stream-external-format stream))))
1445                    ;; For character streams, we create the string-buffer so
1446                    ;; we can convert all available octets at once instead
1447                    ;; of for each character.  The string is one element
1448                    ;; longer than in-buffer-length to leave room for
1449                    ;; unreading.
1450                    ;;
1451                    ;; For ISO8859-1, we don't want this because it's very
1452                    ;; easy and quick to convert octets to iso8859-1.  (See
1453                    ;; FAST-READ-CHAR.)
1454    
1455                    (setf (lisp-stream-string-buffer stream)
1456                          (make-string (1+ in-buffer-length)))
1457                    (setf (fd-stream-octet-count stream)
1458                          (make-array in-buffer-length :element-type '(unsigned-byte 8)))
1459                    (setf (lisp-stream-string-buffer-len stream) 0)
1460                    (setf (lisp-stream-string-index stream) 0)))))
1461          (setf input-size size)          (setf input-size size)
1462          (setf input-type type)))          (setf input-type type)))
1463    
# Line 1051  Line 1466 
1466            (routine type size)            (routine type size)
1467            (pick-output-routine target-type (fd-stream-buffering stream))            (pick-output-routine target-type (fd-stream-buffering stream))
1468          (unless routine          (unless routine
1469            (error "Could not find any output routine for ~S buffered ~S."            (error (intl:gettext "Could not find any output routine for ~S buffered ~S.")
1470                   (fd-stream-buffering stream)                   (fd-stream-buffering stream)
1471                   target-type))                   target-type))
1472          (setf (fd-stream-obuf-sap stream) (next-available-buffer))          (setf (fd-stream-obuf-sap stream) (next-available-buffer))
1473          (setf (fd-stream-obuf-length stream) bytes-per-buffer)          (setf (fd-stream-obuf-length stream) bytes-per-buffer)
1474          (setf (fd-stream-obuf-tail stream) 0)          (setf (fd-stream-obuf-tail stream) 0)
1475            ;; Normally signal errors for reading from a stream with the
1476            ;; wrong element type, but allow binary-text-streams to read
1477            ;; from either.
1478          (if (subtypep type 'character)          (if (subtypep type 'character)
1479            (setf (fd-stream-out stream) routine              (setf (fd-stream-out stream) routine
1480                  (fd-stream-bout stream) #'ill-bout)                    (fd-stream-bout stream)
1481            (setf (fd-stream-out stream)                      (if (and binary-stream-p
1482                  (or (if (eql size 1)                               (eql size 1))
1483                            (pick-output-routine '(unsigned-byte 8)
1484                                                 (fd-stream-buffering stream))
1485                            #'ill-bout))
1486                (setf (fd-stream-out stream)
1487                      (if (and binary-stream-p (eql size 1))
1488                        (pick-output-routine 'base-char                        (pick-output-routine 'base-char
1489                                             (fd-stream-buffering stream)))                                             (fd-stream-buffering stream))
1490                      #'ill-out)                        #'ill-out)
1491                  (fd-stream-bout stream) routine))                    (fd-stream-bout stream) routine))
1492          (setf (fd-stream-sout stream)          (setf (fd-stream-sout stream)
1493                (if (eql size 1) #'fd-sout #'ill-out))                (if (eql size 1) #'fd-sout #'ill-out))
1494          (setf (fd-stream-char-pos stream) 0)          (setf (fd-stream-char-pos stream) 0)
# Line 1073  Line 1496 
1496          (setf output-type type)))          (setf output-type type)))
1497    
1498      (when (and input-size output-size      (when (and input-size output-size
1499                 (not (eq input-size output-size)))                 (not (eql input-size output-size)))
1500        (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"        (error (intl:gettext "Element sizes for input (~S:~S) and output (~S:~S) differ?")
1501               input-type input-size               input-type input-size
1502               output-type output-size))               output-type output-size))
1503      (setf (fd-stream-element-size stream)      (setf (fd-stream-element-size stream)
# Line 1092  Line 1515 
1515                  ((subtypep output-type input-type)                  ((subtypep output-type input-type)
1516                   output-type)                   output-type)
1517                  (t                  (t
1518                   (error "Input type (~S) and output type (~S) are unrelated?"                   (error (intl:gettext "Input type (~S) and output type (~S) are unrelated?")
1519                          input-type                          input-type
1520                          output-type))))))                          output-type))))))
1521    
1522  ;;; REVERT-FILE -- internal  ;;; REVERT-FILE -- internal
1523  ;;;  ;;;
1524  ;;;   Revert a file, if possible; otherwise just delete it.  Used during  ;;;   Revert a file, if possible; otherwise do nothing.  Used during
1525  ;;; CLOSE when the abort flag is set.  ;;; CLOSE when the abort flag is set.
1526  ;;;  ;;;
1527  (defun revert-file (filename original)  (defun revert-file (filename original)
1528    (declare (type simple-base-string filename)    (declare (type simple-base-string filename)
1529             (type (or simple-base-string null) original))             (type (or simple-base-string null) original))
1530    (if original    (when original
1531        (multiple-value-bind (okay err) (unix:unix-rename original filename)      (multiple-value-bind (okay err)
1532          (unless okay          (unix:unix-rename original filename)
1533            (cerror "Go on as if nothing bad happened."        (unless okay
1534                    "Could not restore ~S to its original contents: ~A"            (cerror (intl:gettext "Go on as if nothing bad happened.")
1535                    filename (unix:get-unix-error-msg err))))                    (intl:gettext "Could not restore ~S to its original contents: ~A")
       (multiple-value-bind (okay err) (unix:unix-unlink filename)  
         (unless okay  
           (cerror "Go on as if nothing bad happened."  
                   "Could not remove ~S: ~A"  
1536                    filename (unix:get-unix-error-msg err))))))                    filename (unix:get-unix-error-msg err))))))
1537    
1538  ;;; DELETE-ORIGINAL -- internal  ;;; DELETE-ORIGINAL -- internal
# Line 1150  Line 1569 
1569                                               0 0))                                               0 0))
1570                      1))))                      1))))
1571      (:unread      (:unread
1572         #-unicode
1573       (setf (fd-stream-unread stream) arg1)       (setf (fd-stream-unread stream) arg1)
1574         #+unicode
1575         (cond ((lisp-stream-string-buffer stream)
1576                (if (zerop (lisp-stream-string-index stream))
1577                    (setf (fd-stream-unread stream) arg1)
1578                    (decf (lisp-stream-string-index stream))))
1579               (t
1580                (if (zerop (fd-stream-last-char-read-size stream))
1581                    (setf (fd-stream-unread stream) arg1)
1582                    (decf (fd-stream-ibuf-head stream)
1583                          (fd-stream-last-char-read-size stream)))))
1584         ;; Paul says:
1585         ;;
1586         ;; Not needed for unicode when unreading is implemented by backing up in
1587         ;; the buffer (e.g., with last-char-read-size...)
1588         ;;
1589         ;; (AFAICS there's nothing wrong with setting it there, but it
1590         ;; screws up read-interactive in my toplevel command thing -
1591         ;; leaves it expecting to read arguments when it shouldn't,
1592         ;; because LISTEN returns T when there's no input pending, but I
1593         ;; don't understand why...)
1594         #-unicode
1595       (setf (fd-stream-listen stream) t))       (setf (fd-stream-listen stream) t))
1596      (:close      (:close
1597       (cond (arg1       (cond (arg1
# Line 1162  Line 1603 
1603                (revert-file (fd-stream-file stream)                (revert-file (fd-stream-file stream)
1604                             (fd-stream-original stream))))                             (fd-stream-original stream))))
1605             (t             (t
1606                #+(and unicode (not unicode-bootstrap))
1607                (when (and (output-stream-p stream)
1608                           (eq (stream-element-type stream) 'character))
1609                  ;; For output character streams, we need to flush out
1610                  ;; any state that the external format might have.
1611                  #+nil (format *debug-io* "state = ~S~%" (fd-stream-co-state stream))
1612                  (funcall (ef-flush (fd-stream-external-format stream))
1613                           stream))
1614              (fd-stream-misc-routine stream :finish-output)              (fd-stream-misc-routine stream :finish-output)
1615              (when (fd-stream-delete-original stream)              (when (fd-stream-delete-original stream)
1616                (delete-original (fd-stream-file stream)                (delete-original (fd-stream-file stream)
# Line 1177  Line 1626 
1626         (setf (fd-stream-ibuf-sap stream) nil))         (setf (fd-stream-ibuf-sap stream) nil))
1627       (lisp::set-closed-flame stream))       (lisp::set-closed-flame stream))
1628      (:clear-input      (:clear-input
1629       (setf (fd-stream-unread stream) nil)       (setf (fd-stream-unread stream) nil) ;;@@
1630         #+unicode (setf (fd-stream-last-char-read-size stream) 0)
1631       (setf (fd-stream-ibuf-head stream) 0)       (setf (fd-stream-ibuf-head stream) 0)
1632       (setf (fd-stream-ibuf-tail stream) 0)       (setf (fd-stream-ibuf-tail stream) 0)
1633       (catch 'eof-input-catcher       (catch 'eof-input-catcher
# Line 1216  Line 1666 
1666         (error 'simple-type-error         (error 'simple-type-error
1667                :datum stream                :datum stream
1668                :expected-type 'file-stream                :expected-type 'file-stream
1669                :format-control "~s is not a stream associated with a file."                :format-control (intl:gettext "~s is not a stream associated with a file.")
1670                :format-arguments (list stream)))                :format-arguments (list stream)))
1671       (multiple-value-bind       (multiple-value-bind
1672           (okay dev ino mode nlink uid gid rdev size           (okay dev ino mode nlink uid gid rdev size
# Line 1226  Line 1676 
1676                          atime mtime ctime blksize blocks))                          atime mtime ctime blksize blocks))
1677         (unless okay         (unless okay
1678           (error 'simple-file-error           (error 'simple-file-error
1679                  :format-control "Error fstating ~S: ~A"                  :format-control (intl:gettext "Error fstating ~S: ~A")
1680                  :format-arguments (list stream (unix:get-unix-error-msg dev))))                  :format-arguments (list stream (unix:get-unix-error-msg dev))))
1681         (if (zerop mode)         (if (zerop mode)
1682             nil             nil
# Line 1257  Line 1707 
1707                     (incf posn (- (the index (caddr later))                     (incf posn (- (the index (caddr later))
1708                                   (the index (cadr later)))))                                   (the index (cadr later)))))
1709                   (incf posn (fd-stream-obuf-tail stream))                   (incf posn (fd-stream-obuf-tail stream))
1710    
1711                   ;; Adjust for unread input:                   ;; Adjust for unread input:
1712                   ;;  If there is any input read from UNIX but not supplied to                   ;;  If there is any input read from UNIX but not supplied to
1713                   ;; the user of the stream, the *real* file position will                   ;; the user of the stream, the *real* file position will
# Line 1264  Line 1715 
1715                   ;; unread stuff is still available.                   ;; unread stuff is still available.
1716                   (decf posn (- (fd-stream-ibuf-tail stream)                   (decf posn (- (fd-stream-ibuf-tail stream)
1717                                 (fd-stream-ibuf-head stream)))                                 (fd-stream-ibuf-head stream)))
1718                   (when (fd-stream-unread stream)  
1719                     #+unicode
1720                     (when (fd-stream-string-buffer stream)
1721                       ;; The string buffer contains Lisp characters,
1722                       ;; not octets!  To figure out how many octets
1723                       ;; have not been already supplied, we need to
1724                       ;; count how many octets were consumed for all
1725                       ;; the characters in the string bbuffer that have
1726                       ;; not been supplied.
1727                       (let ((ocount (fd-stream-octet-count stream)))
1728                         (when ocount
1729                           ;; Note: string-index starts at 1 (because
1730                           ;; index 0 is for the unread-char), but
1731                           ;; octet-count doesn't use that.  Hence,
1732                           ;; subtract one from string-index and
1733                           ;; string-buffer-len.
1734                           #+nil
1735                           (progn
1736                             (format t "~&ocount = ~D~%" ocount)
1737                             (format t "posn = ~D~%" posn))
1738                           (loop for k of-type fixnum from (1- (fd-stream-string-index stream))
1739                                   below (1- (fd-stream-string-buffer-len stream))
1740                                 do (decf posn (aref ocount k)))
1741                           #+nil
1742                           (progn
1743                             (format t "new posn = ~D~%" posn)
1744                             (format t "in-buffer-length = ~D~%" in-buffer-length)
1745                             (format t "fd-stream-in-index = ~D~%" (fd-stream-in-index stream))))))
1746                     (when (fd-stream-in-buffer stream)
1747                       ;; When we have an in-buffer (whether we have a
1748                       ;; string-buffer or not!), we need to adjust for
1749                       ;; the octets that have not yet been supplied.
1750                       ;; (This case happens with string-buffer when the
1751                       ;; in-buffer does not have enough octets to form a
1752                       ;; complete character.)  If there's no
1753                       ;; string-buffer and no in-buffer, then the ibuf
1754                       ;; tail and head pointers contain all the
1755                       ;; information needed.
1756                       #+nil
1757                       (progn
1758                         (format t "in-buffer-length = ~D~%" in-buffer-length)
1759                         (format t "fd-stream-in-index = ~D~%" (fd-stream-in-index stream)))
1760                       (decf posn (- in-buffer-length
1761                                     (fd-stream-in-index stream))))
1762                     #+nil
1763                     (format t "fd-stream-unread = ~S~%" (fd-stream-unread stream))
1764                     (when (fd-stream-unread stream) ;;@@
1765                     (decf posn))                     (decf posn))
1766                   ;; Divide bytes by element size.                   ;; Divide bytes by element size.
1767                   (truncate posn (fd-stream-element-size stream)))                   (truncate posn (fd-stream-element-size stream)))
# Line 1272  Line 1769 
1769                   nil)                   nil)
1770                  (t                  (t
1771                   (system:with-interrupts                   (system:with-interrupts
1772                     (error "Error lseek'ing ~S: ~A"                     (error (intl:gettext "Error lseek'ing ~S: ~A")
1773                            stream                            stream
1774                            (unix:get-unix-error-msg errno)))))))                            (unix:get-unix-error-msg errno)))))))
1775        (let ((offset 0)        (let ((offset 0)
# Line 1287  Line 1784 
1784            (system:serve-all-events))            (system:serve-all-events))
1785          ;; 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
1786          ;; disk.          ;; disk.
1787          (setf (fd-stream-unread stream) nil)          (setf (fd-stream-unread stream) nil) ;;@@
1788            #+unicode
1789            (progn
1790              (setf (fd-stream-last-char-read-size stream) 0)
1791              (setf (fd-stream-string-index stream)
1792                    (fd-stream-string-buffer-len stream)))
1793          (setf (fd-stream-ibuf-head stream) 0)          (setf (fd-stream-ibuf-head stream) 0)
1794          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
1795          ;; Trash cached value for listen, so that we check next time.          ;; Trash cached value for listen, so that we check next time.
# Line 1303  Line 1805 
1805                 (setf offset (* newpos (fd-stream-element-size stream))                 (setf offset (* newpos (fd-stream-element-size stream))
1806                       origin unix:l_set))                       origin unix:l_set))
1807                (t                (t
1808                 (error "Invalid position given to file-position: ~S" newpos)))                 (error (intl:gettext "Invalid position given to file-position: ~S") newpos)))
1809          (multiple-value-bind          (multiple-value-bind
1810              (posn errno)              (posn errno)
1811              (unix:unix-lseek (fd-stream-fd stream) offset origin)              (unix:unix-lseek (fd-stream-fd stream) offset origin)
# Line 1312  Line 1814 
1814                  ((eq errno unix:espipe)                  ((eq errno unix:espipe)
1815                   nil)                   nil)
1816                  (t                  (t
1817                   (error "Error lseek'ing ~S: ~A"                   (error (intl:gettext "Error lseek'ing ~S: ~A")
1818                          stream                          stream
1819                          (unix:get-unix-error-msg errno))))))))                          (unix:get-unix-error-msg errno))))))))
1820    
# Line 1336  Line 1838 
1838                         delete-original                         delete-original
1839                         pathname                         pathname
1840                         input-buffer-p                         input-buffer-p
1841                           ;; DO NOT translate these!  It causes an
1842                           ;; infinite loop.  We need to open a file for
1843                           ;; the translations, but if you translate
1844                           ;; these, then we need to do a lookup which
1845                           ;; wants to open the mo file which calls this
1846                           ;; to name which causes a lookup ....
1847                         (name (if file                         (name (if file
1848                                   (format nil "file ~S" file)                                   (format nil "file ~S" file)
1849                                   (format nil "descriptor ~D" fd)))                                   (format nil "descriptor ~D" fd)))
1850                         auto-close                         auto-close
1851                         binary-stream-p)                         (external-format :default)
1852                           binary-stream-p
1853                           decoding-error
1854                           encoding-error)
1855    (declare (type index fd) (type (or index null) timeout)    (declare (type index fd) (type (or index null) timeout)
1856             (type (member :none :line :full) buffering))             (type (member :none :line :full) buffering))
1857    "Create a stream for the given unix file descriptor.    "Create a stream for the given unix file descriptor.
# Line 1352  Line 1863 
1863    Timeout (if true) is the number of seconds to wait for input.  If NIL (the    Timeout (if true) is the number of seconds to wait for input.  If NIL (the
1864      default), then wait forever.  When we time out, we signal IO-TIMEOUT.      default), then wait forever.  When we time out, we signal IO-TIMEOUT.
1865    File is the name of the file (will be returned by PATHNAME).    File is the name of the file (will be returned by PATHNAME).
1866    Name is used to identify the stream when printed."    Name is used to identify the stream when printed.
1867      External-format is the external format to use for the stream.
1868      Decoding-error and Encoding-error indicate how decoding/encoding errors on
1869        the stream should be handled.  The default is to use a replacement character."
1870    (cond ((not (or input-p output-p))    (cond ((not (or input-p output-p))
1871           (setf input t))           (setf input t))
1872          ((not (or input output))          ((not (or input output))
1873           (error "File descriptor must be opened either for input or output.")))           (error (intl:gettext "File descriptor must be opened either for input or output."))))
1874    (let ((stream (if binary-stream-p    (let ((stream (if binary-stream-p
1875                      (%make-binary-text-stream :fd fd                      (%make-binary-text-stream :fd fd
1876                                                :name name                                                :name name
# Line 1366  Line 1880 
1880                                                :pathname pathname                                                :pathname pathname
1881                                                :buffering buffering                                                :buffering buffering
1882                                                :timeout timeout)                                                :timeout timeout)
1883                      (%make-fd-stream :fd fd                      (let ((e (cond ((characterp encoding-error)
1884                                       :name name                                      (constantly (char-code encoding-error)))
1885                                       :file file                                     (t
1886                                       :original original                                      encoding-error)))
1887                                       :delete-original delete-original                            (d (cond ((characterp decoding-error)
1888                                       :pathname pathname                                      (constantly (char-code decoding-error)))
1889                                       :buffering buffering                                     ((eq t decoding-error)
1890                                       :timeout timeout))))                                      #'(lambda (&rest args)
1891                                            (apply 'cerror
1892                                                   #+unicode _"Use Unicode replacement character instead"
1893                                                   #-unicode _"Use question mark character instead"
1894                                                   args)
1895                                            #+unicode
1896                                            stream:+replacement-character-code+
1897                                            #-unicode
1898                                            #\?))
1899                                       (t
1900                                        decoding-error))))
1901                          (%make-fd-stream :fd fd
1902                                           :name name
1903                                           :file file
1904                                           :original original
1905                                           :delete-original delete-original
1906                                           :pathname pathname
1907                                           :buffering buffering
1908                                           :timeout timeout
1909                                           :char-to-octets-error e
1910                                           :octets-to-char-error d)))))
1911        ;; Set the lisp-stream flags appropriately for the kind of stream
1912        ;; we have (character, binary, binary-text-stream).
1913        (cond ((typep stream 'binary-text-stream)
1914               (setf (fd-stream-flags stream) #b100))
1915              ((subtypep element-type 'character)
1916               (setf (fd-stream-flags stream) #b001))
1917              (t
1918               (setf (fd-stream-flags stream) #b010)))
1919    
1920        ;; FIXME: setting the external format here should be better
1921        ;; integrated into set-routines.  We do it before so that
1922        ;; set-routines can create an in-buffer if appropriate.  But we
1923        ;; need to do it after to put the correct input routines for the
1924        ;; external format.
1925        ;;
1926        ;;#-unicode-bootstrap ; fails in stream-reinit otherwise
1927        #+(and unicode (not unicode-bootstrap))
1928        (%set-fd-stream-external-format stream external-format nil)
1929      (set-routines stream element-type input output input-buffer-p      (set-routines stream element-type input output input-buffer-p
1930                    :binary-stream-p binary-stream-p)                    :binary-stream-p binary-stream-p)
1931        #+(and unicode (not unicode-bootstrap))
1932        (%set-fd-stream-external-format stream external-format nil)
1933      (when (and auto-close (fboundp 'finalize))      (when (and auto-close (fboundp 'finalize))
1934        (finalize stream        (finalize stream
1935                  #'(lambda ()                  #'(lambda ()
1936                      (unix:unix-close fd)                      (unix:unix-close fd)
1937                      (format *terminal-io* "** Closed ~A~%" name)                      (format *terminal-io* (intl:gettext "** Closed ~A~%") name)
1938                      (when original                      (when original
1939                        (revert-file file original)))))                        (revert-file file original)))))
1940      stream))      stream))
# Line 1409  Line 1963 
1963  ;;;  ;;;
1964  (defun next-version (name)  (defun next-version (name)
1965    (declare (type simple-string name))    (declare (type simple-string name))
1966    (let* ((sep (position #\/ name :from-end t))    (let* ((*ignore-wildcards* t)
1967             (sep (position #\/ name :from-end t))
1968           (base (if sep (subseq name 0 (1+ sep)) ""))           (base (if sep (subseq name 0 (1+ sep)) ""))
1969           (dir (unix:open-dir base)))           (dir (unix:open-dir base)))
1970      (multiple-value-bind (name type version)      (multiple-value-bind (name type version)
# Line 1444  Line 1999 
1999  (defun assure-one-of (item list what)  (defun assure-one-of (item list what)
2000    (unless (member item list)    (unless (member item list)
2001      (loop      (loop
2002        (cerror "Enter new value for ~*~S"        (cerror (intl:gettext "Enter new value for ~*~S")
2003                "~S is invalid for ~S. Must be one of~{ ~S~}"                (intl:gettext "~S is invalid for ~S. Must be one of~{ ~S~}")
2004                item                item
2005                what                what
2006                list)                list)
2007        (format (the stream *query-io*) "Enter new value for ~S: " what)        (format (the stream *query-io*) (intl:gettext "Enter new value for ~S: ") what)
2008        (force-output *query-io*)        (force-output *query-io*)
2009        (setf item (read *query-io*))        (setf item (read *query-io*))
2010        (when (member item list)        (when (member item list)
# Line 1464  Line 2019 
2019  ;;;  ;;;
2020  (defun do-old-rename (namestring original)  (defun do-old-rename (namestring original)
2021    (unless (unix:unix-access namestring unix:w_ok)    (unless (unix:unix-access namestring unix:w_ok)
2022      (cerror "Try to rename it anyway." "File ~S is not writable." namestring))      (cerror (intl:gettext "Try to rename it anyway.") (intl:gettext "File ~S is not writable.") namestring))
2023    (multiple-value-bind    (multiple-value-bind
2024        (okay err)        (okay err)
2025        (unix:unix-rename namestring original)        (unix:unix-rename namestring original)
2026      (cond (okay t)      (cond (okay t)
2027            (t            (t
2028             (cerror "Use :SUPERSEDE instead."             (cerror (intl:gettext "Use :SUPERSEDE instead.")
2029                     "Could not rename ~S to ~S: ~A."                     (intl:gettext "Could not rename ~S to ~S: ~A.")
2030                     namestring                     namestring
2031                     original                     original
2032                     (unix:get-unix-error-msg err))                     (unix:get-unix-error-msg err))
# Line 1528  Line 2083 
2083      (let ((name (cond ((unix-namestring pathname input))      (let ((name (cond ((unix-namestring pathname input))
2084                        ((and input (eq if-does-not-exist :create))                        ((and input (eq if-does-not-exist :create))
2085                         (unix-namestring pathname nil)))))                         (unix-namestring pathname nil)))))
2086        (let ((original (cond ((eq if-exists :new-version)        (let ((original (cond ((and name (eq if-exists :new-version))
2087                               (next-version name))                               (next-version name))
2088                              ((member if-exists '(:rename :rename-and-delete))                              ((member if-exists '(:rename :rename-and-delete))
2089                               (pick-backup-name name))))                               (pick-backup-name name))))
# Line 1552  Line 2107 
2107                               (error 'simple-file-error                               (error 'simple-file-error
2108                                   :pathname pathname                                   :pathname pathname
2109                                   :format-control                                   :format-control
2110                                   "Cannot open ~S for output: Is a directory."                                   (intl:gettext "Cannot open ~S for output: Is a directory.")
2111                                   :format-arguments (list name)))                                   :format-arguments (list name)))
2112                             (setf mode (logand orig-mode #o777))                             (setf mode (logand orig-mode #o777))
2113                             t)                             t)
# Line 1561  Line 2116 
2116                            (t                            (t
2117                             (error 'simple-file-error                             (error 'simple-file-error
2118                                    :pathname pathname                                    :pathname pathname
2119                                    :format-control "Cannot find ~S: ~A"                                    :format-control (intl:gettext "Cannot find ~S: ~A")
2120                                    :format-arguments                                    :format-arguments
2121                                      (list name                                      (list name
2122                                        (unix:get-unix-error-msg err/dev)))))))))                                        (unix:get-unix-error-msg err/dev)))))))))
# Line 1591  Line 2146 
2146                    ((eql errno unix:enoent)                    ((eql errno unix:enoent)
2147                     (case if-does-not-exist                     (case if-does-not-exist
2148                       (:error                       (:error
2149                         (cerror "Return NIL."                         (cerror (intl:gettext "Return NIL.")
2150                                 'simple-file-error                                 'simple-file-error
2151                                 :pathname pathname                                 :pathname pathname
2152                                 :format-control "Error opening ~S, ~A."                                 :format-control (intl:gettext "Error opening ~S, ~A.")
2153                                 :format-arguments                                 :format-arguments
2154                                     (list pathname                                     (list pathname
2155                                           (unix:get-unix-error-msg errno))))                                           (unix:get-unix-error-msg errno))))
2156                       (:create                       (:create
2157                         (cerror "Return NIL."                         (cerror (intl:gettext "Return NIL.")
2158                                 'simple-file-error                                 'simple-file-error
2159                                 :pathname pathname                                 :pathname pathname
2160                                 :format-control                                 :format-control
2161                                     "Error creating ~S, path does not exist."                                     (intl:gettext "Error creating ~S, path does not exist.")
2162                                 :format-arguments (list pathname))))                                 :format-arguments (list pathname))))
2163                     (return nil))                     (return nil))
2164                    ((eql errno unix:eexist)                    ((eql errno unix:eexist)
2165                     (unless (eq nil if-exists)                     (unless (eq nil if-exists)
2166                       (cerror "Return NIL."                       (cerror (intl:gettext "Return NIL.")
2167                               'simple-file-error                               'simple-file-error
2168                               :pathname pathname                               :pathname pathname
2169                               :format-control "Error opening ~S, ~A."                               :format-control (intl:gettext "Error opening ~S, ~A.")
2170                               :format-arguments                               :format-arguments
2171                                   (list pathname                                   (list pathname
2172                                         (unix:get-unix-error-msg errno))))                                         (unix:get-unix-error-msg errno))))
2173                     (return nil))                     (return nil))
2174                    ((eql errno unix:eacces)                    ((eql errno unix:eacces)
2175                     (cerror "Try again."                     (cerror (intl:gettext "Try again.")
2176                             'simple-file-error                             'simple-file-error
2177                             :pathname pathname                             :pathname pathname
2178                             :format-control "Error opening ~S, ~A."                             :format-control (intl:gettext "Error opening ~S, ~A.")
2179                             :format-arguments                             :format-arguments
2180                                 (list pathname                                 (list pathname
2181                                       (unix:get-unix-error-msg errno))))                                       (unix:get-unix-error-msg errno))))
2182                    (t                    (t
2183                     (cerror "Return NIL."                     (cerror (intl:gettext "Return NIL.")
2184                             'simple-file-error                             'simple-file-error
2185                             :pathname pathname                             :pathname pathname
2186                             :format-control "Error opening ~S, ~A."                             :format-control (intl:gettext "Error opening ~S, ~A.")
2187                             :format-arguments                             :format-arguments
2188                                 (list pathname                                 (list pathname
2189                                       (unix:get-unix-error-msg errno)))                                       (unix:get-unix-error-msg errno)))
# Line 1643  Line 2198 
2198                                  (if-exists nil if-exists-given)                                  (if-exists nil if-exists-given)
2199                                  (if-does-not-exist nil if-does-not-exist-given)                                  (if-does-not-exist nil if-does-not-exist-given)
2200                                  (external-format :default)                                  (external-format :default)
2201                                  class)                                  class
2202                                    decoding-error encoding-error)
2203    (declare (type pathname pathname)    (declare (type pathname pathname)
2204             (type (member :input :output :io :probe) direction)             (type (member :input :output :io :probe) direction)
2205             (type (member :error :new-version :rename :rename-and-delete             (type (member :error :new-version :rename :rename-and-delete
2206                           :overwrite :append :supersede nil) if-exists)                           :overwrite :append :supersede nil) if-exists)
2207             (type (member :error :create nil) if-does-not-exist)             (type (member :error :create nil) if-does-not-exist))
            (ignore external-format))  
2208    (multiple-value-bind (fd namestring original delete-original)    (multiple-value-bind (fd namestring original delete-original)
2209        (fd-open pathname direction if-exists if-exists-given        (fd-open pathname direction if-exists if-exists-given
2210                 if-does-not-exist if-does-not-exist-given)                 if-does-not-exist if-does-not-exist-given)
# Line 1668  Line 2223 
2223                           :pathname pathname                           :pathname pathname
2224                           :input-buffer-p t                           :input-buffer-p t
2225                           :auto-close t                           :auto-close t
2226                           :binary-stream-p class))                           :external-format external-format
2227                             :binary-stream-p class
2228                             :decoding-error decoding-error
2229                             :encoding-error encoding-error))
2230          (:probe          (:probe
2231           (let ((stream (%make-fd-stream :name namestring :fd fd           (let ((stream (%make-fd-stream :name namestring :fd fd
2232                                          :pathname pathname                                          :pathname pathname
# Line 1687  Line 2245 
2245                             (if-does-not-exist nil if-does-not-exist-given)                             (if-does-not-exist nil if-does-not-exist-given)
2246                             (external-format :default)                             (external-format :default)
2247                             class mapped input-handle output-handle                             class mapped input-handle output-handle
2248                               decoding-error encoding-error
2249                        &allow-other-keys                        &allow-other-keys
2250                        &aux ; Squelch assignment warning.                        &aux ; Squelch assignment warning.
2251                          (options options)
2252                        (direction direction)                        (direction direction)
2253                        (if-does-not-exist if-does-not-exist)                        (if-does-not-exist if-does-not-exist)
2254                        (if-exists if-exists))                        (if-exists if-exists))
# Line 1699  Line 2259 
2259     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
2260                         :overwrite, :append, :supersede or nil                         :overwrite, :append, :supersede or nil
2261     :if-does-not-exist - one of :error, :create or nil     :if-does-not-exist - one of :error, :create or nil
2262     :external-format - :default     :external-format - an external format name
2263       :decoding-error - How to handle decoding errors from the external format.
2264                           If a character, then that character is used as
2265                           the replacment character for all errors.  If T,
2266                           then a continuable error is signaled.  If
2267                           continued, the Unicode replacement character is
2268                           used.  Otherwise, it should be a symbol or
2269                           function of 3 arguments.  If it returns, it
2270                           should return a code point to use as the
2271                           replacment.  The function arguments are a
2272                           format message string, the offending octet, and
2273                           the number of octets read in the current
2274                           encoding.
2275       :encoding-error - Like :decoding-error, but for errors when encoding the
2276                           stream.  If a character, that character is used
2277                           as the replacment code point.  Otherwise, it
2278                           should be a symbol or function oof two
2279                           arguments: a format message string and the
2280                           incorrect codepoint.
2281    
2282    See the manual for details."    See the manual for details."
2283    (declare (ignore external-format input-handle output-handle))    (declare (ignore element-type external-format input-handle output-handle
2284                       decoding-error encoding-error))
2285    
2286    ;; OPEN signals a file-error if the filename is wild.    ;; OPEN signals a file-error if the filename is wild.
2287    (when (wild-pathname-p filename)    (when (wild-pathname-p filename)
# Line 1730  Line 2310 
2310                           :if-does-not-exist))                           :if-does-not-exist))
2311      (setf (getf options :if-does-not-exist) if-does-not-exist))      (setf (getf options :if-does-not-exist) if-does-not-exist))
2312    
2313    (let ((filespec (pathname filename))    (let ((filespec (merge-pathnames filename))
2314          (options (copy-list options))          (options (copy-list options))
2315          (class (or class 'fd-stream)))          (class (or class 'fd-stream)))
2316      (cond ((eq class 'fd-stream)      (cond ((eq class 'fd-stream)
# Line 1749  Line 2329 
2329             (apply #'open-fd-stream filespec options))             (apply #'open-fd-stream filespec options))
2330            ((subtypep class 'stream:simple-stream)            ((subtypep class 'stream:simple-stream)
2331             (when element-type-given             (when element-type-given
2332               (cerror "Do it anyway."               (cerror (intl:gettext "Do it anyway.")
2333                       "Can't create simple-streams with an element-type."))                       (intl:gettext "Can't create simple-streams with an element-type.")))
2334             (when (and (eq class 'stream:file-simple-stream) mapped)             (when (and (eq class 'stream:file-simple-stream) mapped)
2335               (setq class 'stream:mapped-file-simple-stream)               (setq class 'stream:mapped-file-simple-stream)
2336               (setf (getf options :class) 'stream:mapped-file-simple-stream))               (setf (getf options :class) 'stream:mapped-file-simple-stream))
# Line 1767  Line 2347 
2347               (when stream               (when stream
2348                 (make-instance class :lisp-stream stream))))                 (make-instance class :lisp-stream stream))))
2349            (t            (t
2350             (error "Unable to open streams of class ~S." class)))))             (error (intl:gettext "Unable to open streams of class ~S.") class)))))
2351    
2352  ;;;; Initialization.  ;;;; Initialization.
2353    
# Line 1804  Line 2384 
2384  (defun stream-reinit ()  (defun stream-reinit ()
2385    (setf *available-buffers* nil)    (setf *available-buffers* nil)
2386    (setf *stdin*    (setf *stdin*
2387          (make-fd-stream 0 :name "Standard Input" :input t :buffering :line))          (make-fd-stream 0 :name "Standard Input" :input t :buffering :line
2388                            :external-format :iso8859-1))
2389    (setf *stdout*    (setf *stdout*
2390          (make-fd-stream 1 :name "Standard Output" :output t :buffering :line))          (make-fd-stream 1 :name "Standard Output" :output t :buffering :line
2391                            :external-format :iso8859-1))
2392    (setf *stderr*    (setf *stderr*
2393          (make-fd-stream 2 :name "Standard Error" :output t :buffering :line))          (make-fd-stream 2 :name "Standard Error" :output t :buffering :line
2394                            :external-format :iso8859-1))
2395    (let ((tty (and (not *batch-mode*)    (let ((tty (and (not *batch-mode*)
2396                    (unix:unix-open "/dev/tty" unix:o_rdwr #o666))))                    (unix:unix-open "/dev/tty" unix:o_rdwr #o666))))
2397      (setf *tty*      (setf *tty*
2398            (if tty            (if tty
2399                (make-fd-stream tty :name "the Terminal" :input t :output t                (make-fd-stream tty :name "the Terminal" :input t :output t
2400                                :buffering :line :auto-close t)                                :buffering :line :auto-close t
2401                                  :external-format :iso8859-1)
2402                (make-two-way-stream *stdin* *stdout*))))                (make-two-way-stream *stdin* *stdout*))))
2403    nil)    nil)
2404    
# Line 1853  Line 2437 
2437              (fd-stream-pathname stream))))))              (fd-stream-pathname stream))))))
2438    
2439    
2440  ;;;; Degenerate international character support:  
2441    #+unicode
2442    (stream::def-ef-macro ef-strlen (extfmt lisp stream::+ef-max+ stream::+ef-str+)
2443      ;; While it would be nice not to have to call CHAR-TO-OCTETS to
2444      ;; figure out the length when the external format has fixed size
2445      ;; outputs, we can't.  For example, utf16 will output a BOM, which
2446      ;; wouldn't be reflected in the count if we don't call
2447      ;; CHAR-TO-OCTETS.
2448      `(lambda (stream object &aux (count 0))
2449         (declare (type fd-stream stream)
2450                  (type (or character string) object)
2451                  (type (and fixnum unsigned-byte) count)
2452                  #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#)
2453         (labels ((efstate (state)
2454                    (stream::copy-state ,extfmt state))
2455                  (eflen (char)
2456                    (stream::char-to-octets ,extfmt char
2457                                            (fd-stream-co-state stream)
2458                                            (lambda (byte)
2459                                              (declare (ignore byte))
2460                                              (incf count))
2461                                            (fd-stream-char-to-octets-erroor stream))))
2462           (let* ((co-state (fd-stream-co-state stream))
2463                  (old-ef-state (efstate (cdr (fd-stream-co-state stream))))
2464                  (old-state (cons (car co-state) old-ef-state)))
2465             (etypecase object
2466               (character (eflen object))
2467               (string (dovector (ch object) (eflen ch))))
2468             ;; Restore state
2469             (setf (fd-stream-co-state stream) old-state)
2470             count))))
2471    
2472    
2473  (defun file-string-length (stream object)  (defun file-string-length (stream object)
2474    (declare (type (or string character) object)    (declare (type (or string character) object)
# Line 1866  Line 2481 
2481      (broadcast-stream      (broadcast-stream
2482       ;; CLHS says we must return 1 in this case       ;; CLHS says we must return 1 in this case
2483       1)       1)
2484      (t      #+unicode
2485       (etypecase object      (t (funcall (ef-strlen (fd-stream-external-format stream))
2486         (character 1)                  stream object))
2487         (string (length object))))))      #-unicode
2488        (t (etypecase object
2489             (character 1)
2490             (string (length object))))))
2491    
2492    #+unicode
2493    (stream::def-ef-macro ef-copy-state (extfmt lisp stream::+ef-max+ stream::+ef-copy-state+)
2494      ;; Return a copy of the state of an external format.
2495      `(lambda (state)
2496         (declare (ignorable state))
2497         (stream::copy-state ,extfmt state)))

Legend:
Removed from v.1.81.2.2  
changed lines
  Added in v.1.125

  ViewVC Help
Powered by ViewVC 1.1.5