From 94476bde095777523c57d3f1e16e8cbcd8f6a2dd Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sat, 8 Sep 2007 17:35:47 +0000
Subject: [PATCH] 1.0.9.47: VALID-WRAPPER-OF

* Renamed CHECK-OBSOLETE-INSTANCE/WRAPPER-OF, and fixed the semantics
  so that it always returns the fresh wrapper.

* Add FIXME re CHECK-WRAPPER-VALIDITY name.
---
 src/pcl/slots.lisp   |  8 ++++----
 src/pcl/vector.lisp  | 16 ++++------------
 src/pcl/wrapper.lisp | 11 +++++++----
 version.lisp-expr    |  2 +-
 4 files changed, 16 insertions(+), 21 deletions(-)

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index ed6c25ada..f406c6fd9 100644
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -97,7 +97,7 @@
 
 (declaim (ftype (sfunction (t symbol) t) slot-value))
 (defun slot-value (object slot-name)
-  (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+  (let* ((wrapper (valid-wrapper-of object))
          (cell (find-slot-cell wrapper slot-name))
          (location (car cell))
          (value
@@ -128,7 +128,7 @@
       form))
 
 (defun set-slot-value (object slot-name new-value)
-  (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+  (let* ((wrapper (valid-wrapper-of object))
          (cell (find-slot-cell wrapper slot-name))
          (location (car cell))
          (type-check-function (cadr cell)))
@@ -171,7 +171,7 @@
       form))
 
 (defun slot-boundp (object slot-name)
-  (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+  (let* ((wrapper (valid-wrapper-of object))
          (cell (find-slot-cell wrapper slot-name))
          (location (car cell))
          (value
@@ -201,7 +201,7 @@
       form))
 
 (defun slot-makunbound (object slot-name)
-  (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+  (let* ((wrapper (valid-wrapper-of object))
          (cell (find-slot-cell wrapper slot-name))
          (location (car cell)))
     (cond ((fixnump location)
diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 27e6bfee3..4a20240a1 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -923,25 +923,17 @@
   (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
 
 (defun pv-wrappers-from-pv-args (&rest args)
-  (let (wrappers)
-    (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers)))
-      (let ((wrapper (wrapper-of arg)))
-        (push (if (invalid-wrapper-p wrapper)
-                  (check-wrapper-validity wrapper)
-                  wrapper)
-              wrappers)))))
+  (loop for arg in args
+        collect (valid-wrapper-of arg)))
 
 (defun pv-wrappers-from-all-args (pv-table args)
   (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args
         when snl
-          collect (wrapper-of arg) into wrappers
-        finally (return (if (cdr wrappers) wrappers (car wrappers)))))
+        collect (valid-wrapper-of arg)))
 
 ;;; Return the subset of WRAPPERS which is used in the cache
 ;;; of PV-TABLE.
 (defun pv-wrappers-from-all-wrappers (pv-table wrappers)
   (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers
         when snl
-          collect w into result
-        finally (return (if (cdr result) result (car result)))))
-
+        collect w))
diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp
index 49738e538..c204e4f8b 100644
--- a/src/pcl/wrapper.lisp
+++ b/src/pcl/wrapper.lisp
@@ -152,6 +152,9 @@
     (remhash owrapper *previous-nwrappers*)
     (setf (gethash nwrapper *previous-nwrappers*) new-previous)))
 
+;;; FIXME: This is not a good name: part of the constract here is that
+;;; we return the valid wrapper, which is not obvious from the name
+;;; (or the names of our callees.)
 (defun check-wrapper-validity (instance)
   (let* ((owrapper (wrapper-of instance))
          (state (layout-invalid owrapper)))
@@ -188,11 +191,11 @@
   (when (invalid-wrapper-p (layout-of instance))
     (check-wrapper-validity instance)))
 
-(defun check-obsolete-instance/wrapper-of (instance)
+(defun valid-wrapper-of (instance)
   (let ((wrapper (wrapper-of instance)))
-    (when (invalid-wrapper-p wrapper)
-      (check-wrapper-validity instance))
-    wrapper))
+    (if (invalid-wrapper-p wrapper)
+	(check-wrapper-validity instance)
+	wrapper)))
 
 ;;;  NIL: means nothing so far, no actual arg info has NILs in the
 ;;;  metatype.
diff --git a/version.lisp-expr b/version.lisp-expr
index b1458fb8c..1c077461f 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.9.46"
+"1.0.9.47"
-- 
2.11.4.GIT