From 1aefe68236aaf048ce602e7725ad26d130be1fd5 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Tue, 12 Nov 2002 08:32:17 +0000 Subject: [PATCH] 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 --- src/code/list.lisp | 114 ++++++++++++++++++++++++++----------------------- src/compiler/fndb.lisp | 9 +++- tests/list.pure.lisp | 33 ++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 102 insertions(+), 56 deletions(-) diff --git a/src/code/list.lisp b/src/code/list.lisp index 6142e0b4b..088394cc4 100644 --- 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)))))))))))) ;;; 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 dbdc0a568..2b6ba93a1 100644 --- 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 0abbdea90..3bc5349cf 100644 --- 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 635883e37..d9b7712e7 100644 --- 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" -- 2.11.4.GIT