/[cmucl]/src/code/fd-stream.lisp
ViewVC logotype

Contents of /src/code/fd-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.85.4.1 - (hide annotations)
Wed May 14 16:12:04 2008 UTC (5 years, 11 months ago) by rtoy
Branch: unicode-utf16-branch
CVS Tags: unicode-utf16-sync-2008-12, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-sync-label-2009-03-16, unicode-utf16-sync-2008-11, unicode-utf16-string-support
Branch point for: unicode-utf16-extfmt-branch
Changes since 1.85: +46 -2 lines
Initial checkin of unicode branch.  This is incomplete.

What works:
o Cross-compile works on sparc and a lisp.core is created.  This core
  is able to build code and appears to use 16-bit strings.

What doesn't:
o The sparc version is not able to rebuild itself.  It hangs when
  trying to create a new lisp.core.
o The x86 version will cross-compile, but worldload fails.  The files
  being loaded have bizarre names.  Probably some deftransform not
  working correctly.

Issues:
o Characters are still essentially 8 bits.  This needs to be fixed.
o All input/output is basically still 8 bits.  Only the low 8 bits of
  a character are output.  For input, characters are assumed to be
  8-bit.
o No external formats or anything is supported.
o Readtable support not done.


Use boot-2008-05-cross-unicode-{sparc,x86}.lisp to cross-compile the
unicode changes.

Untested whether this code can still be compiled without :unicode.

Changes:

code/array.lisp:
o Base-char strings are 16 bits wide, not 8.

code/c-call.lisp:
o Define versions of DEPORT-GEN, %NATURALIZE-C-STRING to "handle"
  unicode strings.

code/debug-info.lisp:
o Adjust READ-VAR-STRING to use 16-bit strings.  (Needed to at least
  to make the disassembler work.)

code/debug.lisp:
o Add address when printing out objects that can't be printed.
  (Generally useful and not just for unicode.)

code/fd-stream.lisp:
o Hack output routines to only use the low 8-bits of the character.
  (This needs significant work!)

code/filesys.lisp:
o Some debugging %primitive prints left in, but commented out, in
  PARSE-UNIX-NAMESTRING.

code/lispinit.lisp:
o Debugging %primitive print's for top-level forms.

code/load.lisp:
o Update FOP-SHORT-CHARACTER for unicode.  But still only output the
  low 8 bits of a character to a fasl/core.  This needs updating.
o Hack routines for symbols to explicitly read in the individual bytes
  of the symbol/package name because READ-N-BYTES isn't working for us
  right now.
o Update FOP-STRING/FOP-SMALL-STRING to read in 16-bit elements for
  strings.  Full 16-bit strings supported.
o Currently only write 8-bit chars for foreign names.  This needs
  fixing.

code/misc.lisp:
o Register :unicode runtime feature.

code/pathname.lisp:
o Debugging %primitive prints left in, but commented out.

code/stream.lisp:
o Replace %primitive byte-blt with REPLACE for now to get the desired
  characters.

code/unix-glibc2.lisp:
o Workaround for unix-current-directory to return 16-bit strings.
  (Not necessary anymore?)
o UNIX-RESOLVE-LINKS doesn't seem to like MAKE-STRING with an
  INITIAL-ELEMENT specified.  Remove initial-element.  (Needs fixing.)

code/unix.lisp:
o Same as for unix-glibc2.lisp

compiler/array-tran.lisp:
o Turn off the MAKE-STRING deftransform.
o Update ARRAY-INFO to create 16-bit arrays for an element-type of
  base-char.

compiler/dump.lisp:
o Only dump 8-bit chars to a fasl for foreign fixups.
o Explicitly dump the characters of symbol name.  DUMP-BYTES not quite
  working for us now?
o Make DUMP-SIMPLE-STRING dump all 16 bits of each character.
o Characters are dumped as the low 8 bits.  Needs fixing.

compiler/generic/new-genesis.lisp:
o STRING-TO-CORE writes 16-bit strings to the core file.
o FOP-SHORT-CHARACTER for unicode added, but we still only write 8
  bits to the core.  (Needs fixing.)
o COLD-LOAD-SYMBOL modified to read 16-bit characters from the fasl
  file to create a symbol.
o FOP-UNINTERNED-SYMBOL-SAVE and FOP-UNINTERNED-SMALL-SYMBOL-SAVE
  reads 16-bit characters for symbol names.
o FOP-STRING/FOP-SMALL-STRING reads 16-bit characters for strings.
o FOP-FOREIGN-FIXUP and FOP-FOREIGN-DATA-FIXUP still only read 8-bit
  characters for foreign names.  (Needs fixing.)

compiler/generic/vm-tran.lisp:
o New deftransforms to support unicode.  Not the most efficient but
  should be workable for now.  Old deftransforms didn't copy enough
  bits.
o Deftransform for concatenate completely disabled.  This needs
  fixing.

compiler/sparc/array.lisp:
o Change simple-string accessor to use halfword accessors instead of
  byte accessors.

compiler/x86/array.lisp:
o Change simple-string accessor to use halfword accessors instead of
  byte accessors.

lisp/Config.linux_gencgc:
o Define -DUNICODE as needed

lisp/Config.sun4_solaris_sunc
o Define -DUNICODE as needed.

lisp/alloc.c:
o alloc_string needs to allocate 16-bit strings

lisp/backtrace.c:
o Tell ldb backtrace how to print out 16-bit strings.  This is a hack!

lisp/gencgc.c:
o Tell GC how long the 16-bit strings are now.

lisp/interr.c:
o Not really needed but make debug_print (aka %primitive print)
  support all objects by calling ldb's print function to print the
  object.

lisp/os-common.c:
o Add hack convert_lisp_string to take a 16-bit Lisp string and create
  a new string containing just the low 8 bits of each Lisp character.
o OS foreign linkage stuff needs 8-bit strings, so we need to convert
  Lisp strings to the desired size.  Very hackish!

lisp/print.c:
o Teach ldb how to print Lisp 16-bit strings.  Currently, just dump
  out each byte of the 16-bit string.  This needs major work!

lisp/purify.c:
o Teach purify about the 16-bit strings.
1 ram 1.1 ;;; -*- Log: code.log; Package: LISP -*-
2 ram 1.11 ;;;
3 ram 1.1 ;;; **********************************************************************
4 ram 1.10 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.85.4.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/fd-stream.lisp,v 1.85.4.1 2008/05/14 16:12:04 rtoy Exp $")
9 ram 1.10 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Streams for UNIX file descriptors.
13     ;;;
14     ;;; Written by William Lott, July 1989 - January 1990.
15 ram 1.15 ;;; Some tuning by Rob MacLachlan.
16 ram 1.1 ;;;
17     ;;; **********************************************************************
18    
19    
20     (in-package "SYSTEM")
21    
22     (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
23 ram 1.15 io-timeout beep *beep-function* output-raw-bytes
24 rtoy 1.83 *tty* *stdin* *stdout* *stderr*
25     binary-text-stream))
26 ram 1.1
27    
28     (in-package "EXTENSIONS")
29    
30     (export '(*backup-extension*))
31    
32    
33     (in-package "LISP")
34    
35 toy 1.66 (export '(file-stream file-string-length))
36 ram 1.22
37 ram 1.1
38     ;;;; Buffer manipulation routines.
39    
40     (defvar *available-buffers* ()
41 ram 1.12 "List of available buffers. Each buffer is an sap pointing to
42     bytes-per-buffer of memory.")
43 ram 1.1
44     (defconstant bytes-per-buffer (* 4 1024)
45     "Number of bytes per buffer.")
46    
47 rtoy 1.79 ;; This limit is rather arbitrary
48     (defconstant max-stream-element-size 1024
49     "The maximum supported byte size for a stream element-type.")
50    
51 ram 1.1 ;;; NEXT-AVAILABLE-BUFFER -- Internal.
52     ;;;
53 ram 1.12 ;;; Returns the next available buffer, creating one if necessary.
54 ram 1.1 ;;;
55 pw 1.55 (declaim (inline next-available-buffer))
56 ram 1.1 ;;;
57     (defun next-available-buffer ()
58     (if *available-buffers*
59     (pop *available-buffers*)
60 wlott 1.5 (allocate-system-memory bytes-per-buffer)))
61 ram 1.1
62 rtoy 1.85 (declaim (inline buffer-sap bref (setf bref) buffer-copy))
63    
64     (defun buffer-sap (thing &optional offset)
65     (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
66     (optimize (speed 3) (space 2) (debug 0) (safety 0)
67     ;; Suppress the note about having to box up the return:
68     (ext:inhibit-warnings 3)))
69     (let ((sap (if (vectorp thing) (sys:vector-sap thing) thing)))
70     (if offset (sys:sap+ sap offset) sap)))
71    
72     (defun bref (buffer index)
73     (declare (type simple-stream-buffer buffer)
74     (type (integer 0 #.most-positive-fixnum) index))
75     (sys:sap-ref-8 (buffer-sap buffer) index))
76    
77     (defun (setf bref) (octet buffer index)
78     (declare (type (unsigned-byte 8) octet)
79     (type simple-stream-buffer buffer)
80     (type (integer 0 #.most-positive-fixnum) index))
81     (setf (sys:sap-ref-8 (buffer-sap buffer) index) octet))
82    
83     (defun buffer-copy (src soff dst doff length)
84     (declare (type simple-stream-buffer src dst)
85     (type fixnum soff doff length))
86     (sys:without-gcing ;; is this necessary??
87     (kernel:system-area-copy (buffer-sap src) (* soff 8)
88     (buffer-sap dst) (* doff 8)
89     (* length 8))))
90    
91     #-(or big-endian little-endian)
92     (eval-when (:compile-toplevel)
93     (push (c::backend-byte-order c::*target-backend*) *features*))
94    
95     (defun vector-elt-width (vector)
96     ;; Return octet-width of vector elements
97     (etypecase vector
98     ;; (simple-array fixnum (*)) not supported
99     ;; (simple-array base-char (*)) treated specially; don't call this
100     ((simple-array bit (*)) 1)
101     ((simple-array (unsigned-byte 2) (*)) 1)
102     ((simple-array (unsigned-byte 4) (*)) 1)
103     ((simple-array (signed-byte 8) (*)) 1)
104     ((simple-array (unsigned-byte 8) (*)) 1)
105     ((simple-array (signed-byte 16) (*)) 2)
106     ((simple-array (unsigned-byte 16) (*)) 2)
107     ((simple-array (signed-byte 32) (*)) 4)
108     ((simple-array (unsigned-byte 32) (*)) 4)
109     ((simple-array single-float (*)) 4)
110     ((simple-array double-float (*)) 8)
111     ((simple-array (complex single-float) (*)) 8)
112     ((simple-array (complex double-float) (*)) 16)
113     #+long-float
114     ((simple-array long-float (*)) 10)
115     #+long-float
116     ((simple-array (complex long-float) (*)) 20)
117     #+double-double
118     ((simple-array double-double-float (*)) 16)
119     #+double-double
120     ((simple-array (complex double-double-float) (*)) 32)))
121    
122     (defun endian-swap-value (vector endian-swap)
123     (case endian-swap
124     (:network-order #+big-endian 0
125     #+little-endian (1- (vector-elt-width vector)))
126     (:byte-8 0)
127     (:byte-16 1)
128     (:byte-32 3)
129     (:byte-64 7)
130     (:byte-128 15)
131     ;; additions by Lynn Quam
132     (:machine-endian 0)
133     (:big-endian #+big-endian 0
134     #+little-endian (1- (vector-elt-width vector)))
135     (:little-endian #+big-endian (1- (vector-elt-width vector))
136     #+little-endian 0)
137     (otherwise endian-swap)))
138    
139 ram 1.1
140     ;;;; The FD-STREAM structure.
141    
142 moore 1.62 ;;;; Superclass defined by the ANSI Spec
143     (defstruct (file-stream
144     (:include lisp-stream)
145     (:constructor nil)
146     (:copier nil)))
147    
148 ram 1.1 (defstruct (fd-stream
149     (:print-function %print-fd-stream)
150     (:constructor %make-fd-stream)
151 moore 1.62 (:include file-stream
152 ram 1.1 (misc #'fd-stream-misc-routine)))
153    
154     (name nil) ; The name of this stream
155     (file nil) ; The file this stream is for
156 ram 1.28 ;;
157     ;; The backup file namestring for the old file, for :if-exists :rename or
158     ;; :rename-and-delete.
159     (original nil :type (or simple-string null))
160 ram 1.1 (delete-original nil) ; for :if-exists :rename-and-delete
161 ram 1.14 ;;
162     ;;; Number of bytes per element.
163     (element-size 1 :type index)
164 wlott 1.16 (element-type 'base-char) ; The type of element being transfered.
165 ram 1.1 (fd -1 :type fixnum) ; The file descriptor
166 ram 1.14 ;;
167     ;; Controls when the output buffer is flushed.
168     (buffering :full :type (member :full :line :none))
169     ;;
170     ;; Character position if known.
171     (char-pos nil :type (or index null))
172     ;;
173     ;; T if input is waiting on FD. :EOF if we hit EOF.
174     (listen nil :type (member nil t :eof))
175     ;;
176 ram 1.1 ;; The input buffer.
177     (unread nil)
178 ram 1.14 (ibuf-sap nil :type (or system-area-pointer null))
179     (ibuf-length nil :type (or index null))
180     (ibuf-head 0 :type index)
181     (ibuf-tail 0 :type index)
182 ram 1.1
183     ;; The output buffer.
184 ram 1.14 (obuf-sap nil :type (or system-area-pointer null))
185     (obuf-length nil :type (or index null))
186     (obuf-tail 0 :type index)
187 ram 1.1
188     ;; Output flushed, but not written due to non-blocking io.
189     (output-later nil)
190 ram 1.15 (handler nil)
191     ;;
192     ;; Timeout specified for this stream, or NIL if none.
193 ram 1.28 (timeout nil :type (or index null))
194     ;;
195     ;; Pathname of the file this stream is opened to (returned by PATHNAME.)
196     (pathname nil :type (or pathname null)))
197 ram 1.1
198     (defun %print-fd-stream (fd-stream stream depth)
199 ram 1.14 (declare (ignore depth) (stream stream))
200 ram 1.1 (format stream "#<Stream for ~A>"
201     (fd-stream-name fd-stream)))
202    
203 rtoy 1.83 ;; CMUCL extension. This is a FD-STREAM, but it allows reading and
204     ;; writing of 8-bit characters and unsigned bytes from the stream.
205     (defstruct (binary-text-stream
206     (:print-function %print-binary-text-stream)
207     (:constructor %make-binary-text-stream)
208     (:include fd-stream)))
209    
210     (defun %print-binary-text-stream (fd-stream stream depth)
211     (declare (ignore depth) (stream stream))
212     (format stream "#<Binary-text Stream for ~A>"
213     (fd-stream-name fd-stream)))
214 ram 1.1
215 ram 1.31 (define-condition io-timeout (stream-error)
216     ((direction :reader io-timeout-direction :initarg :direction))
217 ram 1.15 (:report
218     (lambda (condition stream)
219 ram 1.23 (declare (stream stream))
220 ram 1.15 (format stream "Timeout ~(~A~)ing ~S."
221     (io-timeout-direction condition)
222     (stream-error-stream condition)))))
223    
224 ram 1.1
225     ;;;; Output routines and related noise.
226    
227     (defvar *output-routines* ()
228     "List of all available output routines. Each element is a list of the
229     element-type output, the kind of buffering, the function name, and the number
230     of bytes per element.")
231    
232     ;;; DO-OUTPUT-LATER -- internal
233     ;;;
234     ;;; Called by the server when we can write to the given file descriptor.
235 toy 1.67 ;;; Attempt to write the data again. If it worked, remove the data from the
236 ram 1.1 ;;; output-later list. If it didn't work, something is wrong.
237     ;;;
238     (defun do-output-later (stream)
239     (let* ((stuff (pop (fd-stream-output-later stream)))
240     (base (car stuff))
241     (start (cadr stuff))
242     (end (caddr stuff))
243 wlott 1.5 (reuse-sap (cadddr stuff))
244 ram 1.1 (length (- end start)))
245 ram 1.14 (declare (type index start end length))
246 ram 1.1 (multiple-value-bind
247     (count errno)
248 wlott 1.19 (unix:unix-write (fd-stream-fd stream)
249 ram 1.1 base
250     start
251     length)
252 ram 1.14 (cond ((not count)
253 wlott 1.19 (if (= errno unix:ewouldblock)
254 ram 1.14 (error "Write would have blocked, but SERVER told us to go.")
255     (error "While writing ~S: ~A"
256 wlott 1.19 stream (unix:get-unix-error-msg errno))))
257 toy 1.67 ((eql count length) ; Hot damn, it worked.
258 wlott 1.5 (when reuse-sap
259     (push base *available-buffers*)))
260 ram 1.1 ((not (null count)) ; Sorta worked.
261     (push (list base
262 ram 1.23 (the index (+ start count))
263 wlott 1.5 end)
264 ram 1.14 (fd-stream-output-later stream))))))
265 ram 1.1 (unless (fd-stream-output-later stream)
266     (system:remove-fd-handler (fd-stream-handler stream))
267     (setf (fd-stream-handler stream) nil)))
268    
269     ;;; OUTPUT-LATER -- internal
270     ;;;
271 toy 1.67 ;;; Arrange to output the string when we can write on the file descriptor.
272 ram 1.1 ;;;
273 wlott 1.5 (defun output-later (stream base start end reuse-sap)
274 ram 1.1 (cond ((null (fd-stream-output-later stream))
275     (setf (fd-stream-output-later stream)
276 wlott 1.5 (list (list base start end reuse-sap)))
277 ram 1.1 (setf (fd-stream-handler stream)
278     (system:add-fd-handler (fd-stream-fd stream)
279     :output
280     #'(lambda (fd)
281     (declare (ignore fd))
282     (do-output-later stream)))))
283     (t
284     (nconc (fd-stream-output-later stream)
285 wlott 1.5 (list (list base start end reuse-sap)))))
286     (when reuse-sap
287 ram 1.1 (let ((new-buffer (next-available-buffer)))
288 wlott 1.5 (setf (fd-stream-obuf-sap stream) new-buffer)
289 ram 1.14 (setf (fd-stream-obuf-length stream) bytes-per-buffer))))
290 ram 1.1
291     ;;; DO-OUTPUT -- internal
292     ;;;
293     ;;; Output the given noise. Check to see if there are any pending writes. If
294     ;;; so, just queue this one. Otherwise, try to write it. If this would block,
295     ;;; queue it.
296     ;;;
297 wlott 1.5 (defun do-output (stream base start end reuse-sap)
298 ram 1.14 (declare (type fd-stream stream)
299     (type (or system-area-pointer (simple-array * (*))) base)
300     (type index start end))
301 ram 1.1 (if (not (null (fd-stream-output-later stream))) ; something buffered.
302 ram 1.14 (progn
303     (output-later stream base start end reuse-sap)
304     ;; ### check to see if any of this noise can be output
305     )
306     (let ((length (- end start)))
307     (multiple-value-bind
308 dtc 1.51 (count errno)
309 wlott 1.19 (unix:unix-write (fd-stream-fd stream) base start length)
310 ram 1.14 (cond ((not count)
311 wlott 1.19 (if (= errno unix:ewouldblock)
312 ram 1.14 (output-later stream base start end reuse-sap)
313 emarsden 1.75 (error 'simple-stream-error
314     :stream stream
315     :format-control "while writing: ~A"
316     :format-arguments (list (unix:get-unix-error-msg errno)))))
317 ram 1.14 ((not (eql count length))
318 ram 1.23 (output-later stream base (the index (+ start count))
319     end reuse-sap)))))))
320 ram 1.1
321 ram 1.14
322 ram 1.1 ;;; FLUSH-OUTPUT-BUFFER -- internal
323     ;;;
324     ;;; Flush any data in the output buffer.
325     ;;;
326     (defun flush-output-buffer (stream)
327     (let ((length (fd-stream-obuf-tail stream)))
328     (unless (= length 0)
329 wlott 1.5 (do-output stream (fd-stream-obuf-sap stream) 0 length t)
330 ram 1.1 (setf (fd-stream-obuf-tail stream) 0))))
331    
332     ;;; DEF-OUTPUT-ROUTINES -- internal
333     ;;;
334     ;;; Define output routines that output numbers size bytes long for the
335     ;;; given bufferings. Use body to do the actual output.
336     ;;;
337     (defmacro def-output-routines ((name size &rest bufferings) &body body)
338 ram 1.23 (declare (optimize (speed 1)))
339 ram 1.1 (cons 'progn
340     (mapcar
341     #'(lambda (buffering)
342     (let ((function
343     (intern (let ((*print-case* :upcase))
344     (format nil name (car buffering))))))
345     `(progn
346     (defun ,function (stream byte)
347     ,(unless (eq (car buffering) :none)
348     `(when (< (fd-stream-obuf-length stream)
349     (+ (fd-stream-obuf-tail stream)
350     ,size))
351     (flush-output-buffer stream)))
352 gerd 1.73 ;;
353     ;; If there is any input read from UNIX but not
354     ;; supplied to the user of the stream, reposition
355     ;; to the real file position as seen from Lisp.
356     ,(unless (eq (car buffering) :none)
357     `(when (> (fd-stream-ibuf-tail stream)
358     (fd-stream-ibuf-head stream))
359     (file-position stream (file-position stream))))
360 ram 1.1 ,@body
361     (incf (fd-stream-obuf-tail stream) ,size)
362     ,(ecase (car buffering)
363     (:none
364     `(flush-output-buffer stream))
365     (:line
366     `(when (eq (char-code byte) (char-code #\Newline))
367     (flush-output-buffer stream)))
368     (:full
369     ))
370     (values))
371     (setf *output-routines*
372     (nconc *output-routines*
373     ',(mapcar
374     #'(lambda (type)
375     (list type
376     (car buffering)
377     function
378     size))
379     (cdr buffering)))))))
380     bufferings)))
381    
382 rtoy 1.85.4.1 #-unicode
383 wlott 1.5 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
384     1
385 wlott 1.6 (:none character)
386     (:line character)
387     (:full character))
388 ram 1.37 (if (char= byte #\Newline)
389 wlott 1.5 (setf (fd-stream-char-pos stream) 0)
390     (incf (fd-stream-char-pos stream)))
391     (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
392     (char-code byte)))
393    
394 rtoy 1.85.4.1 #+unicode
395     (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
396     1
397     (:none character)
398     (:line character)
399     (:full character))
400     (if (char= byte #\Newline)
401     (setf (fd-stream-char-pos stream) 0)
402     (incf (fd-stream-char-pos stream)))
403     ;; FIXME! We only use the low 8 bits of a character!
404     (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
405     (logand #xff (char-code byte))))
406    
407 ram 1.37 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
408 ram 1.1 1
409 ram 1.37 (:none (unsigned-byte 8))
410     (:full (unsigned-byte 8)))
411 wlott 1.5 (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
412     byte))
413 ram 1.1
414 ram 1.37 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
415     1
416     (:none (signed-byte 8))
417     (:full (signed-byte 8)))
418     (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)
419     (fd-stream-obuf-tail stream))
420     byte))
421    
422     (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
423 ram 1.1 2
424 ram 1.37 (:none (unsigned-byte 16))
425     (:full (unsigned-byte 16)))
426 wlott 1.20 (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
427 wlott 1.5 byte))
428    
429 ram 1.37 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
430     2
431     (:none (signed-byte 16))
432     (:full (signed-byte 16)))
433     (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)
434     (fd-stream-obuf-tail stream))
435     byte))
436    
437     (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
438 ram 1.1 4
439 ram 1.37 (:none (unsigned-byte 32))
440     (:full (unsigned-byte 32)))
441 wlott 1.20 (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
442 wlott 1.5 byte))
443 ram 1.37
444     (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
445     4
446     (:none (signed-byte 32))
447     (:full (signed-byte 32)))
448     (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)
449     (fd-stream-obuf-tail stream))
450     byte))
451    
452 ram 1.1
453     ;;; OUTPUT-RAW-BYTES -- public
454     ;;;
455     ;;; Does the actual output. If there is space to buffer the string, buffer
456     ;;; it. If the string would normally fit in the buffer, but doesn't because
457     ;;; of other stuff in the buffer, flush the old noise out of the buffer and
458     ;;; put the string in it. Otherwise we have a very long string, so just
459     ;;; send it directly (after flushing the buffer, of course).
460     ;;;
461     (defun output-raw-bytes (stream thing &optional start end)
462     "Output THING to stream. THING can be any kind of vector or a sap. If THING
463     is a SAP, END must be supplied (as length won't work)."
464     (let ((start (or start 0))
465 ram 1.14 (end (or end (length (the (simple-array * (*)) thing)))))
466     (declare (type index start end))
467 gerd 1.74 ;;
468     ;; If there is any input read from UNIX but not
469     ;; supplied to the user of the stream, reposition
470     ;; to the real file position as seen from Lisp.
471     (when (> (fd-stream-ibuf-tail stream)
472     (fd-stream-ibuf-head stream))
473     (file-position stream (file-position stream)))
474 ram 1.1 (let* ((len (fd-stream-obuf-length stream))
475     (tail (fd-stream-obuf-tail stream))
476     (space (- len tail))
477     (bytes (- end start))
478     (newtail (+ tail bytes)))
479     (cond ((minusp bytes) ; Error case
480     (cerror "Just go on as if nothing happened..."
481     "~S called with :END before :START!"
482     'output-raw-bytes))
483     ((zerop bytes)) ; Easy case
484     ((<= bytes space)
485 wlott 1.5 (if (system-area-pointer-p thing)
486     (system-area-copy thing
487     (* start vm:byte-bits)
488     (fd-stream-obuf-sap stream)
489     (* tail vm:byte-bits)
490     (* bytes vm:byte-bits))
491     (copy-to-system-area thing
492     (+ (* start vm:byte-bits)
493     (* vm:vector-data-offset vm:word-bits))
494     (fd-stream-obuf-sap stream)
495     (* tail vm:byte-bits)
496     (* bytes vm:byte-bits)))
497 ram 1.1 (setf (fd-stream-obuf-tail stream) newtail))
498     ((<= bytes len)
499     (flush-output-buffer stream)
500 wlott 1.5 (if (system-area-pointer-p thing)
501     (system-area-copy thing
502     (* start vm:byte-bits)
503     (fd-stream-obuf-sap stream)
504     0
505     (* bytes vm:byte-bits))
506     (copy-to-system-area thing
507     (+ (* start vm:byte-bits)
508     (* vm:vector-data-offset vm:word-bits))
509     (fd-stream-obuf-sap stream)
510     0
511     (* bytes vm:byte-bits)))
512 ram 1.1 (setf (fd-stream-obuf-tail stream) bytes))
513     (t
514     (flush-output-buffer stream)
515     (do-output stream thing start end nil))))))
516    
517     ;;; FD-SOUT -- internal
518     ;;;
519     ;;; Routine to use to output a string. If the stream is unbuffered, slam
520     ;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to
521     ;;; buffer the string. Update charpos by checking to see where the last newline
522     ;;; was.
523     ;;;
524     ;;; Note: some bozos (the FASL dumper) call write-string with things other
525     ;;; than strings. Therefore, we must make sure we have a string before calling
526     ;;; position on it.
527     ;;;
528 rtoy 1.85.4.1 #-unicode
529 ram 1.1 (defun fd-sout (stream thing start end)
530     (let ((start (or start 0))
531 ram 1.14 (end (or end (length (the vector thing)))))
532 dtc 1.51 (declare (type index start end))
533 ram 1.1 (if (stringp thing)
534 wlott 1.5 (let ((last-newline (and (find #\newline (the simple-string thing)
535     :start start :end end)
536     (position #\newline (the simple-string thing)
537     :from-end t
538     :start start
539     :end end))))
540     (ecase (fd-stream-buffering stream)
541     (:full
542     (output-raw-bytes stream thing start end))
543     (:line
544     (output-raw-bytes stream thing start end)
545     (when last-newline
546     (flush-output-buffer stream)))
547     (:none
548     (do-output stream thing start end nil)))
549     (if last-newline
550     (setf (fd-stream-char-pos stream)
551     (- end last-newline 1))
552     (incf (fd-stream-char-pos stream)
553     (- end start))))
554 ram 1.1 (ecase (fd-stream-buffering stream)
555 wlott 1.5 ((:line :full)
556 ram 1.1 (output-raw-bytes stream thing start end))
557     (:none
558 wlott 1.5 (do-output stream thing start end nil))))))
559 ram 1.1
560 rtoy 1.85.4.1 #+unicode
561     (defun fd-sout (stream thing start end)
562     (declare (type string thing))
563     (let ((start (or start 0))
564     (end (or end (length (the vector thing)))))
565     (declare (type index start end))
566     (cond
567     ((stringp thing) ; FIXME - remove this test
568     (let ((out (fd-stream-out stream)))
569     (do ((index start (+ index 1)))
570     ((>= index end))
571     (funcall out stream (elt thing index))))))))
572    
573     #+unicode ; a lame sout hack to make external-format work quickly
574     (defun fd-sout-each-character (stream thing start end)
575     (declare (type string thing))
576     (let ((start (or start 0))
577     (end (or end (length (the vector thing)))))
578     (declare (type index start end))
579     (let ((out (fd-stream-out stream)))
580     (do ((index start (+ index 1)))
581     ((>= index end))
582     (funcall out stream (aref thing index))))))
583    
584 rtoy 1.79 (defmacro output-wrapper ((stream size buffering) &body body)
585     (let ((stream-var (gensym)))
586     `(let ((,stream-var ,stream))
587     ,(unless (eq (car buffering) :none)
588     `(when (< (fd-stream-obuf-length ,stream-var)
589     (+ (fd-stream-obuf-tail ,stream-var)
590     ,size))
591     (flush-output-buffer ,stream-var)))
592     ,(unless (eq (car buffering) :none)
593     `(when (> (fd-stream-ibuf-tail ,stream-var)
594     (fd-stream-ibuf-head ,stream-var))
595     (file-position ,stream-var (file-position ,stream-var))))
596    
597     ,@body
598     (incf (fd-stream-obuf-tail ,stream-var) ,size)
599     ,(ecase (car buffering)
600     (:none
601     `(flush-output-buffer ,stream-var))
602     (:line
603     `(when (eq (char-code byte) (char-code #\Newline))
604     (flush-output-buffer ,stream-var)))
605     (:full))
606     (values))))
607    
608 ram 1.1 ;;; PICK-OUTPUT-ROUTINE -- internal
609     ;;;
610     ;;; Find an output routine to use given the type and buffering. Return as
611     ;;; multiple values the routine, the real type transfered, and the number of
612     ;;; bytes per element.
613     ;;;
614     (defun pick-output-routine (type buffering)
615     (dolist (entry *output-routines*)
616     (when (and (subtypep type (car entry))
617     (eq buffering (cadr entry)))
618 rtoy 1.79 (return-from pick-output-routine
619     (values (symbol-function (caddr entry))
620     (car entry)
621     (cadddr entry)))))
622     ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
623     (loop for i from 40 by 8 to max-stream-element-size ; ARB (KLUDGE)
624     if (subtypep type `(unsigned-byte ,i))
625     do (return-from pick-output-routine
626     (values
627     (ecase buffering
628     (:none
629     (lambda (stream byte)
630     (output-wrapper (stream (/ i 8) (:none))
631     (loop for j from 0 below (/ i 8)
632     do (setf (sap-ref-8
633     (fd-stream-obuf-sap stream)
634     (+ j (fd-stream-obuf-tail stream)))
635     (ldb (byte 8 (- i 8 (* j 8))) byte))))))
636     (:full
637     (lambda (stream byte)
638     (output-wrapper (stream (/ i 8) (:full))
639     (loop for j from 0 below (/ i 8)
640     do (setf (sap-ref-8
641     (fd-stream-obuf-sap stream)
642     (+ j (fd-stream-obuf-tail stream)))
643     (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
644     `(unsigned-byte ,i)
645     (/ i 8))))
646     (loop for i from 40 by 8 to max-stream-element-size ; ARB (KLUDGE)
647     if (subtypep type `(signed-byte ,i))
648     do (return-from pick-output-routine
649     (values
650     (ecase buffering
651     (:none
652     (lambda (stream byte)
653     (output-wrapper (stream (/ i 8) (:none))
654     (loop for j from 0 below (/ i 8)
655     do (setf (sap-ref-8
656     (fd-stream-obuf-sap stream)
657     (+ j (fd-stream-obuf-tail stream)))
658     (ldb (byte 8 (- i 8 (* j 8))) byte))))))
659     (:full
660     (lambda (stream byte)
661     (output-wrapper (stream (/ i 8) (:full))
662     (loop for j from 0 below (/ i 8)
663     do (setf (sap-ref-8
664     (fd-stream-obuf-sap stream)
665     (+ j (fd-stream-obuf-tail stream)))
666     (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
667     `(signed-byte ,i)
668     (/ i 8)))))
669 ram 1.1
670     ;;;; Input routines and related noise.
671    
672     (defvar *input-routines* ()
673     "List of all available input routines. Each element is a list of the
674     element-type input, the function name, and the number of bytes per element.")
675    
676     ;;; DO-INPUT -- internal
677     ;;;
678     ;;; Fills the input buffer, and returns the first character. Throws to
679     ;;; eof-input-catcher if the eof was reached. Drops into system:server if
680     ;;; necessary.
681     ;;;
682     (defun do-input (stream)
683     (let ((fd (fd-stream-fd stream))
684     (ibuf-sap (fd-stream-ibuf-sap stream))
685     (buflen (fd-stream-ibuf-length stream))
686     (head (fd-stream-ibuf-head stream))
687     (tail (fd-stream-ibuf-tail stream)))
688 ram 1.14 (declare (type index head tail))
689 ram 1.1 (unless (zerop head)
690 ram 1.14 (cond ((eql head tail)
691 ram 1.1 (setf head 0)
692     (setf tail 0)
693     (setf (fd-stream-ibuf-head stream) 0)
694     (setf (fd-stream-ibuf-tail stream) 0))
695     (t
696     (decf tail head)
697 wlott 1.5 (system-area-copy ibuf-sap (* head vm:byte-bits)
698     ibuf-sap 0 (* tail vm:byte-bits))
699 ram 1.1 (setf head 0)
700     (setf (fd-stream-ibuf-head stream) 0)
701     (setf (fd-stream-ibuf-tail stream) tail))))
702     (setf (fd-stream-listen stream) nil)
703     (multiple-value-bind
704 dtc 1.41 (count errno)
705     (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
706     (unix:fd-zero read-fds)
707     (unix:fd-set fd read-fds)
708     (unix:unix-fast-select (1+ fd) (alien:addr read-fds) nil nil 0 0))
709 dtc 1.49 ;; Wait if input is not available or if interrupted.
710     (when (or (eql count 0)
711     (and (not count) (eql errno unix:eintr)))
712     (unless #-mp (system:wait-until-fd-usable
713     fd :input (fd-stream-timeout stream))
714     #+mp (mp:process-wait-until-fd-usable
715     fd :input (fd-stream-timeout stream))
716     (error 'io-timeout :stream stream :direction :read))))
717 ram 1.1 (multiple-value-bind
718 dtc 1.42 (count errno)
719 wlott 1.19 (unix:unix-read fd
720 ram 1.1 (system:int-sap (+ (system:sap-int ibuf-sap) tail))
721     (- buflen tail))
722     (cond ((null count)
723 rtoy 1.81 ;; What kinds of errors do we want to look at and what do
724     ;; we want them to do?
725     (cond ((eql errno unix:ewouldblock)
726     (unless #-mp (system:wait-until-fd-usable
727     fd :input (fd-stream-timeout stream))
728     #+mp (mp:process-wait-until-fd-usable
729     fd :input (fd-stream-timeout stream))
730     (error 'io-timeout :stream stream :direction :read))
731     (do-input stream))
732     ((eql errno unix:econnreset)
733     (error 'socket-error
734     :format-control "Socket connection reset: ~A"
735     :format-arguments (list (unix:get-unix-error-msg errno))
736     :errno errno))
737     (t
738     (error "Error reading ~S: ~A"
739     stream
740     (unix:get-unix-error-msg errno)))))
741 ram 1.1 ((zerop count)
742 ram 1.12 (setf (fd-stream-listen stream) :eof)
743 ram 1.1 (throw 'eof-input-catcher nil))
744     (t
745     (incf (fd-stream-ibuf-tail stream) count))))))
746    
747     ;;; INPUT-AT-LEAST -- internal
748     ;;;
749     ;;; Makes sure there are at least ``bytes'' number of bytes in the input
750     ;;; buffer. Keeps calling do-input until that condition is met.
751     ;;;
752     (defmacro input-at-least (stream bytes)
753     (let ((stream-var (gensym))
754     (bytes-var (gensym)))
755     `(let ((,stream-var ,stream)
756     (,bytes-var ,bytes))
757     (loop
758     (when (>= (- (fd-stream-ibuf-tail ,stream-var)
759     (fd-stream-ibuf-head ,stream-var))
760     ,bytes-var)
761     (return))
762     (do-input ,stream-var)))))
763    
764     ;;; INPUT-WRAPPER -- intenal
765     ;;;
766 ram 1.24 ;;; Macro to wrap around all input routines to handle eof-error noise.
767 ram 1.1 ;;;
768 rtoy 1.82 (defmacro input-wrapper ((stream bytes eof-error eof-value &optional type) &body read-forms)
769 ram 1.1 (let ((stream-var (gensym))
770     (element-var (gensym)))
771     `(let ((,stream-var ,stream))
772 ram 1.26 (if (fd-stream-unread ,stream-var)
773     (prog1
774 rtoy 1.82 ,(if (eq type 'character)
775     `(fd-stream-unread ,stream-var)
776     `(char-code (fd-stream-unread ,stream-var)))
777 ram 1.26 (setf (fd-stream-unread ,stream-var) nil)
778     (setf (fd-stream-listen ,stream-var) nil))
779     (let ((,element-var
780     (catch 'eof-input-catcher
781     (input-at-least ,stream-var ,bytes)
782     ,@read-forms)))
783     (cond (,element-var
784     (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
785     ,element-var)
786     (t
787     (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
788 ram 1.1
789     ;;; DEF-INPUT-ROUTINE -- internal
790     ;;;
791     ;;; Defines an input routine.
792     ;;;
793     (defmacro def-input-routine (name
794     (type size sap head)
795     &rest body)
796     `(progn
797     (defun ,name (stream eof-error eof-value)
798 rtoy 1.82 (input-wrapper (stream ,size eof-error eof-value ,type)
799 ram 1.1 (let ((,sap (fd-stream-ibuf-sap stream))
800     (,head (fd-stream-ibuf-head stream)))
801     ,@body)))
802     (setf *input-routines*
803     (nconc *input-routines*
804     (list (list ',type ',name ',size))))))
805    
806 wlott 1.6 ;;; INPUT-CHARACTER -- internal
807 ram 1.1 ;;;
808     ;;; Routine to use in stream-in slot for reading string chars.
809     ;;;
810 wlott 1.6 (def-input-routine input-character
811     (character 1 sap head)
812 wlott 1.5 (code-char (sap-ref-8 sap head)))
813 ram 1.1
814     ;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
815     ;;;
816     ;;; Routine to read in an unsigned 8 bit number.
817     ;;;
818     (def-input-routine input-unsigned-8bit-byte
819     ((unsigned-byte 8) 1 sap head)
820 wlott 1.5 (sap-ref-8 sap head))
821 ram 1.1
822     ;;; INPUT-SIGNED-8BIT-BYTE -- internal
823     ;;;
824     ;;; Routine to read in a signed 8 bit number.
825     ;;;
826     (def-input-routine input-signed-8bit-number
827     ((signed-byte 8) 1 sap head)
828 wlott 1.5 (signed-sap-ref-8 sap head))
829 ram 1.1
830     ;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
831     ;;;
832     ;;; Routine to read in an unsigned 16 bit number.
833     ;;;
834     (def-input-routine input-unsigned-16bit-byte
835     ((unsigned-byte 16) 2 sap head)
836 wlott 1.20 (sap-ref-16 sap head))
837 ram 1.1
838     ;;; INPUT-SIGNED-16BIT-BYTE -- internal
839     ;;;
840     ;;; Routine to read in a signed 16 bit number.
841     ;;;
842     (def-input-routine input-signed-16bit-byte
843     ((signed-byte 16) 2 sap head)
844 wlott 1.20 (signed-sap-ref-16 sap head))
845 ram 1.1
846     ;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
847     ;;;
848     ;;; Routine to read in a unsigned 32 bit number.
849     ;;;
850     (def-input-routine input-unsigned-32bit-byte
851     ((unsigned-byte 32) 4 sap head)
852 wlott 1.20 (sap-ref-32 sap head))
853 ram 1.1
854     ;;; INPUT-SIGNED-32BIT-BYTE -- internal
855     ;;;
856     ;;; Routine to read in a signed 32 bit number.
857     ;;;
858     (def-input-routine input-signed-32bit-byte
859     ((signed-byte 32) 4 sap head)
860 wlott 1.20 (signed-sap-ref-32 sap head))
861 ram 1.1
862     ;;; PICK-INPUT-ROUTINE -- internal
863     ;;;
864     ;;; Find an input routine to use given the type. Return as multiple values
865     ;;; the routine, the real type transfered, and the number of bytes per element.
866     ;;;
867     (defun pick-input-routine (type)
868     (dolist (entry *input-routines*)
869     (when (subtypep type (car entry))
870 rtoy 1.79 (return-from pick-input-routine
871     (values (symbol-function (cadr entry))
872     (car entry)
873     (caddr entry)))))
874     ;; FIXME: let's do it the hard way, then (but ignore things like
875     ;; endianness, efficiency, and the necessary coupling between these
876     ;; and the output routines). -- CSR, 2004-02-09
877     (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
878     if (subtypep type `(unsigned-byte ,i))
879     do (return-from pick-input-routine
880     (values
881     (lambda (stream eof-error eof-value)
882     (input-wrapper (stream (/ i 8) eof-error eof-value)
883     (let ((sap (fd-stream-ibuf-sap stream))
884     (head (fd-stream-ibuf-head stream)))
885     (loop for j from 0 below (/ i 8)
886     with result = 0
887     do (setf result
888     (+ (* 256 result)
889     (sap-ref-8 sap (+ head j))))
890     finally (return result)))))
891     `(unsigned-byte ,i)
892     (/ i 8))))
893     (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
894     if (subtypep type `(signed-byte ,i))
895     do (return-from pick-input-routine
896     (values
897     (lambda (stream eof-error eof-value)
898     (input-wrapper (stream (/ i 8) eof-error eof-value)
899     (let ((sap (fd-stream-ibuf-sap stream))
900     (head (fd-stream-ibuf-head stream)))
901     (loop for j from 0 below (/ i 8)
902     with result = 0
903     do (setf result
904     (+ (* 256 result)
905     (sap-ref-8 sap (+ head j))))
906 rtoy 1.80 finally (return (if (logbitp (1- i) result)
907     (dpb result (byte i 0) -1)
908     result))))))
909 rtoy 1.79 `(signed-byte ,i)
910     (/ i 8)))))
911 ram 1.1
912     ;;; STRING-FROM-SAP -- internal
913     ;;;
914     ;;; Returns a string constructed from the sap, start, and end.
915     ;;;
916     (defun string-from-sap (sap start end)
917 ram 1.14 (declare (type index start end))
918 ram 1.1 (let* ((length (- end start))
919     (string (make-string length)))
920 wlott 1.5 (copy-from-system-area sap (* start vm:byte-bits)
921     string (* vm:vector-data-offset vm:word-bits)
922     (* length vm:byte-bits))
923 ram 1.1 string))
924    
925 ram 1.13 #|
926 ram 1.1 ;;; FD-STREAM-READ-N-BYTES -- internal
927     ;;;
928 dtc 1.50 ;;; This version waits using server. I changed to the non-server version
929     ;;; because it allows this method to be used by CLX w/o confusing serve-event.
930     ;;; The non-server method is also significantly more efficient for large
931     ;;; reads. -- Ram
932     ;;;
933 ram 1.1 ;;; The n-bin routine.
934     ;;;
935     (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
936 dtc 1.50 (declare (type stream stream) (type index start requested))
937 ram 1.1 (let* ((sap (fd-stream-ibuf-sap stream))
938     (elsize (fd-stream-element-size stream))
939     (offset (* elsize start))
940     (bytes (* elsize requested))
941 wlott 1.5 (result
942     (catch 'eof-input-catcher
943     (loop
944     (input-at-least stream 1)
945     (let* ((head (fd-stream-ibuf-head stream))
946     (tail (fd-stream-ibuf-tail stream))
947     (available (- tail head))
948     (copy (min available bytes)))
949     (if (typep buffer 'system-area-pointer)
950     (system-area-copy sap (* head vm:byte-bits)
951     buffer (* offset vm:byte-bits)
952     (* copy vm:byte-bits))
953     (copy-from-system-area sap (* head vm:byte-bits)
954     buffer (+ (* offset vm:byte-bits)
955     (* vm:vector-data-offset
956     vm:word-bits))
957     (* copy vm:byte-bits)))
958     (incf (fd-stream-ibuf-head stream) copy)
959     (incf offset copy)
960     (decf bytes copy))
961     (when (zerop bytes)
962     (return requested))))))
963 ram 1.26 (or result
964     (eof-or-lose stream eof-error-p
965     (- requested (/ bytes elsize))))))
966 ram 1.13 |#
967 ram 1.1
968 ram 1.13
969     ;;; FD-STREAM-READ-N-BYTES -- internal
970     ;;;
971 dtc 1.50 ;;; The N-Bin method for FD-STREAMs. This doesn't use the SERVER; it blocks
972 ram 1.13 ;;; in UNIX-READ. This allows the method to be used to implementing reading
973     ;;; for CLX. It is generally used where there is a definite amount of reading
974 ram 1.14 ;;; to be done, so blocking isn't too problematical.
975 ram 1.13 ;;;
976     ;;; We copy buffered data into the buffer. If there is enough, just return.
977     ;;; Otherwise, we see if the amount of additional data needed will fit in the
978     ;;; stream buffer. If not, inhibit GCing (so we can have a SAP into the Buffer
979     ;;; argument), and read directly into the user supplied buffer. Otherwise,
980     ;;; read a buffer-full into the stream buffer and then copy the amount we need
981     ;;; out.
982     ;;;
983     ;;; We loop doing the reads until we either get enough bytes or hit EOF. We
984 ram 1.24 ;;; must loop when eof-errorp is T because some streams (like pipes) may return
985     ;;; a partial amount without hitting EOF.
986     ;;;
987 ram 1.13 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
988     (declare (type stream stream) (type index start requested))
989     (let* ((sap (fd-stream-ibuf-sap stream))
990 ram 1.24 (offset start)
991 ram 1.13 (head (fd-stream-ibuf-head stream))
992     (tail (fd-stream-ibuf-tail stream))
993     (available (- tail head))
994 ram 1.24 (copy (min requested available)))
995     (declare (type index offset head tail available copy))
996 gerd 1.72 ;;
997     ;; If something has been unread, put that at buffer + start,
998     ;; and read the rest to start + 1.
999     (when (fd-stream-unread stream)
1000     (etypecase buffer
1001     (system-area-pointer
1002     (assert (= 1 (fd-stream-element-size stream)))
1003     (setf (sap-ref-8 buffer start) (char-code (read-char stream))))
1004 rtoy 1.82 (string
1005     (setf (aref buffer start) (read-char stream)))
1006 gerd 1.72 (vector
1007 rtoy 1.82 (setf (aref buffer start) (char-code(read-char stream)))))
1008 gerd 1.72 (return-from fd-stream-read-n-bytes
1009     (1+ (fd-stream-read-n-bytes stream buffer (1+ start) (1- requested)
1010     eof-error-p))))
1011     ;;
1012 ram 1.13 (unless (zerop copy)
1013     (if (typep buffer 'system-area-pointer)
1014     (system-area-copy sap (* head vm:byte-bits)
1015     buffer (* offset vm:byte-bits)
1016     (* copy vm:byte-bits))
1017     (copy-from-system-area sap (* head vm:byte-bits)
1018     buffer (+ (* offset vm:byte-bits)
1019     (* vm:vector-data-offset
1020     vm:word-bits))
1021     (* copy vm:byte-bits)))
1022     (incf (fd-stream-ibuf-head stream) copy))
1023     (cond
1024 ram 1.24 ((or (= copy requested)
1025     (and (not eof-error-p) (/= copy 0)))
1026     copy)
1027     (t
1028 ram 1.13 (setf (fd-stream-ibuf-head stream) 0)
1029     (setf (fd-stream-ibuf-tail stream) 0)
1030     (setf (fd-stream-listen stream) nil)
1031 ram 1.24 (let ((now-needed (- requested copy))
1032 ram 1.13 (len (fd-stream-ibuf-length stream)))
1033     (declare (type index now-needed len))
1034     (cond
1035     ((> now-needed len)
1036 ram 1.32 ;;
1037     ;; If the desired amount is greater than the stream buffer size, then
1038     ;; read directly into the destination, incrementing the start
1039     ;; accordingly. In this case, we never leave anything in the stream
1040     ;; buffer.
1041 ram 1.13 (system:without-gcing
1042     (loop
1043     (multiple-value-bind
1044     (count err)
1045 wlott 1.19 (unix:unix-read (fd-stream-fd stream)
1046 ram 1.13 (sap+ (if (typep buffer 'system-area-pointer)
1047     buffer
1048     (vector-sap buffer))
1049     (+ offset copy))
1050     now-needed)
1051     (declare (type (or index null) count))
1052     (unless count
1053     (error "Error reading ~S: ~A" stream
1054 wlott 1.19 (unix:get-unix-error-msg err)))
1055 pw 1.48 (decf now-needed count)
1056 ram 1.33 (if eof-error-p
1057     (when (zerop count)
1058     (error 'end-of-file :stream stream))
1059     (return (- requested now-needed)))
1060 ram 1.13 (when (zerop now-needed) (return requested))
1061     (incf offset count)))))
1062     (t
1063 ram 1.32 ;;
1064     ;; If we want less than the buffer size, then loop trying to fill the
1065     ;; stream buffer and copying what we get into the destination. When
1066     ;; we have enough, we leave what's left in the stream buffer.
1067 ram 1.13 (loop
1068     (multiple-value-bind
1069     (count err)
1070 wlott 1.19 (unix:unix-read (fd-stream-fd stream) sap len)
1071 ram 1.13 (declare (type (or index null) count))
1072     (unless count
1073     (error "Error reading ~S: ~A" stream
1074 wlott 1.19 (unix:get-unix-error-msg err)))
1075 ram 1.33 (when (and eof-error-p (zerop count))
1076     (error 'end-of-file :stream stream))
1077    
1078 ram 1.13 (let* ((copy (min now-needed count))
1079     (copy-bits (* copy vm:byte-bits))
1080     (buffer-start-bits
1081     (* (+ offset available) vm:byte-bits)))
1082     (declare (type index copy copy-bits buffer-start-bits))
1083     (if (typep buffer 'system-area-pointer)
1084     (system-area-copy sap 0
1085     buffer buffer-start-bits
1086     copy-bits)
1087     (copy-from-system-area sap 0
1088     buffer (+ buffer-start-bits
1089     (* vm:vector-data-offset
1090     vm:word-bits))
1091     copy-bits))
1092 ram 1.32
1093 ram 1.13 (decf now-needed copy)
1094 ram 1.33 (when (or (zerop now-needed) (not eof-error-p))
1095 ram 1.32 (setf (fd-stream-ibuf-head stream) copy)
1096     (setf (fd-stream-ibuf-tail stream) count)
1097 ram 1.33 (return (- requested now-needed)))
1098 ram 1.24 (incf offset copy)))))))))))
1099 ram 1.13
1100 ram 1.1
1101     ;;;; Utility functions (misc routines, etc)
1102    
1103     ;;; SET-ROUTINES -- internal
1104     ;;;
1105 ram 1.24 ;;; Fill in the various routine slots for the given type. Input-p and
1106     ;;; output-p indicate what slots to fill. The buffering slot must be set prior
1107     ;;; to calling this routine.
1108 ram 1.1 ;;;
1109 rtoy 1.82
1110 rtoy 1.83 (defun set-routines (stream type input-p output-p buffer-p &key binary-stream-p)
1111 ram 1.1 (let ((target-type (case type
1112     ((:default unsigned-byte)
1113     '(unsigned-byte 8))
1114     (signed-byte
1115     '(signed-byte 8))
1116     (t
1117     type)))
1118     (input-type nil)
1119     (output-type nil)
1120     (input-size nil)
1121     (output-size nil))
1122    
1123 wlott 1.5 (when (fd-stream-obuf-sap stream)
1124     (push (fd-stream-obuf-sap stream) *available-buffers*)
1125     (setf (fd-stream-obuf-sap stream) nil))
1126     (when (fd-stream-ibuf-sap stream)
1127     (push (fd-stream-ibuf-sap stream) *available-buffers*)
1128     (setf (fd-stream-ibuf-sap stream) nil))
1129 ram 1.1
1130     (when input-p
1131     (multiple-value-bind
1132     (routine type size)
1133     (pick-input-routine target-type)
1134     (unless routine
1135     (error "Could not find any input routine for ~S" target-type))
1136 wlott 1.5 (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
1137     (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
1138     (setf (fd-stream-ibuf-tail stream) 0)
1139 ram 1.1 (if (subtypep type 'character)
1140 ram 1.14 (setf (fd-stream-in stream) routine
1141 ram 1.24 (fd-stream-bin stream) #'ill-bin)
1142 rtoy 1.83 (setf (fd-stream-in stream) (if (and binary-stream-p
1143 rtoy 1.82 (eql size 1))
1144     (pick-input-routine 'character)
1145     #'ill-in)
1146 ram 1.24 (fd-stream-bin stream) routine))
1147 toy 1.58 (when (or (eql size 1)
1148     (eql size 2)
1149     (eql size 4))
1150     ;; Support for n-byte operations on 8-, 16-, and 32-bit streams
1151 ram 1.24 (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
1152 toy 1.60 (when (and buffer-p (eql size 1)
1153     (or (eq type 'unsigned-byte)
1154     (eq type :default)))
1155     ;; We only create this buffer for streams of type
1156     ;; (unsigned-byte 8). Because there's no buffer, the
1157     ;; other element-types will dispatch to the appropriate
1158     ;; input (output) routine in fast-read-byte.
1159 dtc 1.43 (setf (lisp-stream-in-buffer stream)
1160 ram 1.24 (make-array in-buffer-length
1161     :element-type '(unsigned-byte 8)))))
1162 ram 1.1 (setf input-size size)
1163     (setf input-type type)))
1164    
1165     (when output-p
1166     (multiple-value-bind
1167     (routine type size)
1168     (pick-output-routine target-type (fd-stream-buffering stream))
1169     (unless routine
1170     (error "Could not find any output routine for ~S buffered ~S."
1171     (fd-stream-buffering stream)
1172     target-type))
1173 wlott 1.5 (setf (fd-stream-obuf-sap stream) (next-available-buffer))
1174     (setf (fd-stream-obuf-length stream) bytes-per-buffer)
1175 ram 1.1 (setf (fd-stream-obuf-tail stream) 0)
1176     (if (subtypep type 'character)
1177     (setf (fd-stream-out stream) routine
1178     (fd-stream-bout stream) #'ill-bout)
1179     (setf (fd-stream-out stream)
1180     (or (if (eql size 1)
1181 wlott 1.16 (pick-output-routine 'base-char
1182 ram 1.1 (fd-stream-buffering stream)))
1183     #'ill-out)
1184     (fd-stream-bout stream) routine))
1185     (setf (fd-stream-sout stream)
1186 rtoy 1.85.4.1 #-unicode
1187     (if (eql size 1) #'fd-sout #'ill-out)
1188     #+unicode
1189     (if (eql size 1)
1190     #'fd-sout-each-character
1191     #'ill-out))
1192 ram 1.1 (setf (fd-stream-char-pos stream) 0)
1193     (setf output-size size)
1194     (setf output-type type)))
1195    
1196     (when (and input-size output-size
1197     (not (eq input-size output-size)))
1198     (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
1199     input-type input-size
1200     output-type output-size))
1201     (setf (fd-stream-element-size stream)
1202     (or input-size output-size))
1203    
1204     (setf (fd-stream-element-type stream)
1205     (cond ((equal input-type output-type)
1206     input-type)
1207 dtc 1.39 ((null output-type)
1208     input-type)
1209     ((null input-type)
1210     output-type)
1211     ((subtypep input-type output-type)
1212 ram 1.1 input-type)
1213     ((subtypep output-type input-type)
1214     output-type)
1215     (t
1216     (error "Input type (~S) and output type (~S) are unrelated?"
1217     input-type
1218     output-type))))))
1219    
1220 toy 1.66 ;;; REVERT-FILE -- internal
1221     ;;;
1222 rtoy 1.84 ;;; Revert a file, if possible; otherwise do nothing. Used during
1223 toy 1.66 ;;; CLOSE when the abort flag is set.
1224     ;;;
1225     (defun revert-file (filename original)
1226     (declare (type simple-base-string filename)
1227     (type (or simple-base-string null) original))
1228 rtoy 1.84 (when original
1229     (multiple-value-bind (okay err)
1230     (unix:unix-rename original filename)
1231     (unless okay
1232 toy 1.66 (cerror "Go on as if nothing bad happened."
1233 emarsden 1.71 "Could not restore ~S to its original contents: ~A"
1234 toy 1.66 filename (unix:get-unix-error-msg err))))))
1235    
1236     ;;; DELETE-ORIGINAL -- internal
1237     ;;;
1238     ;;; Delete a backup file. Used during CLOSE.
1239     ;;;
1240     (defun delete-original (filename original)
1241     (declare (type simple-base-string filename)
1242     (type (or simple-base-string null) original))
1243     (when original
1244     (multiple-value-bind (okay err) (unix:unix-unlink original)
1245     (unless okay
1246     (cerror "Go on as if nothing bad happened."
1247     "Could not delete ~S during close of ~S: ~A"
1248 emarsden 1.69 original filename (unix:get-unix-error-msg err))))))
1249 toy 1.66
1250 ram 1.1 ;;; FD-STREAM-MISC-ROUTINE -- input
1251     ;;;
1252     ;;; Handle the various misc operations on fd-stream.
1253     ;;;
1254     (defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
1255 ram 1.24 (declare (ignore arg2))
1256 ram 1.1 (case operation
1257 ram 1.24 (:listen
1258 ram 1.1 (or (not (eql (fd-stream-ibuf-head stream)
1259     (fd-stream-ibuf-tail stream)))
1260     (fd-stream-listen stream)
1261     (setf (fd-stream-listen stream)
1262 dtc 1.41 (eql (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1263     (unix:fd-zero read-fds)
1264     (unix:fd-set (fd-stream-fd stream) read-fds)
1265     (unix:unix-fast-select (1+ (fd-stream-fd stream))
1266     (alien:addr read-fds) nil nil
1267     0 0))
1268 ram 1.13 1))))
1269 ram 1.1 (:unread
1270 wlott 1.5 (setf (fd-stream-unread stream) arg1)
1271     (setf (fd-stream-listen stream) t))
1272 ram 1.1 (:close
1273     (cond (arg1
1274     ;; We got us an abort on our hands.
1275 dtc 1.40 (when (fd-stream-handler stream)
1276     (system:remove-fd-handler (fd-stream-handler stream))
1277     (setf (fd-stream-handler stream) nil))
1278 toy 1.66 (when (and (fd-stream-file stream) (fd-stream-obuf-sap stream))
1279     (revert-file (fd-stream-file stream)
1280     (fd-stream-original stream))))
1281 ram 1.1 (t
1282     (fd-stream-misc-routine stream :finish-output)
1283 toy 1.66 (when (fd-stream-delete-original stream)
1284     (delete-original (fd-stream-file stream)
1285     (fd-stream-original stream)))))
1286 wlott 1.17 (when (fboundp 'cancel-finalization)
1287     (cancel-finalization stream))
1288 wlott 1.19 (unix:unix-close (fd-stream-fd stream))
1289 wlott 1.5 (when (fd-stream-obuf-sap stream)
1290     (push (fd-stream-obuf-sap stream) *available-buffers*)
1291     (setf (fd-stream-obuf-sap stream) nil))
1292     (when (fd-stream-ibuf-sap stream)
1293     (push (fd-stream-ibuf-sap stream) *available-buffers*)
1294     (setf (fd-stream-ibuf-sap stream) nil))
1295 ram 1.1 (lisp::set-closed-flame stream))
1296 wlott 1.6 (:clear-input
1297 wlott 1.25 (setf (fd-stream-unread stream) nil)
1298 wlott 1.6 (setf (fd-stream-ibuf-head stream) 0)
1299     (setf (fd-stream-ibuf-tail stream) 0)
1300 ram 1.38 (catch 'eof-input-catcher
1301     (loop
1302 dtc 1.49 (multiple-value-bind
1303     (count errno)
1304     (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1305     (unix:fd-zero read-fds)
1306     (unix:fd-set (fd-stream-fd stream) read-fds)
1307     (unix:unix-fast-select (1+ (fd-stream-fd stream))
1308     (alien:addr read-fds) nil nil 0 0))
1309 ram 1.38 (cond ((eql count 1)
1310     (do-input stream)
1311     (setf (fd-stream-ibuf-head stream) 0)
1312     (setf (fd-stream-ibuf-tail stream) 0))
1313 dtc 1.49 ((and (not count) (eql errno unix:eintr)))
1314 ram 1.38 (t
1315     (return t)))))))
1316 ram 1.1 (:force-output
1317     (flush-output-buffer stream))
1318     (:finish-output
1319     (flush-output-buffer stream)
1320     (do ()
1321     ((null (fd-stream-output-later stream)))
1322     (system:serve-all-events)))
1323     (:element-type
1324     (fd-stream-element-type stream))
1325 ram 1.22 (:interactive-p
1326     (unix:unix-isatty (fd-stream-fd stream)))
1327 ram 1.1 (:line-length
1328     80)
1329     (:charpos
1330     (fd-stream-char-pos stream))
1331     (:file-length
1332 pw 1.56 (unless (fd-stream-file stream)
1333     (error 'simple-type-error
1334     :datum stream
1335     :expected-type 'file-stream
1336     :format-control "~s is not a stream associated with a file."
1337     :format-arguments (list stream)))
1338 ram 1.1 (multiple-value-bind
1339     (okay dev ino mode nlink uid gid rdev size
1340     atime mtime ctime blksize blocks)
1341 wlott 1.19 (unix:unix-fstat (fd-stream-fd stream))
1342 ram 1.1 (declare (ignore ino nlink uid gid rdev
1343     atime mtime ctime blksize blocks))
1344     (unless okay
1345 pmai 1.61 (error 'simple-file-error
1346     :format-control "Error fstating ~S: ~A"
1347     :format-arguments (list stream (unix:get-unix-error-msg dev))))
1348 dtc 1.51 (if (zerop mode)
1349 ram 1.23 nil
1350 toy 1.64 (values (truncate size (fd-stream-element-size stream))))))
1351 ram 1.1 (:file-position
1352 ram 1.29 (fd-stream-file-position stream arg1))))
1353 ram 1.1
1354 ram 1.28
1355 ram 1.1 ;;; FD-STREAM-FILE-POSITION -- internal.
1356     ;;;
1357     (defun fd-stream-file-position (stream &optional newpos)
1358 ram 1.14 (declare (type fd-stream stream)
1359 dtc 1.51 (type (or (integer 0) (member nil :start :end)) newpos))
1360 ram 1.1 (if (null newpos)
1361     (system:without-interrupts
1362 dtc 1.51 ;; First, find the position of the UNIX file descriptor in the file.
1363 ram 1.1 (multiple-value-bind
1364 dtc 1.51 (posn errno)
1365 wlott 1.19 (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
1366 dtc 1.51 (declare (type (or (integer 0) null) posn))
1367     (cond (posn
1368 ram 1.1 ;; Adjust for buffered output:
1369     ;; If there is any output buffered, the *real* file position
1370     ;; will be larger than reported by lseek because lseek
1371 toy 1.70 ;; obviously cannot take into account output we have not
1372 ram 1.1 ;; sent yet.
1373     (dolist (later (fd-stream-output-later stream))
1374 ram 1.14 (incf posn (- (the index (caddr later))
1375     (the index (cadr later)))))
1376 ram 1.1 (incf posn (fd-stream-obuf-tail stream))
1377     ;; Adjust for unread input:
1378     ;; If there is any input read from UNIX but not supplied to
1379     ;; the user of the stream, the *real* file position will
1380     ;; smaller than reported, because we want to look like the
1381     ;; unread stuff is still available.
1382     (decf posn (- (fd-stream-ibuf-tail stream)
1383     (fd-stream-ibuf-head stream)))
1384     (when (fd-stream-unread stream)
1385     (decf posn))
1386     ;; Divide bytes by element size.
1387 ram 1.14 (truncate posn (fd-stream-element-size stream)))
1388 wlott 1.19 ((eq errno unix:espipe)
1389 ram 1.1 nil)
1390     (t
1391     (system:with-interrupts
1392     (error "Error lseek'ing ~S: ~A"
1393     stream
1394 wlott 1.19 (unix:get-unix-error-msg errno)))))))
1395 dtc 1.51 (let ((offset 0)
1396     origin)
1397     (declare (type (integer 0) offset))
1398 ram 1.1 ;; Make sure we don't have any output pending, because if we move the
1399     ;; file pointer before writing this stuff, it will be written in the
1400     ;; wrong location.
1401     (flush-output-buffer stream)
1402     (do ()
1403     ((null (fd-stream-output-later stream)))
1404     (system:serve-all-events))
1405 ram 1.4 ;; Clear out any pending input to force the next read to go to the
1406     ;; disk.
1407     (setf (fd-stream-unread stream) nil)
1408     (setf (fd-stream-ibuf-head stream) 0)
1409     (setf (fd-stream-ibuf-tail stream) 0)
1410 dtc 1.51 ;; Trash cached value for listen, so that we check next time.
1411 wlott 1.5 (setf (fd-stream-listen stream) nil)
1412 ram 1.4 ;; Now move it.
1413 ram 1.1 (cond ((eq newpos :start)
1414 dtc 1.51 (setf offset 0
1415     origin unix:l_set))
1416 ram 1.1 ((eq newpos :end)
1417 dtc 1.51 (setf offset 0
1418     origin unix:l_xtnd))
1419     ((typep newpos '(integer 0))
1420 ram 1.1 (setf offset (* newpos (fd-stream-element-size stream))
1421 wlott 1.19 origin unix:l_set))
1422 ram 1.1 (t
1423     (error "Invalid position given to file-position: ~S" newpos)))
1424     (multiple-value-bind
1425     (posn errno)
1426 wlott 1.19 (unix:unix-lseek (fd-stream-fd stream) offset origin)
1427 dtc 1.51 (cond (posn
1428 ram 1.1 t)
1429 wlott 1.19 ((eq errno unix:espipe)
1430 ram 1.1 nil)
1431     (t
1432     (error "Error lseek'ing ~S: ~A"
1433     stream
1434 wlott 1.19 (unix:get-unix-error-msg errno))))))))
1435 ram 1.1
1436    
1437    
1438     ;;;; Creation routines (MAKE-FD-STREAM and OPEN)
1439    
1440     ;;; MAKE-FD-STREAM -- Public.
1441     ;;;
1442     ;;; Returns a FD-STREAM on the given file.
1443     ;;;
1444     (defun make-fd-stream (fd
1445     &key
1446     (input nil input-p)
1447     (output nil output-p)
1448 wlott 1.16 (element-type 'base-char)
1449 ram 1.1 (buffering :full)
1450 ram 1.15 timeout
1451 ram 1.1 file
1452     original
1453     delete-original
1454 ram 1.28 pathname
1455 ram 1.24 input-buffer-p
1456 ram 1.1 (name (if file
1457     (format nil "file ~S" file)
1458 wlott 1.17 (format nil "descriptor ~D" fd)))
1459 rtoy 1.83 auto-close
1460     binary-stream-p)
1461 ram 1.15 (declare (type index fd) (type (or index null) timeout)
1462     (type (member :none :line :full) buffering))
1463     "Create a stream for the given unix file descriptor.
1464     If input is non-nil, allow input operations.
1465     If output is non-nil, allow output operations.
1466     If neither input nor output are specified, default to allowing input.
1467     Element-type indicates the element type to use (as for open).
1468     Buffering indicates the kind of buffering to use.
1469     Timeout (if true) is the number of seconds to wait for input. If NIL (the
1470     default), then wait forever. When we time out, we signal IO-TIMEOUT.
1471     File is the name of the file (will be returned by PATHNAME).
1472     Name is used to identify the stream when printed."
1473 ram 1.1 (cond ((not (or input-p output-p))
1474     (setf input t))
1475     ((not (or input output))
1476     (error "File descriptor must be opened either for input or output.")))
1477 rtoy 1.83 (let ((stream (if binary-stream-p
1478     (%make-binary-text-stream :fd fd
1479     :name name
1480     :file file
1481     :original original
1482     :delete-original delete-original
1483     :pathname pathname
1484     :buffering buffering
1485     :timeout timeout)
1486     (%make-fd-stream :fd fd
1487     :name name
1488     :file file
1489     :original original
1490     :delete-original delete-original
1491     :pathname pathname
1492     :buffering buffering
1493     :timeout timeout))))
1494     (set-routines stream element-type input output input-buffer-p
1495     :binary-stream-p binary-stream-p)
1496 wlott 1.17 (when (and auto-close (fboundp 'finalize))
1497     (finalize stream
1498     #'(lambda ()
1499 wlott 1.19 (unix:unix-close fd)
1500 toy 1.70 (format *terminal-io* "** Closed ~A~%" name)
1501     (when original
1502     (revert-file file original)))))
1503 ram 1.1 stream))
1504    
1505 ram 1.24
1506 toy 1.66 ;;; PICK-BACKUP-NAME -- internal
1507 ram 1.1 ;;;
1508     ;;; Pick a name to use for the backup file.
1509     ;;;
1510     (defvar *backup-extension* ".BAK"
1511     "This is a string that OPEN tacks on the end of a file namestring to produce
1512     a name for the :if-exists :rename-and-delete and :rename options. Also,
1513     this can be a function that takes a namestring and returns a complete
1514     namestring.")
1515     ;;;
1516     (defun pick-backup-name (name)
1517 ram 1.14 (declare (type simple-string name))
1518     (let ((ext *backup-extension*))
1519     (etypecase ext
1520     (simple-string (concatenate 'simple-string name ext))
1521     (function (funcall ext name)))))
1522 ram 1.1
1523 toy 1.65 ;;; NEXT-VERSION -- internal
1524     ;;;
1525     ;;; Find the next available versioned name for a file.
1526     ;;;
1527     (defun next-version (name)
1528     (declare (type simple-string name))
1529     (let* ((sep (position #\/ name :from-end t))
1530     (base (if sep (subseq name 0 (1+ sep)) ""))
1531     (dir (unix:open-dir base)))
1532     (multiple-value-bind (name type version)
1533     (extract-name-type-and-version name (if sep (1+ sep) 0) (length name))
1534     (let ((version (if (symbolp version) 1 (1+ version)))
1535 toy 1.67 (match (if type
1536     (concatenate 'string name "." type ".~")
1537     (concatenate 'string name ".~"))))
1538 toy 1.65 (when dir
1539     (unwind-protect
1540     (loop
1541     (let ((name (unix:read-dir dir)))
1542     (cond ((null name) (return))
1543     ((and (> (length name) (length match))
1544     (string= name match :end1 (length match)))
1545     (multiple-value-bind (v e)
1546     (parse-integer name :start (length match)
1547     :junk-allowed t)
1548     (when (and v
1549     (= (length name) (1+ e))
1550     (char= (schar name e) #\~))
1551     (setq version (max version (1+ v)))))))))
1552     (unix:close-dir dir)))
1553     (concatenate 'string base
1554     match (quick-integer-to-string version) "~")))))
1555    
1556 ram 1.1 ;;; ASSURE-ONE-OF -- internal
1557     ;;;
1558     ;;; Assure that the given arg is one of the given list of valid things.
1559     ;;; Allow the user to fix any problems.
1560     ;;;
1561     (defun assure-one-of (item list what)
1562     (unless (member item list)
1563     (loop
1564     (cerror "Enter new value for ~*~S"
1565     "~S is invalid for ~S. Must be one of~{ ~S~}"
1566     item
1567     what
1568     list)
1569 ram 1.14 (format (the stream *query-io*) "Enter new value for ~S: " what)
1570 ram 1.1 (force-output *query-io*)
1571     (setf item (read *query-io*))
1572     (when (member item list)
1573     (return))))
1574     item)
1575    
1576 ram 1.14 ;;; DO-OLD-RENAME -- Internal
1577     ;;;
1578     ;;; Rename Namestring to Original. First, check if we have write access,
1579     ;;; since we don't want to trash unwritable files even if we technically can.
1580 toy 1.70 ;;; We return true if we succeed in renaming.
1581 ram 1.14 ;;;
1582     (defun do-old-rename (namestring original)
1583 wlott 1.19 (unless (unix:unix-access namestring unix:w_ok)
1584 ram 1.14 (cerror "Try to rename it anyway." "File ~S is not writable." namestring))
1585     (multiple-value-bind
1586     (okay err)
1587 wlott 1.19 (unix:unix-rename namestring original)
1588 ram 1.14 (cond (okay t)
1589     (t
1590     (cerror "Use :SUPERSEDE instead."
1591     "Could not rename ~S to ~S: ~A."
1592     namestring
1593     original
1594 wlott 1.19 (unix:get-unix-error-msg err))
1595 ram 1.14 nil))))
1596    
1597 toy 1.66 ;;; FD-OPEN -- Internal
1598 pw 1.57 ;;;
1599 toy 1.66 ;;; Open a file.
1600 pw 1.57 ;;;
1601 toy 1.66 (defun fd-open (pathname direction if-exists if-exists-given
1602     if-does-not-exist if-does-not-exist-given)
1603     (declare (type pathname pathname)
1604     (type (member :input :output :io :probe) direction)
1605     (type (member :error :new-version :rename :rename-and-delete
1606     :overwrite :append :supersede nil) if-exists)
1607     (type (member :error :create nil) if-does-not-exist))
1608     (multiple-value-bind (input output mask)
1609     (ecase direction
1610     (:input (values t nil unix:o_rdonly))
1611     (:output (values nil t unix:o_wronly))
1612     (:io (values t t unix:o_rdwr))
1613     (:probe (values t nil unix:o_rdonly)))
1614     (declare (type index mask))
1615 emarsden 1.76 ;; Process if-exists argument if we are doing any output.
1616     (cond (output
1617     (unless if-exists-given
1618     (setf if-exists
1619     (if (eq (pathname-version pathname) :newest)
1620     :new-version
1621     :error)))
1622     (case if-exists
1623     ((:error nil)
1624     (setf mask (logior mask unix:o_excl)))
1625     ((:new-version :rename :rename-and-delete)
1626     (setf mask (logior mask unix:o_creat)))
1627     (:supersede
1628     (setf mask (logior mask unix:o_trunc)))))
1629     (t
1630     (setf if-exists nil))) ; :ignore-this-arg
1631    
1632     (unless if-does-not-exist-given
1633     (setf if-does-not-exist
1634     (cond ((eq direction :input) :error)
1635     ((and output
1636     (member if-exists '(:overwrite :append)))
1637     :error)
1638     ((eq direction :probe)
1639     nil)
1640     (t
1641     :create))))
1642     (if (eq if-does-not-exist :create)
1643     (setf mask (logior mask unix:o_creat)))
1644    
1645 toy 1.66 (let ((name (cond ((unix-namestring pathname input))
1646     ((and input (eq if-does-not-exist :create))
1647     (unix-namestring pathname nil)))))
1648     (let ((original (cond ((eq if-exists :new-version)
1649     (next-version name))
1650     ((member if-exists '(:rename :rename-and-delete))
1651     (pick-backup-name name))))
1652     (delete-original (eq if-exists :rename-and-delete))
1653     (mode #o666))
1654     (when original
1655     ;; We are doing a :rename or :rename-and-delete.
1656     ;; Determine if the file already exists, make sure the original
1657     ;; file is not a directory and keep the mode
1658     (let ((exists
1659     (and name
1660     (multiple-value-bind
1661     (okay err/dev inode orig-mode)
1662     (unix:unix-stat name)
1663     (declare (ignore inode)
1664     (type (or index null) orig-mode))
1665     (cond
1666     (okay
1667     (when (and output (= (logand orig-mode #o170000)
1668     #o40000))
1669     (error 'simple-file-error
1670     :pathname pathname
1671     :format-control
1672     "Cannot open ~S for output: Is a directory."
1673     :format-arguments (list name)))
1674     (setf mode (logand orig-mode #o777))
1675     t)
1676     ((eql err/dev unix:enoent)
1677     nil)
1678     (t
1679     (error 'simple-file-error
1680     :pathname pathname
1681     :format-control "Cannot find ~S: ~A"
1682     :format-arguments
1683     (list name
1684     (unix:get-unix-error-msg err/dev)))))))))
1685     (unless (and exists
1686     (do-old-rename name original))
1687     (setf original nil)
1688     (setf delete-original nil)
1689     ;; In order to use SUPERSEDE instead, we have
1690     ;; to make sure unix:o_creat corresponds to
1691     ;; if-does-not-exist. unix:o_creat was set
1692     ;; before because of if-exists being :rename.
1693     (unless (eq if-does-not-exist :create)
1694     (setf mask (logior (logandc2 mask unix:o_creat)
1695     unix:o_trunc)))
1696     (setf if-exists :supersede))))
1697    
1698     ;; Okay, now we can try the actual open.
1699     (loop
1700     (multiple-value-bind (fd errno)
1701     (if name
1702     (unix:unix-open name mask mode)
1703     (values nil unix:enoent))
1704     (cond ((fixnump fd)
1705 toy 1.68 (when (eq if-exists :append)
1706     (unix:unix-lseek fd 0 unix:l_xtnd)) ; SEEK_END
1707 toy 1.66 (return (values fd name original delete-original)))
1708     ((eql errno unix:enoent)
1709     (case if-does-not-exist
1710     (:error
1711     (cerror "Return NIL."
1712     'simple-file-error
1713     :pathname pathname
1714     :format-control "Error opening ~S, ~A."
1715     :format-arguments
1716     (list pathname
1717     (unix:get-unix-error-msg errno))))
1718     (:create
1719     (cerror "Return NIL."
1720     'simple-file-error
1721     :pathname pathname
1722     :format-control
1723     "Error creating ~S, path does not exist."
1724     :format-arguments (list pathname))))
1725     (return nil))
1726     ((eql errno unix:eexist)
1727     (unless (eq nil if-exists)
1728     (cerror "Return NIL."
1729     'simple-file-error
1730     :pathname pathname
1731     :format-control "Error opening ~S, ~A."
1732     :format-arguments
1733     (list pathname
1734     (unix:get-unix-error-msg errno))))
1735     (return nil))
1736     ((eql errno unix:eacces)
1737     (cerror "Try again."
1738     'simple-file-error
1739     :pathname pathname
1740     :format-control "Error opening ~S, ~A."
1741     :format-arguments
1742     (list pathname
1743     (unix:get-unix-error-msg errno))))
1744     (t
1745     (cerror "Return NIL."
1746     'simple-file-error
1747     :pathname pathname
1748     :format-control "Error opening ~S, ~A."
1749     :format-arguments
1750     (list pathname
1751     (unix:get-unix-error-msg errno)))
1752     (return nil)))))))))
1753    
1754     ;;; OPEN-FD-STREAM -- Internal
1755     ;;;
1756     ;;; Open an fd-stream connected to a file.
1757     ;;;
1758     (defun open-fd-stream (pathname &key (direction :input)
1759     (element-type 'base-char)
1760     (if-exists nil if-exists-given)
1761     (if-does-not-exist nil if-does-not-exist-given)
1762 rtoy 1.83 (external-format :default)
1763     class)
1764 toy 1.66 (declare (type pathname pathname)
1765     (type (member :input :output :io :probe) direction)
1766     (type (member :error :new-version :rename :rename-and-delete
1767     :overwrite :append :supersede nil) if-exists)
1768     (type (member :error :create nil) if-does-not-exist)
1769     (ignore external-format))
1770     (multiple-value-bind (fd namestring original delete-original)
1771     (fd-open pathname direction if-exists if-exists-given
1772     if-does-not-exist if-does-not-exist-given)
1773     (when fd
1774     (case direction
1775     ((:input :output :io)
1776 rtoy 1.83 ;; We use the :class option to tell us if we want a
1777     ;; binary-text stream or not.
1778 toy 1.66 (make-fd-stream fd
1779     :input (member direction '(:input :io))
1780     :output (member direction '(:output :io))
1781     :element-type element-type
1782     :file namestring
1783     :original original
1784     :delete-original delete-original
1785     :pathname pathname
1786     :input-buffer-p t
1787 rtoy 1.83 :auto-close t
1788     :binary-stream-p class))
1789 toy 1.66 (:probe
1790     (let ((stream (%make-fd-stream :name namestring :fd fd
1791     :pathname pathname
1792     :element-type element-type)))
1793     (close stream)
1794     stream))))))
1795 ram 1.14
1796 ram 1.1 ;;; OPEN -- public
1797     ;;;
1798     ;;; Open the given file.
1799     ;;;
1800 toy 1.66 (defun open (filename &rest options
1801     &key (direction :input)
1802     (element-type 'base-char element-type-given)
1803     (if-exists nil if-exists-given)
1804     (if-does-not-exist nil if-does-not-exist-given)
1805     (external-format :default)
1806     class mapped input-handle output-handle
1807     &allow-other-keys
1808     &aux ; Squelch assignment warning.
1809     (direction direction)
1810     (if-does-not-exist if-does-not-exist)
1811     (if-exists if-exists))
1812 ram 1.1 "Return a stream which reads from or writes to Filename.
1813     Defined keywords:
1814     :direction - one of :input, :output, :io, or :probe
1815 wlott 1.16 :element-type - Type of object to read or write, default BASE-CHAR
1816 ram 1.1 :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1817     :overwrite, :append, :supersede or nil
1818     :if-does-not-exist - one of :error, :create or nil
1819 toy 1.66 :external-format - :default
1820 ram 1.1 See the manual for details."
1821 toy 1.66 (declare (ignore external-format input-handle output-handle))
1822 rtoy 1.78
1823     ;; OPEN signals a file-error if the filename is wild.
1824     (when (wild-pathname-p filename)
1825     (error 'file-error :pathname filename))
1826 dtc 1.46
1827 ram 1.1 ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
1828 toy 1.67 (setq direction
1829 ram 1.1 (assure-one-of direction
1830     '(:input :output :io :probe)
1831     :direction))
1832 toy 1.67 (setf (getf options :direction) direction)
1833 ram 1.1
1834 toy 1.66 (when (and if-exists-given (member direction '(:output :io)))
1835     (setq if-exists
1836     (assure-one-of if-exists
1837     '(:error :new-version :rename
1838     :rename-and-delete :overwrite
1839     :append :supersede nil)
1840     :if-exists))
1841     (setf (getf options :if-exists) if-exists))
1842    
1843     (when if-does-not-exist-given
1844     (setq if-does-not-exist
1845     (assure-one-of if-does-not-exist
1846     '(:error :create nil)
1847     :if-does-not-exist))
1848     (setf (getf options :if-does-not-exist) if-does-not-exist))
1849    
1850 toy 1.67 (let ((filespec (pathname filename))
1851 toy 1.66 (options (copy-list options))
1852 toy 1.67 (class (or class 'fd-stream)))
1853 toy 1.66 (cond ((eq class 'fd-stream)
1854     (remf options :class)
1855     (remf options :mapped)
1856     (remf options :input-handle)
1857     (remf options :output-handle)
1858     (apply #'open-fd-stream filespec options))
1859 rtoy 1.83 ((eq class 'binary-text-stream)
1860     ;; Like fd-stream, but binary and text allowed. This is
1861     ;; indicated by leaving the :class option around for
1862     ;; open-fd-stream to see.
1863     (remf options :mapped)
1864     (remf options :input-handle)
1865     (remf options :output-handle)
1866     (apply #'open-fd-stream filespec options))
1867 toy 1.66 ((subtypep class 'stream:simple-stream)
1868     (when element-type-given
1869 toy 1.70 (cerror "Do it anyway."
1870     "Can't create simple-streams with an element-type."))
1871     (when (and (eq class 'stream:file-simple-stream) mapped)
1872     (setq class 'stream:mapped-file-simple-stream)
1873     (setf (getf options :class) 'stream:mapped-file-simple-stream))
1874     (when (subtypep class 'stream:file-simple-stream)
1875 toy 1.66 (when (eq direction :probe)
1876 toy 1.70 (setq class 'stream:probe-simple-stream)))
1877 toy 1.66 (apply #'make-instance class :filename filespec options))
1878     ((subtypep class 'ext:fundamental-stream)
1879     (remf options :class)
1880     (remf options :mapped)
1881     (remf options :input-handle)
1882     (remf options :output-handle)
1883     (let ((stream (apply #'open-fd-stream filespec options)))
1884     (when stream
1885     (make-instance class :lisp-stream stream))))
1886     (t
1887     (error "Unable to open streams of class ~S." class)))))
1888 ram 1.1
1889     ;;;; Initialization.
1890    
1891     (defvar *tty* nil
1892     "The stream connected to the controlling terminal or NIL if there is none.")
1893     (defvar *stdin* nil
1894     "The stream connected to the standard input (file descriptor 0).")
1895     (defvar *stdout* nil
1896     "The stream connected to the standard output (file descriptor 1).")
1897     (defvar *stderr* nil
1898     "The stream connected to the standard error output (file descriptor 2).")
1899    
1900     ;;; STREAM-INIT -- internal interface
1901     ;;;
1902     ;;; Called when the cold load is first started up.
1903     ;;;
1904     (defun stream-init ()
1905     (stream-reinit)
1906     (setf *terminal-io* (make-synonym-stream '*tty*))
1907     (setf *standard-output* (make-synonym-stream '*stdout*))
1908 ram 1.11 (setf *standard-input*
1909     (make-two-way-stream (make-synonym-stream '*stdin*)
1910     *standard-output*))
1911 ram 1.1 (setf *error-output* (make-synonym-stream '*stderr*))
1912     (setf *query-io* (make-synonym-stream '*terminal-io*))
1913 pw 1.53 (setf *debug-io* *query-io*)
1914 ram 1.1 (setf *trace-output* *standard-output*)
1915     nil)
1916    
1917     ;;; STREAM-REINIT -- internal interface
1918     ;;;
1919     ;;; Called whenever a saved core is restarted.
1920     ;;;
1921     (defun stream-reinit ()
1922     (setf *available-buffers* nil)
1923     (setf *stdin*
1924     (make-fd-stream 0 :name "Standard Input" :input t :buffering :line))
1925     (setf *stdout*
1926     (make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
1927     (setf *stderr*
1928     (make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
1929 dtc 1.54 (let ((tty (and (not *batch-mode*)
1930     (unix:unix-open "/dev/tty" unix:o_rdwr #o666))))
1931     (setf *tty*
1932     (if tty
1933 ram 1.1 (make-fd-stream tty :name "the Terminal" :input t :output t
1934 dtc 1.54 :buffering :line :auto-close t)
1935     (make-two-way-stream *stdin* *stdout*))))
1936 ram 1.1 nil)
1937    
1938    
1939     ;;;; Beeping.
1940    
1941     (defun default-beep-function (stream)
1942     (write-char #\bell stream)
1943     (finish-output stream))
1944    
1945     (defvar *beep-function* #'default-beep-function
1946     "This is called in BEEP to feep the user. It takes a stream.")
1947    
1948     (defun beep (&optional (stream *terminal-io*))
1949     (funcall *beep-function* stream))
1950    
1951    
1952     ;;; File-Name -- internal interface
1953     ;;;
1954     ;;; Kind of like File-Position, but is an internal hack used by the filesys
1955     ;;; stuff to get and set the file name.
1956     ;;;
1957     (defun file-name (stream &optional new-name)
1958 toy 1.66 (typecase stream
1959     (stream:simple-stream
1960     (if new-name
1961     (stream::%file-rename stream new-name)
1962     (stream::%file-name stream)))
1963     (fd-stream
1964     (cond (new-name
1965     (setf (fd-stream-pathname stream) new-name)
1966     (setf (fd-stream-file stream)
1967     (unix-namestring new-name nil))
1968     t)
1969     (t
1970     (fd-stream-pathname stream))))))
1971 ram 1.29
1972 ram 1.27
1973     ;;;; Degenerate international character support:
1974    
1975     (defun file-string-length (stream object)
1976 toy 1.66 (declare (type (or string character) object)
1977 rtoy 1.77 (type (or file-stream broadcast-stream stream:simple-stream) stream))
1978 ram 1.27 "Return the delta in Stream's FILE-POSITION that would be caused by writing
1979     Object to Stream. Non-trivial only in implementations that support
1980     international character sets."
1981 toy 1.66 (typecase stream
1982     (stream:simple-stream (stream::%file-string-length stream object))
1983 rtoy 1.77 (broadcast-stream
1984     ;; CLHS says we must return 1 in this case
1985     1)
1986 toy 1.66 (t
1987     (etypecase object
1988     (character 1)
1989     (string (length object))))))

  ViewVC Help
Powered by ViewVC 1.1.5