Mercurial > hg > xemacs-beta
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 (%))