+++ /dev/null
-(in-package #:sb!impl)
-
-;;; TODO Macro for generating different variants:
-;;; :ucs-2le (little endian) sap-ref-16le
-;;; :ucs-2be (big endian) sap-ref-16be
-;;; :ucs-2 (native) sap-ref-16
-
-;;; Utilities
-
-(declaim (inline sap-ref-16le (setf sap-ref-16le)
- sap-ref-16be (setf sap-ref-16be)))
-
-;;; Define feature LITTLE-ENDIAN-AND-MISALIGNED-READ?
-(defun sap-ref-16le (sap offset)
- #!+(or x86 x86-64)
- (sap-ref-16 sap offset)
- #!-(or x86 x86-64)
- (dpb (sap-ref-8 sap (1+ offset)) (byte 8 8)
- (sap-ref-8 sap offset)))
-
-(defun (setf sap-ref-16le) (value sap offset)
- #!+(or x86 x86-64)
- (setf (sap-ref-16 sap offset) value)
- #!-(or x86 x86-64)
- (setf (sap-ref-8 sap offset) (logand #xFF value)
- (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value)))
-
-(defun sap-ref-16be (sap offset)
- (dpb (sap-ref-8 sap offset) (byte 8 8)
- (sap-ref-8 sap (1+ offset))))
-
-(defun (setf sap-ref-16be) (value sap offset)
- (setf (sap-ref-8 sap (1+ offset)) (logand #xFF value)
- (sap-ref-8 sap offset) (ldb (byte 8 8) value)))
-
-;;;
-;;; octets
-;;;
-
-;;; Conversion to UCS-2{LE,BE}
-(declaim (inline char->ucs-2le))
-(defun char->ucs-2le (char dest string pos)
- (declare (optimize speed (safety 0))
- (type (array (unsigned-byte 8) (*)) dest))
- (let ((code (char-code char)))
- (if (< code #x10000)
- (flet ((add-byte (b)
- (declare (type (unsigned-byte 8) b))
- (vector-push b dest)))
- (declare (inline add-byte))
- (add-byte (ldb (byte 8 0) code))
- (add-byte (ldb (byte 8 8) code)))
- ; signal error
- (encoding-error :ucs-2le string pos))))
-
-(declaim (inline char->ucs-2be))
-(defun char->ucs-2be (char dest string pos)
- (declare (optimize speed (safety 0))
- (type (array (unsigned-byte 8) (*)) dest))
- (let ((code (char-code char)))
- (if (< code #x10000)
- (flet ((add-byte (b)
- (declare (type (unsigned-byte 8) b))
- (vector-push b dest)))
- (declare (inline add-byte))
- (add-byte (ldb (byte 8 8) code))
- (add-byte (ldb (byte 8 0) code)))
- ; signal error
- (encoding-error :ucs-16be string pos))))
-
-(defun string->ucs-2le (string sstart send additional-space)
- (declare (optimize speed (safety 0))
- (type simple-string string)
- (type array-range sstart send additional-space))
- (let ((array (make-array (* 2 (+ additional-space (- send sstart)))
- :element-type '(unsigned-byte 8)
- :fill-pointer 0)))
- (loop for i from sstart below send
- do (char->ucs-2le (char string i) array string i))
- (dotimes (i additional-space)
- (vector-push 0 array)
- (vector-push 0 array))
- (coerce array '(simple-array (unsigned-byte 8) (*)))))
-
-(defun string->ucs-2be (string sstart send additional-space)
- (declare (optimize speed (safety 0))
- (type simple-string string)
- (type array-range sstart send additional-space))
- (let ((array (make-array (* 2 (+ additional-space (- send sstart)))
- :element-type '(unsigned-byte 8)
- :fill-pointer 0)))
- (loop for i from sstart below send
- do (char->ucs-2be (char string i) array string i))
- (dotimes (i additional-space)
- (vector-push 0 array)
- (vector-push 0 array))
- (coerce array '(simple-array (unsigned-byte 8) (*)))))
-
-;; Conversion from UCS-2{LE,BE}
-(defmacro define-bytes-per-ucs2-character (accessor type)
- (declare (ignore type))
- (let ((name-le (make-od-name 'bytes-per-ucs-2le-character accessor))
- (name-be (make-od-name 'bytes-per-ucs-2be-character accessor)))
- `(progn
- (defun ,name-le (array pos end)
- (declare (ignore array pos end))
- (values 2 nil))
- (defun ,name-be (array pos end)
- (declare (ignore array pos end))
- (values 2 nil)))))
-(instantiate-octets-definition define-bytes-per-ucs2-character)
-
-(defmacro define-simple-get-ucs2-character (accessor type)
- (let ((name-le (make-od-name 'simple-get-ucs-2le-char accessor))
- (name-be (make-od-name 'simple-get-ucs-2be-char accessor)))
- `(progn
- (defun ,name-le (array pos bytes)
- (declare (optimize speed (safety 0))
- (type ,type array)
- (type array-range pos)
- (type (integer 1 4) bytes)
- (ignore bytes))
- ;; Optimization for SYSTEM-AREA-POINTER: use SAP-REF-16LE that
- ;; reads two bytes at once on some architectures.
- ,(if (and (eq accessor 'sap-ref-8)
- (eq type 'system-area-pointer))
- '(code-char (sap-ref-16le array pos))
- `(flet ((cref (x)
- (,accessor array (the array-range (+ pos x)))))
- (declare (inline cref))
- (code-char (dpb (cref 1) (byte 8 8)
- (cref 0))))))
- (defun ,name-be (array pos bytes)
- (declare (optimize speed (safety 0))
- (type ,type array)
- (type array-range pos)
- (type (integer 1 4) bytes)
- (ignore bytes))
- ;; Use SAP-REF-16BE even if it is not optimized
- ,(if (and (eq accessor 'sap-ref-8)
- (eq type 'system-area-pointer))
- '(code-char (sap-ref-16be array pos))
- `(flet ((cref (x)
- (,accessor array (the array-range (+ pos x)))))
- (declare (inline cref))
- (code-char (dpb (cref 0) (byte 8 8)
- (cref 1)))))))))
-
-(instantiate-octets-definition define-simple-get-ucs2-character)
-
-(defmacro define-ucs-2->string (accessor type)
- (let ((name-le (make-od-name 'ucs-2le->string accessor))
- (name-be (make-od-name 'ucs-2be->string accessor)))
- `(progn
- (defun ,name-le (array astart aend)
- (declare (optimize speed (safety 0))
- (type ,type array)
- (type array-range astart aend))
- (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
- (loop with pos = astart
- while (< pos aend)
- do (multiple-value-bind (bytes invalid)
- (,(make-od-name 'bytes-per-ucs-2le-character accessor) array pos aend)
- (declare (type (or null string) invalid))
- (assert (null invalid))
- (vector-push-extend
- (,(make-od-name 'simple-get-ucs-2le-char accessor)
- array pos bytes)
- string)
- (incf pos bytes)))
- string))
- (defun ,name-be (array astart aend)
- (declare (optimize speed (safety 0))
- (type ,type array)
- (type array-range astart aend))
- (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character)))
- (loop with pos = astart
- while (< pos aend)
- do (multiple-value-bind (bytes invalid)
- (,(make-od-name 'bytes-per-ucs-2be-character accessor) array pos aend)
- (declare (type (or null string) invalid))
- (assert (null invalid))
- (vector-push-extend
- (,(make-od-name 'simple-get-ucs-2be-char accessor)
- array pos bytes)
- string)
- (incf pos bytes)))
- string)))))
-
-(instantiate-octets-definition define-ucs-2->string)
-
-(define-external-format/variable-width (:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2) t
- (code-char #xfffd)
- 2
- (if (< bits #x10000)
- (setf (sap-ref-16le sap tail) bits)
- (external-format-encoding-error stream bits))
- 2
- (code-char (sap-ref-16le sap head))
- ucs-2le->string-aref
- string->ucs-2le)
-
-(define-external-format/variable-width (:ucs-2be :ucs2be) t
- (code-char #xfffd)
- 2
- (if (< bits #x10000)
- (setf (sap-ref-16be sap tail) bits)
- (external-format-encoding-error stream bits))
- 2
- (code-char (sap-ref-16be sap head))
- ucs-2be->string-aref
- string->ucs-2be)
projects / sbcl.git / blobdiff