Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 5915:1af53d35dd53

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 750fab17b299
children
comparison
equal deleted inserted replaced
5914:bd4d2c8ef9cc 5915:1af53d35dd53
838 Otherwise, return CHARACTER." 838 Otherwise, return CHARACTER."
839 (and (stringp character) (check-type character character)) 839 (and (stringp character) (check-type character character))
840 (with-case-table (standard-case-table) (downcase character))) 840 (with-case-table (standard-case-table) (downcase character)))
841 841
842 (defun integer-length (integer) 842 (defun integer-length (integer)
843 "Return the number of bits need to represent INTEGER in two's complement." 843 "Return the number of bits need to represent INTEGER in two's complement.
844 (ecase (signum integer) 844
845 (0 0) 845 Equivalent to `(ceiling (log (1+ integer) 2))' for positive integers, and
846 (-1 (1- (length (format "%b" (- integer))))) 846 `(ceiling (log (- integer) 2))' for negative integers."
847 (1 (length (format "%b" integer))))) 847 (check-type integer integer)
848 (when (< integer 0)
849 ;; Don't use #'-, which fails silently with most-negative-fixnum.
850 (setf integer (lognot integer)))
851 (let ((count 0) (last integer))
852 (while (not (eql (setq integer (/ integer 16)) 0))
853 (setf last integer
854 count (+ count 4)))
855 (+ (aref (eval-when-compile
856 (vconcat [0] (loop for fixnum from 1 below 16
857 collect (length (format "%b" fixnum)))))
858 last)
859 count)))
860
861 (defun logcount (integer)
862 "Return the number of one bits in INTEGER, if non-negative.
863
864 If INTEGER is negative, return the number of zero bits of lower order than the
865 most significant non-zero bit."
866 (let ((integer (if (>= integer 0) integer (- (1+ integer))))
867 (count 0))
868 (while (not (eql 0 integer))
869 (setf count
870 (+ count (aref
871 (eval-when-compile
872 (vconcat
873 (loop for fixnum from 0 below 16
874 collect (count ?1 (format "%b" fixnum)))))
875 (% integer 16)))
876 integer (/ integer 16)))
877 count))
848 878
849 ;; These are here because labels and symbol-macrolet are not available in 879 ;; These are here because labels and symbol-macrolet are not available in
850 ;; obsolete.el. They are, however, all marked as obsolete in that file. 880 ;; obsolete.el. They are, however, all marked as obsolete in that file.
851 (symbol-macrolet ((not-nil '#:not-nil)) 881 (symbol-macrolet ((not-nil '#:not-nil))
852 (labels ((car-or-not-nil (object) 882 (labels ((car-or-not-nil (object)