/[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.11 - (show annotations)
Sat May 18 13:38:36 1991 UTC (22 years, 11 months ago) by ram
Branch: MAIN
Changes since 1.10: +5 -6 lines
Merged with systems-work sources.  The only change was to make
*standard-output* a two-way stream so that reading *standard-input* will force
output on standard output.
1 ;;; -*- Log: code.log; Package: LISP -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/fd-stream.lisp,v 1.11 1991/05/18 13:38:36 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Streams for UNIX file descriptors.
15 ;;;
16 ;;; Written by William Lott, July 1989 - January 1990.
17 ;;;
18 ;;; **********************************************************************
19
20
21 (in-package "SYSTEM")
22
23 (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
24 beep *beep-function*
25 output-raw-bytes
26 *tty* *stdin* *stdout* *stderr*))
27
28
29 (in-package "EXTENSIONS")
30
31 (export '(*backup-extension*))
32
33
34 (in-package "LISP")
35
36
37 ;;;; Buffer manipulation routines.
38
39 (defvar *available-buffers* ()
40 "List of available buffers. Each buffer is an dynamic alien.")
41
42 (defconstant bytes-per-buffer (* 4 1024)
43 "Number of bytes per buffer.")
44
45 ;;; NEXT-AVAILABLE-BUFFER -- Internal.
46 ;;;
47 ;;; Returns the next available alien buffer, creating one if necessary.
48 ;;;
49 (proclaim '(inline next-available-buffer))
50 ;;;
51 (defun next-available-buffer ()
52 (if *available-buffers*
53 (pop *available-buffers*)
54 (allocate-system-memory bytes-per-buffer)))
55
56
57 ;;;; The FD-STREAM structure.
58
59 (defstruct (fd-stream
60 (:print-function %print-fd-stream)
61 (:constructor %make-fd-stream)
62 (:include stream
63 (misc #'fd-stream-misc-routine)))
64
65 (name nil) ; The name of this stream
66 (file nil) ; The file this stream is for
67 (original nil) ; The original file (for :if-exists :rename)
68 (delete-original nil) ; for :if-exists :rename-and-delete
69 (element-size 1) ; Number of bytes per element.
70 (element-type 'base-character) ; The type of element being transfered.
71 (fd -1 :type fixnum) ; The file descriptor
72 (buffering :full) ; One of :none, :line, or :full
73 (char-pos nil) ; Character position if known.
74 (listen nil) ; T if we don't need to listen
75
76 ;; The input buffer.
77 (unread nil)
78 (ibuf-sap nil)
79 (ibuf-length nil)
80 (ibuf-head 0 :type fixnum)
81 (ibuf-tail 0 :type fixnum)
82
83 ;; The output buffer.
84 (obuf-sap nil)
85 (obuf-length nil)
86 (obuf-tail 0 :type fixnum)
87
88 ;; Output flushed, but not written due to non-blocking io.
89 (output-later nil)
90 (handler nil))
91
92 (defun %print-fd-stream (fd-stream stream depth)
93 (declare (ignore depth))
94 (format stream "#<Stream for ~A>"
95 (fd-stream-name fd-stream)))
96
97
98
99 ;;;; Output routines and related noise.
100
101 (defvar *output-routines* ()
102 "List of all available output routines. Each element is a list of the
103 element-type output, the kind of buffering, the function name, and the number
104 of bytes per element.")
105
106 ;;; DO-OUTPUT-LATER -- internal
107 ;;;
108 ;;; Called by the server when we can write to the given file descriptor.
109 ;;; Attemt to write the data again. If it worked, remove the data from the
110 ;;; output-later list. If it didn't work, something is wrong.
111 ;;;
112 (defun do-output-later (stream)
113 (let* ((stuff (pop (fd-stream-output-later stream)))
114 (base (car stuff))
115 (start (cadr stuff))
116 (end (caddr stuff))
117 (reuse-sap (cadddr stuff))
118 (length (- end start)))
119 (multiple-value-bind
120 (count errno)
121 (mach:unix-write (fd-stream-fd stream)
122 base
123 start
124 length)
125 (cond ((eql count length) ; Hot damn, it workded.
126 (when reuse-sap
127 (push base *available-buffers*)))
128 ((not (null count)) ; Sorta worked.
129 (push (list base
130 (+ start count)
131 end)
132 (fd-stream-output-later stream)))
133 ((= errno mach:ewouldblock)
134 (error "Write would have blocked, but SERVER told us to go."))
135 (t
136 (error "While writing ~S: ~A"
137 stream
138 (mach:get-unix-error-msg errno))))))
139 (unless (fd-stream-output-later stream)
140 (system:remove-fd-handler (fd-stream-handler stream))
141 (setf (fd-stream-handler stream) nil)))
142
143 ;;; OUTPUT-LATER -- internal
144 ;;;
145 ;;; Arange to output the string when we can write on the file descriptor.
146 ;;;
147 (defun output-later (stream base start end reuse-sap)
148 (cond ((null (fd-stream-output-later stream))
149 (setf (fd-stream-output-later stream)
150 (list (list base start end reuse-sap)))
151 (setf (fd-stream-handler stream)
152 (system:add-fd-handler (fd-stream-fd stream)
153 :output
154 #'(lambda (fd)
155 (declare (ignore fd))
156 (do-output-later stream)))))
157 (t
158 (nconc (fd-stream-output-later stream)
159 (list (list base start end reuse-sap)))))
160 (when reuse-sap
161 (let ((new-buffer (next-available-buffer)))
162 (setf (fd-stream-obuf-sap stream) new-buffer)
163 (setf (fd-stream-obuf-length stream) bytes-per-buffer))))
164
165 ;;; DO-OUTPUT -- internal
166 ;;;
167 ;;; Output the given noise. Check to see if there are any pending writes. If
168 ;;; so, just queue this one. Otherwise, try to write it. If this would block,
169 ;;; queue it.
170 ;;;
171 (defun do-output (stream base start end reuse-sap)
172 (if (not (null (fd-stream-output-later stream))) ; something buffered.
173 (progn
174 (output-later stream base start end reuse-sap)
175 ;; ### check to see if any of this noise can be output
176 )
177 (let ((length (- end start)))
178 (multiple-value-bind
179 (count errno)
180 (mach:unix-write (fd-stream-fd stream) base start length)
181 (cond ((eql count length)) ; Hot damn, it worked.
182 ((not (null count))
183 (output-later stream base (+ start count) end reuse-sap))
184 ((= errno mach:ewouldblock)
185 (output-later stream base start end reuse-sap))
186 (t
187 (error "While writing ~S: ~A"
188 stream
189 (mach:get-unix-error-msg errno))))))))
190
191 ;;; FLUSH-OUTPUT-BUFFER -- internal
192 ;;;
193 ;;; Flush any data in the output buffer.
194 ;;;
195 (defun flush-output-buffer (stream)
196 (let ((length (fd-stream-obuf-tail stream)))
197 (unless (= length 0)
198 (do-output stream (fd-stream-obuf-sap stream) 0 length t)
199 (setf (fd-stream-obuf-tail stream) 0))))
200
201 ;;; DEF-OUTPUT-ROUTINES -- internal
202 ;;;
203 ;;; Define output routines that output numbers size bytes long for the
204 ;;; given bufferings. Use body to do the actual output.
205 ;;;
206 (defmacro def-output-routines ((name size &rest bufferings) &body body)
207 (cons 'progn
208 (mapcar
209 #'(lambda (buffering)
210 (let ((function
211 (intern (let ((*print-case* :upcase))
212 (format nil name (car buffering))))))
213 `(progn
214 (defun ,function (stream byte)
215 ,(unless (eq (car buffering) :none)
216 `(when (< (fd-stream-obuf-length stream)
217 (+ (fd-stream-obuf-tail stream)
218 ,size))
219 (flush-output-buffer stream)))
220 ,@body
221 (incf (fd-stream-obuf-tail stream) ,size)
222 ,(ecase (car buffering)
223 (:none
224 `(flush-output-buffer stream))
225 (:line
226 `(when (eq (char-code byte) (char-code #\Newline))
227 (flush-output-buffer stream)))
228 (:full
229 ))
230 (values))
231 (setf *output-routines*
232 (nconc *output-routines*
233 ',(mapcar
234 #'(lambda (type)
235 (list type
236 (car buffering)
237 function
238 size))
239 (cdr buffering)))))))
240 bufferings)))
241
242 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
243 1
244 (:none character)
245 (:line character)
246 (:full character))
247 (if (eq (char-code byte)
248 (char-code #\Newline))
249 (setf (fd-stream-char-pos stream) 0)
250 (incf (fd-stream-char-pos stream)))
251 (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
252 (char-code byte)))
253
254 (def-output-routines ("OUTPUT-BYTE-~A-BUFFERED"
255 1
256 (:none (signed-byte 8) (unsigned-byte 8))
257 (:full (signed-byte 8) (unsigned-byte 8)))
258 (when (characterp byte)
259 (if (eq (char-code byte)
260 (char-code #\Newline))
261 (setf (fd-stream-char-pos stream) 0)
262 (incf (fd-stream-char-pos stream))))
263 (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
264 byte))
265
266 (def-output-routines ("OUTPUT-SHORT-~A-BUFFERED"
267 2
268 (:none (signed-byte 16) (unsigned-byte 16))
269 (:full (signed-byte 16) (unsigned-byte 16)))
270 (setf (sap-ref-16 (fd-stream-obuf-sap stream)
271 (truncate (fd-stream-obuf-tail stream) 2))
272 byte))
273
274 (def-output-routines ("OUTPUT-LONG-~A-BUFFERED"
275 4
276 (:none (signed-byte 32) (unsigned-byte 32))
277 (:full (signed-byte 32) (unsigned-byte 32)))
278 (setf (sap-ref-32 (fd-stream-obuf-sap stream)
279 (truncate (fd-stream-obuf-tail stream) 4))
280 byte))
281
282 ;;; OUTPUT-RAW-BYTES -- public
283 ;;;
284 ;;; Does the actual output. If there is space to buffer the string, buffer
285 ;;; it. If the string would normally fit in the buffer, but doesn't because
286 ;;; of other stuff in the buffer, flush the old noise out of the buffer and
287 ;;; put the string in it. Otherwise we have a very long string, so just
288 ;;; send it directly (after flushing the buffer, of course).
289 ;;;
290 (defun output-raw-bytes (stream thing &optional start end)
291 "Output THING to stream. THING can be any kind of vector or a sap. If THING
292 is a SAP, END must be supplied (as length won't work)."
293 (let ((start (or start 0))
294 (end (or end (length thing))))
295 (declare (fixnum start end))
296 (let* ((len (fd-stream-obuf-length stream))
297 (tail (fd-stream-obuf-tail stream))
298 (space (- len tail))
299 (bytes (- end start))
300 (newtail (+ tail bytes)))
301 (cond ((minusp bytes) ; Error case
302 (cerror "Just go on as if nothing happened..."
303 "~S called with :END before :START!"
304 'output-raw-bytes))
305 ((zerop bytes)) ; Easy case
306 ((<= bytes space)
307 (if (system-area-pointer-p thing)
308 (system-area-copy thing
309 (* start vm:byte-bits)
310 (fd-stream-obuf-sap stream)
311 (* tail vm:byte-bits)
312 (* bytes vm:byte-bits))
313 (copy-to-system-area thing
314 (+ (* start vm:byte-bits)
315 (* vm:vector-data-offset vm:word-bits))
316 (fd-stream-obuf-sap stream)
317 (* tail vm:byte-bits)
318 (* bytes vm:byte-bits)))
319 (setf (fd-stream-obuf-tail stream) newtail))
320 ((<= bytes len)
321 (flush-output-buffer stream)
322 (if (system-area-pointer-p thing)
323 (system-area-copy thing
324 (* start vm:byte-bits)
325 (fd-stream-obuf-sap stream)
326 0
327 (* bytes vm:byte-bits))
328 (copy-to-system-area thing
329 (+ (* start vm:byte-bits)
330 (* vm:vector-data-offset vm:word-bits))
331 (fd-stream-obuf-sap stream)
332 0
333 (* bytes vm:byte-bits)))
334 (setf (fd-stream-obuf-tail stream) bytes))
335 (t
336 (flush-output-buffer stream)
337 (do-output stream thing start end nil))))))
338
339 ;;; FD-SOUT -- internal
340 ;;;
341 ;;; Routine to use to output a string. If the stream is unbuffered, slam
342 ;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to
343 ;;; buffer the string. Update charpos by checking to see where the last newline
344 ;;; was.
345 ;;;
346 ;;; Note: some bozos (the FASL dumper) call write-string with things other
347 ;;; than strings. Therefore, we must make sure we have a string before calling
348 ;;; position on it.
349 ;;;
350 (defun fd-sout (stream thing start end)
351 (let ((start (or start 0))
352 (end (or end (length thing))))
353 (declare (fixnum start end))
354 (if (stringp thing)
355 (let ((last-newline (and (find #\newline (the simple-string thing)
356 :start start :end end)
357 (position #\newline (the simple-string thing)
358 :from-end t
359 :start start
360 :end end))))
361 (ecase (fd-stream-buffering stream)
362 (:full
363 (output-raw-bytes stream thing start end))
364 (:line
365 (output-raw-bytes stream thing start end)
366 (when last-newline
367 (flush-output-buffer stream)))
368 (:none
369 (do-output stream thing start end nil)))
370 (if last-newline
371 (setf (fd-stream-char-pos stream)
372 (- end last-newline 1))
373 (incf (fd-stream-char-pos stream)
374 (- end start))))
375 (ecase (fd-stream-buffering stream)
376 ((:line :full)
377 (output-raw-bytes stream thing start end))
378 (:none
379 (do-output stream thing start end nil))))))
380
381 ;;; PICK-OUTPUT-ROUTINE -- internal
382 ;;;
383 ;;; Find an output routine to use given the type and buffering. Return as
384 ;;; multiple values the routine, the real type transfered, and the number of
385 ;;; bytes per element.
386 ;;;
387 (defun pick-output-routine (type buffering)
388 (dolist (entry *output-routines*)
389 (when (and (subtypep type (car entry))
390 (eq buffering (cadr entry)))
391 (return (values (symbol-function (caddr entry))
392 (car entry)
393 (cadddr entry))))))
394
395
396 ;;;; Input routines and related noise.
397
398 (defvar *input-routines* ()
399 "List of all available input routines. Each element is a list of the
400 element-type input, the function name, and the number of bytes per element.")
401
402 ;;; DO-INPUT -- internal
403 ;;;
404 ;;; Fills the input buffer, and returns the first character. Throws to
405 ;;; eof-input-catcher if the eof was reached. Drops into system:server if
406 ;;; necessary.
407 ;;;
408 (defun do-input (stream)
409 (let ((fd (fd-stream-fd stream))
410 (ibuf-sap (fd-stream-ibuf-sap stream))
411 (buflen (fd-stream-ibuf-length stream))
412 (head (fd-stream-ibuf-head stream))
413 (tail (fd-stream-ibuf-tail stream)))
414 (unless (zerop head)
415 (cond ((eq head tail)
416 (setf head 0)
417 (setf tail 0)
418 (setf (fd-stream-ibuf-head stream) 0)
419 (setf (fd-stream-ibuf-tail stream) 0))
420 (t
421 (decf tail head)
422 (system-area-copy ibuf-sap (* head vm:byte-bits)
423 ibuf-sap 0 (* tail vm:byte-bits))
424 (setf head 0)
425 (setf (fd-stream-ibuf-head stream) 0)
426 (setf (fd-stream-ibuf-tail stream) tail))))
427 (setf (fd-stream-listen stream) nil)
428 #+serve-event
429 (multiple-value-bind
430 (count errno)
431 (mach:unix-select (1+ fd) (ash 1 fd) 0 0 0)
432 (case count
433 (1)
434 (0
435 (system:wait-until-fd-usable fd :input))
436 (t
437 (error "Problem checking to see if ~S is readable: ~A"
438 stream
439 (mach:get-unix-error-msg errno)))))
440 (multiple-value-bind
441 (count errno)
442 (mach:unix-read fd
443 (system:int-sap (+ (system:sap-int ibuf-sap) tail))
444 (- buflen tail))
445 (cond ((null count)
446 (if #+serve-event (eql errno mach:ewouldblock)
447 #-serve-event nil
448 (progn
449 (system:wait-until-fd-usable fd :input)
450 (do-input stream))
451 (error "Error reading ~S: ~A"
452 stream
453 (mach:get-unix-error-msg errno))))
454 ((zerop count)
455 (throw 'eof-input-catcher nil))
456 (t
457 (incf (fd-stream-ibuf-tail stream) count))))))
458
459 ;;; INPUT-AT-LEAST -- internal
460 ;;;
461 ;;; Makes sure there are at least ``bytes'' number of bytes in the input
462 ;;; buffer. Keeps calling do-input until that condition is met.
463 ;;;
464 (defmacro input-at-least (stream bytes)
465 (let ((stream-var (gensym))
466 (bytes-var (gensym)))
467 `(let ((,stream-var ,stream)
468 (,bytes-var ,bytes))
469 (loop
470 (when (>= (- (fd-stream-ibuf-tail ,stream-var)
471 (fd-stream-ibuf-head ,stream-var))
472 ,bytes-var)
473 (return))
474 (do-input ,stream-var)))))
475
476 ;;; INPUT-WRAPPER -- intenal
477 ;;;
478 ;;; Macro to wrap around all input routines to handle eof-error noise. This
479 ;;; should make provisions for filling stream-in-buffer.
480 ;;;
481 (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
482 (let ((stream-var (gensym))
483 (element-var (gensym)))
484 `(let ((,stream-var ,stream))
485 (if (fd-stream-unread ,stream)
486 (prog1
487 (fd-stream-unread ,stream)
488 (setf (fd-stream-unread ,stream) nil)
489 (setf (fd-stream-listen ,stream) nil))
490 (let ((,element-var
491 (catch 'eof-input-catcher
492 (input-at-least ,stream-var ,bytes)
493 ,@read-forms)))
494 (cond (,element-var
495 (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
496 ,element-var)
497 (,eof-error
498 (error "EOF while reading ~S" stream))
499 (t
500 ,eof-value)))))))
501
502 ;;; DEF-INPUT-ROUTINE -- internal
503 ;;;
504 ;;; Defines an input routine.
505 ;;;
506 (defmacro def-input-routine (name
507 (type size sap head)
508 &rest body)
509 `(progn
510 (defun ,name (stream eof-error eof-value)
511 (input-wrapper (stream ,size eof-error eof-value)
512 (let ((,sap (fd-stream-ibuf-sap stream))
513 (,head (fd-stream-ibuf-head stream)))
514 ,@body)))
515 (setf *input-routines*
516 (nconc *input-routines*
517 (list (list ',type ',name ',size))))))
518
519 ;;; INPUT-CHARACTER -- internal
520 ;;;
521 ;;; Routine to use in stream-in slot for reading string chars.
522 ;;;
523 (def-input-routine input-character
524 (character 1 sap head)
525 (code-char (sap-ref-8 sap head)))
526
527 ;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
528 ;;;
529 ;;; Routine to read in an unsigned 8 bit number.
530 ;;;
531 (def-input-routine input-unsigned-8bit-byte
532 ((unsigned-byte 8) 1 sap head)
533 (sap-ref-8 sap head))
534
535 ;;; INPUT-SIGNED-8BIT-BYTE -- internal
536 ;;;
537 ;;; Routine to read in a signed 8 bit number.
538 ;;;
539 (def-input-routine input-signed-8bit-number
540 ((signed-byte 8) 1 sap head)
541 (signed-sap-ref-8 sap head))
542
543 ;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
544 ;;;
545 ;;; Routine to read in an unsigned 16 bit number.
546 ;;;
547 (def-input-routine input-unsigned-16bit-byte
548 ((unsigned-byte 16) 2 sap head)
549 (sap-ref-16 sap (truncate head 2)))
550
551 ;;; INPUT-SIGNED-16BIT-BYTE -- internal
552 ;;;
553 ;;; Routine to read in a signed 16 bit number.
554 ;;;
555 (def-input-routine input-signed-16bit-byte
556 ((signed-byte 16) 2 sap head)
557 (signed-sap-ref-16 sap (truncate head 2)))
558
559 ;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
560 ;;;
561 ;;; Routine to read in a unsigned 32 bit number.
562 ;;;
563 (def-input-routine input-unsigned-32bit-byte
564 ((unsigned-byte 32) 4 sap head)
565 (sap-ref-32 sap (truncate head 4)))
566
567 ;;; INPUT-SIGNED-32BIT-BYTE -- internal
568 ;;;
569 ;;; Routine to read in a signed 32 bit number.
570 ;;;
571 (def-input-routine input-signed-32bit-byte
572 ((signed-byte 32) 4 sap head)
573 (signed-sap-ref-32 sap (truncate head 2)))
574
575 ;;; PICK-INPUT-ROUTINE -- internal
576 ;;;
577 ;;; Find an input routine to use given the type. Return as multiple values
578 ;;; the routine, the real type transfered, and the number of bytes per element.
579 ;;;
580 (defun pick-input-routine (type)
581 (dolist (entry *input-routines*)
582 (when (subtypep type (car entry))
583 (return (values (symbol-function (cadr entry))
584 (car entry)
585 (caddr entry))))))
586
587 ;;; STRING-FROM-SAP -- internal
588 ;;;
589 ;;; Returns a string constructed from the sap, start, and end.
590 ;;;
591 (defun string-from-sap (sap start end)
592 (let* ((length (- end start))
593 (string (make-string length)))
594 (copy-from-system-area sap (* start vm:byte-bits)
595 string (* vm:vector-data-offset vm:word-bits)
596 (* length vm:byte-bits))
597 string))
598
599 ;;; FD-STREAM-READ-LINE -- internal
600 ;;;
601 ;;; Reads a line, returning a simple string. Note: this relies on the fact
602 ;;; that the input buffer does not change during do-input.
603 ;;;
604 (defun fd-stream-read-line (stream eof-error-p eof-value)
605 (let ((eof t))
606 (values
607 (or (let ((sap (fd-stream-ibuf-sap stream))
608 (results (when (fd-stream-unread stream)
609 (prog1
610 (list (string (fd-stream-unread stream)))
611 (setf (fd-stream-unread stream) nil)
612 (setf (fd-stream-listen stream) nil)))))
613 (catch 'eof-input-catcher
614 (loop
615 (input-at-least stream 1)
616 (let* ((head (fd-stream-ibuf-head stream))
617 (tail (fd-stream-ibuf-tail stream))
618 (newline (do ((index head (1+ index)))
619 ((= index tail) nil)
620 (when (= (sap-ref-8 sap index)
621 (char-code #\newline))
622 (return index))))
623 (end (or newline tail)))
624 (push (string-from-sap sap head end)
625 results)
626
627 (when newline
628 (setf eof nil)
629 (setf (fd-stream-ibuf-head stream)
630 (1+ newline))
631 (return))
632 (setf (fd-stream-ibuf-head stream) end))))
633 (cond ((null results)
634 nil)
635 ((null (cdr results))
636 (car results))
637 (t
638 (apply #'concatenate 'simple-string (nreverse results)))))
639 (if eof-error-p
640 (error "EOF while reading ~S" stream)
641 eof-value))
642 eof)))
643
644
645 ;;; FD-STREAM-READ-N-BYTES -- internal
646 ;;;
647 ;;; The n-bin routine.
648 ;;;
649 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
650 (let* ((sap (fd-stream-ibuf-sap stream))
651 (elsize (fd-stream-element-size stream))
652 (offset (* elsize start))
653 (bytes (* elsize requested))
654 (result
655 (catch 'eof-input-catcher
656 (loop
657 (input-at-least stream 1)
658 (let* ((head (fd-stream-ibuf-head stream))
659 (tail (fd-stream-ibuf-tail stream))
660 (available (- tail head))
661 (copy (min available bytes)))
662 (if (typep buffer 'system-area-pointer)
663 (system-area-copy sap (* head vm:byte-bits)
664 buffer (* offset vm:byte-bits)
665 (* copy vm:byte-bits))
666 (copy-from-system-area sap (* head vm:byte-bits)
667 buffer (+ (* offset vm:byte-bits)
668 (* vm:vector-data-offset
669 vm:word-bits))
670 (* copy vm:byte-bits)))
671 (incf (fd-stream-ibuf-head stream) copy)
672 (incf offset copy)
673 (decf bytes copy))
674 (when (zerop bytes)
675 (return requested))))))
676 (cond (result)
677 ((not eof-error-p)
678 (- requested (/ bytes elsize)))
679 (t
680 (error "Hit eof on ~S after reading ~D ~D~2:*-bit byte~P~*, ~
681 but ~D~2:* ~D-bit byte~P~:* ~[were~;was~:;were~] requested."
682 stream
683 (- requested (/ bytes elsize))
684 (* elsize 8)
685 requested)))))
686
687
688 ;;;; Utility functions (misc routines, etc)
689
690 ;;; SET-ROUTINES -- internal
691 ;;;
692 ;;; Fill in the various routine slots for the given type. Input-p and output-p
693 ;;; indicate what slots to fill. The buffering slot must be set prior to
694 ;;; calling this routine.
695 ;;;
696 (defun set-routines (stream type input-p output-p)
697 (let ((target-type (case type
698 ((:default unsigned-byte)
699 '(unsigned-byte 8))
700 (signed-byte
701 '(signed-byte 8))
702 (t
703 type)))
704 (input-type nil)
705 (output-type nil)
706 (input-size nil)
707 (output-size nil))
708
709 (when (fd-stream-obuf-sap stream)
710 (push (fd-stream-obuf-sap stream) *available-buffers*)
711 (setf (fd-stream-obuf-sap stream) nil))
712 (when (fd-stream-ibuf-sap stream)
713 (push (fd-stream-ibuf-sap stream) *available-buffers*)
714 (setf (fd-stream-ibuf-sap stream) nil))
715
716 (when input-p
717 (multiple-value-bind
718 (routine type size)
719 (pick-input-routine target-type)
720 (unless routine
721 (error "Could not find any input routine for ~S" target-type))
722 (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
723 (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
724 (setf (fd-stream-ibuf-tail stream) 0)
725 (if (subtypep type 'character)
726 (setf (fd-stream-in stream) routine
727 (fd-stream-bin stream) #'ill-bin
728 (fd-stream-n-bin stream) #'ill-bin)
729 (setf (fd-stream-in stream) #'ill-in
730 (fd-stream-bin stream) routine
731 (fd-stream-n-bin stream) #'fd-stream-read-n-bytes))
732 (setf input-size size)
733 (setf input-type type)))
734
735 (when output-p
736 (multiple-value-bind
737 (routine type size)
738 (pick-output-routine target-type (fd-stream-buffering stream))
739 (unless routine
740 (error "Could not find any output routine for ~S buffered ~S."
741 (fd-stream-buffering stream)
742 target-type))
743 (setf (fd-stream-obuf-sap stream) (next-available-buffer))
744 (setf (fd-stream-obuf-length stream) bytes-per-buffer)
745 (setf (fd-stream-obuf-tail stream) 0)
746 (if (subtypep type 'character)
747 (setf (fd-stream-out stream) routine
748 (fd-stream-bout stream) #'ill-bout)
749 (setf (fd-stream-out stream)
750 (or (if (eql size 1)
751 (pick-output-routine 'base-character
752 (fd-stream-buffering stream)))
753 #'ill-out)
754 (fd-stream-bout stream) routine))
755 (setf (fd-stream-sout stream)
756 (if (eql size 1) #'fd-sout #'ill-out))
757 (setf (fd-stream-char-pos stream) 0)
758 (setf output-size size)
759 (setf output-type type)))
760
761 (when (and input-size output-size
762 (not (eq input-size output-size)))
763 (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
764 input-type input-size
765 output-type output-size))
766 (setf (fd-stream-element-size stream)
767 (or input-size output-size))
768
769 (setf (fd-stream-element-type stream)
770 (cond ((equal input-type output-type)
771 input-type)
772 ((or (null output-type) (subtypep input-type output-type))
773 input-type)
774 ((subtypep output-type input-type)
775 output-type)
776 (t
777 (error "Input type (~S) and output type (~S) are unrelated?"
778 input-type
779 output-type))))))
780
781 ;;; FD-STREAM-MISC-ROUTINE -- input
782 ;;;
783 ;;; Handle the various misc operations on fd-stream.
784 ;;;
785 (defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
786 (case operation
787 (:read-line
788 (fd-stream-read-line stream arg1 arg2))
789 (:listen
790 (or (not (eql (fd-stream-ibuf-head stream)
791 (fd-stream-ibuf-tail stream)))
792 (fd-stream-listen stream)
793 (setf (fd-stream-listen stream)
794 (not (zerop (mach:unix-select (1+ (fd-stream-fd stream))
795 (ash 1 (fd-stream-fd stream))
796 0
797 0
798 0))))))
799 (:unread
800 (setf (fd-stream-unread stream) arg1)
801 (setf (fd-stream-listen stream) t))
802 (:close
803 (cond (arg1
804 ;; We got us an abort on our hands.
805 (when (and (fd-stream-file stream)
806 (fd-stream-obuf-sap stream))
807 ;; Can't do anything unless we know what file were dealing with,
808 ;; and we don't want to do anything strange unless we were
809 ;; writing to the file.
810 (if (fd-stream-original stream)
811 ;; Have an handle on the original, just revert.
812 (multiple-value-bind
813 (okay err)
814 (mach:unix-rename (fd-stream-original stream)
815 (fd-stream-file stream))
816 (unless okay
817 (cerror "Go on as if nothing bad happened."
818 "Could not restore ~S to it's original contents: ~A"
819 (fd-stream-file stream)
820 (mach:get-unix-error-msg err))))
821 ;; Can't restore the orignal, so nuke that puppy.
822 (multiple-value-bind
823 (okay err)
824 (mach:unix-unlink (fd-stream-file stream))
825 (unless okay
826 (cerror "Go on as if nothing bad happened."
827 "Could not remove ~S: ~A"
828 (fd-stream-file stream)
829 (mach:get-unix-error-msg err)))))))
830 (t
831 (fd-stream-misc-routine stream :finish-output)
832 (when (and (fd-stream-original stream)
833 (fd-stream-delete-original stream))
834 (multiple-value-bind
835 (okay err)
836 (mach:unix-unlink (fd-stream-original stream))
837 (unless okay
838 (cerror "Go on as if nothing bad happened."
839 "Could not delete ~S during close of ~S: ~A"
840 (fd-stream-original stream)
841 stream
842 (mach:get-unix-error-msg err)))))))
843 (mach:unix-close (fd-stream-fd stream))
844 (when (fd-stream-obuf-sap stream)
845 (push (fd-stream-obuf-sap stream) *available-buffers*)
846 (setf (fd-stream-obuf-sap stream) nil))
847 (when (fd-stream-ibuf-sap stream)
848 (push (fd-stream-ibuf-sap stream) *available-buffers*)
849 (setf (fd-stream-ibuf-sap stream) nil))
850 (lisp::set-closed-flame stream))
851 (:clear-input
852 (setf (fd-stream-ibuf-head stream) 0)
853 (setf (fd-stream-ibuf-tail stream) 0)
854 (loop
855 (multiple-value-bind
856 (count errno)
857 (mach:unix-select (1+ (fd-stream-fd stream))
858 (ash 1 (fd-stream-fd stream))
859 0 0 0)
860 (cond ((eql count 1)
861 (do-input stream)
862 (setf (fd-stream-ibuf-head stream) 0)
863 (setf (fd-stream-ibuf-tail stream) 0))
864 (t
865 (return))))))
866 (:force-output
867 (flush-output-buffer stream))
868 (:finish-output
869 (flush-output-buffer stream)
870 #+serve-event
871 (do ()
872 ((null (fd-stream-output-later stream)))
873 (system:serve-all-events)))
874 (:element-type
875 (fd-stream-element-type stream))
876 (:line-length
877 80)
878 (:charpos
879 (fd-stream-char-pos stream))
880 (:file-length
881 (multiple-value-bind
882 (okay dev ino mode nlink uid gid rdev size
883 atime mtime ctime blksize blocks)
884 (mach:unix-fstat (fd-stream-fd stream))
885 (declare (ignore ino nlink uid gid rdev
886 atime mtime ctime blksize blocks))
887 (unless okay
888 (error "Error fstating ~S: ~A"
889 stream
890 (mach:get-unix-error-msg dev)))
891 (if (zerop mode)
892 nil
893 (/ size (fd-stream-element-size stream)))))
894 (:file-position
895 (fd-stream-file-position stream arg1))
896 (:file-name
897 (fd-stream-file stream))))
898
899 ;;; FD-STREAM-FILE-POSITION -- internal.
900 ;;;
901 (defun fd-stream-file-position (stream &optional newpos)
902 (if (null newpos)
903 (system:without-interrupts
904 ;; First, find the position of the UNIX file descriptor in the
905 ;; file.
906 (multiple-value-bind
907 (posn errno)
908 (mach:unix-lseek (fd-stream-fd stream) 0 mach:l_incr)
909 (cond ((numberp posn)
910 ;; Adjust for buffered output:
911 ;; If there is any output buffered, the *real* file position
912 ;; will be larger than reported by lseek because lseek
913 ;; obviously cannot take into account output we have not
914 ;; sent yet.
915 (dolist (later (fd-stream-output-later stream))
916 (incf posn (- (caddr later) (cadr later))))
917 (incf posn (fd-stream-obuf-tail stream))
918 ;; Adjust for unread input:
919 ;; If there is any input read from UNIX but not supplied to
920 ;; the user of the stream, the *real* file position will
921 ;; smaller than reported, because we want to look like the
922 ;; unread stuff is still available.
923 (decf posn (- (fd-stream-ibuf-tail stream)
924 (fd-stream-ibuf-head stream)))
925 (when (fd-stream-unread stream)
926 (decf posn))
927 ;; Divide bytes by element size.
928 (/ posn (fd-stream-element-size stream)))
929 ((eq errno mach:espipe)
930 nil)
931 (t
932 (system:with-interrupts
933 (error "Error lseek'ing ~S: ~A"
934 stream
935 (mach:get-unix-error-msg errno)))))))
936 (let (offset origin)
937 ;; Make sure we don't have any output pending, because if we move the
938 ;; file pointer before writing this stuff, it will be written in the
939 ;; wrong location.
940 (flush-output-buffer stream)
941 (do ()
942 ((null (fd-stream-output-later stream)))
943 (system:serve-all-events))
944 ;; Clear out any pending input to force the next read to go to the
945 ;; disk.
946 (setf (fd-stream-unread stream) nil)
947 (setf (fd-stream-ibuf-head stream) 0)
948 (setf (fd-stream-ibuf-tail stream) 0)
949 ;; Trash cashed value for listen, so that we check next time.
950 (setf (fd-stream-listen stream) nil)
951 ;; Now move it.
952 (cond ((eq newpos :start)
953 (setf offset 0 origin mach:l_set))
954 ((eq newpos :end)
955 (setf offset 0 origin mach:l_xtnd))
956 ((numberp newpos)
957 (setf offset (* newpos (fd-stream-element-size stream))
958 origin mach:l_set))
959 (t
960 (error "Invalid position given to file-position: ~S" newpos)))
961 (multiple-value-bind
962 (posn errno)
963 (mach:unix-lseek (fd-stream-fd stream) offset origin)
964 (cond ((numberp posn)
965 t)
966 ((eq errno mach:espipe)
967 nil)
968 (t
969 (error "Error lseek'ing ~S: ~A"
970 stream
971 (mach:get-unix-error-msg errno))))))))
972
973
974
975 ;;;; Creation routines (MAKE-FD-STREAM and OPEN)
976
977 ;;; MAKE-FD-STREAM -- Public.
978 ;;;
979 ;;; Returns a FD-STREAM on the given file.
980 ;;;
981 (defun make-fd-stream (fd
982 &key
983 (input nil input-p)
984 (output nil output-p)
985 (element-type 'base-character)
986 (buffering :full)
987 file
988 original
989 delete-original
990 (name (if file
991 (format nil "file ~S" file)
992 (format nil "descriptor ~D" fd))))
993 "Create a stream for the given unix file descriptor. If input is non-nil,
994 allow input operations. If output is non-nil, allow output operations. If
995 neither input nor output are specified, default to allowing input.
996 element-type indicates the element type to use (as for open). Buffering
997 indicates the kind of buffering to use (one of :none, :line, or :full). If
998 file is spesified, it should be the name of the file. Name is used to
999 identify the stream when printed."
1000 (cond ((not (or input-p output-p))
1001 (setf input t))
1002 ((not (or input output))
1003 (error "File descriptor must be opened either for input or output.")))
1004 (let ((stream (%make-fd-stream :fd fd
1005 :name name
1006 :file file
1007 :original original
1008 :delete-original delete-original
1009 :buffering buffering)))
1010 (set-routines stream element-type input output)
1011 stream))
1012
1013 ;;; PICK-PACKUP-NAME -- internal
1014 ;;;
1015 ;;; Pick a name to use for the backup file.
1016 ;;;
1017 (defvar *backup-extension* ".BAK"
1018 "This is a string that OPEN tacks on the end of a file namestring to produce
1019 a name for the :if-exists :rename-and-delete and :rename options. Also,
1020 this can be a function that takes a namestring and returns a complete
1021 namestring.")
1022 ;;;
1023 (defun pick-backup-name (name)
1024 (etypecase *backup-extension*
1025 (string (concatenate 'simple-string name *backup-extension*))
1026 (function (funcall *backup-extension* name))))
1027
1028 ;;; ASSURE-ONE-OF -- internal
1029 ;;;
1030 ;;; Assure that the given arg is one of the given list of valid things.
1031 ;;; Allow the user to fix any problems.
1032 ;;;
1033 (defun assure-one-of (item list what)
1034 (unless (member item list)
1035 (loop
1036 (cerror "Enter new value for ~*~S"
1037 "~S is invalid for ~S. Must be one of~{ ~S~}"
1038 item
1039 what
1040 list)
1041 (format *query-io* "Enter new value for ~S: " what)
1042 (force-output *query-io*)
1043 (setf item (read *query-io*))
1044 (when (member item list)
1045 (return))))
1046 item)
1047
1048 ;;; OPEN -- public
1049 ;;;
1050 ;;; Open the given file.
1051 ;;;
1052 (defun open (filename
1053 &key
1054 (direction :input)
1055 (element-type 'base-character)
1056 (if-exists nil if-exists-given)
1057 (if-does-not-exist nil if-does-not-exist-given))
1058 "Return a stream which reads from or writes to Filename.
1059 Defined keywords:
1060 :direction - one of :input, :output, :io, or :probe
1061 :element-type - Type of object to read or write, default BASE-CHARACTER
1062 :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1063 :overwrite, :append, :supersede or nil
1064 :if-does-not-exist - one of :error, :create or nil
1065 See the manual for details."
1066 ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
1067 (setf direction
1068 (assure-one-of direction
1069 '(:input :output :io :probe)
1070 :direction))
1071
1072 ;; Calculate useful stuff.
1073 (multiple-value-bind
1074 (input output mask)
1075 (case direction
1076 (:input (values t nil mach:o_rdonly))
1077 (:output (values nil t mach:o_wronly))
1078 (:io (values t t mach:o_rdwr))
1079 (:probe (values t nil mach:o_rdonly)))
1080 (let* ((pathname (pathname filename))
1081 (namestring (unix-namestring pathname input)))
1082 ;; Process if-exists argument if we are doing any output.
1083 (cond (output
1084 (unless if-exists-given
1085 (setf if-exists
1086 (if (eq (pathname-version pathname) :newest)
1087 :new-version
1088 :error)))
1089 (setf if-exists
1090 (assure-one-of if-exists
1091 '(:error :new-version :rename
1092 :rename-and-delete :overwrite
1093 :append :supersede nil)
1094 :if-exists))
1095 (case if-exists
1096 ((:error nil)
1097 (setf mask (logior mask mach:o_excl)))
1098 ((:rename :rename-and-delete)
1099 (setf mask (logior mask mach:o_creat)))
1100 ((:new-version :supersede)
1101 (setf mask (logior mask mach:o_trunc)))
1102 (:append
1103 (setf mask (logior mask mach:o_append)))))
1104 (t
1105 (setf if-exists :ignore-this-arg)))
1106
1107 (unless if-does-not-exist-given
1108 (setf if-does-not-exist
1109 (cond ((eq direction :input) :error)
1110 ((and output
1111 (member if-exists '(:overwrite :append)))
1112 :error)
1113 ((eq direction :probe)
1114 nil)
1115 (t
1116 :create))))
1117 (setf if-does-not-exist
1118 (assure-one-of if-does-not-exist
1119 '(:error :create nil)
1120 :if-does-not-exist))
1121 (if (eq if-does-not-exist :create)
1122 (setf mask (logior mask mach:o_creat)))
1123
1124 (let ((original (if (member if-exists
1125 '(:rename :rename-and-delete))
1126 (pick-backup-name namestring)))
1127 (delete-original (eq if-exists :rename-and-delete))
1128 (mode #o666))
1129 (when original
1130 ;; We are doing a :rename or :rename-and-delete.
1131 ;; Determine if the file already exists, make sure the original
1132 ;; file is not a directory and keep the mode
1133 (let ((exists
1134 (multiple-value-bind
1135 (okay err/dev inode orig-mode)
1136 (mach:unix-stat namestring)
1137 (declare (ignore inode))
1138 (cond (okay
1139 (when (and output (= (logand orig-mode #o170000)
1140 #o40000))
1141 (error "Cannot open ~S for output: Is a directory."
1142 namestring))
1143 (setf mode (logand orig-mode #o777))
1144 t)
1145 ((eql err/dev mach:enoent)
1146 nil)
1147 (t
1148 (error "Cannot find ~S: ~A"
1149 namestring
1150 (mach:get-unix-error-msg err/dev)))))))
1151 (when (or (not exists)
1152 ;; Do the rename.
1153 (multiple-value-bind
1154 (okay err)
1155 (mach:unix-rename namestring original)
1156 (unless okay
1157 (cerror "Use :SUPERSEDE instead."
1158 "Could not rename ~S to ~S: ~A."
1159 namestring
1160 original
1161 (mach:get-unix-error-msg err))
1162 t)))
1163 (setf original nil)
1164 (setf delete-original nil)
1165 ;; In order to use SUPERSEDE instead, we have
1166 ;; to make sure mach:o_creat corresponds to
1167 ;; if-does-not-exist. mach:o_creat was set
1168 ;; before because of if-exists being :rename.
1169 (unless (eq if-does-not-exist :create)
1170 (setf mask (logior (logandc2 mask mach:o_creat) mach:o_trunc)))
1171 (setf if-exists :supersede))))
1172
1173 ;; Okay, now we can try the actual open.
1174 (loop
1175 (multiple-value-bind
1176 (fd errno)
1177 (mach:unix-open namestring mask mode)
1178 (cond ((numberp fd)
1179 (return
1180 (case direction
1181 ((:input :output :io)
1182 (make-fd-stream fd
1183 :input input
1184 :output output
1185 :element-type element-type
1186 :file namestring
1187 :original original
1188 :delete-original delete-original))
1189 (:probe
1190 (let ((stream
1191 (%make-fd-stream :name namestring :fd fd
1192 :element-type element-type)))
1193 (close stream)
1194 stream)))))
1195 ((eql errno mach:enoent)
1196 (case if-does-not-exist
1197 (:error
1198 (cerror "Return NIL."
1199 "Error opening ~S, ~A."
1200 pathname
1201 (mach:get-unix-error-msg errno)))
1202 (:create
1203 (cerror "Return NIL."
1204 "Error creating ~S, path does not exist."
1205 pathname)))
1206 (return nil))
1207 ((eql errno mach:eexist)
1208 (unless (eq nil if-exists)
1209 (cerror "Return NIL."
1210 "Error opening ~S, ~A."
1211 pathname
1212 (mach:get-unix-error-msg errno)))
1213 (return nil))
1214 ((eql errno mach:eacces)
1215 (cerror "Try again."
1216 "Error opening ~S, ~A."
1217 pathname
1218 (mach:get-unix-error-msg errno)))
1219 (t
1220 (cerror "Return NIL."
1221 "Error opening ~S, ~A."
1222 pathname
1223 (mach:get-unix-error-msg errno))
1224 (return nil)))))))))
1225
1226 ;;;; Initialization.
1227
1228 (defvar *tty* nil
1229 "The stream connected to the controlling terminal or NIL if there is none.")
1230 (defvar *stdin* nil
1231 "The stream connected to the standard input (file descriptor 0).")
1232 (defvar *stdout* nil
1233 "The stream connected to the standard output (file descriptor 1).")
1234 (defvar *stderr* nil
1235 "The stream connected to the standard error output (file descriptor 2).")
1236
1237 ;;; STREAM-INIT -- internal interface
1238 ;;;
1239 ;;; Called when the cold load is first started up.
1240 ;;;
1241 (defun stream-init ()
1242 (stream-reinit)
1243 (setf *terminal-io* (make-synonym-stream '*tty*))
1244 (setf *standard-output* (make-synonym-stream '*stdout*))
1245 (setf *standard-input*
1246 (make-two-way-stream (make-synonym-stream '*stdin*)
1247 *standard-output*))
1248 (setf *error-output* (make-synonym-stream '*stderr*))
1249 (setf *query-io* (make-synonym-stream '*terminal-io*))
1250 (setf *debug-io* *query-io*)
1251 (setf *trace-output* *standard-output*)
1252 nil)
1253
1254 ;;; STREAM-REINIT -- internal interface
1255 ;;;
1256 ;;; Called whenever a saved core is restarted.
1257 ;;;
1258 (defun stream-reinit ()
1259 (setf *available-buffers* nil)
1260 (setf *stdin*
1261 (make-fd-stream 0 :name "Standard Input" :input t :buffering :line))
1262 (setf *stdout*
1263 (make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
1264 (setf *stderr*
1265 (make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
1266 (let ((tty (mach:unix-open "/dev/tty" mach:o_rdwr #o666)))
1267 (if tty
1268 (setf *tty*
1269 (make-fd-stream tty :name "the Terminal" :input t :output t
1270 :buffering :line))
1271 (setf *tty* (make-two-way-stream *stdin* *stdout*))))
1272 nil)
1273
1274
1275 ;;;; Beeping.
1276
1277 (defun default-beep-function (stream)
1278 (write-char #\bell stream)
1279 (finish-output stream))
1280
1281 (defvar *beep-function* #'default-beep-function
1282 "This is called in BEEP to feep the user. It takes a stream.")
1283
1284 (defun beep (&optional (stream *terminal-io*))
1285 (funcall *beep-function* stream))
1286
1287
1288 ;;;; File position and file length.
1289
1290 ;;; File-Position -- Public
1291 ;;;
1292 ;;; Call the misc method with the :file-position operation.
1293 ;;;
1294 (defun file-position (stream &optional position)
1295 "With one argument returns the current position within the file
1296 File-Stream is open to. If the second argument is supplied, then
1297 this becomes the new file position. The second argument may also
1298 be :start or :end for the start and end of the file, respectively."
1299 (unless (streamp stream)
1300 (error "Argument ~S is not a stream." stream))
1301 (funcall (stream-misc stream) stream :file-position position))
1302
1303 ;;; File-Length -- Public
1304 ;;;
1305 ;;; Like File-Position, only use :file-length.
1306 ;;;
1307 (defun file-length (stream)
1308 "This function returns the length of the file that File-Stream is open to."
1309 (unless (streamp stream)
1310 (error "Argument ~S is not a stream." stream))
1311 (funcall (stream-misc stream) stream :file-length))
1312
1313 ;;; File-Name -- internal interface
1314 ;;;
1315 ;;; Kind of like File-Position, but is an internal hack used by the filesys
1316 ;;; stuff to get and set the file name.
1317 ;;;
1318 (defun file-name (stream &optional new-name)
1319 (when (fd-stream-p stream)
1320 (if new-name
1321 (setf (fd-stream-file stream) new-name)
1322 (fd-stream-file stream))))

  ViewVC Help
Powered by ViewVC 1.1.5