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 (file)
--- 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))
-\f
-;;;; 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))))
 \f
-;;;; 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))))))
+
+
 \f
 ;;;; 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"