From 6f1507bc47503d08288c72426b4e42011d909725 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sat, 8 Mar 2003 12:02:10 +0000 Subject: [PATCH] 0.7.13.20: Fixed APPEND.ERROR.1. --- NEWS | 1 + src/code/list.lisp | 63 ++++++++++++++++++++++---------------------------- tests/list.pure.lisp | 11 +++++---- version.lisp-expr | 2 +- 4 files changed, 36 insertions(+), 41 deletions(-) diff --git a/NEWS b/NEWS index 9d069f5..52fc2aa 100644 --- a/NEWS +++ b/NEWS @@ -1589,6 +1589,7 @@ changes in sbcl-0.7.14 relative to sbcl-0.7.13: types got intertwined, has been fixed; ** the type system is now able to reason about the interaction between INTEGER and RATIO types more completely; + ** APPEND checks its arguments for being proper lists; * fixed CEILING optimization for a divisor of form 2^k. * fixed bug 240 (emitting extra style warnings "using the lexical binding of the symbol *XXX*" for &OPTIONAL arguments). (reported diff --git a/src/code/list.lisp b/src/code/list.lisp index cacffe8..8bc2a88 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -257,45 +257,36 @@ ((zerop count) result) (declare (type index count)))) -;;; The outer loop finds the first non-null list and the result is -;;; started. The remaining lists in the arguments are tacked to the -;;; end of the result using splice which cdr's down the end of the new -;;; list. (defun append (&rest lists) #!+sb-doc "Construct a new list by concatenating the list arguments" - (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)))))))))))) + (labels ((fail (object) + (error 'type-error + :datum object + :expected-type 'list)) + (append-into (last-cons current rest) + "Set (CDR LAST-CONS) to (APPLY #'APPEND CURRENT REST)." + (declare (cons last-cons rest)) + (cond ((consp current) + (append-into (setf (cdr last-cons) (list (car current))) + (cdr current) + rest)) + ((not (null current)) (fail current)) + ((null (cdr rest)) (setf (cdr last-cons) (car rest))) + (t (append-into last-cons (car rest) (cdr rest))))) + (append1 (lists) + (let ((current (car lists)) + (rest (cdr lists))) + (cond ((null rest) current) + ((consp current) + (let ((result (truly-the cons (list (car current))))) + (append-into result + (cdr current) + rest) + result)) + ((null current) (append1 rest)) + (t (fail current)))))) + (append1 lists))) ;;;; list copying functions diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp index 3bc5349..cb93d28 100644 --- a/tests/list.pure.lisp +++ b/tests/list.pure.lisp @@ -101,7 +101,10 @@ 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))) +(dolist (test '((1 2) + ((1 2) nil (3 . 4) nil) + (nil (1 2) nil (3 . 4) nil))) + (multiple-value-bind (result error) + (ignore-errors (apply 'append test)) + (assert (null result)) + (assert (typep error 'type-error)))) diff --git a/version.lisp-expr b/version.lisp-expr index 8fc625c..eed2ce6 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.13.19" +"0.7.13.20" -- 1.7.10.4