- (setf (sm charpos stream) -1) ;; set to 0 "if reading" ???
+ ;; FIXME: Currently, -1 is wrong, since callers of CHARPOS expect
+ ;; a result in (or null (and fixnum unsigned-byte)), so they must
+ ;; never see this temporary value. Note that in
+ ;; STD-NEWLINE-OUT-HANDLER it is correct to use -1, since CHARPOS
+ ;; is incremented to zero before WRITE-CHAR returns. Perhaps the
+ ;; same should happen for input?
+ (setf (sm charpos stream) 0) ; was -1
- `(lambda (,state ,input ,unput)
- (declare (type (function () (unsigned-byte 8)) ,input)
- (type (function (sb-int:index) t) ,unput)
- (ignorable ,state ,input ,unput)
- (values character sb-int:index t))
- ,@body))
- (char-to-octets ((char state output) &body body)
- `(lambda (,char ,state ,output)
- (declare (type character ,char)
- (type (function ((unsigned-byte 8)) t) ,output)
- (ignorable state ,output)
- (values t))
- ,@body)))
+ `(lambda (,state ,input ,unput)
+ (declare (type (function () (unsigned-byte 8)) ,input)
+ (type (function (sb-int:index) t) ,unput)
+ (ignorable ,state ,input ,unput)
+ (values character sb-int:index t))
+ ,@body))
+ (char-to-octets ((char state output) &body body)
+ `(lambda (,char ,state ,output)
+ (declare (type character ,char)
+ (type (function ((unsigned-byte 8)) t) ,output)
+ (ignorable state ,output)
+ (values t))
+ ,@body)))
- (do ((alias (read stm nil stm) (read stm nil stm))
- (value (read stm nil stm) (read stm nil stm)))
- ((or (eq alias stm) (eq value stm))
- (unless (eq alias stm)
- (warn "External-format aliases file ends early.")))
- (if (and (keywordp alias) (keywordp value))
- (setf (gethash alias *external-format-aliases*) value)
- (warn "Bad entry in external-format aliases file: ~S => ~S."
- alias value)))))))
+ (do ((alias (read stm nil stm) (read stm nil stm))
+ (value (read stm nil stm) (read stm nil stm)))
+ ((or (eq alias stm) (eq value stm))
+ (unless (eq alias stm)
+ (warn "External-format aliases file ends early.")))
+ (if (and (keywordp alias) (keywordp value))
+ (setf (gethash alias *external-format-aliases*) value)
+ (warn "Bad entry in external-format aliases file: ~S => ~S."
+ alias value)))))))
(setf ,state ,tmp3 ,count ,tmp2)
,tmp1)))
(defmacro char-to-octets (external-format char state output)
`(progn
(setf ,state (funcall (ef-char-to-octets ,external-format)
(setf ,state ,tmp3 ,count ,tmp2)
,tmp1)))
(defmacro char-to-octets (external-format char state output)
`(progn
(setf ,state (funcall (ef-char-to-octets ,external-format)
- (cond
- ((and (not blocking) (= start end)) (if flag -3 0))
- ((and (not blocking) (not flag)) 0)
- (t (block nil
- (let ((count 0))
- (declare (type fixnum count))
- (tagbody
- again
- ;; Avoid CMUCL gengc write barrier
- (do ((i start (+ i (the fixnum #.(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)
+ (cond
+ ((and (not blocking) (= start end)) (if flag -3 0))
+ ((and (not blocking) (not flag)) 0)
+ (t (block nil
+ (let ((count 0))
+ (declare (type fixnum count))
+ (tagbody
+ again
+ ;; Avoid CMUCL gengc write barrier
+ (do ((i start (+ i (the fixnum #.(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)
- (declare (type (or null fixnum) bytes)
- (type (integer 0 100) errno))
- (when bytes
- (incf count bytes)
- (incf start bytes))
- (cond ((null bytes)
- (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
- (cond ((= errno sb-unix:eintr) (go again))
- ((and blocking
- (or (= errno ;;sb-unix:eagain
+ (declare (type (or null fixnum) bytes)
+ (type (integer 0 100) errno))
+ (when bytes
+ (incf count bytes)
+ (incf start bytes))
+ (cond ((null bytes)
+ (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
+ (cond ((= errno sb-unix:eintr) (go again))
+ ((and blocking
+ (or (= errno ;;sb-unix:eagain
- (= errno sb-unix:ewouldblock)))
- (sb-sys:wait-until-fd-usable fd :input nil)
- (go again))
- (t (return (- -10 errno)))))
- ((zerop count) (return -1))
- (t (return count)))))))))))
- (t (%read-vector buffer fd start end :byte-8
- (if blocking :bnb nil)))))))
+ (= errno sb-unix:ewouldblock)))
+ (sb-sys:wait-until-fd-usable fd :input nil)
+ (go again))
+ (t (return (- -10 errno)))))
+ ((zerop count) (return -1))
+ (t (return count)))))))))))
+ (t (%read-vector buffer fd start end :byte-8
+ (if blocking :bnb nil)))))))
- (cond
- ((and (not blocking) (= start end)) (if flag -3 0))
- ((and (not blocking) (not flag)) 0)
- (t
- (block nil
- (let ((count 0))
- (tagbody again
- (multiple-value-bind (bytes errno)
- (sb-unix:unix-write fd (buffer-sap buffer) start
- (- end start))
- (when bytes
- (incf count bytes)
- (incf start bytes))
- (cond ((null bytes)
- (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno)
- (cond ((= errno sb-unix:eintr) (go again))
- ;; don't block for subsequent chars
- (t (return (- -10 errno)))))
- (t (return count)))))))))))
- (t (error "implement me"))))))
+ (cond
+ ((and (not blocking) (= start end)) (if flag -3 0))
+ ((and (not blocking) (not flag)) 0)
+ (t
+ (block nil
+ (let ((count 0))
+ (tagbody again
+ (multiple-value-bind (bytes errno)
+ (sb-unix:unix-write fd (buffer-sap buffer) start
+ (- end start))
+ (when bytes
+ (incf count bytes)
+ (incf start bytes))
+ (cond ((null bytes)
+ (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno)
+ (cond ((= errno sb-unix:eintr) (go again))
+ ;; don't block for subsequent chars
+ (t (return (- -10 errno)))))
+ (t (return count)))))))))))
+ (t (error "implement me"))))))
- (let ((list (pop (sm pending stream))))
- (unless list
- (sb-sys:remove-fd-handler (sm handler stream))
- (setf (sm handler stream) nil)
- (return t))
- (let* ((buffer (first list))
- (start (second list))
- (end (third list))
- (len (- end start)))
- (declare (type simple-stream-buffer buffer)
- (type sb-int:index start end len))
- (tagbody again
- (multiple-value-bind (bytes errno)
- (sb-unix:unix-write fd (buffer-sap buffer) start len)
- (cond ((null bytes)
- (if (= errno sb-unix:eintr)
- (go again)
- (progn (push list (sm pending stream))
- (return nil))))
- ((< bytes len)
- (setf (second list) (+ start bytes))
- (push list (sm pending stream))
- (return nil))
- ((= bytes len)
- (free-buffer buffer)))))))))))
+ (let ((list (pop (sm pending stream))))
+ (unless list
+ (sb-sys:remove-fd-handler (sm handler stream))
+ (setf (sm handler stream) nil)
+ (return t))
+ (let* ((buffer (first list))
+ (start (second list))
+ (end (third list))
+ (len (- end start)))
+ (declare (type simple-stream-buffer buffer)
+ (type sb-int:index start end len))
+ (tagbody again
+ (multiple-value-bind (bytes errno)
+ (sb-unix:unix-write fd (buffer-sap buffer) start len)
+ (cond ((null bytes)
+ (if (= errno sb-unix:eintr)
+ (go again)
+ (progn (push list (sm pending stream))
+ (return nil))))
+ ((< bytes len)
+ (setf (second list) (+ start bytes))
+ (push list (sm pending stream))
+ (return nil))
+ ((= bytes len)
+ (free-buffer buffer)))))))))))
- (unless if-exists-given
- (setf if-exists
- (if (eq (pathname-version pathname) :newest)
- :new-version
- :error)))
- (case if-exists
- ((:error nil)
- (setf mask (logior mask sb-unix:o_excl)))
- ((:rename :rename-and-delete)
- (setf mask (logior mask sb-unix:o_creat)))
- ((:new-version :supersede)
- (setf mask (logior mask sb-unix:o_trunc)))))
- (t
- (setf if-exists nil))) ; :ignore-this-arg
+ (unless if-exists-given
+ (setf if-exists
+ (if (eq (pathname-version pathname) :newest)
+ :new-version
+ :error)))
+ (case if-exists
+ ((:error nil :new-version)
+ (setf mask (logior mask sb-unix:o_excl)))
+ ((:rename :rename-and-delete)
+ (setf mask (logior mask sb-unix:o_creat)))
+ ((:supersede)
+ (setf mask (logior mask sb-unix:o_trunc)))))
+ (t
+ (setf if-exists nil))) ; :ignore-this-arg
- (delete-original (eq if-exists :rename-and-delete))
- (mode #o666))
- (when original
- ;; We are doing a :rename or :rename-and-delete.
- ;; Determine if the file already exists, make sure the original
- ;; file is not a directory and keep the mode
- (let ((exists
- (and name
- (multiple-value-bind
- (okay err/dev inode orig-mode)
- (sb-unix:unix-stat name)
- (declare (ignore inode)
- (type (or sb-int:index null) orig-mode))
- (cond
- (okay
- (when (and output (= (logand orig-mode #o170000)
- #o40000))
- (error 'sb-int:simple-file-error
- :pathname pathname
- :format-control
- "Cannot open ~S for output: Is a directory."
- :format-arguments (list name)))
- (setf mode (logand orig-mode #o777))
- t)
- ((eql err/dev sb-unix:enoent)
- nil)
- (t
- (error 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Cannot find ~S: ~A"
- :format-arguments
- (list name
- (sb-int:strerror err/dev)))))))))
- (unless (and exists
- (rename-file name original))
- (setf original nil)
- (setf delete-original nil)
- ;; In order to use SUPERSEDE instead, we have
- ;; to make sure unix:o_creat corresponds to
- ;; if-does-not-exist. unix:o_creat was set
- ;; before because of if-exists being :rename.
- (unless (eq if-does-not-exist :create)
- (setf mask (logior (logandc2 mask sb-unix:o_creat)
- sb-unix:o_trunc)))
- (setf if-exists :supersede))))
-
- ;; Okay, now we can try the actual open.
- (loop
- (multiple-value-bind (fd errno)
- (if name
- (sb-unix:unix-open name mask mode)
- (values nil sb-unix:enoent))
- (cond ((sb-int:fixnump fd)
+ (delete-original (eq if-exists :rename-and-delete))
+ (mode #o666))
+ (when original
+ ;; We are doing a :rename or :rename-and-delete.
+ ;; Determine if the file already exists, make sure the original
+ ;; file is not a directory and keep the mode
+ (let ((exists
+ (and name
+ (multiple-value-bind
+ (okay err/dev inode orig-mode)
+ (sb-unix:unix-stat name)
+ (declare (ignore inode)
+ (type (or sb-int:index null) orig-mode))
+ (cond
+ (okay
+ (when (and output (= (logand orig-mode #o170000)
+ #o40000))
+ (error 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control
+ "Cannot open ~S for output: Is a directory."
+ :format-arguments (list name)))
+ (setf mode (logand orig-mode #o777))
+ t)
+ ((eql err/dev sb-unix:enoent)
+ nil)
+ (t
+ (error 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Cannot find ~S: ~A"
+ :format-arguments
+ (list name
+ (sb-int:strerror err/dev)))))))))
+ (unless (and exists
+ (rename-file name original))
+ (setf original nil)
+ (setf delete-original nil)
+ ;; In order to use SUPERSEDE instead, we have
+ ;; to make sure unix:o_creat corresponds to
+ ;; if-does-not-exist. unix:o_creat was set
+ ;; before because of if-exists being :rename.
+ (unless (eq if-does-not-exist :create)
+ (setf mask (logior (logandc2 mask sb-unix:o_creat)
+ sb-unix:o_trunc)))
+ (setf if-exists :supersede))))
+
+ ;; Okay, now we can try the actual open.
+ (loop
+ (multiple-value-bind (fd errno)
+ (if name
+ (sb-unix:unix-open name mask mode)
+ (values nil sb-unix:enoent))
+ (cond ((sb-int:fixnump fd)
- (return (values fd name original delete-original)))
- ((eql errno sb-unix:enoent)
- (case if-does-not-exist
- (:error
- (cerror "Return NIL."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno))))
- (:create
+ (return (values fd name original delete-original)))
+ ((eql errno sb-unix:enoent)
+ (case if-does-not-exist
+ (:error
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (:create
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control
- "Error creating ~S, path does not exist."
- :format-arguments (list pathname))))
- (return nil))
- ((eql errno sb-unix:eexist)
- (unless (eq nil if-exists)
- (cerror "Return NIL."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno))))
- (return nil))
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control
+ "Error creating ~S, path does not exist."
+ :format-arguments (list pathname))))
+ (return nil))
+ ((eql errno sb-unix:eexist)
+ (unless (eq nil if-exists)
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (return nil))
- ((eql errno sb-unix:eacces)
- (cerror "Try again."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno))))
- (t
- (cerror "Return NIL."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno)))
- (return nil)))))))))
+ ((eql errno sb-unix:eacces)
+ (cerror "Try again."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (t
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno)))
+ (return nil)))))))))
- (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 :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))