changeset 5915:1af53d35dd53

Avoid allocation in #'integer-length; add #'logcount. lisp/ChangeLog addition: 2015-05-29 Aidan Kehoe <kehoea@parhasard.net> * byte-optimize.el (side-effect-free-fns): Add #'integer-length, #'logcount here. * cl-extra.el: * cl-extra.el (integer-length): Update this to avoid allocating memory. * cl-extra.el (logcount): New. Return the number of one bits in INTEGER, if non-negative. Function from Common Lisp. tests/ChangeLog addition: 2015-05-29 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el: Test #'integer-length, #'logcount in this file.
author Aidan Kehoe <kehoea@parhasard.net>
date Fri, 29 May 2015 17:06:24 +0100
parents bd4d2c8ef9cc
children 1152e0091f8c
files lisp/ChangeLog lisp/byte-optimize.el lisp/cl-extra.el tests/ChangeLog tests/automated/lisp-tests.el
diffstat 5 files changed, 102 insertions(+), 7 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Fri May 15 18:11:47 2015 +0100
+++ b/lisp/ChangeLog	Fri May 29 17:06:24 2015 +0100
@@ -4,6 +4,16 @@
 	* simple.el (line-number): Moved to buffer.c; we have an existing
 	line number cache in C, it's a shame not to have it available.
 
+2015-05-29  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* byte-optimize.el (side-effect-free-fns):
+	Add #'integer-length, #'logcount here.
+	* cl-extra.el:
+	* cl-extra.el (integer-length):
+	Update this to avoid allocating memory.
+	* cl-extra.el (logcount): New. Return the number of one bits in
+	INTEGER, if non-negative. Function from Common Lisp.
+
 2015-04-11  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* mule/mule-cmds.el (set-locale-for-language-environment):
--- a/lisp/byte-optimize.el	Fri May 15 18:11:47 2015 +0100
+++ b/lisp/byte-optimize.el	Fri May 29 17:06:24 2015 +0100
@@ -1303,8 +1303,8 @@
 	 hash-table-test
 	 hash-table-type
 	 ;;
-	 int-to-string
-	 length log log10 logand logb logior lognot logxor lsh
+	 integer-length int-to-string
+	 length log log10 logand logb logcount logior lognot logxor lsh
 	 marker-buffer max member memq min mod
 	 next-window nth nthcdr number-to-string numerator
 	 parse-colon-path plist-get previous-window
--- a/lisp/cl-extra.el	Fri May 15 18:11:47 2015 +0100
+++ b/lisp/cl-extra.el	Fri May 29 17:06:24 2015 +0100
@@ -840,11 +840,41 @@
   (with-case-table (standard-case-table) (downcase character)))
 
 (defun integer-length (integer)
-  "Return the number of bits need to represent INTEGER in two's complement."
-  (ecase (signum integer)
-    (0 0)
-    (-1 (1- (length (format "%b" (- integer)))))
-    (1 (length (format "%b" integer)))))
+  "Return the number of bits need to represent INTEGER in two's complement.
+
+Equivalent to `(ceiling (log (1+ integer) 2))' for positive integers, and
+`(ceiling (log (- integer) 2))' for negative integers."
+  (check-type integer integer)
+  (when (< integer 0)
+    ;; Don't use #'-, which fails silently with most-negative-fixnum.
+    (setf integer (lognot integer)))
+  (let ((count 0) (last integer))
+    (while (not (eql (setq integer (/ integer 16)) 0))
+      (setf last integer
+            count (+ count 4)))
+    (+ (aref (eval-when-compile
+              (vconcat [0] (loop for fixnum from 1 below 16
+                                 collect (length (format "%b" fixnum)))))
+             last)
+       count)))
+
+(defun logcount (integer)
+  "Return the number of one bits in INTEGER, if non-negative.
+
+If INTEGER is negative, return the number of zero bits of lower order than the
+most significant non-zero bit."
+  (let ((integer (if (>= integer 0) integer (- (1+ integer))))
+        (count 0))
+    (while (not (eql 0 integer))
+      (setf count
+            (+ count (aref
+                      (eval-when-compile
+                       (vconcat
+                        (loop for fixnum from 0 below 16
+                              collect (count ?1 (format "%b" fixnum)))))
+                      (% integer 16)))
+            integer (/ integer 16)))
+    count))
 
 ;; These are here because labels and symbol-macrolet are not available in
 ;; obsolete.el. They are, however, all marked as obsolete in that file.
--- a/tests/ChangeLog	Fri May 15 18:11:47 2015 +0100
+++ b/tests/ChangeLog	Fri May 29 17:06:24 2015 +0100
@@ -1,3 +1,8 @@
+2015-05-29  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* automated/lisp-tests.el:
+	Test #'integer-length, #'logcount in this file.
+
 2015-05-11  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* automated/mule-tests.el:
--- a/tests/automated/lisp-tests.el	Fri May 15 18:11:47 2015 +0100
+++ b/tests/automated/lisp-tests.el	Fri May 29 17:06:24 2015 +0100
@@ -564,6 +564,56 @@
     (Assert (eq 2 (logxor one three)) (list one three))))
 
 ;;-----------------------------------------------------
+;; Test `integer-length', `logcount'
+;;-----------------------------------------------------
+
+(Check-Error wrong-type-argument (integer-length 0.0))
+(Check-Error wrong-type-argument (integer-length 'symbol))
+(Assert (eql (integer-length 0) 0))
+(Assert (eql (integer-length -1) 0))
+(Assert (eql (integer-length 1) 1))
+(Assert (eql (integer-length #x-F) 4))
+(Assert (eql (integer-length #xF) 4))
+(Assert (eql (integer-length #x-10) 4))
+(Assert (eql (integer-length #x10) 5))
+
+(Check-Error wrong-type-argument (logcount 0.0))
+(Check-Error wrong-type-argument (logcount 'symbol))
+(Assert (eql (logcount 0) 0))
+(Assert (eql (logcount 1) 1))
+(Assert (eql (logcount -1) 0))
+(Assert (eql (logcount #x-F) 3))
+(Assert (eql (logcount #xF) 4))
+(Assert (eql (logcount #x-10) 4))
+(Assert (eql (logcount #x10) 1))
+
+(macrolet
+    ((random-sample-n () 10) ;; Increase this to get a bigger sample.
+     (test-integer-length-random-sample ()
+       (cons
+        'progn
+        (loop for index from 0 to (random-sample-n)
+              nconc (let* ((value (random (if (featurep 'bignum)
+                                              (lsh most-positive-fixnum 4)
+                                            most-positive-fixnum)))
+                           (length (length (format "%b" value))))
+                      `((Assert (eql (integer-length ,value) ,length))
+                        (Assert (eql (integer-length ,(1- (- value)))
+                                                     ,length)))))))
+     (test-logcount-random-sample ()
+       (cons
+        'progn
+        (loop for index from 0 to (random-sample-n)
+              nconc (let* ((value (random (if (featurep 'bignum)
+                                              (lsh most-positive-fixnum 4)
+                                            most-positive-fixnum)))
+                           (count (count ?1 (format "%b" value))))
+                      `((Assert (eql (logcount ,value) ,count))
+                        (Assert (eql (logcount ,(lognot value)) ,count))))))))
+  (test-integer-length-random-sample)
+  (test-logcount-random-sample))
+
+;;-----------------------------------------------------
 ;; Test `%', mod
 ;;-----------------------------------------------------
 (Check-Error wrong-number-of-arguments (%))