From 8ca3c25b1eb655d1d731fae8e151cdad7ea384b3 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 5 Oct 2004 21:57:27 +0000
Subject: [PATCH] Don't use NTH to determine if a list is a named structure
 because the list may not be a proper list.  Instead, use a special version of
 NTHCDR that will exit early if we reach the end of a non-proper list.

---
 code/defstruct.lisp | 21 +++++++++++++++++++--
 1 file changed, 19 insertions(+), 2 deletions(-)

diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index d3a2f2191..4a68ec8de 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.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/defstruct.lisp,v 1.94 2004/09/03 03:05:58 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.95 2004/10/05 21:57:27 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1272,12 +1272,29 @@
 	(if (eq ltype 'list)
 	    `((defun ,pred (object)
 		(and (typep object 'list)
-		     (eq (nth ,index object) ',name))))
+		     (defstruct-list-p ,index object ',name))))
 	    `((defun ,pred (object)
 		(and (typep object 'vector)
 		     (array-in-bounds-p object ,index)
 		     (eq (aref object ,index) ',name)))))))))
 
+;; A predicate to determine if the given list is a defstruct object of
+;; :type list.  This used to be done using (eq (nth index object)
+;; name), but that fails if the (nth index object) doesn't work
+;; because object is not a proper list.
+(defun defstruct-list-p (index list name)
+  ;; Basically do (nth index list), but don't crash if the list is not
+  ;; a proper list.
+  (declare (type index index)
+	   (type list list))
+  (do ((i index (1- i))
+       (result list (cdr result)))
+      ((or (atom result) (not (plusp i)))
+       (unless (atom result)
+	 (eq (car result) name)))
+    (declare (type index i))))
+
+
 
 ;;;; Load time support for default structures (%DEFSTRUCT)
 ;;;
-- 
GitLab