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

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 6142e0b..088394c 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -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))))))))))))
 \f
 ;;; 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

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index dbdc0a5..2b6ba93 100644 (file)
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -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 ())

diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp
index 0abbdea..3bc5349 100644 (file)
--- a/tests/list.pure.lisp
+++ b/tests/list.pure.lisp
@@ -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)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 635883e..d9b7712 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.42"
+"0.7.9.43"