From 22c592cbf7e81e78ceaef80d1c15ad7a7fc3b40a Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Mon, 20 May 2013 01:03:01 -0400 Subject: [PATCH] Fix (CONCATENATE 'null ...) for generic sequences * (CONCATENATE 'NULL SEQUENCE1 SEQUENCE2 ...) ensures that SEQUENCE1, SEQUENCE2, ... are empty, but only did so for lists and vectors. Instead, use new function EMPTYP which works for all sequences. EMPTYP is not exported. * Add generic function SEQUENCE:EMPTYP to which EMPTYP dispatches for generic sequences. Methods for lists, vectors and generic sequences use NULL or (ZEROP (LENGTH ...)). * Test cases in seq.impure.lisp. * Patch by Jan Moringen; fixes lp#1162301. --- NEWS | 2 ++ package-data-list.lisp-expr | 2 +- src/code/seq.lisp | 22 ++++++++++++++-------- src/pcl/sequence.lisp | 5 +++++ tests/seq.impure.lisp | 28 ++++++++++++++++++++++++++-- 5 files changed, 48 insertions(+), 11 deletions(-) diff --git a/NEWS b/NEWS index 105f6e5..11a6507 100644 --- a/NEWS +++ b/NEWS @@ -59,6 +59,8 @@ changes relative to sbcl-1.1.7: recursion no longer causes undescriptive compiler errors. (lp#1180992) * bug fix: sub-word BOOLEAN alien types now disregard higher order bits when testing for non-zero-ness. + * bug fix: (CONCATENATE 'null ...) no longer fails for generic sequences. + (lp#1162301) * optimization: faster ISQRT on fixnums and small bignums * optimization: faster and smaller INTEGER-LENGTH on fixnums on x86-64. * optimization: On x86-64, the number of multi-byte NOP instructions used diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2731792..4b8befe 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2334,7 +2334,7 @@ be submitted as a CDR" "CANONIZE-TEST" "CANONIZE-KEY" - "LENGTH" "ELT" + "EMPTYP" "LENGTH" "ELT" "MAKE-SEQUENCE-LIKE" "ADJUST-SEQUENCE" "COUNT" "COUNT-IF" "COUNT-IF-NOT" diff --git a/src/code/seq.lisp b/src/code/seq.lisp index f2f9cd4..2cd9d52 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -266,6 +266,16 @@ :type '(and list (satisfies list-length))))) + +(defun emptyp (sequence) + #!+sb-doc + "Returns T if SEQUENCE is an empty sequence and NIL + otherwise. Signals an error if SEQUENCE is not a sequence." + (seq-dispatch sequence + (null sequence) + (zerop (length sequence)) + (sb!sequence:emptyp sequence))) + (defun elt (sequence index) #!+sb-doc "Return the element of SEQUENCE specified by INDEX." (seq-dispatch sequence @@ -851,14 +861,10 @@ many elements are copied." ((eq type *empty-type*) (bad-sequence-type-error nil)) ((type= type (specifier-type 'null)) - (if (every (lambda (x) (or (null x) - (and (vectorp x) (= (length x) 0)))) - sequences) - 'nil - (sequence-type-length-mismatch-error - type - ;; FIXME: circular list issues. - (reduce #'+ sequences :key #'length)))) + (unless (every #'emptyp sequences) + (sequence-type-length-mismatch-error + type (reduce #'+ sequences :key #'length))) ; FIXME: circular list issues. + '()) ((cons-type-p type) (multiple-value-bind (min exactp) (sb!kernel::cons-type-length-info type) diff --git a/src/pcl/sequence.lisp b/src/pcl/sequence.lisp index 7dc5904..89912ad 100644 --- a/src/pcl/sequence.lisp +++ b/src/pcl/sequence.lisp @@ -17,6 +17,11 @@ (error 'sequence::protocol-unimplemented :datum sequence :expected-type '(or list vector))) +(defgeneric sequence:emptyp (sequence) + (:method ((s list)) (null s)) + (:method ((s vector)) (zerop (length s))) + (:method ((s sequence)) (zerop (length s)))) + (defgeneric sequence:length (sequence) (:method ((s list)) (length s)) (:method ((s vector)) (length s)) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index e497115..9616cde 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -21,6 +21,8 @@ (in-package :seq-test) +;;; user-defined mock sequence class for testing generic versions of +;;; sequence functions. (defclass list-backed-sequence (standard-object sequence) ((elements :initarg :elements :type list :accessor %elements))) @@ -133,6 +135,12 @@ (assert (eql 4 ; modified more, avoids charset technicalities completely (find 5 '(6 4) :test '>))) +(with-test (:name sequence:emptyp) + (for-every-seq #() + '((eq t (sequence:emptyp seq)))) + (for-every-seq #(1) + '((eq nil (sequence:emptyp seq))))) + ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too) (for-every-seq #() @@ -327,6 +335,24 @@ ;; ... though not in all cases. (assert-type-error (coerce '(#\f #\o #\o) 'simple-array)))) +;; CONCATENATE used to fail for generic sequences for result-type NULL. +(with-test (:name (concatenate :result-type-null :bug-1162301)) + (assert (sequence:emptyp (concatenate 'null))) + + (for-every-seq #() + '((sequence:emptyp (concatenate 'null seq)) + (sequence:emptyp (concatenate 'null seq seq)) + (sequence:emptyp (concatenate 'null seq #())) + (sequence:emptyp (concatenate 'null seq "")))) + + (for-every-seq #(1) + (mapcar (lambda (form) + `(typep (nth-value 1 (ignore-errors ,form)) 'type-error)) + '((concatenate 'null seq) + (concatenate 'null seq seq) + (concatenate 'null seq #()) + (concatenate 'null seq "2"))))) + ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues ;;; with user-defined types until sbcl-0.7.8.11 (deftype list-typeoid () 'list) @@ -375,10 +401,8 @@ 4)) (assert-type-error (merge 'nil () () '<)) ;; CONCATENATE - (assert-type-error (concatenate 'null '(1) "2")) (assert-type-error (concatenate 'cons #() ())) (assert-type-error (concatenate '(cons t null) #(1 2 3) #(4 5 6))) - (assert (null (concatenate 'null () #()))) (assert (= (length (concatenate 'cons #() '(1) "2 3")) 4)) (assert (= (length (concatenate '(cons t cons) '(1) "34")) 3)) (assert-type-error (concatenate 'nil '(3))) -- 1.7.10.4