Use sb-nibbles contrib, if available

nibbles.asd

@@ -25,6 +25,7 @@
   :maintainer "Sharp Lispers <[email protected]>"
   :description "A library for accessing octet-addressed blocks of data in big- and little-endian orders"
   :license "BSD-style (http://opensource.org/licenses/BSD-3-Clause)"
+  :weakly-depends-on ("sb-nibbles")
   :default-component-class nibbles-source-file
   :components ((:static-file "README.md")
                (:static-file "LICENSE")

sbcl-opt/fndb.lisp

@@ -4,6 +4,44 @@
 
 #+sbcl (progn
 
+#+#.(cl:if (cl:find-package "SB-NIBBLES") '(:and) '(:or)) (progn
+
+(macrolet ((def (name size signedp setterp be-p)
+             (let* ((result-type `(,(if signedp 'signed-byte 'unsigned-byte) ,size))
+                    (arg-types `(array index ,@(when setterp (list result-type)))))
+               `(sb-c:defknown ,name ,arg-types ,result-type (sb-c:any)
+                  :overwrite-fndb-silently t))))
+  (def ub16ref/be 16 nil nil t)
+  (def ub16ref/le 16 nil nil nil)
+  (def ub16set/be 16 nil t t)
+  (def ub16set/le 16 nil t nil)
+  (def sb16ref/be 16 t nil t)
+  (def sb16ref/le 16 t nil nil)
+  (def sb16set/be 16 t t t)
+  (def sb16set/le 16 t t nil)
+
+  (def ub32ref/be 32 nil nil t)
+  (def ub32ref/le 32 nil nil nil)
+  (def ub32set/be 32 nil t t)
+  (def ub32set/le 32 nil t nil)
+  (def sb32ref/be 32 t nil t)
+  (def sb32ref/le 32 t nil nil)
+  (def sb32set/be 32 t t t)
+  (def sb32set/le 32 t t nil)
+
+  (def ub64ref/be 64 nil nil t)
+  (def ub64ref/le 64 nil nil nil)
+  (def ub64set/be 64 nil t t)
+  (def ub64set/le 64 nil t nil)
+  (def sb64ref/be 64 t nil t)
+  (def sb64ref/le 64 t nil nil)
+  (def sb64set/be 64 t t t)
+  (def sb64set/le 64 t t nil))
+
+);#+(find-package "SB-NIBBLES")
+
+#-#.(cl:if (cl:find-package "SB-NIBBLES") '(:and) '(:or)) (progn
+
 ;;; Efficient array bounds checking
 (sb-c:defknown %check-bound
   ((simple-array (unsigned-byte 8) (*)) index (and fixnum sb-vm:word)
@@ -42,4 +80,6 @@
                      ,arg-type (sb-c:any) :overwrite-fndb-silently t) into defknowns
         finally (return `(progn ,@defknowns)))
 
+);#-(find-package "SB-NIBBLES")
+
 );#+sbcl

sbcl-opt/nib-tran.lisp

@@ -4,6 +4,49 @@
 
 #+sbcl (progn
 
+#+#.(cl:if (cl:find-package "SB-NIBBLES") '(:and) '(:or)) (progn
+
+(macrolet ((def (name size signedp setterp be-p)
+             (let* ((arglist `(vector offset ,@(when setterp '(value))))
+                    (sb-name (find-symbol (symbol-name name) "SB-NIBBLES"))
+                    (result-type `(,(if signedp 'signed-byte 'unsigned-byte) ,size))
+                    (arg-types `(array index ,@(when setterp (list result-type)))))
+               (when sb-name
+                 `(sb-c:deftransform ,name (,arglist ,arg-types ,result-type)
+                    `(progn
+                       (,',sb-name vector (sb-nibbles::%check-bound vector (length vector) offset ,',(truncate size 8)) ,@',(when setterp '(value)))
+                       ,@',(when setterp '(value))))))))
+  (def ub16ref/be 16 nil nil t)
+  (def ub16ref/le 16 nil nil nil)
+  (def ub16set/be 16 nil t t)
+  (def ub16set/le 16 nil t nil)
+  (def sb16ref/be 16 t nil t)
+  (def sb16ref/le 16 t nil nil)
+  (def sb16set/be 16 t t t)
+  (def sb16set/le 16 t t nil)
+
+  (def ub32ref/be 32 nil nil t)
+  (def ub32ref/le 32 nil nil nil)
+  (def ub32set/be 32 nil t t)
+  (def ub32set/le 32 nil t nil)
+  (def sb32ref/be 32 t nil t)
+  (def sb32ref/le 32 t nil nil)
+  (def sb32set/be 32 t t t)
+  (def sb32set/le 32 t t nil)
+
+  (def ub64ref/be 64 nil nil t)
+  (def ub64ref/le 64 nil nil nil)
+  (def ub64set/be 64 nil t t)
+  (def ub64set/le 64 nil t nil)
+  (def sb64ref/be 64 t nil t)
+  (def sb64ref/le 64 t nil nil)
+  (def sb64set/be 64 t t t)
+  (def sb64set/le 64 t t nil))
+
+);#+(find-package "SB-NIBBLES")
+
+#-#.(cl:if (cl:find-package "SB-NIBBLES") '(:and) '(:or)) (progn
+
 (sb-c:deftransform %check-bound ((vector bound offset n-bytes)
 				 ((simple-array (unsigned-byte 8) (*)) index
 				  (and fixnum sb-vm:word)
@@ -93,4 +136,6 @@
             collect generic-little-transform into transforms
           finally (return `(progn ,@transforms))))
 
+);#-(find-package "SB-NIBBLES")
+
 );#+sbcl

sbcl-opt/x86-64-vm.lisp

@@ -3,7 +3,7 @@
 #+sbcl
 (cl:in-package :sb-vm)
 
-#+(and sbcl x86-64) (progn
+#+(and sbcl x86-64 #.(cl:if (cl:find-package "SB-NIBBLES") '(:or) '(:and))) (progn
 
 (define-vop (%check-bound)
   (:translate nibbles::%check-bound)
@@ -20,7 +20,7 @@
   (:vop-var vop)
   (:generator 5
     (let ((error (generate-error-code vop 'invalid-array-index-error
-                                      array bound index)))
+                                      array bound temp)))
       ;; We want to check the conditions:
       ;;
       ;; 0 <= INDEX
@@ -36,9 +36,9 @@
       ;; If INDEX + OFFSET <_u BOUND, though, INDEX must be less than
       ;; BOUND.  We *do* need to check for 0 <= INDEX, but that has
       ;; already been assured by higher-level machinery.
-      (inst lea temp (ea (fixnumize offset) nil index))
+      (inst lea temp (ea (fixnumize (1- offset)) nil index))
       (inst cmp temp bound)
-      (inst jmp :a error)
+      (inst jmp :ae error)
       (move result index))))
 
 #.(flet ((frob (bitsize setterp signedp big-endian-p)
@@ -134,4 +134,4 @@
           collect (frob bitsize setterp signedp big-endian-p) into forms
           finally (return `(progn ,@forms))))
 
-);#+(and sbcl x86-64)
+);#+(and sbcl x86-64 (not (find-package "SB-NIBBLES")))

sbcl-opt/x86-vm.lisp

@@ -3,7 +3,7 @@
 #+sbcl
 (cl:in-package :sb-vm)
 
-#+(and sbcl x86) (progn
+#+(and sbcl x86 #.(cl:if (cl:find-package "SB-NIBBLES") '(:or) '(:and))) (progn
 
 (define-vop (%check-bound)
   (:translate nibbles::%check-bound)
@@ -20,7 +20,7 @@
   (:vop-var vop)
   (:generator 5
     (let ((error (generate-error-code vop 'invalid-array-index-error
-                                      array bound index)))
+                                      array bound temp)))
       ;; We want to check the conditions:
       ;;
       ;; 0 <= INDEX
@@ -36,9 +36,9 @@
       ;; If INDEX + OFFSET <_u BOUND, though, INDEX must be less than
       ;; BOUND.  We *do* need to check for 0 <= INDEX, but that has
       ;; already been assured by higher-level machinery.
-      (inst lea temp (make-ea :dword :index index :disp (fixnumize offset)))
+      (inst lea temp (make-ea :dword :index index :disp (fixnumize (1- offset))))
       (inst cmp temp bound)
-      (inst jmp :a error)
+      (inst jmp :ae error)
       (move result index))))
 
 #.(flet ((frob (setterp signedp big-endian-p)
@@ -162,4 +162,4 @@
           collect (frob setterp signedp big-endian-p) into forms
           finally (return `(progn ,@forms))))
 
-);#+(and sbcl x86)
+);#+(and sbcl x86 (not (find-package "SB-NIBBLES")))