Loading disk.lisp +12 −6 Original line number Diff line number Diff line Loading @@ -331,13 +331,23 @@ (defun write-ascii-string (string stream) (declare (simple-string string)) (write-n-bytes #.(type-code 'ascii-string) 1 stream) (write-n-bytes (length string) +sequence-length+ stream) #-(and sb-unicode (or x86 x86-64)) (loop for char across string do (write-n-bytes (char-code char) 1 stream))) do (write-n-bytes (char-code char) 1 stream)) #+(and sb-unicode (or x86 x86-64)) (write-ascii-non-base-string-optimized string stream)) (defun write-multibyte-string (string stream) (declare (simple-string string)) (write-n-bytes #.(type-code 'string) 1 stream) (write-n-bytes (length string) +sequence-length+ stream) #-(and sb-unicode (or x86 x86-64)) (loop for char across string do (write-n-bytes (char-code char) +char-length+ stream))) do (write-n-bytes (char-code char) +char-length+ stream)) #+(and sb-unicode (or x86 x86-64)) (write-multibyte-string-optimized string stream)) (defmethod write-object ((string string) stream) (etypecase string Loading @@ -349,12 +359,8 @@ (write-n-bytes (length string) +sequence-length+ stream) (write-ascii-string-optimized string stream)) (ascii-string (write-n-bytes #.(type-code 'ascii-string) 1 stream) (write-n-bytes (length string) +sequence-length+ stream) (write-ascii-string string stream)) (string (write-n-bytes #.(type-code 'string) 1 stream) (write-n-bytes (length string) +sequence-length+ stream) (write-multibyte-string string stream)))) (declaim (inline read-ascii-string)) Loading io-sbcl.lisp +42 −0 Original line number Diff line number Diff line Loading @@ -286,6 +286,48 @@ +buffer-size+))))) string) (declaim (inline copy-mem-non-base-string)) (defun copy-mem-non-base-string (from to length) (declare (word length) (optimize (safety 0))) (loop for string-index fixnum by 4 for i fixnum below length do (setf (sb-sys:sap-ref-8 to i) (sb-sys:sap-ref-8 from string-index)))) (declaim (inline write-ascii-non-base-string-optimized)) (defun write-ascii-non-base-string-optimized (string stream) (declare (optimize speed) (simple-string string) (sb-ext:muffle-conditions sb-ext:compiler-note)) (sb-sys:with-pinned-objects (string) (let* ((length (length string)) (position (output-stream-buffer-position stream)) (string-sap (sb-sys:vector-sap string)) (new-position (sb-ext:truly-the word (+ position length)))) (declare (type word position new-position)) (cond ((<= new-position (output-stream-buffer-end stream)) (copy-mem-non-base-string string-sap (sb-sys:int-sap position) length) (setf (output-stream-buffer-position stream) new-position)) ((<= length +buffer-size+) (let* ((start (output-stream-buffer-start stream)) (left (- (output-stream-buffer-end stream) position)) (left-length (sb-ext:truly-the word (- length left)))) (declare (word left left-length)) (copy-mem-non-base-string string-sap (sb-sys:int-sap position) left) (setf (output-stream-buffer-position stream) (output-stream-buffer-end stream)) (flush-buffer stream) (copy-mem-non-base-string (sb-sys:sap+ string-sap left) (sb-sys:int-sap start) left-length) (setf (output-stream-buffer-position stream) (sb-ext:truly-the word (+ start left-length))))) (t (error "Strings of more than ~a are not supported yet." +buffer-size+))))) string) ;;; (defmacro with-io-file ((stream file Loading Loading
disk.lisp +12 −6 Original line number Diff line number Diff line Loading @@ -331,13 +331,23 @@ (defun write-ascii-string (string stream) (declare (simple-string string)) (write-n-bytes #.(type-code 'ascii-string) 1 stream) (write-n-bytes (length string) +sequence-length+ stream) #-(and sb-unicode (or x86 x86-64)) (loop for char across string do (write-n-bytes (char-code char) 1 stream))) do (write-n-bytes (char-code char) 1 stream)) #+(and sb-unicode (or x86 x86-64)) (write-ascii-non-base-string-optimized string stream)) (defun write-multibyte-string (string stream) (declare (simple-string string)) (write-n-bytes #.(type-code 'string) 1 stream) (write-n-bytes (length string) +sequence-length+ stream) #-(and sb-unicode (or x86 x86-64)) (loop for char across string do (write-n-bytes (char-code char) +char-length+ stream))) do (write-n-bytes (char-code char) +char-length+ stream)) #+(and sb-unicode (or x86 x86-64)) (write-multibyte-string-optimized string stream)) (defmethod write-object ((string string) stream) (etypecase string Loading @@ -349,12 +359,8 @@ (write-n-bytes (length string) +sequence-length+ stream) (write-ascii-string-optimized string stream)) (ascii-string (write-n-bytes #.(type-code 'ascii-string) 1 stream) (write-n-bytes (length string) +sequence-length+ stream) (write-ascii-string string stream)) (string (write-n-bytes #.(type-code 'string) 1 stream) (write-n-bytes (length string) +sequence-length+ stream) (write-multibyte-string string stream)))) (declaim (inline read-ascii-string)) Loading
io-sbcl.lisp +42 −0 Original line number Diff line number Diff line Loading @@ -286,6 +286,48 @@ +buffer-size+))))) string) (declaim (inline copy-mem-non-base-string)) (defun copy-mem-non-base-string (from to length) (declare (word length) (optimize (safety 0))) (loop for string-index fixnum by 4 for i fixnum below length do (setf (sb-sys:sap-ref-8 to i) (sb-sys:sap-ref-8 from string-index)))) (declaim (inline write-ascii-non-base-string-optimized)) (defun write-ascii-non-base-string-optimized (string stream) (declare (optimize speed) (simple-string string) (sb-ext:muffle-conditions sb-ext:compiler-note)) (sb-sys:with-pinned-objects (string) (let* ((length (length string)) (position (output-stream-buffer-position stream)) (string-sap (sb-sys:vector-sap string)) (new-position (sb-ext:truly-the word (+ position length)))) (declare (type word position new-position)) (cond ((<= new-position (output-stream-buffer-end stream)) (copy-mem-non-base-string string-sap (sb-sys:int-sap position) length) (setf (output-stream-buffer-position stream) new-position)) ((<= length +buffer-size+) (let* ((start (output-stream-buffer-start stream)) (left (- (output-stream-buffer-end stream) position)) (left-length (sb-ext:truly-the word (- length left)))) (declare (word left left-length)) (copy-mem-non-base-string string-sap (sb-sys:int-sap position) left) (setf (output-stream-buffer-position stream) (output-stream-buffer-end stream)) (flush-buffer stream) (copy-mem-non-base-string (sb-sys:sap+ string-sap left) (sb-sys:int-sap start) left-length) (setf (output-stream-buffer-position stream) (sb-ext:truly-the word (+ start left-length))))) (t (error "Strings of more than ~a are not supported yet." +buffer-size+))))) string) ;;; (defmacro with-io-file ((stream file Loading