From: William Harold Newman Date: Tue, 5 Nov 2002 00:23:17 +0000 (+0000) Subject: 0.7.9.30: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=97e52e46f9bcb054eec35a9c326db75993441ca1;p=sbcl.git 0.7.9.30: merged Matthew Danish's "count, count-if, ..." patch (from sbcl-devel 2002-11-02) added some test cases --- diff --git a/src/code/seq.lisp b/src/code/seq.lisp index fe09338..d203edd 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -2042,112 +2042,96 @@ (def-find-position-if-not find-if-not 0) (def-find-position-if-not position-if-not 1)) - -;;;; COUNT - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-count (item sequence) - `(do ((index start (1+ index)) - (count 0)) - ((= index (the fixnum end)) count) - (declare (fixnum index count)) - (if test-not - (unless (funcall test-not ,item - (apply-key key (aref ,sequence index))) - (setq count (1+ count))) - (when (funcall test ,item (apply-key key (aref ,sequence index))) - (setq count (1+ count)))))) - -(sb!xc:defmacro list-count (item sequence) - `(do ((sequence (nthcdr start ,sequence)) - (index start (1+ index)) - (count 0)) - ((or (= index (the fixnum end)) (null sequence)) count) - (declare (fixnum index count)) - (if test-not - (unless (funcall test-not ,item (apply-key key (pop sequence))) - (setq count (1+ count))) - (when (funcall test ,item (apply-key key (pop sequence))) - (setq count (1+ count)))))) -) ; EVAL-WHEN - -(defun count (item sequence &key from-end (test #'eql) test-not (start 0) - end key) - #!+sb-doc - "Return the number of elements in SEQUENCE satisfying a test with ITEM, - which defaults to EQL." - (declare (ignore from-end) (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-count item sequence) - (vector-count item sequence)))) -;;;; COUNT-IF and COUNT-IF-NOT +;;;; COUNT-IF, COUNT-IF-NOT, and COUNT (eval-when (:compile-toplevel :execute) -(sb!xc:defmacro vector-count-if (predicate sequence) - `(do ((index start (1+ index)) - (count 0)) - ((= index (the fixnum end)) count) - (declare (fixnum index count)) - (if (funcall ,predicate (apply-key key (aref ,sequence index))) - (setq count (1+ count))))) - -(sb!xc:defmacro list-count-if (predicate sequence) - `(do ((sequence (nthcdr start ,sequence)) - (index start (1+ index)) - (count 0)) - ((or (= index (the fixnum end)) (null sequence)) count) - (declare (fixnum index count)) - (if (funcall ,predicate (apply-key key (pop sequence))) - (setq count (1+ count))))) +(sb!xc:defmacro vector-count-if (notp from-end-p predicate sequence) + (let ((next-index (if from-end-p '(1- index) '(1+ index))) + (pred `(funcall ,predicate (apply-key key (aref ,sequence index))))) + `(let ((%start ,(if from-end-p '(1- end) 'start)) + (%end ,(if from-end-p '(1- start) 'end))) + (do ((index %start ,next-index) + (count 0)) + ((= index (the fixnum %end)) count) + (declare (fixnum index count)) + (,(if notp 'unless 'when) ,pred + (setq count (1+ count))))))) + +(sb!xc:defmacro list-count-if (notp from-end-p predicate sequence) + (let ((pred `(funcall ,predicate (apply-key key (pop sequence))))) + `(let ((%start ,(if from-end-p '(- length end) 'start)) + (%end ,(if from-end-p '(- length start) 'end)) + (sequence ,(if from-end-p '(reverse sequence) 'sequence))) + (do ((sequence (nthcdr %start ,sequence)) + (index %start (1+ index)) + (count 0)) + ((or (= index (the fixnum %end)) (null sequence)) count) + (declare (fixnum index count)) + (,(if notp 'unless 'when) ,pred + (setq count (1+ count))))))) + ) ; EVAL-WHEN (defun count-if (test sequence &key from-end (start 0) end key) #!+sb-doc "Return the number of elements in SEQUENCE satisfying TEST(el)." - (declare (ignore from-end) (fixnum start)) - (let ((end (or end (length sequence)))) + (declare (fixnum start)) + (let* ((length (length sequence)) + (end (or end length))) (declare (type index end)) (seq-dispatch sequence - (list-count-if test sequence) - (vector-count-if test sequence)))) - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-count-if-not (predicate sequence) - `(do ((index start (1+ index)) - (count 0)) - ((= index (the fixnum end)) count) - (declare (fixnum index count)) - (if (not (funcall ,predicate (apply-key key (aref ,sequence index)))) - (setq count (1+ count))))) - -(sb!xc:defmacro list-count-if-not (predicate sequence) - `(do ((sequence (nthcdr start ,sequence)) - (index start (1+ index)) - (count 0)) - ((or (= index (the fixnum end)) (null sequence)) count) - (declare (fixnum index count)) - (if (not (funcall ,predicate (apply-key key (pop sequence)))) - (setq count (1+ count))))) - -) ; EVAL-WHEN - + (if from-end + (list-count-if nil t test sequence) + (list-count-if nil nil test sequence)) + (if from-end + (vector-count-if nil t test sequence) + (vector-count-if nil nil test sequence))))) + (defun count-if-not (test sequence &key from-end (start 0) end key) #!+sb-doc "Return the number of elements in SEQUENCE not satisfying TEST(el)." - (declare (ignore from-end) (fixnum start)) - (let ((end (or end (length sequence)))) + (declare (fixnum start)) + (let* ((length (length sequence)) + (end (or end length))) (declare (type index end)) (seq-dispatch sequence - (list-count-if-not test sequence) - (vector-count-if-not test sequence)))) + (if from-end + (list-count-if t t test sequence) + (list-count-if t nil test sequence)) + (if from-end + (vector-count-if t t test sequence) + (vector-count-if t nil test sequence))))) + +(defun count (item sequence &key from-end (start 0) end key (test #'eql test-p) (test-not nil test-not-p)) + #!+sb-doc + "Return the number of elements in SEQUENCE satisfying a test with ITEM, + which defaults to EQL." + (declare (fixnum start)) + (when (and test-p test-not-p) + ;; ANSI Common Lisp has left the behavior in this situation unspecified. + ;; (CLHS 17.2.1) + (error ":TEST and :TEST-NOT are both present.")) + (let* ((length (length sequence)) + (end (or end length))) + (declare (type index end)) + (let ((%test (if test-not-p + (lambda (x) + (not (funcall test-not item x))) + (lambda (x) + (funcall test item x))))) + (seq-dispatch sequence + (if from-end + (list-count-if nil t %test sequence) + (list-count-if nil nil %test sequence)) + (if from-end + (vector-count-if nil t %test sequence) + (vector-count-if nil nil %test sequence)))))) + + ;;;; MISMATCH @@ -2228,7 +2212,7 @@ #!+sb-doc "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared element-wise. If they are of equal length and match in every element, the - result is Nil. Otherwise, the result is a non-negative integer, the index + result is NIL. Otherwise, the result is a non-negative integer, the index within SEQUENCE1 of the leftmost position at which they fail to match; or, if one is shorter than and a matching prefix of the other, the index within SEQUENCE1 beyond the last position tested is returned. If a non-NIL diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 5343ea7..4f9b4e5 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1652,7 +1652,8 @@ (setq ,n-value ,n-value-temp)))))) (when (and (not allowp) (eq keyword :allow-other-keys)) (setq found-allow-p t) - (setq clause (append clause `((setq ,n-allowp ,n-value-temp))))) + (setq clause + (append clause `((setq ,n-allowp ,n-value-temp))))) (temps `(,n-value ,default)) (tests clause))) diff --git a/tests/bug204-test.lisp b/tests/bug204-test.lisp index a1f0fc6..cb97647 100644 --- a/tests/bug204-test.lisp +++ b/tests/bug204-test.lisp @@ -1,4 +1,7 @@ -;;;; Test of EVAL-WHEN inside a local environment +;;;; a test of EVAL-WHEN inside a local environment (which will be +;;;; compiled and loaded, and have its side effects checked, by some +;;;; other file which runs automatically as part of the test suite) + (cl:in-package :cl-user) (macrolet ((def (x) diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp index aa7cef7..a36bb35 100644 --- a/tests/seq.pure.lisp +++ b/tests/seq.pure.lisp @@ -64,3 +64,53 @@ (make-list (- 10 j) :initial-element 'a)))))))) +;;; tests of COUNT +(assert (= 1 (count 1 '(1 2 3)))) +(assert (= 2 (count 'z #(z 1 2 3 z)))) +(assert (= 0 (count 'y '(z 1 2 3 z)))) + +;;; tests of COUNT-IF and COUNT-IF-NOT +(macrolet (;; the guts of CCI, abstracted over whether we're testing + ;; COUNT-IF or COUNT-IF-NOT + (%cci (expected count-if test sequence-as-list &rest keys) + `(let* ((list ',sequence-as-list) + (simple-vector (coerce list 'simple-vector)) + (length (length list)) + (vector (make-array (* 2 length) :fill-pointer length))) + (replace vector list :end1 length) + (dolist (seq (list list simple-vector vector)) + (assert (= ,expected (,count-if ,test seq ,@keys)))))) + ;; "Check COUNT-IF" + (cci (expected test sequence-as-list &rest keys) + `(progn + (format t "~&SEQUENCE-AS-LIST=~S~%" ',sequence-as-list) + (%cci ,expected + count-if + ,test + ,sequence-as-list + ,@keys) + (%cci ,expected + count-if-not + (complement ,test) + ,sequence-as-list + ,@keys)))) + (cci 1 #'consp (1 (12) 1)) + (cci 3 #'consp (1 (2) 3 (4) (5) 6)) + (cci 3 #'consp (1 (2) 3 (4) (5) 6) :from-end t) + (cci 2 #'consp (1 (2) 3 (4) (5) 6) :start 2) + (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 3) + (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 3) + (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 2) + (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 2) + (cci 2 #'zerop (0 10 0 11 12)) + (cci 1 #'zerop (0 10 0 11 12) :start 1) + (cci 2 #'minusp (0 10 0 11 12) :key #'1-) + (cci 1 #'minusp (0 10 0 11 12) :key #'1- :end 2)) +(multiple-value-bind (v e) + (ignore-errors (count-if #'zerop '(0 a 0 b c) :start 1)) + (declare (ignore v)) + (assert (eql (type-error-datum e) 'a))) +(multiple-value-bind (v e) + (ignore-errors (count-if #'zerop #(0 a 0 b c) :start 1 :from-end 11)) + (declare (ignore v)) + (assert (eql (type-error-datum e) 'c))) diff --git a/version.lisp-expr b/version.lisp-expr index d7be55c..8751e86 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.9.29" +"0.7.9.30"