Suppress warnings about possible slot name conflicts with slots from SB-PCL.
[sbcl.git] / contrib / sb-simple-streams / internal.lisp
1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
2
3 ;;; **********************************************************************
4 ;;; This code was written by Paul Foley and has been placed in the public
5 ;;; domain.
6 ;;;
7
8 ;;; Sbcl port by Rudi Schlatte.
9
10 (in-package "SB-SIMPLE-STREAMS")
11
12 ;;;
13 ;;; **********************************************************************
14 ;;;
15 ;;; Various functions needed by simple-streams
16 (declaim (inline buffer-sap bref (setf bref) buffer-copy
17                  allocate-buffer free-buffer))
18
19 (defun buffer-sap (thing &optional offset)
20   (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
21            (optimize (speed 3) (space 2) (debug 0) (safety 0)
22                      ;; Suppress the note about having to box up the return:
23                      (sb-ext:inhibit-warnings 3)))
24   (let ((sap (if (vectorp thing) (sb-sys:vector-sap thing) thing)))
25     (if offset (sb-sys:sap+ sap offset) sap)))
26
27 (defun bref (buffer index)
28   (declare (type simple-stream-buffer buffer)
29            (type (integer 0 #.most-positive-fixnum) index))
30   (if (vectorp buffer)
31       (sb-sys:with-pinned-objects (buffer)
32         (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index))
33       (sb-sys:sap-ref-8 buffer index)))
34
35 (defun (setf bref) (octet buffer index)
36   (declare (type (unsigned-byte 8) octet)
37            (type simple-stream-buffer buffer)
38            (type (integer 0 #.most-positive-fixnum) index))
39   (if (vectorp buffer)
40       (sb-sys:with-pinned-objects (buffer)
41         (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet))
42       (setf (sb-sys:sap-ref-8 buffer index) octet)))
43
44 (defun buffer-copy (src soff dst doff length)
45   (declare (type simple-stream-buffer src dst)
46            (type fixnum soff doff length))
47   ;; FIXME: Should probably be with-pinned-objects
48   (sb-sys:without-gcing
49    (sb-kernel:system-area-ub8-copy (buffer-sap src) soff
50                                    (buffer-sap dst) doff
51                                    length)))
52
53 (defun allocate-buffer (size)
54   (make-array size :element-type '(unsigned-byte 8)))
55
56 (defun free-buffer (buffer)
57   (sb-int:aver (typep buffer '(simple-array (unsigned-byte 8) (*))))
58   t)
59
60 (defun make-control-table (&rest inits)
61   (let ((table (make-array 32 :initial-element nil)))
62     (do* ((char (pop inits) (pop inits))
63           (func (pop inits) (pop inits)))
64          ((null char))
65       (when (< (char-code char) 32)
66         (setf (aref table (char-code char)) func)))
67     table))
68
69 (defun std-newline-out-handler (stream character)
70   (declare (ignore character))
71   (with-stream-class (simple-stream stream)
72     (setf (sm charpos stream) -1)
73     nil))
74
75 (defun std-tab-out-handler (stream character)
76   (declare (ignore character))
77   (with-stream-class (simple-stream stream)
78     (let ((col (sm charpos stream)))
79       (when col
80         (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
81     nil))
82
83 (defun std-dc-newline-in-handler (stream character)
84   (with-stream-class (dual-channel-simple-stream stream)
85     ;; FIXME: Currently, -1 is wrong, since callers of CHARPOS expect
86     ;; a result in (or null (and fixnum unsigned-byte)), so they must
87     ;; never see this temporary value.  Note that in
88     ;; STD-NEWLINE-OUT-HANDLER it is correct to use -1, since CHARPOS
89     ;; is incremented to zero before WRITE-CHAR returns.  Perhaps the
90     ;; same should happen for input?
91     (setf (sm charpos stream) 0) ; was -1
92     character))
93
94 (defvar *std-control-out-table*
95   (make-control-table #\Newline #'std-newline-out-handler
96                       #\Tab     #'std-tab-out-handler))
97
98 (defvar *default-external-format* :iso8859-1)
99
100 (defvar *external-formats* (make-hash-table))
101 (defvar *external-format-aliases* (make-hash-table))
102
103 (defstruct (external-format
104              (:conc-name ef-)
105              (:print-function %print-external-format)
106              (:constructor make-external-format (name octets-to-char
107                                                       char-to-octets)))
108   (name (sb-int:missing-arg) :type keyword :read-only t)
109   (octets-to-char (sb-int:missing-arg) :type function :read-only t)
110   (char-to-octets (sb-int:missing-arg) :type function :read-only t))
111
112 (defun %print-external-format (ef stream depth)
113   (declare (ignore depth))
114   (print-unreadable-object (ef stream :type t :identity t)
115     (princ (ef-name ef) stream)))
116
117 (defmacro define-external-format (name octets-to-char char-to-octets)
118   `(macrolet ((octets-to-char ((state input unput) &body body)
119                 `(lambda (,state ,input ,unput)
120                    (declare (type (function () (unsigned-byte 8)) ,input)
121                             (type (function (sb-int:index) t) ,unput)
122                             (ignorable ,state ,input ,unput)
123                             (values character sb-int:index t))
124                    ,@body))
125               (char-to-octets ((char state output) &body body)
126                 `(lambda (,char ,state ,output)
127                    (declare (type character ,char)
128                             (type (function ((unsigned-byte 8)) t) ,output)
129                             (ignorable state ,output)
130                             (values t))
131                    ,@body)))
132      (setf (gethash ,name *external-formats*)
133            (make-external-format ,name ,octets-to-char ,char-to-octets))))
134
135 ;;; TODO: make this work
136 (defun load-external-format-aliases ()
137   (let ((*package* (find-package "KEYWORD")))
138     (with-open-file (stm "ef:aliases" :if-does-not-exist nil)
139       (when stm
140         (do ((alias (read stm nil stm) (read stm nil stm))
141              (value (read stm nil stm) (read stm nil stm)))
142             ((or (eq alias stm) (eq value stm))
143              (unless (eq alias stm)
144                (warn "External-format aliases file ends early.")))
145           (if (and (keywordp alias) (keywordp value))
146               (setf (gethash alias *external-format-aliases*) value)
147               (warn "Bad entry in external-format aliases file: ~S => ~S."
148                     alias value)))))))
149
150 (defun find-external-format (name &optional (error-p t))
151   (when (external-format-p name)
152     (return-from find-external-format name))
153
154   (when (eq name :default)
155     (setq name *default-external-format*))
156
157   ;; TODO: make this work
158   #+nil
159   (unless (ext:search-list-defined-p "ef:")
160     (setf (ext:search-list "ef:") '("library:ef/")))
161
162   (when (zerop (hash-table-count *external-format-aliases*))
163     (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
164     (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
165     (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)
166     (load-external-format-aliases))
167
168   (do ((tmp (gethash name *external-format-aliases*)
169             (gethash tmp *external-format-aliases*))
170        (cnt 0 (1+ cnt)))
171       ((or (null tmp) (= cnt 50))
172        (unless (null tmp)
173          (error "External-format aliasing depth exceeded.")))
174     (setq name tmp))
175
176   (or (gethash name *external-formats*)
177       (and (let ((*package* (find-package "SB-SIMPLE-STREAMS")))
178              (load (format nil "ef:~(~A~)" name) :if-does-not-exist nil))
179            (gethash name *external-formats*))
180       (if error-p (error "External format ~S not found." name) nil)))
181
182 (define-condition void-external-format (error)
183   ()
184   (:report
185     (lambda (condition stream)
186       (declare (ignore condition))
187       (format stream "Attempting I/O through void external-format."))))
188
189 (define-external-format :void
190     (octets-to-char (state input unput)
191       (declare (ignore state input unput))
192       (error 'void-external-format))
193   (char-to-octets (char state output)
194     (declare (ignore char state output))
195     (error 'void-external-format)))
196
197 (define-external-format :iso8859-1
198     (octets-to-char (state input unput)
199       (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
200       (values (code-char (funcall input)) 1 state))
201   (char-to-octets (char state output)
202     (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
203     (let ((code (char-code char)))
204       #-(or)
205       (funcall output code)
206       #+(or)
207       (if (< code 256)
208           (funcall output code)
209           (funcall output (char-code #\?))))
210     state))
211
212 (defmacro octets-to-char (external-format state count input unput)
213   (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym)))
214     `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3)
215          (funcall (ef-octets-to-char ,external-format) ,state ,input ,unput)
216        (setf ,state ,tmp3 ,count ,tmp2)
217        ,tmp1)))
218
219 (defmacro char-to-octets (external-format char state output)
220   `(progn
221      (setf ,state (funcall (ef-char-to-octets ,external-format)
222                            ,char ,state ,output))
223      nil))
224
225 (defun string-to-octets (string &key (start 0) end (external-format :default))
226   (declare (type string string)
227            (type sb-int:index start)
228            (type (or null sb-int:index) end))
229   (let ((ef (find-external-format external-format))
230         (buffer (make-array (length string) :element-type '(unsigned-byte 8)))
231         (ptr 0)
232         (state nil))
233     (flet ((out (b)
234              (setf (aref buffer ptr) b)
235              (when (= (incf ptr) (length buffer))
236                (setq buffer (adjust-array buffer (* 2 ptr))))))
237       (dotimes (i (- (or end (length string)) start))
238         (declare (type sb-int:index i))
239         (char-to-octets ef (char string (+ start i)) state #'out))
240       (sb-kernel:shrink-vector buffer ptr))))
241
242 (defun octets-to-string (octets &key (start 0) end (external-format :default))
243   (declare (type vector octets)
244            (type sb-int:index start)
245            (type (or null sb-int:index) end))
246   (let ((ef (find-external-format external-format))
247         (end (1- (or end (length octets))))
248         (string (make-string (length octets)))
249         (ptr (1- start))
250         (pos -1)
251         (count 0)
252         (state nil))
253     (flet ((input ()
254              (aref octets (incf ptr)))
255            (unput (n)
256              (decf ptr n)))
257       (loop until (>= ptr end)
258             do (setf (schar string (incf pos))
259                  (octets-to-char ef state count #'input #'unput))))
260     (sb-kernel:shrink-vector string (1+ pos))))
261
262 (defun vector-elt-width (vector)
263   ;; Return octet-width of vector elements
264   (etypecase vector
265     ;; (simple-array fixnum (*)) not supported
266     ;; (simple-array base-char (*)) treated specially; don't call this
267     ((simple-array bit (*)) 1)
268     ((simple-array (unsigned-byte 2) (*)) 1)
269     ((simple-array (unsigned-byte 4) (*)) 1)
270     ((simple-array (signed-byte 8) (*)) 1)
271     ((simple-array (unsigned-byte 8) (*)) 1)
272     ((simple-array (signed-byte 16) (*)) 2)
273     ((simple-array (unsigned-byte 16) (*)) 2)
274     ((simple-array (signed-byte 32) (*)) 4)
275     ((simple-array (unsigned-byte 32) (*)) 4)
276     ((simple-array single-float (*)) 4)
277     ((simple-array double-float (*)) 8)
278     ((simple-array (complex single-float) (*)) 8)
279     ((simple-array (complex double-float) (*)) 16)))
280
281 #-(or big-endian little-endian)
282 (eval-when (:compile-toplevel)
283   (push sb-c::*backend-byte-order* *features*))
284
285 (defun endian-swap-value (vector endian-swap)
286   #+big-endian (declare (ignore vector))
287   (case endian-swap
288     (:network-order #+big-endian 0
289                     #+little-endian (1- (vector-elt-width vector)))
290     (:byte-8 0)
291     (:byte-16 1)
292     (:byte-32 3)
293     (:byte-64 7)
294     (:byte-128 15)
295     (otherwise endian-swap)))
296
297 #+(or)
298 (defun %read-vector (vector stream start end endian-swap blocking)
299   (declare (type (kernel:simple-unboxed-array (*)) vector)
300            (type stream stream))
301   ;; move code from read-vector
302   )
303
304 #+(or)
305 (defun %write-vector (... blocking)
306   ;; implement me
307   )
308
309 (defun read-octets (stream buffer start end blocking)
310   (declare (type simple-stream stream)
311            (type (or null simple-stream-buffer) buffer)
312            (type fixnum start)
313            (type (or null fixnum) end)
314            (type blocking blocking)
315            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
316   (with-stream-class (simple-stream stream)
317     (let ((fd (sm input-handle stream))
318           (end (or end (sm buf-len stream)))
319           (buffer (or buffer (sm buffer stream))))
320       (declare (fixnum end))
321       (typecase fd
322         (fixnum
323          (let ((flag (sb-sys:wait-until-fd-usable fd :input
324                                                   (if blocking nil 0))))
325            (cond
326              ((and (not blocking) (= start end)) (if flag -3 0))
327              ((and (not blocking) (not flag)) 0)
328              (t (block nil
329                   (let ((count 0))
330                     (declare (type fixnum count))
331                     (tagbody
332                      again
333                        ;; Avoid CMUCL gengc write barrier
334                        (do ((i start (+ i #.(sb-posix:getpagesize))))
335                            ((>= i end))
336                          (declare (type fixnum i))
337                          (setf (bref buffer i) 0))
338                        (setf (bref buffer (1- end)) 0)
339                        (multiple-value-bind (bytes errno)
340                            (sb-sys:with-pinned-objects (buffer)
341                              (sb-unix:unix-read fd (buffer-sap buffer start)
342                                                 (the fixnum (- end start))))
343                          (declare (type (or null fixnum) bytes)
344                                   (type (integer 0 100) errno))
345                          (when bytes
346                            (incf count bytes)
347                            (incf start bytes))
348                          (cond ((null bytes)
349                                 (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
350                                 (cond ((= errno sb-unix:eintr) (go again))
351                                       ((and blocking
352                                             (or (= errno ;;sb-unix:eagain
353                                                    ;; TODO: move
354                                                    ;; eagain into
355                                                    ;; sb-unix
356                                                    11)
357                                                 (= errno
358                                                    #-win32
359                                                    sb-unix:ewouldblock
360                                                    #+win32
361                                                    sb-unix:eintr)))
362                                        (sb-sys:wait-until-fd-usable fd :input nil)
363                                        (go again))
364                                       (t (return (- -10 errno)))))
365                                ((zerop count) (return -1))
366                                (t (return count)))))))))))
367         (t (%read-vector buffer fd start end :byte-8
368                          (if blocking :bnb nil)))))))
369
370 (defun write-octets (stream buffer start end blocking)
371   (declare (type simple-stream stream)
372            (type simple-stream-buffer buffer)
373            (type fixnum start)
374            (type (or null fixnum) end))
375   (with-stream-class (simple-stream stream)
376     (when (sm handler stream)
377       (do ()
378           ((null (sm pending stream)))
379         (sb-sys:serve-all-events)))
380
381     (let ((fd (sm output-handle stream))
382           (end (or end (length buffer))))
383       (typecase fd
384         (fixnum
385          (let ((flag (sb-sys:wait-until-fd-usable fd :output
386                                                   (if blocking nil 0))))
387            (cond
388              ((and (not blocking) (= start end)) (if flag -3 0))
389              ((and (not blocking) (not flag)) 0)
390              (t
391               (block nil
392                 (let ((count 0))
393                   (tagbody again
394                      (multiple-value-bind (bytes errno)
395                          (sb-sys:with-pinned-objects (buffer)
396                            (sb-unix:unix-write fd (buffer-sap buffer) start
397                                                (- end start)))
398                        (when bytes
399                          (incf count bytes)
400                          (incf start bytes))
401                        (cond ((null bytes)
402                               (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno)
403                               (cond ((= errno sb-unix:eintr) (go again))
404                                     ;; don't block for subsequent chars
405                                     (t (return (- -10 errno)))))
406                              (t (return count)))))))))))
407         (t (error "implement me"))))))
408
409 (defun do-some-output (stream)
410   ;; Do some pending output; return T if completed, NIL if more to do
411   (with-stream-class (simple-stream stream)
412     (let ((fd (sm output-handle stream)))
413       (loop
414         (let ((list (pop (sm pending stream))))
415           (unless list
416             (sb-sys:remove-fd-handler (sm handler stream))
417             (setf (sm handler stream) nil)
418             (return t))
419           (let* ((buffer (first list))
420                  (start (second list))
421                  (end (third list))
422                  (len (- end start)))
423             (declare (type simple-stream-buffer buffer)
424                      (type sb-int:index start end len))
425             (tagbody again
426                (multiple-value-bind (bytes errno)
427                    (sb-sys:with-pinned-objects (buffer)
428                      (sb-unix:unix-write fd (buffer-sap buffer) start len))
429                  (cond ((null bytes)
430                         (if (= errno sb-unix:eintr)
431                             (go again)
432                             (progn (push list (sm pending stream))
433                                    (return nil))))
434                        ((< bytes len)
435                         (setf (second list) (+ start bytes))
436                         (push list (sm pending stream))
437                         (return nil))
438                        ((= bytes len)
439                         (free-buffer buffer)))))))))))
440
441 (defun queue-write (stream buffer start end)
442   ;; Queue a write; return T if buffer needs changing, NIL otherwise
443   (declare (type simple-stream stream)
444            (type simple-stream-buffer buffer)
445            (type sb-int:index start end))
446   (with-stream-class (simple-stream stream)
447     (when (sm handler stream)
448       (unless (do-some-output stream)
449         (let ((last (last (sm pending stream))))
450           (setf (cdr last) (list (list buffer start end)))
451           (return-from queue-write t))))
452     (let ((bytes (write-octets stream buffer start end nil)))
453       (unless (or (= bytes (- end start)) ; completed
454                   (= bytes -3)) ; empty buffer; shouldn't happen
455         (setf (sm pending stream) (list (list buffer start end)))
456         (setf (sm handler stream)
457               (sb-sys:add-fd-handler (sm output-handle stream) :output
458                                      (lambda (fd)
459                                        (declare (ignore fd))
460                                        (do-some-output stream))))
461         t))))
462
463
464
465
466 (defun %fd-open (pathname direction if-exists if-exists-given
467                           if-does-not-exist if-does-not-exist-given)
468   (declare (type pathname pathname)
469            (type (member :input :output :io :probe) direction)
470            (type (member :error :new-version :rename :rename-and-delete
471                          :overwrite :append :supersede nil) if-exists)
472            (type (member :error :create nil) if-does-not-exist))
473   (multiple-value-bind (input output mask)
474       (ecase direction
475         (:input (values t nil sb-unix:o_rdonly))
476         (:output (values nil t sb-unix:o_wronly))
477         (:io (values t t sb-unix:o_rdwr))
478         (:probe (values t nil sb-unix:o_rdonly)))
479     (declare (type sb-int:index mask))
480     (let* ((phys (sb-int:physicalize-pathname (merge-pathnames pathname)))
481            (true (probe-file phys))
482            (name (cond (true
483                         (sb-ext:native-namestring true :as-file t))
484                        ((or (not input)
485                             (and input (eq if-does-not-exist :create))
486                             (and (eq direction :io) (not if-does-not-exist-given)))
487                         (sb-ext:native-namestring phys :as-file t)))))
488       ;; Process if-exists argument if we are doing any output.
489       (cond (output
490              (unless if-exists-given
491                (setf if-exists
492                      (if (eq (pathname-version pathname) :newest)
493                          :new-version
494                          :error)))
495              (case if-exists
496                ((:error nil :new-version)
497                 (setf mask (logior mask sb-unix:o_excl)))
498                ((:rename :rename-and-delete)
499                 (setf mask (logior mask sb-unix:o_creat)))
500                ((:supersede)
501                 (setf mask (logior mask sb-unix:o_trunc)))))
502             (t
503              (setf if-exists nil)))     ; :ignore-this-arg
504       (unless if-does-not-exist-given
505         (setf if-does-not-exist
506               (cond ((eq direction :input) :error)
507                     ((and output
508                           (member if-exists '(:overwrite :append)))
509                      :error)
510                     ((eq direction :probe)
511                      nil)
512                     (t
513                      :create))))
514       (if (eq if-does-not-exist :create)
515           (setf mask (logior mask sb-unix:o_creat)))
516
517       (let ((original (if (member if-exists
518                                   '(:rename :rename-and-delete))
519                           (sb-impl::pick-backup-name name)
520                           nil))
521             (delete-original (eq if-exists :rename-and-delete))
522             (mode #o666))
523         (when original
524           ;; We are doing a :rename or :rename-and-delete.
525           ;; Determine if the file already exists, make sure the original
526           ;; file is not a directory and keep the mode
527           (let ((exists
528                  (and name
529                       (multiple-value-bind
530                             (okay err/dev inode orig-mode)
531                           (sb-unix:unix-stat name)
532                         (declare (ignore inode)
533                                  (type (or sb-int:index null) orig-mode))
534                         (cond
535                           (okay
536                            (when (and output (= (logand orig-mode #o170000)
537                                                 #o40000))
538                              (error 'sb-int:simple-file-error
539                                  :pathname pathname
540                                  :format-control
541                                  "Cannot open ~S for output: Is a directory."
542                                  :format-arguments (list name)))
543                            (setf mode (logand orig-mode #o777))
544                            t)
545                           ((eql err/dev sb-unix:enoent)
546                            nil)
547                           (t
548                            (error 'sb-int:simple-file-error
549                                   :pathname pathname
550                                   :format-control "Cannot find ~S: ~A"
551                                   :format-arguments
552                                     (list name
553                                       (sb-int:strerror err/dev)))))))))
554             (unless (and exists
555                          (rename-file name original))
556               (setf original nil)
557               (setf delete-original nil)
558               ;; In order to use SUPERSEDE instead, we have
559               ;; to make sure unix:o_creat corresponds to
560               ;; if-does-not-exist.  unix:o_creat was set
561               ;; before because of if-exists being :rename.
562               (unless (eq if-does-not-exist :create)
563                 (setf mask (logior (logandc2 mask sb-unix:o_creat)
564                                    sb-unix:o_trunc)))
565               (setf if-exists :supersede))))
566
567         ;; Okay, now we can try the actual open.
568         (loop
569           (multiple-value-bind (fd errno)
570               (if name
571                   #+win32
572                   (sb-win32:unixlike-open name mask mode)
573                   #-win32
574                   (sb-unix:unix-open name mask mode)
575                   (values nil sb-unix:enoent))
576             (cond ((integerp fd)
577                    (when (eql if-exists :append)
578                      (sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
579                    (return (values fd name original delete-original)))
580                   ((eql errno sb-unix:enoent)
581                    (case if-does-not-exist
582                      (:error
583                        (cerror "Return NIL."
584                                'sb-int:simple-file-error
585                                :pathname pathname
586                                :format-control "Error opening ~S, ~A."
587                                :format-arguments
588                                    (list pathname
589                                          (sb-int:strerror errno))))
590                      (:create
591                       (cerror "Return NIL."
592                                'sb-int:simple-file-error
593                                :pathname pathname
594                                :format-control
595                                    "Error creating ~S, path does not exist."
596                                :format-arguments (list pathname))))
597                    (return nil))
598                   ((eql errno sb-unix:eexist)
599                    (unless (eq nil if-exists)
600                      (cerror "Return NIL."
601                              'sb-int:simple-file-error
602                              :pathname pathname
603                              :format-control "Error opening ~S, ~A."
604                              :format-arguments
605                                  (list pathname
606                                        (sb-int:strerror errno))))
607                    (return nil))
608                   #+nil ; FIXME: reinstate this; error reporting is nice.
609                   ((eql errno sb-unix:eacces)
610                    (cerror "Try again."
611                            'sb-int:simple-file-error
612                            :pathname pathname
613                            :format-control "Error opening ~S, ~A."
614                            :format-arguments
615                                (list pathname
616                                      (sb-int:strerror errno))))
617                   (t
618                    (cerror "Return NIL."
619                            'sb-int:simple-file-error
620                            :pathname pathname
621                            :format-control "Error opening ~S, ~A."
622                            :format-arguments
623                                (list pathname
624                                      (sb-int:strerror errno)))
625                    (return nil)))))))))
626
627 (defun open-fd-stream (pathname &key (direction :input)
628                                 (element-type 'base-char)
629                                 (if-exists nil if-exists-given)
630                                 (if-does-not-exist nil if-does-not-exist-given)
631                                 (external-format :default))
632   (declare (type (or pathname string stream) pathname)
633            (type (member :input :output :io :probe) direction)
634            (type (member :error :new-version :rename :rename-and-delete
635                          :overwrite :append :supersede nil) if-exists)
636            (type (member :error :create nil) if-does-not-exist))
637   (let ((filespec (merge-pathnames pathname)))
638     (multiple-value-bind (fd namestring original delete-original)
639         (%fd-open filespec direction if-exists if-exists-given
640                   if-does-not-exist if-does-not-exist-given)
641       (when fd
642         (case direction
643           ((:input :output :io)
644            (sb-sys:make-fd-stream fd
645                                   :input (member direction '(:input :io))
646                                   :output (member direction '(:output :io))
647                                   :element-type element-type
648                                   :file namestring
649                                   :original original
650                                   :delete-original delete-original
651                                   :pathname pathname
652                                   :dual-channel-p nil
653                                   :input-buffer-p t
654                                   :auto-close t
655                                   :external-format external-format))
656           (:probe
657            (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
658                                                    :pathname pathname
659                                                    :element-type element-type)))
660              (close stream)
661              stream)))))))
662
663
664 ;; Experimental "filespec" stuff
665
666 ;; sat: Hooks to parse URIs etc apparently go here
667
668 (defstruct (filespec-parser
669              (:constructor make-filespec-parser (name priority function)))
670   name
671   priority
672   function)
673
674 (defvar *filespec-parsers* ())
675
676 (defun add-filespec (name priority function)
677   (let ((filespec (make-filespec-parser name priority function)))
678     (setf *filespec-parsers*
679           (stable-sort (cons filespec (delete name *filespec-parsers*
680                                               :key #'filespec-parser-name))
681                        #'>
682                        :key #'filespec-parser-priority)))
683   t)
684
685 (defmacro define-filespec (name lambda-list &body body)
686   (let ((truename (if (consp name) (first name) name))
687         (priority (if (consp name) (second name) 0)))
688     `(add-filespec ',truename ,priority (lambda ,lambda-list
689                                           (block ,truename
690                                             ,@body)))))
691
692 (defun parse-filespec (string &optional (errorp t))
693   (dolist (i *filespec-parsers* (when errorp
694                                   (error "~S not recognised." string)))
695     (let ((result (ignore-errors
696                     (funcall (filespec-parser-function i) string))))
697       (when result (return result)))))
698
699 (define-filespec pathname (string)
700   (pathname string))