/[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.40.2.9 by pw, Wed Apr 3 18:32:24 2002 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*
27              binary-text-stream))
28    
29    
30  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
# Line 31  Line 34 
34    
35  (in-package "LISP")  (in-package "LISP")
36    
37  (export '(file-stream file-string-length stream-external-format))  (export '(file-stream file-string-length))
 (deftype file-stream () 'fd-stream)  
38    
39    
40  ;;;; Buffer manipulation routines.  ;;;; Buffer manipulation routines.
# 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    
51    ;; This limit is rather arbitrary
52    (defconstant max-stream-element-size 1024
53      "The maximum supported byte size for a stream element-type.")
54    
55  ;;; NEXT-AVAILABLE-BUFFER -- Internal.  ;;; NEXT-AVAILABLE-BUFFER -- Internal.
56  ;;;  ;;;
57  ;;; Returns the next available buffer, creating one if necessary.  ;;; Returns the next available buffer, creating one if necessary.
# Line 55  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    
180    ;;;; Superclass defined by the ANSI Spec
181    (defstruct (file-stream
182                 (:include lisp-stream)
183                 (:constructor nil)
184                 (:copier nil)))
185    
186  (defstruct (fd-stream  (defstruct (fd-stream
187              (:print-function %print-fd-stream)              (:print-function %print-fd-stream)
188              (:constructor %make-fd-stream)              (:constructor %make-fd-stream)
189              (:include lisp-stream              (:include file-stream
190                        (misc #'fd-stream-misc-routine)))                        (misc #'fd-stream-misc-routine)))
191    
192    (name nil)                  ; The name of this stream    (name nil)                  ; The name of this stream
# Line 106  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))
283    (format stream "#<Stream for ~A>"    (format stream "#<Stream for ~A>"
284            (fd-stream-name fd-stream)))            (fd-stream-name fd-stream)))
285    
286    ;; CMUCL extension.  This is a FD-STREAM, but it allows reading and
287    ;; writing of 8-bit characters and unsigned bytes from the stream.
288    (defstruct (binary-text-stream
289                 (:print-function %print-binary-text-stream)
290                 (:constructor %make-binary-text-stream)
291                 (:include fd-stream)))
292    
293    (defun %print-binary-text-stream (fd-stream stream depth)
294      (declare (ignore depth) (stream stream))
295      (format stream "#<Binary-text Stream for ~A>"
296              (fd-stream-name fd-stream)))
297    
298  (define-condition io-timeout (stream-error)  (define-condition io-timeout (stream-error)
299    ((direction :reader io-timeout-direction :initarg :direction))    ((direction :reader io-timeout-direction :initarg :direction))
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 134  Line 315 
315  ;;; DO-OUTPUT-LATER -- internal  ;;; DO-OUTPUT-LATER -- internal
316  ;;;  ;;;
317  ;;;   Called by the server when we can write to the given file descriptor.  ;;;   Called by the server when we can write to the given file descriptor.
318  ;;; Attemt to write the data again. If it worked, remove the data from the  ;;; Attempt to write the data again. If it worked, remove the data from the
319  ;;; output-later list. If it didn't work, something is wrong.  ;;; output-later list. If it didn't work, something is wrong.
320  ;;;  ;;;
321  (defun do-output-later (stream)  (defun do-output-later (stream)
# Line 153  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 workded.              ((eql count length) ; Hot damn, it worked.
341               (when reuse-sap               (when reuse-sap
342                 (push base *available-buffers*)))                 (push base *available-buffers*)))
343              ((not (null count)) ; Sorta worked.              ((not (null count)) ; Sorta worked.
# Line 170  Line 351 
351    
352  ;;; OUTPUT-LATER -- internal  ;;; OUTPUT-LATER -- internal
353  ;;;  ;;;
354  ;;;   Arange to output the string when we can write on the file descriptor.  ;;;   Arrange to output the string when we can write on the file descriptor.
355  ;;;  ;;;
356  (defun output-later (stream base start end reuse-sap)  (defun output-later (stream base start end reuse-sap)
357    (cond ((null (fd-stream-output-later stream))    (cond ((null (fd-stream-output-later stream))
# Line 212  Line 393 
393            (cond ((not count)            (cond ((not count)
394                   (if (= errno unix:ewouldblock)                   (if (= errno unix:ewouldblock)
395                       (output-later stream base start end reuse-sap)                       (output-later stream base start end reuse-sap)
396                       (error "While writing ~S: ~A"                       (error 'simple-stream-error
397                              stream (unix:get-unix-error-msg errno))))                              :stream stream
398                                :format-control "while writing: ~A"
399                                :format-arguments (list (unix:get-unix-error-msg errno)))))
400                  ((not (eql count length))                  ((not (eql count length))
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 249  Line 477 
477                                      (+ (fd-stream-obuf-tail stream)                                      (+ (fd-stream-obuf-tail stream)
478                                         ,size))                                         ,size))
479                               (flush-output-buffer stream)))                               (flush-output-buffer stream)))
480                           ;;
481                           ;; If there is any input read from UNIX but not
482                           ;; supplied to the user of the stream, reposition
483                           ;; to the real file position as seen from Lisp.
484                           ,(unless (eq (car buffering) :none)
485                              `(when (> (fd-stream-ibuf-tail stream)
486                                        (fd-stream-ibuf-head stream))
487                                 (file-position stream (file-position stream))))
488                         ,@body                         ,@body
489                         (incf (fd-stream-obuf-tail stream) ,size)                         (incf (fd-stream-obuf-tail stream) ,size)
490                         ,(ecase (car buffering)                         ,(ecase (car buffering)
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 271  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 282  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 327  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 342  Line 627 
627    (let ((start (or start 0))    (let ((start (or start 0))
628          (end (or end (length (the (simple-array * (*)) thing)))))          (end (or end (length (the (simple-array * (*)) thing)))))
629      (declare (type index start end))      (declare (type index start end))
630        ;;
631        ;; If there is any input read from UNIX but not
632        ;; supplied to the user of the stream, reposition
633        ;; to the real file position as seen from Lisp.
634        (when (> (fd-stream-ibuf-tail stream)
635                 (fd-stream-ibuf-head stream))
636          (file-position stream (file-position stream)))
637      (let* ((len (fd-stream-obuf-length stream))      (let* ((len (fd-stream-obuf-length stream))
638             (tail (fd-stream-obuf-tail stream))             (tail (fd-stream-obuf-tail stream))
639             (space (- len tail))             (space (- len tail))
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 395  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 427  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)
770      (let ((stream-var (gensym)))
771        `(let ((,stream-var ,stream))
772          ,(unless (eq (car buffering) :none)
773             `(when (< (fd-stream-obuf-length ,stream-var)
774                       (+ (fd-stream-obuf-tail ,stream-var)
775                           ,size))
776                (flush-output-buffer ,stream-var)))
777          ,(unless (eq (car buffering) :none)
778             `(when (> (fd-stream-ibuf-tail ,stream-var)
779                       (fd-stream-ibuf-head ,stream-var))
780                (file-position ,stream-var (file-position ,stream-var))))
781    
782          ,@body
783          (incf (fd-stream-obuf-tail ,stream-var) ,size)
784          ,(ecase (car buffering)
785             (:none
786              `(flush-output-buffer ,stream-var))
787             (:line
788              `(when (eq (char-code byte) (char-code #\Newline))
789                 (flush-output-buffer ,stream-var)))
790             (:full))
791          (values))))
792    
793  ;;; PICK-OUTPUT-ROUTINE -- internal  ;;; PICK-OUTPUT-ROUTINE -- internal
794  ;;;  ;;;
795  ;;;   Find an output routine to use given the type and buffering. Return as  ;;;   Find an output routine to use given the type and buffering. Return as
# Line 437  Line 800 
800    (dolist (entry *output-routines*)    (dolist (entry *output-routines*)
801      (when (and (subtypep type (car entry))      (when (and (subtypep type (car entry))
802                 (eq buffering (cadr entry)))                 (eq buffering (cadr entry)))
803        (return (values (symbol-function (caddr entry))        (return-from pick-output-routine
804                        (car entry)          (values (symbol-function (caddr entry))
805                        (cadddr entry))))))                  (car entry)
806                    (cadddr entry)))))
807      ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
808      (loop for i from 40 by 8 to max-stream-element-size ; ARB (KLUDGE)
809            if (subtypep type `(unsigned-byte ,i))
810            do (return-from pick-output-routine
811                 (values
812                  (ecase buffering
813                    (:none
814                     (lambda (stream byte)
815                       (output-wrapper (stream (/ i 8) (:none))
816                         (loop for j from 0 below (/ i 8)
817                               do (setf (sap-ref-8
818                                         (fd-stream-obuf-sap stream)
819                                         (+ j (fd-stream-obuf-tail stream)))
820                                        (ldb (byte 8 (- i 8 (* j 8))) byte))))))
821                    (:full
822                     (lambda (stream byte)
823                       (output-wrapper (stream (/ i 8) (:full))
824                         (loop for j from 0 below (/ i 8)
825                               do (setf (sap-ref-8
826                                         (fd-stream-obuf-sap stream)
827                                         (+ j (fd-stream-obuf-tail stream)))
828                                        (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
829                  `(unsigned-byte ,i)
830                  (/ i 8))))
831      (loop for i from 40 by 8 to max-stream-element-size ; ARB (KLUDGE)
832            if (subtypep type `(signed-byte ,i))
833            do (return-from pick-output-routine
834                 (values
835                  (ecase buffering
836                    (:none
837                     (lambda (stream byte)
838                       (output-wrapper (stream (/ i 8) (:none))
839                         (loop for j from 0 below (/ i 8)
840                               do (setf (sap-ref-8
841                                         (fd-stream-obuf-sap stream)
842                                         (+ j (fd-stream-obuf-tail stream)))
843                                        (ldb (byte 8 (- i 8 (* j 8))) byte))))))
844                    (:full
845                     (lambda (stream byte)
846                       (output-wrapper (stream (/ i 8) (:full))
847                         (loop for j from 0 below (/ i 8)
848                               do (setf (sap-ref-8
849                                         (fd-stream-obuf-sap stream)
850                                         (+ j (fd-stream-obuf-tail stream)))
851                                        (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
852                  `(signed-byte ,i)
853                  (/ i 8)))))
854    
855  ;;;; Input routines and related noise.  ;;;; Input routines and related noise.
856    
# Line 459  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 495  Line 907 
907                          (system:int-sap (+ (system:sap-int ibuf-sap) tail))                          (system:int-sap (+ (system:sap-int ibuf-sap) tail))
908                          (- buflen tail))                          (- buflen tail))
909        (cond ((null count)        (cond ((null count)
910               (if (eql errno unix:ewouldblock)               ;; What kinds of errors do we want to look at and what do
911                   (progn               ;; we want them to do?
912                     (unless #-mp (system:wait-until-fd-usable               (cond ((eql errno unix:ewouldblock)
913                                   fd :input (fd-stream-timeout stream))                      (unless #-mp (system:wait-until-fd-usable
914                             #+mp (mp:process-wait-until-fd-usable                                    fd :input (fd-stream-timeout stream))
915                                   fd :input (fd-stream-timeout stream))                              #+mp (mp:process-wait-until-fd-usable
916                       (error 'io-timeout :stream stream :direction :read))                                    fd :input (fd-stream-timeout stream))
917                     (do-input stream))                              (error 'io-timeout :stream stream :direction :read))
918                   (error "Error reading ~S: ~A"                      (do-input stream))
919                          stream                     ((eql errno unix:econnreset)
920                          (unix:get-unix-error-msg errno))))                      (error 'socket-error
921                               :format-control "Socket connection reset: ~A"
922                               :format-arguments (list (unix:get-unix-error-msg errno))
923                               :errno errno))
924                       (t
925                        (error (intl:gettext "Error reading ~S: ~A")
926                               stream
927                               (unix:get-unix-error-msg errno)))))
928              ((zerop count)              ((zerop count)
929               (setf (fd-stream-listen stream) :eof)               (setf (fd-stream-listen stream) :eof)
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 529  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  ;;;  ;;;
955  (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)  (defmacro input-wrapper ((stream bytes eof-error eof-value &optional type) &body read-forms)
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                 (fd-stream-unread ,stream-var)                 ,(if (eq type 'character)
962                        `(fd-stream-unread ,stream-var)
963                        `(char-code (fd-stream-unread ,stream-var)))
964               (setf (fd-stream-unread ,stream-var) nil)               (setf (fd-stream-unread ,stream-var) nil)
965               (setf (fd-stream-listen ,stream-var) nil))               (setf (fd-stream-listen ,stream-var) nil))
966             (let ((,element-var             (let ((,element-var
# Line 561  Line 982 
982                               &rest body)                               &rest body)
983    `(progn    `(progn
984       (defun ,name (stream eof-error eof-value)       (defun ,name (stream eof-error eof-value)
985         (input-wrapper (stream ,size eof-error eof-value)         (input-wrapper (stream ,size eof-error eof-value ,type)
986           (let ((,sap (fd-stream-ibuf-sap stream))           (let ((,sap (fd-stream-ibuf-sap stream))
987                 (,head (fd-stream-ibuf-head stream)))                 (,head (fd-stream-ibuf-head stream)))
988             ,@body)))             ,@body)))
# Line 625  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 633  Line 1129 
1129  (defun pick-input-routine (type)  (defun pick-input-routine (type)
1130    (dolist (entry *input-routines*)    (dolist (entry *input-routines*)
1131      (when (subtypep type (car entry))      (when (subtypep type (car entry))
1132        (return (values (symbol-function (cadr entry))        (return-from pick-input-routine
1133                        (car entry)          (values (symbol-function (cadr entry))
1134                        (caddr entry))))))                  (car entry)
1135                    (caddr entry)))))
1136      ;; FIXME: let's do it the hard way, then (but ignore things like
1137      ;; endianness, efficiency, and the necessary coupling between these
1138      ;; and the output routines).  -- CSR, 2004-02-09
1139      (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
1140            if (subtypep type `(unsigned-byte ,i))
1141            do (return-from pick-input-routine
1142                 (values
1143                  (lambda (stream eof-error eof-value)
1144                    (input-wrapper (stream (/ i 8) eof-error eof-value)
1145                      (let ((sap (fd-stream-ibuf-sap stream))
1146                            (head (fd-stream-ibuf-head stream)))
1147                        (loop for j from 0 below (/ i 8)
1148                              with result = 0
1149                              do (setf result
1150                                       (+ (* 256 result)
1151                                          (sap-ref-8 sap (+ head j))))
1152                              finally (return result)))))
1153                  `(unsigned-byte ,i)
1154                  (/ i 8))))
1155      (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
1156            if (subtypep type `(signed-byte ,i))
1157            do (return-from pick-input-routine
1158                 (values
1159                  (lambda (stream eof-error eof-value)
1160                    (input-wrapper (stream (/ i 8) eof-error eof-value)
1161                      (let ((sap (fd-stream-ibuf-sap stream))
1162                            (head (fd-stream-ibuf-head stream)))
1163                        (loop for j from 0 below (/ i 8)
1164                              with result = 0
1165                              do (setf result
1166                                       (+ (* 256 result)
1167                                          (sap-ref-8 sap (+ head j))))
1168                              finally (return (if (logbitp (1- i) result)
1169                                                  (dpb result (byte i 0) -1)
1170                                                  result))))))
1171                  `(signed-byte ,i)
1172                  (/ i 8)))))
1173    
1174  ;;; STRING-FROM-SAP -- internal  ;;; STRING-FROM-SAP -- internal
1175  ;;;  ;;;
# Line 697  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 721  Line 1255 
1255           (available (- tail head))           (available (- tail head))
1256           (copy (min requested available)))           (copy (min requested available)))
1257      (declare (type index offset head tail available copy))      (declare (type index offset head tail available copy))
1258        ;;
1259        ;; If something has been unread, put that at buffer + start,
1260        ;; and read the rest to start + 1.
1261        (when (fd-stream-unread stream) ;;@@
1262          (etypecase buffer
1263            (system-area-pointer
1264             (assert (= 1 (fd-stream-element-size stream)))
1265             (setf (sap-ref-8 buffer start) (char-code (read-char stream))))
1266            (string
1267             (setf (aref buffer start) (read-char stream)))
1268            (vector
1269             (setf (aref buffer start) (char-code(read-char stream)))))
1270          (return-from fd-stream-read-n-bytes
1271            (1+ (fd-stream-read-n-bytes stream buffer (1+ start) (1- requested)
1272                                        eof-error-p))))
1273        ;;
1274      (unless (zerop copy)      (unless (zerop copy)
1275        (if (typep buffer 'system-area-pointer)        (if (typep buffer 'system-area-pointer)
1276            (system-area-copy sap (* head vm:byte-bits)            (system-area-copy sap (* head vm:byte-bits)
# Line 762  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 782  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 818  Line 1368 
1368  ;;; output-p indicate what slots to fill. The buffering slot must be set prior  ;;; output-p indicate what slots to fill. The buffering slot must be set prior
1369  ;;; to calling this routine.  ;;; to calling this routine.
1370  ;;;  ;;;
1371  (defun set-routines (stream type input-p output-p buffer-p)  
1372    (defun set-routines (stream type input-p output-p buffer-p &key binary-stream-p)
1373    (let ((target-type (case type    (let ((target-type (case type
1374                         ((:default unsigned-byte)                         ((:default unsigned-byte)
1375                          '(unsigned-byte 8))                          '(unsigned-byte 8))
# Line 837  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              (setf (fd-stream-in stream) #'ill-in                                                    (eql size 1))
1413                                                 (pick-input-routine '(unsigned-byte 8))
1414                                                 #'ill-bin))
1415                (setf (fd-stream-in stream) (if (and binary-stream-p
1416                                                     (eql size 1))
1417                                                (pick-input-routine 'character)
1418                                                #'ill-in)
1419                    (fd-stream-bin stream) routine))                    (fd-stream-bin stream) routine))
1420          (when (or (eql size 1)          (when (or (eql size 1)
1421                    (eql size 2)                    (eql size 2)
1422                    (eql size 4))                    (eql size 4))
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              (setf (lisp-stream-in-buffer stream)                       (or
1427                    (make-array in-buffer-length                        ;; FIXME: Do this better.  We want to check for
1428                                :element-type '(unsigned-byte 8)))))                        ;; (unsigned-byte 8).  The 8 is unnecessary
1429                          ;; since we already have size = 1.
1430                          (or (eq 'unsigned-byte (and (consp type) (car type)))
1431                              (eq type :default))
1432                          (eq type 'character)))
1433                (when *enable-stream-buffer-p*
1434                  (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 869  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 891  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 910  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
1523    ;;;
1524    ;;;   Revert a file, if possible; otherwise do nothing.  Used during
1525    ;;; CLOSE when the abort flag is set.
1526    ;;;
1527    (defun revert-file (filename original)
1528      (declare (type simple-base-string filename)
1529               (type (or simple-base-string null) original))
1530      (when original
1531        (multiple-value-bind (okay err)
1532            (unix:unix-rename original filename)
1533          (unless okay
1534              (cerror (intl:gettext "Go on as if nothing bad happened.")
1535                      (intl:gettext "Could not restore ~S to its original contents: ~A")
1536                      filename (unix:get-unix-error-msg err))))))
1537    
1538    ;;; DELETE-ORIGINAL -- internal
1539    ;;;
1540    ;;;   Delete a backup file.  Used during CLOSE.
1541    ;;;
1542    (defun delete-original (filename original)
1543      (declare (type simple-base-string filename)
1544               (type (or simple-base-string null) original))
1545      (when original
1546        (multiple-value-bind (okay err) (unix:unix-unlink original)
1547          (unless okay
1548            (cerror "Go on as if nothing bad happened."
1549                    "Could not delete ~S during close of ~S: ~A"
1550                    original filename (unix:get-unix-error-msg err))))))
1551    
1552  ;;; FD-STREAM-MISC-ROUTINE -- input  ;;; FD-STREAM-MISC-ROUTINE -- input
1553  ;;;  ;;;
1554  ;;;   Handle the various misc operations on fd-stream.  ;;;   Handle the various misc operations on fd-stream.
# Line 934  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 942  Line 1599 
1599              (when (fd-stream-handler stream)              (when (fd-stream-handler stream)
1600                    (system:remove-fd-handler (fd-stream-handler stream))                    (system:remove-fd-handler (fd-stream-handler stream))
1601                    (setf (fd-stream-handler stream) nil))                    (setf (fd-stream-handler stream) nil))
1602              (when (and (fd-stream-file stream)              (when (and (fd-stream-file stream) (fd-stream-obuf-sap stream))
1603                         (fd-stream-obuf-sap stream))                (revert-file (fd-stream-file stream)
1604                ;; Can't do anything unless we know what file were dealing with,                             (fd-stream-original stream))))
               ;; and we don't want to do anything strange unless we were  
               ;; writing to the file.  
               (if (fd-stream-original stream)  
                   ;; Have an handle on the original, just revert.  
                   (multiple-value-bind  
                       (okay err)  
                       (unix:unix-rename (fd-stream-original stream)  
                                         (fd-stream-file stream))  
                     (unless okay  
                       (cerror "Go on as if nothing bad happened."  
                         "Could not restore ~S to it's original contents: ~A"  
                               (fd-stream-file stream)  
                               (unix:get-unix-error-msg err))))  
                   ;; Can't restore the orignal, so nuke that puppy.  
                   (multiple-value-bind  
                       (okay err)  
                       (unix:unix-unlink (fd-stream-file stream))  
                     (unless okay  
                       (cerror "Go on as if nothing bad happened."  
                               "Could not remove ~S: ~A"  
                               (fd-stream-file stream)  
                               (unix:get-unix-error-msg err)))))))  
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 (and (fd-stream-original stream)              (when (fd-stream-delete-original stream)
1616                         (fd-stream-delete-original stream))                (delete-original (fd-stream-file stream)
1617                (multiple-value-bind                                 (fd-stream-original stream)))))
                   (okay err)  
                   (unix:unix-unlink (fd-stream-original stream))  
                 (unless okay  
                   (cerror "Go on as if nothing bad happened."  
                           "Could not delete ~S during close of ~S: ~A"  
                           (fd-stream-original stream)  
                           stream  
                           (unix:get-unix-error-msg err)))))))  
1618       (when (fboundp 'cancel-finalization)       (when (fboundp 'cancel-finalization)
1619         (cancel-finalization stream))         (cancel-finalization stream))
1620       (unix:unix-close (fd-stream-fd stream))       (unix:unix-close (fd-stream-fd stream))
# Line 991  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 1030  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 1039  Line 1675 
1675         (declare (ignore ino nlink uid gid rdev         (declare (ignore ino nlink uid gid rdev
1676                          atime mtime ctime blksize blocks))                          atime mtime ctime blksize blocks))
1677         (unless okay         (unless okay
1678           (error "Error fstating ~S: ~A"           (error 'simple-file-error
1679                  stream                  :format-control (intl:gettext "Error fstating ~S: ~A")
1680                  (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
1683             (truncate size (fd-stream-element-size stream)))))             (values (truncate size (fd-stream-element-size stream))))))
1684      (:file-position      (:file-position
1685       (fd-stream-file-position stream arg1))))       (fd-stream-file-position stream arg1))))
1686    
# Line 1065  Line 1701 
1701                   ;; Adjust for buffered output:                   ;; Adjust for buffered output:
1702                   ;;  If there is any output buffered, the *real* file position                   ;;  If there is any output buffered, the *real* file position
1703                   ;; will be larger than reported by lseek because lseek                   ;; will be larger than reported by lseek because lseek
1704                   ;; obviously cannot take< into account output we have not                   ;; obviously cannot take into account output we have not
1705                   ;; sent yet.                   ;; sent yet.
1706                   (dolist (later (fd-stream-output-later stream))                   (dolist (later (fd-stream-output-later stream))
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 1078  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 1086  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 1101  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 1117  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 1126  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 1150  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                           (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 1165  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 (%make-fd-stream :fd fd    (let ((stream (if binary-stream-p
1875                                   :name name                      (%make-binary-text-stream :fd fd
1876                                   :file file                                                :name name
1877                                   :original original                                                :file file
1878                                   :delete-original delete-original                                                :original original
1879                                   :pathname pathname                                                :delete-original delete-original
1880                                   :buffering buffering                                                :pathname pathname
1881                                   :timeout timeout)))                                                :buffering buffering
1882      (set-routines stream element-type input output input-buffer-p)                                                :timeout timeout)
1883                        (let ((e (cond ((characterp encoding-error)
1884                                        (constantly (char-code encoding-error)))
1885                                       (t
1886                                        encoding-error)))
1887                              (d (cond ((characterp decoding-error)
1888                                        (constantly (char-code decoding-error)))
1889                                       ((eq t decoding-error)
1890                                        #'(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
1930                      :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 file descriptor ~D~%"                      (format *terminal-io* (intl:gettext "** Closed ~A~%") name)
1938                              fd))))                      (when original
1939                          (revert-file file original)))))
1940      stream))      stream))
1941    
1942    
1943  ;;; PICK-PACKUP-NAME -- internal  ;;; PICK-BACKUP-NAME -- internal
1944  ;;;  ;;;
1945  ;;; Pick a name to use for the backup file.  ;;; Pick a name to use for the backup file.
1946  ;;;  ;;;
# Line 1205  Line 1957 
1957        (simple-string (concatenate 'simple-string name ext))        (simple-string (concatenate 'simple-string name ext))
1958        (function (funcall ext name)))))        (function (funcall ext name)))))
1959    
1960    ;;; NEXT-VERSION -- internal
1961    ;;;
1962    ;;; Find the next available versioned name for a file.
1963    ;;;
1964    (defun next-version (name)
1965      (declare (type simple-string name))
1966      (let* ((*ignore-wildcards* t)
1967             (sep (position #\/ name :from-end t))
1968             (base (if sep (subseq name 0 (1+ sep)) ""))
1969             (dir (unix:open-dir base)))
1970        (multiple-value-bind (name type version)
1971            (extract-name-type-and-version name (if sep (1+ sep) 0) (length name))
1972          (let ((version (if (symbolp version) 1 (1+ version)))
1973                (match (if type
1974                           (concatenate 'string name "." type ".~")
1975                           (concatenate 'string name ".~"))))
1976            (when dir
1977              (unwind-protect
1978                   (loop
1979                     (let ((name (unix:read-dir dir)))
1980                       (cond ((null name) (return))
1981                             ((and (> (length name) (length match))
1982                                   (string= name match :end1 (length match)))
1983                              (multiple-value-bind (v e)
1984                                  (parse-integer name :start (length match)
1985                                                      :junk-allowed t)
1986                                (when (and v
1987                                           (= (length name) (1+ e))
1988                                           (char= (schar name e) #\~))
1989                                  (setq version (max version (1+ v)))))))))
1990                (unix:close-dir dir)))
1991            (concatenate 'string base
1992                         match (quick-integer-to-string version) "~")))))
1993    
1994  ;;; ASSURE-ONE-OF -- internal  ;;; ASSURE-ONE-OF -- internal
1995  ;;;  ;;;
1996  ;;; Assure that the given arg is one of the given list of valid things.  ;;; Assure that the given arg is one of the given list of valid things.
# Line 1213  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 1229  Line 2015 
2015  ;;;  ;;;
2016  ;;;    Rename Namestring to Original.  First, check if we have write access,  ;;;    Rename Namestring to Original.  First, check if we have write access,
2017  ;;; since we don't want to trash unwritable files even if we technically can.  ;;; since we don't want to trash unwritable files even if we technically can.
2018  ;;; We return true if we suceed in renaming.  ;;; We return true if we succeed in renaming.
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))
2033             nil))))             nil))))
2034    
2035  ;;; RETURN-STREAM -- internal  ;;; FD-OPEN  --  Internal
2036  ;;;  ;;;
2037  ;;; (this is just to save having to reindent the code in OPEN...move it there)  ;;;    Open a file.
2038  ;;;  ;;;
2039  (defmacro return-stream (class &body body)  (defun fd-open (pathname direction if-exists if-exists-given
2040    (let ((stream (gensym)))                            if-does-not-exist if-does-not-exist-given)
2041      `(let ((,stream (progn ,@body)))    (declare (type pathname pathname)
2042         (return (if ,class             (type (member :input :output :io :probe) direction)
2043                    (make-instance ,class :lisp-stream ,stream)             (type (member :error :new-version :rename :rename-and-delete
2044                    ,stream)))))                           :overwrite :append :supersede nil) if-exists)
2045               (type (member :error :create nil) if-does-not-exist))
2046      (multiple-value-bind (input output mask)
2047          (ecase direction
2048            (:input (values t nil unix:o_rdonly))
2049            (:output (values nil t unix:o_wronly))
2050            (:io (values t t unix:o_rdwr))
2051            (:probe (values t nil unix:o_rdonly)))
2052        (declare (type index mask))
2053        ;; Process if-exists argument if we are doing any output.
2054        (cond (output
2055               (unless if-exists-given
2056                 (setf if-exists
2057                       (if (eq (pathname-version pathname) :newest)
2058                           :new-version
2059                           :error)))
2060               (case if-exists
2061                 ((:error nil)
2062                  (setf mask (logior mask unix:o_excl)))
2063                 ((:new-version :rename :rename-and-delete)
2064                  (setf mask (logior mask unix:o_creat)))
2065                 (:supersede
2066                  (setf mask (logior mask unix:o_trunc)))))
2067              (t
2068               (setf if-exists nil)))     ; :ignore-this-arg
2069    
2070        (unless if-does-not-exist-given
2071          (setf if-does-not-exist
2072                (cond ((eq direction :input) :error)
2073                      ((and output
2074                            (member if-exists '(:overwrite :append)))
2075                       :error)
2076                      ((eq direction :probe)
2077                       nil)
2078                      (t
2079                       :create))))
2080        (if (eq if-does-not-exist :create)
2081            (setf mask (logior mask unix:o_creat)))
2082    
2083        (let ((name (cond ((unix-namestring pathname input))
2084                          ((and input (eq if-does-not-exist :create))
2085                           (unix-namestring pathname nil)))))
2086          (let ((original (cond ((and name (eq if-exists :new-version))
2087                                 (next-version name))
2088                                ((member if-exists '(:rename :rename-and-delete))
2089                                 (pick-backup-name name))))
2090                (delete-original (eq if-exists :rename-and-delete))
2091                (mode #o666))
2092            (when original
2093              ;; We are doing a :rename or :rename-and-delete.
2094              ;; Determine if the file already exists, make sure the original
2095              ;; file is not a directory and keep the mode
2096              (let ((exists
2097                     (and name
2098                          (multiple-value-bind
2099                                (okay err/dev inode orig-mode)
2100                              (unix:unix-stat name)
2101                            (declare (ignore inode)
2102                                     (type (or index null) orig-mode))
2103                            (cond
2104                              (okay
2105                               (when (and output (= (logand orig-mode #o170000)
2106                                                    #o40000))
2107                                 (error 'simple-file-error
2108                                     :pathname pathname
2109                                     :format-control
2110                                     (intl:gettext "Cannot open ~S for output: Is a directory.")
2111                                     :format-arguments (list name)))
2112                               (setf mode (logand orig-mode #o777))
2113                               t)
2114                              ((eql err/dev unix:enoent)
2115                               nil)
2116                              (t
2117                               (error 'simple-file-error
2118                                      :pathname pathname
2119                                      :format-control (intl:gettext "Cannot find ~S: ~A")
2120                                      :format-arguments
2121                                        (list name
2122                                          (unix:get-unix-error-msg err/dev)))))))))
2123                (unless (and exists
2124                             (do-old-rename name original))
2125                  (setf original nil)
2126                  (setf delete-original nil)
2127                  ;; In order to use SUPERSEDE instead, we have
2128                  ;; to make sure unix:o_creat corresponds to
2129                  ;; if-does-not-exist.  unix:o_creat was set
2130                  ;; before because of if-exists being :rename.
2131                  (unless (eq if-does-not-exist :create)
2132                    (setf mask (logior (logandc2 mask unix:o_creat)
2133                                       unix:o_trunc)))
2134                  (setf if-exists :supersede))))
2135    
2136            ;; Okay, now we can try the actual open.
2137            (loop
2138              (multiple-value-bind (fd errno)
2139                  (if name
2140                      (unix:unix-open name mask mode)
2141                      (values nil unix:enoent))
2142                (cond ((fixnump fd)
2143                       (when (eq if-exists :append)
2144                         (unix:unix-lseek fd 0 unix:l_xtnd)) ; SEEK_END
2145                       (return (values fd name original delete-original)))
2146                      ((eql errno unix:enoent)
2147                       (case if-does-not-exist
2148                         (:error
2149                           (cerror (intl:gettext "Return NIL.")
2150                                   'simple-file-error
2151                                   :pathname pathname
2152                                   :format-control (intl:gettext "Error opening ~S, ~A.")
2153                                   :format-arguments
2154                                       (list pathname
2155                                             (unix:get-unix-error-msg errno))))
2156                         (:create
2157                           (cerror (intl:gettext "Return NIL.")
2158                                   'simple-file-error
2159                                   :pathname pathname
2160                                   :format-control
2161                                       (intl:gettext "Error creating ~S, path does not exist.")
2162                                   :format-arguments (list pathname))))
2163                       (return nil))
2164                      ((eql errno unix:eexist)
2165                       (unless (eq nil if-exists)
2166                         (cerror (intl:gettext "Return NIL.")
2167                                 'simple-file-error
2168                                 :pathname pathname
2169                                 :format-control (intl:gettext "Error opening ~S, ~A.")
2170                                 :format-arguments
2171                                     (list pathname
2172                                           (unix:get-unix-error-msg errno))))
2173                       (return nil))
2174                      ((eql errno unix:eacces)
2175                       (cerror (intl:gettext "Try again.")
2176                               'simple-file-error
2177                               :pathname pathname
2178                               :format-control (intl:gettext "Error opening ~S, ~A.")
2179                               :format-arguments
2180                                   (list pathname
2181                                         (unix:get-unix-error-msg errno))))
2182                      (t
2183                       (cerror (intl:gettext "Return NIL.")
2184                               'simple-file-error
2185                               :pathname pathname
2186                               :format-control (intl:gettext "Error opening ~S, ~A.")
2187                               :format-arguments
2188                                   (list pathname
2189                                         (unix:get-unix-error-msg errno)))
2190                       (return nil)))))))))
2191    
2192    ;;; OPEN-FD-STREAM  --  Internal
2193    ;;;
2194    ;;;    Open an fd-stream connected to a file.
2195    ;;;
2196    (defun open-fd-stream (pathname &key (direction :input)
2197                                    (element-type 'base-char)
2198                                    (if-exists nil if-exists-given)
2199                                    (if-does-not-exist nil if-does-not-exist-given)
2200                                    (external-format :default)
2201                                    class
2202                                    decoding-error encoding-error)
2203      (declare (type pathname pathname)
2204               (type (member :input :output :io :probe) direction)
2205               (type (member :error :new-version :rename :rename-and-delete
2206                             :overwrite :append :supersede nil) if-exists)
2207               (type (member :error :create nil) if-does-not-exist))
2208      (multiple-value-bind (fd namestring original delete-original)
2209          (fd-open pathname direction if-exists if-exists-given
2210                   if-does-not-exist if-does-not-exist-given)
2211        (when fd
2212          (case direction
2213            ((:input :output :io)
2214             ;; We use the :class option to tell us if we want a
2215             ;; binary-text stream or not.
2216             (make-fd-stream fd
2217                             :input (member direction '(:input :io))
2218                             :output (member direction '(:output :io))
2219                             :element-type element-type
2220                             :file namestring
2221                             :original original
2222                             :delete-original delete-original
2223                             :pathname pathname
2224                             :input-buffer-p t
2225                             :auto-close t
2226                             :external-format external-format
2227                             :binary-stream-p class
2228                             :decoding-error decoding-error
2229                             :encoding-error encoding-error))
2230            (:probe
2231             (let ((stream (%make-fd-stream :name namestring :fd fd
2232                                            :pathname pathname
2233                                            :element-type element-type)))
2234               (close stream)
2235               stream))))))
2236    
2237  ;;; OPEN -- public  ;;; OPEN -- public
2238  ;;;  ;;;
2239  ;;;   Open the given file.  ;;;   Open the given file.
2240  ;;;  ;;;
2241  (defun open (filename  (defun open (filename &rest options
2242               &key                        &key (direction :input)
2243               (direction :input)                             (element-type 'base-char element-type-given)
2244               (element-type 'base-char)                             (if-exists nil if-exists-given)
2245               (if-exists nil if-exists-given)                             (if-does-not-exist nil if-does-not-exist-given)
2246               (if-does-not-exist nil if-does-not-exist-given)                             (external-format :default)
2247               (external-format :default)                             class mapped input-handle output-handle
2248               class                             decoding-error encoding-error
2249               &aux ; Squelch assignment warning.                        &allow-other-keys
2250               (direction direction)                        &aux ; Squelch assignment warning.
2251               (if-does-not-exist if-does-not-exist)                        (options options)
2252               (if-exists if-exists))                        (direction direction)
2253                          (if-does-not-exist if-does-not-exist)
2254                          (if-exists if-exists))
2255    "Return a stream which reads from or writes to Filename.    "Return a stream which reads from or writes to Filename.
2256    Defined keywords:    Defined keywords:
2257     :direction - one of :input, :output, :io, or :probe     :direction - one of :input, :output, :io, or :probe
# Line 1280  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 - 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))    (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.
2287      (when (wild-pathname-p filename)
2288        (error 'file-error :pathname filename))
2289    
2290    ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.    ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
2291    (setf direction    (setq direction
2292          (assure-one-of direction          (assure-one-of direction
2293                         '(:input :output :io :probe)                         '(:input :output :io :probe)
2294                         :direction))                         :direction))
2295      (setf (getf options :direction) direction)
2296    
2297    ;; Calculate useful stuff.    (when (and if-exists-given (member direction '(:output :io)))
2298    (multiple-value-bind      (setq if-exists
2299        (input output mask)            (assure-one-of if-exists
2300        (case direction                           '(:error :new-version :rename
2301          (:input (values t nil unix:o_rdonly))                             :rename-and-delete :overwrite
2302          (:output (values nil t unix:o_wronly))                             :append :supersede nil)
2303          (:io (values t t unix:o_rdwr))                           :if-exists))
2304          (:probe (values t nil unix:o_rdonly)))      (setf (getf options :if-exists) if-exists))
2305      (declare (type index mask))  
2306      (let* ((pathname (pathname filename))    (when if-does-not-exist-given
2307             (namestring      (setq if-does-not-exist
2308              (cond ((unix-namestring pathname input))            (assure-one-of if-does-not-exist
2309                    ((and input (eq if-does-not-exist :create))                           '(:error :create nil)
2310                     (unix-namestring pathname nil)))))                           :if-does-not-exist))
2311        ;; Process if-exists argument if we are doing any output.      (setf (getf options :if-does-not-exist) if-does-not-exist))
2312        (cond (output  
2313               (unless if-exists-given    (let ((filespec (merge-pathnames filename))
2314                 (setf if-exists          (options (copy-list options))
2315                       (if (eq (pathname-version pathname) :newest)          (class (or class 'fd-stream)))
2316                           :new-version      (cond ((eq class 'fd-stream)
2317                           :error)))             (remf options :class)
2318               (setf if-exists             (remf options :mapped)
2319                     (assure-one-of if-exists             (remf options :input-handle)
2320                                    '(:error :new-version :rename             (remf options :output-handle)
2321                                      :rename-and-delete :overwrite             (apply #'open-fd-stream filespec options))
2322                                      :append :supersede nil)            ((eq class 'binary-text-stream)
2323                                    :if-exists))             ;; Like fd-stream, but binary and text allowed.  This is
2324               (case if-exists             ;; indicated by leaving the :class option around for
2325                 ((:error nil)             ;; open-fd-stream to see.
2326                  (setf mask (logior mask unix:o_excl)))             (remf options :mapped)
2327                 ((:rename :rename-and-delete)             (remf options :input-handle)
2328                  (setf mask (logior mask unix:o_creat)))             (remf options :output-handle)
2329                 ((:new-version :supersede)             (apply #'open-fd-stream filespec options))
2330                  (setf mask (logior mask unix:o_trunc)))            ((subtypep class 'stream:simple-stream)
2331                 (:append             (when element-type-given
2332                  (setf mask (logior mask unix:o_append)))))               (cerror (intl:gettext "Do it anyway.")
2333              (t                       (intl:gettext "Can't create simple-streams with an element-type.")))
2334               (setf if-exists :ignore-this-arg)))             (when (and (eq class 'stream:file-simple-stream) mapped)
2335                 (setq class 'stream:mapped-file-simple-stream)
2336        (unless if-does-not-exist-given               (setf (getf options :class) 'stream:mapped-file-simple-stream))
2337          (setf if-does-not-exist             (when (subtypep class 'stream:file-simple-stream)
2338                (cond ((eq direction :input) :error)               (when (eq direction :probe)
2339                      ((and output                 (setq class 'stream:probe-simple-stream)))
2340                            (member if-exists '(:overwrite :append)))             (apply #'make-instance class :filename filespec options))
2341                       :error)            ((subtypep class 'ext:fundamental-stream)
2342                      ((eq direction :probe)             (remf options :class)
2343                       nil)             (remf options :mapped)
2344                      (t             (remf options :input-handle)
2345                       :create))))             (remf options :output-handle)
2346        (setf if-does-not-exist             (let ((stream (apply #'open-fd-stream filespec options)))
2347              (assure-one-of if-does-not-exist               (when stream
2348                             '(:error :create nil)                 (make-instance class :lisp-stream stream))))
2349                             :if-does-not-exist))            (t
2350        (if (eq if-does-not-exist :create)             (error (intl:gettext "Unable to open streams of class ~S.") class)))))
         (setf mask (logior mask unix:o_creat)))  
   
       (let ((original (if (member if-exists  
                                   '(:rename :rename-and-delete))  
                           (pick-backup-name namestring)))  
             (delete-original (eq if-exists :rename-and-delete))  
             (mode #o666))  
         (when original  
           ;; We are doing a :rename or :rename-and-delete.  
           ;; Determine if the file already exists, make sure the original  
           ;; file is not a directory and keep the mode  
           (let ((exists  
                  (and namestring  
                       (multiple-value-bind  
                           (okay err/dev inode orig-mode)  
                           (unix:unix-stat namestring)  
                         (declare (ignore inode)  
                                  (type (or index null) orig-mode))  
                         (cond  
                          (okay  
                           (when (and output (= (logand orig-mode #o170000)  
                                                #o40000))  
                             (error "Cannot open ~S for output: Is a directory."  
                                    namestring))  
                           (setf mode (logand orig-mode #o777))  
                           t)  
                          ((eql err/dev unix:enoent)  
                           nil)  
                          (t  
                           (error "Cannot find ~S: ~A"  
                                  namestring  
                                  (unix:get-unix-error-msg err/dev))))))))  
             (unless (and exists  
                          (do-old-rename namestring original))  
               (setf original nil)  
               (setf delete-original nil)  
               ;; In order to use SUPERSEDE instead, we have  
               ;; to make sure unix:o_creat corresponds to  
               ;; if-does-not-exist.  unix:o_creat was set  
               ;; before because of if-exists being :rename.  
               (unless (eq if-does-not-exist :create)  
                 (setf mask (logior (logandc2 mask unix:o_creat) unix:o_trunc)))  
               (setf if-exists :supersede))))  
   
         ;; Okay, now we can try the actual open.  
         (loop  
           (multiple-value-bind  
               (fd errno)  
               (if namestring  
                   (unix:unix-open namestring mask mode)  
                   (values nil unix:enoent))  
             (cond ((numberp fd)  
                    (return-stream class  
                     (case direction  
                       ((:input :output :io)  
                        (make-fd-stream fd  
                                        :input input  
                                        :output output  
                                        :element-type element-type  
                                        :file namestring  
                                        :original original  
                                        :delete-original delete-original  
                                        :pathname pathname  
                                        :input-buffer-p t  
                                        :auto-close t))  
                       (:probe  
                        (let ((stream  
                               (%make-fd-stream :name namestring :fd fd  
                                                :pathname pathname  
                                                :element-type element-type)))  
                          (close stream)  
                          stream)))))  
                   ((eql errno unix:enoent)  
                    (case if-does-not-exist  
                      (:error  
                       (cerror "Return NIL."  
                               'simple-file-error  
                               :pathname pathname  
                               :format-control "Error opening ~S, ~A."  
                               :format-arguments  
                               (list pathname (unix:get-unix-error-msg errno))))  
                      (:create  
                       (cerror "Return NIL."  
                               "Error creating ~S, path does not exist."  
                               pathname)))  
                    (return nil))  
                   ((eql errno unix:eexist)  
                    (unless (eq nil if-exists)  
                      (cerror "Return NIL."  
                              'simple-file-error  
                              :pathname pathname  
                              :format-control "Error opening ~S, ~A."  
                              :format-arguments  
                              (list pathname (unix:get-unix-error-msg errno))))  
                    (return nil))  
                   ((eql errno unix:eacces)  
                    (cerror "Try again."  
                           "Error opening ~S, ~A."  
                           pathname  
                           (unix:get-unix-error-msg errno)))  
                   (t  
                    (cerror "Return NIL."  
                            "Error opening ~S, ~A."  
                            pathname  
                            (unix:get-unix-error-msg errno))  
                    (return nil)))))))))  
2351    
2352  ;;;; Initialization.  ;;;; Initialization.
2353    
# Line 1485  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 1519  Line 2422 
2422  ;;; stuff to get and set the file name.  ;;; stuff to get and set the file name.
2423  ;;;  ;;;
2424  (defun file-name (stream &optional new-name)  (defun file-name (stream &optional new-name)
2425    (when (typep stream 'fd-stream)    (typecase stream
2426        (cond (new-name      (stream:simple-stream
2427               (setf (fd-stream-pathname stream) new-name)       (if new-name
2428               (setf (fd-stream-file stream)           (stream::%file-rename stream new-name)
2429                     (unix-namestring new-name nil))           (stream::%file-name stream)))
2430               t)      (fd-stream
2431              (t       (cond (new-name
2432               (fd-stream-pathname stream)))))              (setf (fd-stream-pathname stream) new-name)
2433                (setf (fd-stream-file stream)
2434                      (unix-namestring new-name nil))
2435                t)
2436               (t
2437                (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) (type file-stream stream))    (declare (type (or string character) object)
2475               (type (or file-stream broadcast-stream stream:simple-stream) stream))
2476    "Return the delta in Stream's FILE-POSITION that would be caused by writing    "Return the delta in Stream's FILE-POSITION that would be caused by writing
2477     Object to Stream.  Non-trivial only in implementations that support     Object to Stream.  Non-trivial only in implementations that support
2478     international character sets."     international character sets."
2479    (declare (ignore stream))    (typecase stream
2480    (etypecase object      (stream:simple-stream (stream::%file-string-length stream object))
2481      (character 1)      (broadcast-stream
2482      (string (length object))))       ;; CLHS says we must return 1 in this case
2483         1)
2484  (defun stream-external-format (stream)      #+unicode
2485    (declare (type file-stream stream) (ignore stream))      (t (funcall (ef-strlen (fd-stream-external-format stream))
2486    "Returns :DEFAULT."                  stream object))
2487    :default)      #-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.40.2.9  
changed lines
  Added in v.1.125

  ViewVC Help
Powered by ViewVC 1.1.5