1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
3 ;;; This code is in the public domain.
5 ;;; The cmucl implementation of simple-streams was done by Paul Foley,
6 ;;; who placed the code in the public domain. Sbcl port by Rudi
9 (in-package "SB-SIMPLE-STREAMS")
15 ;; All known stream flags. Note that the position in the constant
16 ;; list is significant (cf. %flags below).
17 (sb-int:defconstant-eqx +flag-bits+
18 '(:simple ; instance is valid
19 :input :output ; direction
20 :dual :string ; type of stream
22 :dirty ; output buffer needs write
23 :interactive) ; interactive stream
26 (eval-when (:compile-toplevel :load-toplevel :execute)
28 (loop for flag in flags
29 as pos = (position flag +flag-bits+)
30 when (eq flag :gray) do
31 (error "Gray streams not supported.")
33 sum (ash 1 pos) into bits
35 collect flag into unused
37 (warn "Invalid stream instance flag~P: ~{~S~^, ~}"
38 (length unused) unused))
41 ;;; Setup an environment where sm, funcall-stm-handler and
42 ;;; funcall-stm-handler-2 are valid and efficient for a stream of type
43 ;;; class-name or for the stream argument (in which case the
44 ;;; class-name argument is ignored). In nested with-stream-class
45 ;;; forms, the inner with-stream-class form must specify a stream
46 ;;; argument if the outer one specifies one, or the wrong object will
49 ;;; Commented out in favor of standard class machinery that does not
50 ;;; depend on implementation internals.
52 (defmacro with-stream-class ((class-name &optional stream) &body body)
54 (let ((stm (gensym "STREAM"))
56 `(let* ((,stm ,stream)
57 (,slt (sb-pcl::std-instance-slots ,stm)))
58 (declare (type ,class-name ,stm) (ignorable ,slt))
59 (macrolet ((sm (slot-name stream)
60 (declare (ignore stream))
61 (let ((slot-access (gethash slot-name
62 *slot-access-functions*)))
63 (cond ((sb-int:fixnump (cdr slot-access))
64 ;; Get value in nth slot
65 `(the ,(car slot-access)
66 (sb-pcl::clos-slots-ref ,',slt
69 ;; Call memorized function
70 `(the ,(car slot-access) (,(cdr slot-access)
74 `(slot-value ,',stm ',slot-name)))))
75 (add-stream-instance-flags (stream &rest flags)
76 (declare (ignore stream))
77 `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
79 (remove-stream-instance-flags (stream &rest flags)
80 (declare (ignore stream))
81 `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
83 (any-stream-instance-flags (stream &rest flags)
84 (declare (ignore stream))
85 `(not (zerop (logand (sm %flags ,',stm)
88 `(macrolet ((sm (slot-name stream)
89 (let ((slot-access (gethash slot-name
90 *slot-access-functions*)))
91 (cond ((sb-int:fixnump (cdr slot-access))
92 `(the ,(car slot-access)
93 (sb-pcl::clos-slots-ref
94 (sb-pcl::std-instance-slots ,stream)
97 `(the ,(car slot-access) (,(cdr slot-access)
99 (t `(slot-value ,stream ',slot-name))))))
103 (defmacro with-stream-class ((class-name &optional stream) &body body)
105 (let ((stm (gensym "STREAM"))
107 `(let* ((,stm ,stream)
108 (,slt (sb-kernel:%instance-ref ,stm 1)))
109 (declare (type ,class-name ,stm)
110 (type simple-vector ,slt)
112 (macrolet ((sm (slot-name stream)
113 (declare (ignore stream))
115 `(slot-value ,',stm ',slot-name)
117 `(%sm ',slot-name ,',stm))
118 (add-stream-instance-flags (stream &rest flags)
119 (declare (ignore stream))
120 `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
122 (remove-stream-instance-flags (stream &rest flags)
123 (declare (ignore stream))
124 `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
126 (any-stream-instance-flags (stream &rest flags)
127 (declare (ignore stream))
128 `(not (zerop (logand (sm %flags ,',stm)
131 `(macrolet ((sm (slot-name stream)
133 `(slot-value ,stream ',slot-name)
135 `(%sm ',slot-name ,stream)))
138 ;;; Commented out in favor of standard class machinery that does not
139 ;;; depend on implementation internals.
141 (defmacro sm (slot-name stream)
142 (let ((slot-access (gethash slot-name *slot-access-functions*)))
143 (warn "Using ~S macro outside ~S" 'sm 'with-stream-class)
144 (cond ((sb-int:fixnump (cdr slot-access))
145 `(the ,(car slot-access) (sb-pcl::clos-slots-ref
146 (sb-pcl::std-instance-slots ,stream)
147 ,(cdr slot-access))))
149 `(the ,(car slot-access) (,(cdr slot-access) ,stream)))
150 (t `(slot-value ,stream ',slot-name)))))
153 (defmacro sm (slot-name stream)
154 "Access the named slot in Stream."
155 (warn "Using ~S macro outside ~S." 'sm 'with-stream-class)
156 `(slot-value ,stream ',slot-name))
158 (defmacro funcall-stm-handler (slot-name stream &rest args)
161 (funcall (sm ,slot-name ,s) ,s ,@args))))
163 (defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
166 (funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))
168 (defmacro add-stream-instance-flags (stream &rest flags)
169 "Set the given flag bits in STREAM."
170 (let ((s (gensym "STREAM")))
172 (with-stream-class (simple-stream ,s)
173 (setf (sm %flags ,s) (logior (sm %flags ,s) ,(%flags flags)))))))
175 (defmacro remove-stream-instance-flags (stream &rest flags)
176 "Clear the given flag bits in STREAM."
177 (let ((s (gensym "STREAM")))
179 (with-stream-class (simple-stream ,s)
180 (setf (sm %flags ,s) (logandc2 (sm %flags ,s) ,(%flags flags)))))))
182 (defmacro any-stream-instance-flags (stream &rest flags)
183 "Determine whether any one of the FLAGS is set in STREAM."
184 (let ((s (gensym "STREAM")))
186 (with-stream-class (simple-stream ,s)
187 (not (zerop (logand (sm %flags ,s) ,(%flags flags))))))))
189 (defmacro simple-stream-dispatch (stream single dual string)
190 (let ((s (gensym "STREAM")))
192 (with-stream-class (simple-stream ,s)
193 (let ((%flags (sm %flags ,s)))
194 (cond ((zerop (logand %flags ,(%flags '(:string :dual))))
196 ((zerop (logand %flags ,(%flags '(:string))))
201 (declaim (inline buffer-sap bref (setf bref) buffer-copy))
203 (defun buffer-sap (thing &optional offset)
204 (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
205 (optimize (speed 3) (space 2) (debug 0) (safety 0)
206 ;; Suppress the note about having to box up the return:
207 (sb-ext:inhibit-warnings 3)))
208 (let ((sap (if (vectorp thing) (sb-sys:vector-sap thing) thing)))
209 (if offset (sb-sys:sap+ sap offset) sap)))
211 (defun bref (buffer index)
212 (declare (type simple-stream-buffer buffer)
213 (type (integer 0 #.most-positive-fixnum) index))
214 (sb-sys:sap-ref-8 (buffer-sap buffer) index))
216 (defun (setf bref) (octet buffer index)
217 (declare (type (unsigned-byte 8) octet)
218 (type simple-stream-buffer buffer)
219 (type (integer 0 #.most-positive-fixnum) index))
220 (setf (sb-sys:sap-ref-8 (buffer-sap buffer) index) octet))
222 (defun buffer-copy (src soff dst doff length)
223 (declare (type simple-stream-buffer src dst)
224 (type fixnum soff doff length))
225 (sb-sys:without-gcing ;; is this necessary??
226 (sb-kernel:system-area-copy (buffer-sap src) (* soff 8)
227 (buffer-sap dst) (* doff 8)
230 (defun allocate-buffer (size)
231 (if (= size sb-impl::bytes-per-buffer)
232 (sb-impl::next-available-buffer)
233 (make-array size :element-type '(unsigned-byte 8))))
235 (defun free-buffer (buffer)
236 (when (sb-sys:system-area-pointer-p buffer)
237 (push buffer sb-impl::*available-buffers*))
240 (defun %fd-open (pathname direction if-exists if-exists-given
241 if-does-not-exist if-does-not-exist-given)
242 (declare (type pathname pathname)
243 (type (member :input :output :io :probe) direction)
244 (type (member :error :new-version :rename :rename-and-delete
245 :overwrite :append :supersede nil) if-exists)
246 (type (member :error :create nil) if-does-not-exist))
247 (multiple-value-bind (input output mask)
249 (:input (values t nil sb-unix:o_rdonly))
250 (:output (values nil t sb-unix:o_wronly))
251 (:io (values t t sb-unix:o_rdwr))
252 (:probe (values t nil sb-unix:o_rdonly)))
253 (declare (type sb-int:index mask))
254 (let ((name (cond ((sb-int:unix-namestring pathname input))
255 ((and input (eq if-does-not-exist :create))
256 (sb-int:unix-namestring pathname nil)))))
257 ;; Process if-exists argument if we are doing any output.
259 (unless if-exists-given
261 (if (eq (pathname-version pathname) :newest)
266 (setf mask (logior mask sb-unix:o_excl)))
267 ((:rename :rename-and-delete)
268 (setf mask (logior mask sb-unix:o_creat)))
269 ((:new-version :supersede)
270 (setf mask (logior mask sb-unix:o_trunc)))))
272 (setf if-exists nil))) ; :ignore-this-arg
273 (unless if-does-not-exist-given
274 (setf if-does-not-exist
275 (cond ((eq direction :input) :error)
277 (member if-exists '(:overwrite :append)))
279 ((eq direction :probe)
283 (if (eq if-does-not-exist :create)
284 (setf mask (logior mask sb-unix:o_creat)))
286 (let ((original (if (member if-exists
287 '(:rename :rename-and-delete))
288 (sb-impl::pick-backup-name name)
290 (delete-original (eq if-exists :rename-and-delete))
293 ;; We are doing a :rename or :rename-and-delete.
294 ;; Determine if the file already exists, make sure the original
295 ;; file is not a directory and keep the mode
299 (okay err/dev inode orig-mode)
300 (sb-unix:unix-stat name)
301 (declare (ignore inode)
302 (type (or sb-int:index null) orig-mode))
305 (when (and output (= (logand orig-mode #o170000)
307 (error 'sb-int:simple-file-error
310 "Cannot open ~S for output: Is a directory."
311 :format-arguments (list name)))
312 (setf mode (logand orig-mode #o777))
314 ((eql err/dev sb-unix:enoent)
317 (error 'sb-int:simple-file-error
319 :format-control "Cannot find ~S: ~A"
322 (sb-int:strerror err/dev)))))))))
324 (rename-file name original))
326 (setf delete-original nil)
327 ;; In order to use SUPERSEDE instead, we have
328 ;; to make sure unix:o_creat corresponds to
329 ;; if-does-not-exist. unix:o_creat was set
330 ;; before because of if-exists being :rename.
331 (unless (eq if-does-not-exist :create)
332 (setf mask (logior (logandc2 mask sb-unix:o_creat)
334 (setf if-exists :supersede))))
336 ;; Okay, now we can try the actual open.
338 (multiple-value-bind (fd errno)
340 (sb-unix:unix-open name mask mode)
341 (values nil sb-unix:enoent))
342 (cond ((sb-int:fixnump fd)
343 (when (eql if-exists :append)
344 (sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
345 (return (values fd name original delete-original)))
346 ((eql errno sb-unix:enoent)
347 (case if-does-not-exist
349 (cerror "Return NIL."
350 'sb-int:simple-file-error
352 :format-control "Error opening ~S, ~A."
355 (sb-int:strerror errno))))
357 (cerror "Return NIL."
358 'sb-int:simple-file-error
361 "Error creating ~S, path does not exist."
362 :format-arguments (list pathname))))
364 ((eql errno sb-unix:eexist)
365 (unless (eq nil if-exists)
366 (cerror "Return NIL."
367 'sb-int:simple-file-error
369 :format-control "Error opening ~S, ~A."
372 (sb-int:strerror errno))))
374 #+nil ; FIXME: reinstate this; error reporting is nice.
375 ((eql errno sb-unix:eacces)
377 'sb-int:simple-file-error
379 :format-control "Error opening ~S, ~A."
382 (sb-int:strerror errno))))
384 (cerror "Return NIL."
385 'sb-int:simple-file-error
387 :format-control "Error opening ~S, ~A."
390 (sb-int:strerror errno)))
393 (defun open-fd-stream (pathname &key (direction :input)
394 (element-type 'base-char)
395 (if-exists nil if-exists-given)
396 (if-does-not-exist nil if-does-not-exist-given)
397 (external-format :default))
398 (declare (type (or pathname string stream) pathname)
399 (type (member :input :output :io :probe) direction)
400 (type (member :error :new-version :rename :rename-and-delete
401 :overwrite :append :supersede nil) if-exists)
402 (type (member :error :create nil) if-does-not-exist)
403 (ignore external-format))
404 (let ((filespec (merge-pathnames pathname)))
405 (multiple-value-bind (fd namestring original delete-original)
406 (%fd-open filespec direction if-exists if-exists-given
407 if-does-not-exist if-does-not-exist-given)
410 ((:input :output :io)
411 (sb-sys:make-fd-stream fd
412 :input (member direction '(:input :io))
413 :output (member direction '(:output :io))
414 :element-type element-type
417 :delete-original delete-original
422 (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
424 :element-type element-type)))
429 ;; Experimental "filespec" stuff
431 ;; sat: Hooks to parse URIs etc apparently go here
433 (defstruct (filespec-parser
434 (:constructor make-filespec-parser (name priority function)))
439 (defvar *filespec-parsers* ())
441 (defun add-filespec (name priority function)
442 (let ((filespec (make-filespec-parser name priority function)))
443 (setf *filespec-parsers*
444 (stable-sort (cons filespec (delete name *filespec-parsers*
445 :key #'filespec-parser-name))
447 :key #'filespec-parser-priority)))
450 (defmacro define-filespec (name lambda-list &body body)
451 (let ((truename (if (consp name) (first name) name))
452 (priority (if (consp name) (second name) 0)))
453 `(add-filespec ',truename ,priority (lambda ,lambda-list
457 (defun parse-filespec (string &optional (errorp t))
458 (dolist (i *filespec-parsers* (when errorp
459 (error "~S not recognised." string)))
460 (let ((result (ignore-errors
461 (funcall (filespec-parser-function i) string))))
462 (when result (return result)))))
464 (define-filespec pathname (string)