(declare (type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
(if (vectorp buffer)
- (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index)
+ (sb-sys:with-pinned-objects (buffer)
+ (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index))
(sb-sys:sap-ref-8 buffer index)))
(defun (setf bref) (octet buffer index)
(type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
(if (vectorp buffer)
- (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet)
+ (sb-sys:with-pinned-objects (buffer)
+ (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet))
(setf (sb-sys:sap-ref-8 buffer index) octet)))
(defun buffer-copy (src soff dst doff length)
(declare (type simple-stream-buffer src dst)
(type fixnum soff doff length))
- (sb-sys:without-gcing ;; is this necessary??
+ ;; FIXME: Should probably be with-pinned-objects
+ (sb-sys:without-gcing
(sb-kernel:system-area-ub8-copy (buffer-sap src) soff
(buffer-sap dst) doff
length)))
(defun allocate-buffer (size)
- (if (= size sb-impl::bytes-per-buffer)
- (sb-impl::next-available-buffer)
- (make-array size :element-type '(unsigned-byte 8))))
+ (make-array size :element-type '(unsigned-byte 8)))
(defun free-buffer (buffer)
- (when (sb-sys:system-area-pointer-p buffer)
- (push buffer sb-impl::*available-buffers*))
+ (sb-int:aver (typep buffer '(simple-array (unsigned-byte 8) (*))))
t)
-
(defun make-control-table (&rest inits)
(let ((table (make-array 32 :initial-element nil)))
(do* ((char (pop inits) (pop inits))
(tagbody
again
;; Avoid CMUCL gengc write barrier
- (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize)))))
+ (do ((i start (+ i #.(sb-posix:getpagesize))))
((>= i end))
(declare (type fixnum i))
(setf (bref buffer i) 0))
(setf (bref buffer (1- end)) 0)
(multiple-value-bind (bytes errno)
- (sb-unix:unix-read fd (buffer-sap buffer start)
- (the fixnum (- end start)))
+ (sb-sys:with-pinned-objects (buffer)
+ (sb-unix:unix-read fd (buffer-sap buffer start)
+ (the fixnum (- end start))))
(declare (type (or null fixnum) bytes)
(type (integer 0 100) errno))
(when bytes
;; eagain into
;; sb-unix
11)
- (= errno sb-unix:ewouldblock)))
+ (= errno
+ #-win32
+ sb-unix:ewouldblock
+ #+win32
+ sb-unix:eintr)))
(sb-sys:wait-until-fd-usable fd :input nil)
(go again))
(t (return (- -10 errno)))))
(let ((count 0))
(tagbody again
(multiple-value-bind (bytes errno)
- (sb-unix:unix-write fd (buffer-sap buffer) start
- (- end start))
+ (sb-sys:with-pinned-objects (buffer)
+ (sb-unix:unix-write fd (buffer-sap buffer) start
+ (- end start)))
(when bytes
(incf count bytes)
(incf start bytes))
(type sb-int:index start end len))
(tagbody again
(multiple-value-bind (bytes errno)
- (sb-unix:unix-write fd (buffer-sap buffer) start len)
+ (sb-sys:with-pinned-objects (buffer)
+ (sb-unix:unix-write fd (buffer-sap buffer) start len))
(cond ((null bytes)
(if (= errno sb-unix:eintr)
(go again)
(:io (values t t sb-unix:o_rdwr))
(:probe (values t nil sb-unix:o_rdonly)))
(declare (type sb-int:index mask))
- (let ((name (cond ((sb-int:unix-namestring pathname input))
- ((and input (eq if-does-not-exist :create))
- (sb-int:unix-namestring pathname nil))
- ((and (eq direction :io) (not if-does-not-exist-given))
- (sb-int:unix-namestring pathname nil)))))
+ (let* ((phys (sb-int:physicalize-pathname (merge-pathnames pathname)))
+ (true (probe-file phys))
+ (name (cond (true
+ (sb-ext:native-namestring true :as-file t))
+ ((or (not input)
+ (and input (eq if-does-not-exist :create))
+ (and (eq direction :io) (not if-does-not-exist-given)))
+ (sb-ext:native-namestring phys :as-file t)))))
;; Process if-exists argument if we are doing any output.
(cond (output
(unless if-exists-given
(loop
(multiple-value-bind (fd errno)
(if name
+ #+win32
+ (sb-win32:unixlike-open name mask mode)
+ #-win32
(sb-unix:unix-open name mask mode)
(values nil sb-unix:enoent))
- (cond ((sb-int:fixnump fd)
+ (cond ((integerp fd)
(when (eql if-exists :append)
(sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
(return (values fd name original delete-original)))
(type (member :input :output :io :probe) direction)
(type (member :error :new-version :rename :rename-and-delete
:overwrite :append :supersede nil) if-exists)
- (type (member :error :create nil) if-does-not-exist)
- (ignore external-format))
+ (type (member :error :create nil) if-does-not-exist))
(let ((filespec (merge-pathnames pathname)))
(multiple-value-bind (fd namestring original delete-original)
(%fd-open filespec direction if-exists if-exists-given
:pathname pathname
:dual-channel-p nil
:input-buffer-p t
- :auto-close t))
+ :auto-close t
+ :external-format external-format))
(:probe
(let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
:pathname pathname