- `(progn
- (declaim (inline ,byte-char-name))
- (defun ,byte-char-name (byte)
- (declare (optimize speed (safety 0))
- (type (unsigned-byte 8) byte))
- (aref ,(make-array 256
- :initial-contents (loop for byte below 256
- collect
- (let ((exception (cadr (assoc byte exceptions))))
- (if exception
- exception
- byte))))
- byte))
- ;; This used to be inlined, but it caused huge slowdowns in SBCL builds,
- ;; bloated the core by about 700k on x86-64. Removing the inlining
- ;; didn't seem to have any performance effect. -- JES, 2005-10-15
- (defun ,code-byte-name (code)
- (declare (optimize speed (safety 0))
- (type char-code code))
- ;; FIXME: I'm not convinced doing this with CASE is a good idea as
- ;; long as it's just macroexpanded into a stupid COND. Consider
- ;; for example the output of (DISASSEMBLE 'SB-IMPL::CODE->CP1250-MAPPER)
- ;; -- JES, 2005-10-15
- (case code
- ,@(mapcar (lambda (exception)
- (destructuring-bind (byte code) exception
- `(,code ,byte)))
- exceptions)
- (,(mapcar #'car exceptions) nil)
- (otherwise (if (< code 256) code nil))))))
+ (let* (;; Build a list of (CODE BYTE) pairs
+ (pairs (loop for byte below 256
+ for code = (let ((exception (cdr (assoc byte exceptions))))
+ (cond
+ ((car exception) (car exception))
+ ((null exception) byte)
+ (t nil)))
+ when code collect (list code byte) into elements
+ finally (return elements)))
+ ;; Find the smallest character code such that the corresponding
+ ;; byte is != to the code.
+ (lowest-non-equivalent-code (position-if-not #'(lambda (pair)
+ (apply #'= pair))
+ pairs))
+ ;; Sort them for our lookup table.
+ (sorted-pairs (sort (subseq pairs lowest-non-equivalent-code)
+ #'< :key #'car))
+ ;; Create the lookup table.
+ (sorted-lookup-table
+ (reduce #'append sorted-pairs :from-end t :initial-value nil)))
+ `(progn
+ ; Can't inline it with a non-null lexical environment anyway.
+ ;(declaim (inline ,byte-char-name))
+ (let ((byte-to-code-table
+ ,(make-array 256 :element-type t #+nil 'char-code
+ :initial-contents (loop for byte below 256
+ collect
+ (let ((exception (cadr (assoc byte exceptions))))
+ (if exception
+ exception
+ byte)))))
+ (code-to-byte-table
+ ,(make-array (length sorted-lookup-table)
+ :initial-contents sorted-lookup-table)))
+ (defun ,byte-char-name (byte)
+ (declare (optimize speed (safety 0))
+ (type (unsigned-byte 8) byte))
+ (aref byte-to-code-table byte))
+ (defun ,code-byte-name (code)
+ (declare (optimize speed (safety 0))
+ (type char-code code))
+ (if (< code ,lowest-non-equivalent-code)
+ code
+ ;; We could toss in some TRULY-THEs if we really needed to
+ ;; make this faster...
+ (loop with low = 0
+ with high = (- (length code-to-byte-table) 2)
+ while (< low high)
+ do (let ((mid (logandc2 (truncate (+ low high 2) 2) 1)))
+ (if (< code (aref code-to-byte-table mid))
+ (setf high (- mid 2))
+ (setf low mid)))
+ finally (return (if (eql code (aref code-to-byte-table low))
+ (aref code-to-byte-table (1+ low))
+ nil)))))))))