Permalink
Browse files

0.7.9.43:

        * Fixed bug NCONC-6: last argument of NCONC may be any object
        * APPEND signals TYPE-ERROR if any of its arguments but the
          last is not a list
  • Loading branch information...
Alexey Dejneka
Alexey Dejneka committed Nov 12, 2002
1 parent a96369c commit 1aefe68236aaf048ce602e7725ad26d130be1fd5
Showing with 102 additions and 56 deletions.
  1. +61 −53 src/code/list.lisp
  2. +7 −2 src/compiler/fndb.lisp
  3. +33 −0 tests/list.pure.lisp
  4. +1 −1 version.lisp-expr
View
@@ -259,34 +259,38 @@
(defun append (&rest lists)
#!+sb-doc
"Construct a new list by concatenating the list arguments"
(do ((top lists (cdr top))) ;;Cdr to first non-null list.
((atom top) '())
(cond ((null (car top))) ; Nil -> Keep looping
((not (consp (car top))) ; Non cons
(if (cdr top)
(error "~S is not a list." (car top))
(return (car top))))
(t ; Start appending
(return
(if (atom (cdr top))
(car top) ;;Special case.
(let* ((result (cons (caar top) '()))
(splice result))
(do ((x (cdar top) (cdr x))) ;;Copy first list
((atom x))
(setq splice
(cdr (rplacd splice (cons (car x) ()) ))) )
(do ((y (cdr top) (cdr y))) ;;Copy rest of lists.
((atom (cdr y))
(setq splice (rplacd splice (car y)))
result)
(if (listp (car y))
(do ((x (car y) (cdr x))) ;;Inner copy loop.
((atom x))
(setq
splice
(cdr (rplacd splice (cons (car x) ())))))
(error "~S is not a list." (car y)))))))))))
(flet ((fail (object)
(error 'type-error
:datum object
:expected-type 'list)))
(do ((top lists (cdr top))) ; CDR to first non-null list.
((atom top) '())
(cond ((null (car top))) ; NIL -> Keep looping
((not (consp (car top))) ; Non CONS
(if (cdr top)
(fail (car top))
(return (car top))))
(t ; Start appending
(return
(if (atom (cdr top))
(car top) ; Special case.
(let* ((result (cons (caar top) '()))
(splice result))
(do ((x (cdar top) (cdr x))) ; Copy first list
((atom x))
(setq splice
(cdr (rplacd splice (cons (car x) ()) ))) )
(do ((y (cdr top) (cdr y))) ; Copy rest of lists.
((atom (cdr y))
(setq splice (rplacd splice (car y)))
result)
(if (listp (car y))
(do ((x (car y) (cdr x))) ; Inner copy loop.
((atom x))
(setq
splice
(cdr (rplacd splice (cons (car x) ())))))
(fail (car y))))))))))))
;;; list copying functions
@@ -361,31 +365,35 @@
(defun nconc (&rest lists)
#!+sb-doc
"Concatenates the lists given as arguments (by changing them)"
(do ((top lists (cdr top)))
((null top) nil)
(let ((top-of-top (car top)))
(typecase top-of-top
(cons
(let* ((result top-of-top)
(splice result))
(do ((elements (cdr top) (cdr elements)))
((endp elements))
(let ((ele (car elements)))
(typecase ele
(cons (rplacd (last splice) ele)
(setf splice ele))
(null (rplacd (last splice) nil))
(atom (if (cdr elements)
(error "Argument is not a list -- ~S." ele)
(rplacd (last splice) ele)))
(t (error "Argument is not a list -- ~S." ele)))))
(return result)))
(null)
(atom
(if (cdr top)
(error "Argument is not a list -- ~S." top-of-top)
(return top-of-top)))
(t (error "Argument is not a list -- ~S." top-of-top))))))
(flet ((fail (object)
(error 'type-error
:datum object
:expected-type 'list)))
(do ((top lists (cdr top)))
((null top) nil)
(let ((top-of-top (car top)))
(typecase top-of-top
(cons
(let* ((result top-of-top)
(splice result))
(do ((elements (cdr top) (cdr elements)))
((endp elements))
(let ((ele (car elements)))
(typecase ele
(cons (rplacd (last splice) ele)
(setf splice ele))
(null (rplacd (last splice) nil))
(atom (if (cdr elements)
(fail ele)
(rplacd (last splice) ele)))
(t (fail ele)))))
(return result)))
(null)
(atom
(if (cdr top)
(fail top-of-top)
(return top-of-top)))
(t (fail top-of-top)))))))
(defun nreconc (x y)
#!+sb-doc
View
@@ -667,14 +667,19 @@
(movable flushable unsafe))
;;; All but last must be of type LIST, but there seems to be no way to
;;; express that in this syntax..
;;; express that in this syntax.
(defknown append (&rest t) t (flushable))
(defknown copy-list (list) list (flushable))
(defknown copy-alist (list) list (flushable))
(defknown copy-tree (t) t (flushable recursive))
(defknown revappend (list t) t (flushable))
(defknown nconc (&rest list) list ())
;;; All but last must be of type LIST, but there seems to be no way to
;;; express that in this syntax. The result must be LIST, but we do
;;; not check it now :-).
(defknown nconc (&rest t) t ())
(defknown nreconc (list t) list ())
(defknown butlast (list &optional index) list (flushable))
(defknown nbutlast (list &optional index) list ())
View
@@ -72,3 +72,36 @@
(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)))))
(multiple-value-bind (result error)
(ignore-errors (append 1 2))
(assert (null result))
(assert (typep error 'type-error)))
View
@@ -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.42"
"0.7.9.43"

0 comments on commit 1aefe68

Please sign in to comment.