X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Flist.pure.lisp;h=555b0c2b0948395fb5c32e04da531a9a47ae8dd6;hb=23a229276c2447a658b7a30217ec774067c27d5e;hp=4e61a7cd66a9c444af15e6b2c1a5531d671a47b6;hpb=1ac7e7c95d8badd4ff01d676dffece6b710cea13;p=sbcl.git diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp index 4e61a7c..555b0c2 100644 --- a/tests/list.pure.lisp +++ b/tests/list.pure.lisp @@ -130,12 +130,8 @@ (assert (null (butlast s (* 1440 most-positive-fixnum)))) (assert (null (nbutlast s (* 1440 most-positive-fixnum))))) -;;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a -;;; alist -(let ((f (compile nil '(lambda (x) - (assoc x '(nil (a . b) nil (nil . c) (c . d)) - :test #'eq))))) - (assert (equal (funcall f 'nil) '(nil . c)))) +(assert (eq :atom (last (list* 1 2 3 :atom) (eval 0)))) +(assert (eq :atom (last (list* 1 2 3 :atom) 0))) ;;; enforce lists in symbol-plist (let ((s (gensym)) @@ -151,32 +147,137 @@ (macrolet ((test (expected form) `(progn - (assert (eq ,expected (funcall fun ,@(cdr form)))) - (assert (eq ,expected (funcall (lambda () - (declare (optimize speed)) - ,form)))) - (assert (eq ,expected (funcall (lambda () - (declare (optimize space)) - ,form))))))) - (let ((numbers '(1 2)) + (assert (equal ,expected (let ((numbers '(1 2))) + (funcall fun ,@(cdr form))))) + (assert (equal ,expected (funcall (lambda () + (declare (optimize speed)) + (let ((numbers '(1 2))) + ,form))))) + (assert (equal ,expected (funcall (lambda () + (declare (optimize space)) + (let ((numbers '(1 2))) + ,form)))))))) + (let ((x-numbers '(1 2)) (fun (car (list 'member)))) - (test numbers (member 1 numbers)) - (test (cdr numbers) (member 2 numbers)) + (test x-numbers (member 1 numbers)) + (test x-numbers (member 1 numbers :key 'identity)) + (test x-numbers (member 1 numbers :key #'identity)) + (test (cdr x-numbers) (member 2 numbers)) (test nil (member 1.0 numbers )) - (test numbers (member 1.0 numbers :test #'=)) - (test numbers (member 1.0 numbers :test #'= :key nil)) - (test (cdr numbers) (member 2.0 numbers :test '=)) + (test x-numbers (member 1.0 numbers :test #'=)) + (test x-numbers (member 1.0 numbers :test #'= :key nil)) + (test (cdr x-numbers) (member 2.0 numbers :test '=)) (test nil (member 0 numbers :test '=)) - (test numbers (member 0 numbers :test-not #'>)) - (test (cdr numbers) (member 1 numbers :test-not 'eql)) + (test x-numbers (member 0 numbers :test-not #'>)) + (test (cdr x-numbers) (member 1 numbers :test-not 'eql)) (test nil (member 0 numbers :test-not '<)) - (test numbers (member -1 numbers :key #'-)) - (test (cdr numbers) (member -2 numbers :key '-)) + (test x-numbers (member -1 numbers :key #'-)) + (test (cdr x-numbers) (member -2 numbers :key '-)) (test nil (member -1.0 numbers :key #'-)) - (test numbers (member -1.0 numbers :key #'- :test '=)) - (test (cdr numbers) (member -2.0 numbers :key #'- :test '=)) + (test x-numbers (member -1.0 numbers :key #'- :test '=)) + (test (cdr x-numbers) (member -2.0 numbers :key #'- :test '=)) (test nil (member -1.0 numbers :key #'- :test 'eql)))) + +;;; assoc + +(macrolet ((test (expected form) + (let ((numbers '((1 a) (2 b))) + (tricky '(nil (a . b) nil (nil . c) (c . d)))) + `(progn + (assert (equal ',expected (let ((numbers ',numbers) + (tricky ',tricky)) + (funcall fun ,@(cdr form))))) + (assert (equal ',expected (funcall (lambda () + (declare (optimize speed)) + (let ((numbers ',numbers) + (tricky ',tricky)) + ,form))))) + (assert (equal ',expected (funcall (lambda () + (declare (optimize space)) + (let ((numbers ',numbers) + (tricky ',tricky)) + ,form))))))))) + (let ((fun (car (list 'assoc)))) + (test (1 a) (assoc 1 numbers)) + (test (2 b) (assoc 2 numbers)) + (test (1 a) (assoc 1 numbers :key 'identity)) + (test (2 b) (assoc 2 numbers :key #'identity)) + (test nil (assoc 1.0 numbers)) + + (test (1 a) (assoc 1.0 numbers :test #'=)) + (test (1 a) (assoc 1.0 numbers :test #'= :key nil)) + (test (2 b) (assoc 2.0 numbers :test '=)) + (test nil (assoc 0 numbers :test '=)) + + (test (1 a) (assoc 0 numbers :test-not #'>)) + (test (2 b) (assoc 1 numbers :test-not 'eql)) + (test nil (assoc 0 numbers :test-not '<)) + + (test (1 a) (assoc -1 numbers :key #'-)) + (test (2 b) (assoc -2 numbers :key '-)) + (test nil (assoc -1.0 numbers :key #'-)) + + (test (1 a) (assoc -1.0 numbers :key #'- :test '=)) + (test (2 b) (assoc -2.0 numbers :key #'- :test '=)) + (test nil (assoc -1.0 numbers :key #'- :test 'eql)) + + ;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a + ;; alist + (test (nil . c) (assoc nil tricky :test #'eq)))) + +;;; bug reported by Dan Corkill: *PRINT-CASE* affected the compiler transforms +;;; for ASSOC & MEMBER +(let ((*print-case* :downcase)) + (assert (eql 2 (cdr (funcall (compile nil '(lambda (i l) (assoc i l))) + :b '((:a . 1) (:b . 2)))))) + (assert (equal '(3 4 5) (funcall (compile nil '(lambda (i l) (member i l))) + 3 '(1 2 3 4 5))))) + +;;; bad bounding index pair to SUBSEQ on a list +(let ((list (list 0 1 2 3 4 5))) + (multiple-value-bind (res err) (ignore-errors (subseq list 4 2)) + (assert (not res)) + (assert (typep err 'sb-kernel:bounding-indices-bad-error)))) + +;;; ADJOIN must apply key to item as well +(assert (equal '((:b)) (funcall + (compile nil '(lambda (x y) (adjoin x y :key #'car :test #'string=))) + (list 'b) (list '(:b))))) +(assert (equal '((:b)) + (let ((sb-ext:*evaluator-mode* :interpret)) + (eval '(adjoin (list 'b) (list '(:b)) :key #'car :test #'string=))))) + +;;; constant list argument to ADJOIN +(assert (equal '(:x :y) (funcall + (compile nil '(lambda (elt) + (declare (optimize speed)) + (adjoin elt '(:x :y)))) + ':x))) +(assert (equal '(:x :y) (funcall + (compile nil '(lambda (elt) + (declare (optimize speed)) + (adjoin elt '(:y)))) + ':x))) + + +(macrolet ((test (expected list-1 list-2 &rest args) + `(progn + (assert (equal ,expected (funcall #'union ,list-1 ,list-2 ,@args))) + (assert (equal ,expected (funcall #'nunion + (copy-list ,list-1) + (copy-list ,list-2) + ,@args)))))) + (test nil nil nil) + (test '(42) nil '(42)) + (test '(42) '(42) nil) + (test '(42) '(42) '(42)) + (test '((42) (42)) '((42)) '((42))) + (test '((42) (42)) '((42)) '((42)) :test-not #'equal) + (test '((42)) '((42)) '((42)) :test #'equal) + (test '((42)) '((42)) '((42)) :key #'car) + (test '((42)) '((42)) '((42)) :key #'car :test-not #'<)) +