From 32677b404dc3a20940e9b6f7226237ef1afed6e2 Mon Sep 17 00:00:00 2001 From: toy <toy> Date: Sat, 19 Apr 2003 15:24:02 +0000 Subject: [PATCH] Make append and copy-alist check for improper (dotted) lists. --- code/list.lisp | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/code/list.lisp b/code/list.lisp index fc88199f2..e1b44915e 100644 --- a/code/list.lisp +++ b/code/list.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/list.lisp,v 1.28 2003/04/18 12:00:37 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/list.lisp,v 1.29 2003/04/19 15:24:02 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -215,6 +215,14 @@ (declare (type index count)))) +;; Signal a simple-type-error that LIST is not a proper list. +(defun not-proper-list-error (list) + (error 'simple-type-error + :datum list + :expected-type 'list + :format-control "~S is not a proper list" + :format-arguments (list list))) + ;;; 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 @@ -235,7 +243,9 @@ (let* ((result (cons (caar top) '())) (splice result)) (do ((x (cdar top) (cdr x))) ;;Copy first list - ((atom x)) + ((atom x) + (unless (null x) + (not-proper-list-error (car top)))) (setq splice (cdr (rplacd splice (cons (car x) ()) ))) ) (do ((y (cdr top) (cdr y))) ;;Copy rest of lists. @@ -244,7 +254,9 @@ result) (if (listp (car y)) (do ((x (car y) (cdr x))) ;;Inner copy loop. - ((atom x)) + ((atom x) + (unless (null x) + (not-proper-list-error (car y)))) (setq splice (cdr (rplacd splice (cons (car x) ()))))) @@ -287,10 +299,9 @@ (car x) (cons (caar x) (cdar x))) nil))))) - ;; Non-null terminated alist done here. ((atom x) (unless (null x) - (rplacd splice x)))) + (not-proper-list-error alist)))) result))) (defun copy-tree (object) @@ -352,7 +363,12 @@ (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st))) (2nd x 1st) ;2nd follows first down the list. (3rd y 2nd)) ;3rd follows 2nd down the list. - ((atom 2nd) 3rd) + ((atom 2nd) + (if 2nd + (error 'simple-type-error + :format-control "First argument is not a proper list." + :format-arguments nil) + 3rd)) (rplacd 2nd 3rd))) (defun butlast (list &optional (n 1)) -- GitLab