X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Flist.pure.lisp;h=ce4ec85adc7e56889fd29a171ba1e0658d523f3a;hb=aa8c8cd473f1d487fa2c1a7490c78a59b9955bbe;hp=e898b542a8bbb650abadef0f62594ce9a1c31af2;hpb=8a3bbf707f43fd95bc3025e3f222563c36b599fd;p=sbcl.git diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp index e898b54..ce4ec85 100644 --- a/tests/list.pure.lisp +++ b/tests/list.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -18,36 +18,121 @@ ;;; looks as though it's past time to start accumulating regression ;;; tests for these. (dolist (testcase - '((:args ((1 2 3 4 5)) :result (1 2 3 4)) - (:args ((1 2 3 4 5) 6) :result nil) - (:args (nil) :result nil) - (:args (t) :result nil) - (:args (foosymbol 0) :result foosymbol) - (:args (foosymbol) :result nil) - (:args (foosymbol 1) :result nil) - (:args (foosymbol 2) :result nil) - (:args ((1 2 3) 0) :result (1 2 3)) - (:args ((1 2 3) 1) :result (1 2)) - (:args ((1 2 3)) :result (1 2)) - (:args ((1 2 3) 2) :result (1)) - (:args ((1 2 3) 3) :result nil) - (:args ((1 2 3) 4) :result nil) - (:args ((1 2 3 . 4) 0) :result (1 2 3 . 4)) - (:args ((1 2 3 . 4) 1) :result (1 2)) - (:args ((1 2 3 . 4)) :result (1 2)) - (:args ((1 2 3 . 4) 2) :result (1)) - (:args ((1 2 3 . 4) 3) :result nil) - (:args ((1 2 3 . 4) 4) :result nil))) + '((:args ((1 2 3 4 5)) :result (1 2 3 4)) + (:args ((1 2 3 4 5) 6) :result nil) + (:args (nil) :result nil) + (:args ((1 2 3) 0) :result (1 2 3)) + (:args ((1 2 3) 1) :result (1 2)) + (:args ((1 2 3)) :result (1 2)) + (:args ((1 2 3) 2) :result (1)) + (:args ((1 2 3) 3) :result nil) + (:args ((1 2 3) 4) :result nil) + (:args ((1 2 3 . 4) 0) :result (1 2 3 . 4)) + (:args ((1 2 3 . 4) 1) :result (1 2)) + (:args ((1 2 3 . 4)) :result (1 2)) + (:args ((1 2 3 . 4) 2) :result (1)) + (:args ((1 2 3 . 4) 3) :result nil) + (:args ((1 2 3 . 4) 4) :result nil))) (destructuring-bind (&key args result) testcase (destructuring-bind (list &rest rest) args ;; Test with BUTLAST. (let ((actual-result (apply #'butlast args))) - (when (and (consp list) (eq actual-result list)) - (error "not a copy in BUTLAST for ~S" args)) - (unless (equal actual-result result) - (error "failed BUTLAST for ~S" args))) + (when (and (consp list) (eq actual-result list)) + (error "not a copy in BUTLAST for ~S" args)) + (unless (equal actual-result result) + (error "failed BUTLAST for ~S" args))) ;; Test with NBUTLAST. (let* ((copied-list (copy-list list)) - (actual-result (apply #'nbutlast copied-list rest))) - (unless (equal actual-result result) - (error "failed NBUTLAST for ~S" args)))))) + (actual-result (apply #'nbutlast copied-list rest))) + (unless (equal actual-result result) + (error "failed NBUTLAST for ~S" args)))))) + +(multiple-value-bind (result error) + (ignore-errors (apply #'butlast (list t))) + (assert (null result)) + (assert (typep error 'type-error))) + +;;; reported by Paul Dietz on cmucl-imp: LDIFF does not check type of +;;; its first argument +(assert (not (ignore-errors (ldiff 1 2)))) + +;;; evaluation order in PUSH, PUSHNEW +(let ((a (map 'vector #'list '(a b c)))) + (let ((i 0)) + (pushnew (incf i) (aref a (incf i))) + (assert (equalp a #((a) (b) (1 c)))))) + +(symbol-macrolet ((s (aref a (incf i)))) + (let ((a (map 'vector #'list '(a b c)))) + (let ((i 0)) + (push t s) + (assert (equalp a #((a) (t b) (c)))) + (pushnew 1 s) + (assert (equalp a #((a) (t b) (1 c)))) + (setq i 0) + (assert (eql (pop s) 't)) + (assert (equalp a #((a) (b) (1 c))))))) + +;;; Type checking in NCONC +(let ((tests '((((1 . 2)) (1 . 2)) + (((1 . 2) (3 . 4)) (1 3 . 4)) + (((1 . 2) 3) (1 . 3)) + ((3) 3)))) + (loop for (args result) in tests + do (assert (equal (apply 'nconc (copy-tree args)) result)) + do (let ((exp `(nconc ,@ (mapcar (lambda (arg) + `(copy-tree ',arg)) + args)))) + (assert (equal (funcall (compile nil `(lambda () ,exp))) result))))) + +(let ((tests '(((3 (1 . 2)) 3) + (((1 . 2) 3 (4 . 5)) 3)))) + (macrolet ((check-error (form failed-arg) + `(multiple-value-bind (.result. .error.) + (ignore-errors ,form) + (assert (null .result.)) + (assert (typep .error. 'type-error)) + (assert (eq (type-error-expected-type .error.) 'list)) + (assert (equal (type-error-datum .error.) ,failed-arg))))) + (loop for (args fail) in tests + do (check-error (apply #'nconc (copy-tree args)) fail) + do (let ((exp `(nconc ,@ (mapcar (lambda (arg) + `(copy-tree ',arg)) + args)))) + (check-error (funcall (compile nil `(lambda () ,exp))) fail))))) + +(dolist (test '((append 1 2) + (append (1 2) nil (3 . 4) nil) + (append nil (1 2) nil (3 . 4) nil) + (reverse (1 2 . 3)) + (nreverse (1 2 . 3)) + (nreconc (1 2 . 3) (4 5)) + (copy-alist ((1 . 2) (3 . 4) . 5)))) + (assert (raises-error? (apply (first test) (copy-tree (rest test))) + type-error))) + +;;; Bug reported by Paul Dietz: NSET-EXCLUSIVE-OR should not return +;;; extra elements, even when given "sets" contain duplications +(assert (equal (remove-duplicates (sort (nset-exclusive-or (list 1 2 1 3) + (list 4 1 3 3)) + #'<)) + '(2 4))) + +;;; Bug reported by Adam Warner: valid list index designator is not +;;; necessary a fixnum +(let ((s (read-from-string "(a . #1=(b c . #1#))"))) + (assert (eq (nth (* 1440 most-positive-fixnum) s) 'c)) + (setf (nth (* 1440 most-positive-fixnum) s) 14) + (assert (eq (nth (* 1440 most-positive-fixnum) s) 14))) + +(let ((s (copy-list '(1 2 3)))) + (assert (eq s (last s (* 1440 most-positive-fixnum)))) + (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))))