X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=e6006942ec8b0bc4b01a83fb4b50a3fc8a5bdb37;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=7b6fb1a18c8db15e2e7bbe9a4629e4d18996cf9b;hpb=0ee1135a83da462e6de2a98bb2eff837b278f926;p=sbcl.git

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 7b6fb1a..e600694 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -513,9 +513,6 @@ bootstrapping.
     (sb-c:source-location)))
 
 (defmacro make-method-function (method-lambda &environment env)
-  (make-method-function-internal method-lambda env))
-
-(defun make-method-function-internal (method-lambda &optional env)
   (multiple-value-bind (proto-gf proto-method)
       (prototypes-for-make-method-lambda nil)
     (multiple-value-bind (method-function-lambda initargs)
@@ -578,14 +575,170 @@ bootstrapping.
   (setf (gdefinition 'make-method-initargs-form)
         (symbol-function 'real-make-method-initargs-form)))
 
+;;; When bootstrapping PCL MAKE-METHOD-LAMBDA starts out as a regular
+;;; functions: REAL-MAKE-METHOD-LAMBDA set to the fdefinition of
+;;; MAKE-METHOD-LAMBDA. Once generic functions are born, the
+;;; REAL-MAKE-METHOD lambda is used as the body of the default method.
+;;; MAKE-METHOD-LAMBDA-INTERNAL is split out into a separate function
+;;; so that changing it in a live image is easy, and changes actually
+;;; take effect.
 (defun real-make-method-lambda (proto-gf proto-method method-lambda env)
-  (declare (ignore proto-gf proto-method))
-  (make-method-lambda-internal method-lambda env))
+  (make-method-lambda-internal proto-gf proto-method method-lambda env))
 
 (unless (fboundp 'make-method-lambda)
   (setf (gdefinition 'make-method-lambda)
         (symbol-function 'real-make-method-lambda)))
 
+(defun make-method-lambda-internal (proto-gf proto-method method-lambda env)
+  (declare (ignore proto-gf proto-method))
+  (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
+    (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
+            is not a lambda form."
+           method-lambda))
+  (multiple-value-bind (real-body declarations documentation)
+      (parse-body (cddr method-lambda))
+    (let* ((name-decl (get-declaration '%method-name declarations))
+           (sll-decl (get-declaration '%method-lambda-list declarations))
+           (method-name (when (consp name-decl) (car name-decl)))
+           (generic-function-name (when method-name (car method-name)))
+           (specialized-lambda-list (or sll-decl (cadr method-lambda)))
+           ;; the method-cell is a way of communicating what method a
+           ;; method-function implements, for the purpose of
+           ;; NO-NEXT-METHOD.  We need something that can be shared
+           ;; between function and initargs, but not something that
+           ;; will be coalesced as a constant (because we are naughty,
+           ;; oh yes) with the expansion of any other methods in the
+           ;; same file.  -- CSR, 2007-05-30
+           (method-cell (list (make-symbol "METHOD-CELL"))))
+      (multiple-value-bind (parameters lambda-list specializers)
+          (parse-specialized-lambda-list specialized-lambda-list)
+        (let* ((required-parameters
+                (mapcar (lambda (r s) (declare (ignore s)) r)
+                        parameters
+                        specializers))
+               (slots (mapcar #'list required-parameters))
+               (class-declarations
+                `(declare
+                  ;; These declarations seem to be used by PCL to pass
+                  ;; information to itself; when I tried to delete 'em
+                  ;; ca. 0.6.10 it didn't work. I'm not sure how
+                  ;; they work, but note the (VAR-DECLARATION '%CLASS ..)
+                  ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30
+                  ,@(remove nil
+                            (mapcar (lambda (a s) (and (symbolp s)
+                                                       (neq s t)
+                                                       `(%class ,a ,s)))
+                                    parameters
+                                    specializers))
+                  ;; These TYPE declarations weren't in the original
+                  ;; PCL code, but the Python compiler likes them a
+                  ;; lot. (We're telling the compiler about our
+                  ;; knowledge of specialized argument types so that
+                  ;; it can avoid run-time type dispatch overhead,
+                  ;; which can be a huge win for Python.)
+                  ;;
+                  ;; KLUDGE: when I tried moving these to
+                  ;; ADD-METHOD-DECLARATIONS, things broke.  No idea
+                  ;; why.  -- CSR, 2004-06-16
+                  ,@(mapcar #'parameter-specializer-declaration-in-defmethod
+                            parameters
+                            specializers)))
+               (method-lambda
+                ;; Remove the documentation string and insert the
+                ;; appropriate class declarations. The documentation
+                ;; string is removed to make it easy for us to insert
+                ;; new declarations later, they will just go after the
+                ;; CADR of the method lambda. The class declarations
+                ;; are inserted to communicate the class of the method's
+                ;; arguments to the code walk.
+                `(lambda ,lambda-list
+                   ;; The default ignorability of method parameters
+                   ;; doesn't seem to be specified by ANSI. PCL had
+                   ;; them basically ignorable but was a little
+                   ;; inconsistent. E.g. even though the two
+                   ;; method definitions
+                   ;;   (DEFMETHOD FOO ((X T) (Y T)) "Z")
+                   ;;   (DEFMETHOD FOO ((X T) Y) "Z")
+                   ;; are otherwise equivalent, PCL treated Y as
+                   ;; ignorable in the first definition but not in the
+                   ;; second definition. We make all required
+                   ;; parameters ignorable as a way of systematizing
+                   ;; the old PCL behavior. -- WHN 2000-11-24
+                   (declare (ignorable ,@required-parameters))
+                   ,class-declarations
+                   ,@declarations
+                   (block ,(fun-name-block-name generic-function-name)
+                     ,@real-body)))
+               (constant-value-p (and (null (cdr real-body))
+                                      (constantp (car real-body))))
+               (constant-value (and constant-value-p
+                                    (constant-form-value (car real-body))))
+               (plist (and constant-value-p
+                           (or (typep constant-value
+                                      '(or number character))
+                               (and (symbolp constant-value)
+                                    (symbol-package constant-value)))
+                           (list :constant-value constant-value)))
+               (applyp (dolist (p lambda-list nil)
+                         (cond ((memq p '(&optional &rest &key))
+                                (return t))
+                               ((eq p '&aux)
+                                (return nil))))))
+          (multiple-value-bind
+                (walked-lambda call-next-method-p closurep
+                               next-method-p-p setq-p
+                               parameters-setqd)
+              (walk-method-lambda method-lambda
+                                  required-parameters
+                                  env
+                                  slots)
+            (multiple-value-bind (walked-lambda-body
+                                  walked-declarations
+                                  walked-documentation)
+                (parse-body (cddr walked-lambda))
+              (declare (ignore walked-documentation))
+              (when (some #'cdr slots)
+                (let ((slot-name-lists (slot-name-lists-from-slots slots)))
+                  (setq plist
+                        `(,@(when slot-name-lists
+                                  `(:slot-name-lists ,slot-name-lists))
+                            ,@plist))
+                  (setq walked-lambda-body
+                        `((pv-binding (,required-parameters
+                                       ,slot-name-lists
+                                       (load-time-value
+                                        (intern-pv-table
+                                         :slot-name-lists ',slot-name-lists)))
+                            ,@walked-lambda-body)))))
+              (when (and (memq '&key lambda-list)
+                         (not (memq '&allow-other-keys lambda-list)))
+                (let ((aux (memq '&aux lambda-list)))
+                  (setq lambda-list (nconc (ldiff lambda-list aux)
+                                           (list '&allow-other-keys)
+                                           aux))))
+              (values `(lambda (.method-args. .next-methods.)
+                         (simple-lexical-method-functions
+                             (,lambda-list .method-args. .next-methods.
+                                           :call-next-method-p
+                                           ,call-next-method-p
+                                           :next-method-p-p ,next-method-p-p
+                                           :setq-p ,setq-p
+                                           :method-cell ,method-cell
+                                           :closurep ,closurep
+                                           :applyp ,applyp)
+                           ,@walked-declarations
+                           (locally
+                               (declare (disable-package-locks
+                                         %parameter-binding-modified))
+                             (symbol-macrolet ((%parameter-binding-modified
+                                                ',@parameters-setqd))
+                               (declare (enable-package-locks
+                                         %parameter-binding-modified))
+                               ,@walked-lambda-body))))
+                      `(,@(when call-next-method-p `(method-cell ,method-cell))
+                          ,@(when plist `(plist ,plist))
+                          ,@(when documentation `(:documentation ,documentation)))))))))))
+
 (defun real-make-method-specializers-form
     (proto-gf proto-method specializer-names env)
   (declare (ignore env proto-gf proto-method))
@@ -776,161 +929,6 @@ bootstrapping.
 ;;; optimized-slot-value* macros.
 (define-symbol-macro %parameter-binding-modified ())
 
-(defun make-method-lambda-internal (method-lambda &optional env)
-  (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
-    (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
-            is not a lambda form."
-           method-lambda))
-  (multiple-value-bind (real-body declarations documentation)
-      (parse-body (cddr method-lambda))
-    (let* ((name-decl (get-declaration '%method-name declarations))
-           (sll-decl (get-declaration '%method-lambda-list declarations))
-           (method-name (when (consp name-decl) (car name-decl)))
-           (generic-function-name (when method-name (car method-name)))
-           (specialized-lambda-list (or sll-decl (cadr method-lambda)))
-           ;; the method-cell is a way of communicating what method a
-           ;; method-function implements, for the purpose of
-           ;; NO-NEXT-METHOD.  We need something that can be shared
-           ;; between function and initargs, but not something that
-           ;; will be coalesced as a constant (because we are naughty,
-           ;; oh yes) with the expansion of any other methods in the
-           ;; same file.  -- CSR, 2007-05-30
-           (method-cell (list (make-symbol "METHOD-CELL"))))
-      (multiple-value-bind (parameters lambda-list specializers)
-          (parse-specialized-lambda-list specialized-lambda-list)
-        (let* ((required-parameters
-                (mapcar (lambda (r s) (declare (ignore s)) r)
-                        parameters
-                        specializers))
-               (slots (mapcar #'list required-parameters))
-               (calls (list nil))
-               (class-declarations
-                `(declare
-                  ;; These declarations seem to be used by PCL to pass
-                  ;; information to itself; when I tried to delete 'em
-                  ;; ca. 0.6.10 it didn't work. I'm not sure how
-                  ;; they work, but note the (VAR-DECLARATION '%CLASS ..)
-                  ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30
-                  ,@(remove nil
-                            (mapcar (lambda (a s) (and (symbolp s)
-                                                       (neq s t)
-                                                       `(%class ,a ,s)))
-                                    parameters
-                                    specializers))
-                  ;; These TYPE declarations weren't in the original
-                  ;; PCL code, but the Python compiler likes them a
-                  ;; lot. (We're telling the compiler about our
-                  ;; knowledge of specialized argument types so that
-                  ;; it can avoid run-time type dispatch overhead,
-                  ;; which can be a huge win for Python.)
-                  ;;
-                  ;; KLUDGE: when I tried moving these to
-                  ;; ADD-METHOD-DECLARATIONS, things broke.  No idea
-                  ;; why.  -- CSR, 2004-06-16
-                  ,@(mapcar #'parameter-specializer-declaration-in-defmethod
-                            parameters
-                            specializers)))
-               (method-lambda
-                ;; Remove the documentation string and insert the
-                ;; appropriate class declarations. The documentation
-                ;; string is removed to make it easy for us to insert
-                ;; new declarations later, they will just go after the
-                ;; CADR of the method lambda. The class declarations
-                ;; are inserted to communicate the class of the method's
-                ;; arguments to the code walk.
-                `(lambda ,lambda-list
-                   ;; The default ignorability of method parameters
-                   ;; doesn't seem to be specified by ANSI. PCL had
-                   ;; them basically ignorable but was a little
-                   ;; inconsistent. E.g. even though the two
-                   ;; method definitions
-                   ;;   (DEFMETHOD FOO ((X T) (Y T)) "Z")
-                   ;;   (DEFMETHOD FOO ((X T) Y) "Z")
-                   ;; are otherwise equivalent, PCL treated Y as
-                   ;; ignorable in the first definition but not in the
-                   ;; second definition. We make all required
-                   ;; parameters ignorable as a way of systematizing
-                   ;; the old PCL behavior. -- WHN 2000-11-24
-                   (declare (ignorable ,@required-parameters))
-                   ,class-declarations
-                   ,@declarations
-                   (block ,(fun-name-block-name generic-function-name)
-                     ,@real-body)))
-               (constant-value-p (and (null (cdr real-body))
-                                      (constantp (car real-body))))
-               (constant-value (and constant-value-p
-                                    (constant-form-value (car real-body))))
-               (plist (and constant-value-p
-                           (or (typep constant-value
-                                      '(or number character))
-                               (and (symbolp constant-value)
-                                    (symbol-package constant-value)))
-                           (list :constant-value constant-value)))
-               (applyp (dolist (p lambda-list nil)
-                         (cond ((memq p '(&optional &rest &key))
-                                (return t))
-                               ((eq p '&aux)
-                                (return nil))))))
-          (multiple-value-bind
-                (walked-lambda call-next-method-p closurep
-                               next-method-p-p setq-p
-                               parameters-setqd)
-              (walk-method-lambda method-lambda
-                                  required-parameters
-                                  env
-                                  slots
-                                  calls)
-            (multiple-value-bind (walked-lambda-body
-                                  walked-declarations
-                                  walked-documentation)
-                (parse-body (cddr walked-lambda))
-              (declare (ignore walked-documentation))
-              (when (some #'cdr slots)
-                (multiple-value-bind (slot-name-lists call-list)
-                    (slot-name-lists-from-slots slots calls)
-                  (setq plist
-                        `(,@(when slot-name-lists
-                                  `(:slot-name-lists ,slot-name-lists))
-                            ,@(when call-list
-                                    `(:call-list ,call-list))
-                            ,@plist))
-                  (setq walked-lambda-body
-                        `((pv-binding (,required-parameters
-                                       ,slot-name-lists
-                                       (load-time-value
-                                        (intern-pv-table
-                                         :slot-name-lists ',slot-name-lists
-                                         :call-list ',call-list)))
-                            ,@walked-lambda-body)))))
-              (when (and (memq '&key lambda-list)
-                         (not (memq '&allow-other-keys lambda-list)))
-                (let ((aux (memq '&aux lambda-list)))
-                  (setq lambda-list (nconc (ldiff lambda-list aux)
-                                           (list '&allow-other-keys)
-                                           aux))))
-              (values `(lambda (.method-args. .next-methods.)
-                         (simple-lexical-method-functions
-                             (,lambda-list .method-args. .next-methods.
-                                           :call-next-method-p
-                                           ,call-next-method-p
-                                           :next-method-p-p ,next-method-p-p
-                                           :setq-p ,setq-p
-                                           :method-cell ,method-cell
-                                           :closurep ,closurep
-                                           :applyp ,applyp)
-                           ,@walked-declarations
-                           (locally
-                               (declare (disable-package-locks
-                                         %parameter-binding-modified))
-                             (symbol-macrolet ((%parameter-binding-modified
-                                                ',@parameters-setqd))
-                               (declare (enable-package-locks
-                                         %parameter-binding-modified))
-                               ,@walked-lambda-body))))
-                      `(,@(when call-next-method-p `(method-cell ,method-cell))
-                        ,@(when plist `(plist ,plist))
-                        ,@(when documentation `(:documentation ,documentation)))))))))))
-
 (defmacro simple-lexical-method-functions ((lambda-list
                                             method-args
                                             next-methods
@@ -1017,7 +1015,7 @@ bootstrapping.
 
 (defstruct (fast-method-call (:copier nil))
   (function #'identity :type function)
-  pv-cell
+  pv
   next-method-call
   arg-info)
 (defstruct (constant-fast-method-call
@@ -1034,7 +1032,7 @@ bootstrapping.
 
 (defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg)
   `(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call)
-                                (fast-method-call-pv-cell ,method-call)
+                                (fast-method-call-pv ,method-call)
                                 (fast-method-call-next-method-call ,method-call)
                                 ,@required-args+rest-arg))
 
@@ -1044,7 +1042,7 @@ bootstrapping.
                                         &rest required-args)
   (macrolet ((generate-call (n)
                ``(funcall (fast-method-call-function ,method-call)
-                          (fast-method-call-pv-cell ,method-call)
+                          (fast-method-call-pv ,method-call)
                           (fast-method-call-next-method-call ,method-call)
                           ,@required-args
                           ,@(loop for x below ,n
@@ -1058,7 +1056,7 @@ bootstrapping.
        (0 ,(generate-call 0))
        (1 ,(generate-call 1))
        (t (multiple-value-call (fast-method-call-function ,method-call)
-            (values (fast-method-call-pv-cell ,method-call))
+            (values (fast-method-call-pv ,method-call))
             (values (fast-method-call-next-method-call ,method-call))
             ,@required-args
             (sb-c::%more-arg-values ,more-context 0 ,more-count))))))
@@ -1206,7 +1204,7 @@ bootstrapping.
             (nreq (car arg-info)))
        (if restp
            (apply (fast-method-call-function emf)
-                  (fast-method-call-pv-cell emf)
+                  (fast-method-call-pv emf)
                   (fast-method-call-next-method-call emf)
                   args)
            (cond ((null args)
@@ -1229,7 +1227,7 @@ bootstrapping.
                              :format-arguments nil)))
                  (t
                   (apply (fast-method-call-function emf)
-                         (fast-method-call-pv-cell emf)
+                         (fast-method-call-pv emf)
                          (fast-method-call-next-method-call emf)
                          args))))))
     (method-call
@@ -1435,7 +1433,7 @@ bootstrapping.
         when (eq key keyword)
           return tail))
 
-(defun walk-method-lambda (method-lambda required-parameters env slots calls)
+(defun walk-method-lambda (method-lambda required-parameters env slots)
   (let (;; flag indicating that CALL-NEXT-METHOD should be in the
         ;; method definition
         (call-next-method-p nil)
@@ -1512,15 +1510,12 @@ bootstrapping.
                                (t nil))))
                    ((and (memq (car form)
                                '(slot-value set-slot-value slot-boundp))
-                         (constantp (caddr form)))
-                    (let ((parameter (can-optimize-access form
-                                                          required-parameters
-                                                          env)))
-                      (let ((fun (ecase (car form)
-                                   (slot-value #'optimize-slot-value)
-                                   (set-slot-value #'optimize-set-slot-value)
-                                   (slot-boundp #'optimize-slot-boundp))))
-                        (funcall fun slots parameter form))))
+                         (constantp (caddr form) env))
+                    (let ((fun (ecase (car form)
+                                 (slot-value #'optimize-slot-value)
+                                 (set-slot-value #'optimize-set-slot-value)
+                                 (slot-boundp #'optimize-slot-boundp))))
+                        (funcall fun form slots required-parameters env)))
                    (t form))))
 
       (let ((walked-lambda (walk-form method-lambda env #'walk-function)))
@@ -1618,11 +1613,10 @@ bootstrapping.
           (set-fun-name mff fast-name))))
     (when plist
       (let ((plist plist))
-        (let ((snl (getf plist :slot-name-lists))
-              (cl (getf plist :call-list)))
-          (when (or snl cl)
+        (let ((snl (getf plist :slot-name-lists)))
+          (when snl
             (setf (method-plist-value method :pv-table)
-                  (intern-pv-table :slot-name-lists snl :call-list cl))))))))
+                  (intern-pv-table :slot-name-lists snl))))))))
 
 (defun analyze-lambda-list (lambda-list)
   (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
@@ -2053,6 +2047,7 @@ bootstrapping.
                                                               lambda-list-p)
                                             argument-precedence-order
                                             source-location
+                                            documentation
                                             &allow-other-keys)
   (declare (ignore keys))
   (cond ((and existing (early-gf-p existing))
@@ -2062,7 +2057,8 @@ bootstrapping.
         ((assoc spec *!generic-function-fixups* :test #'equal)
          (if existing
              (make-early-gf spec lambda-list lambda-list-p existing
-                            argument-precedence-order source-location)
+                            argument-precedence-order source-location
+                            documentation)
              (bug "The function ~S is not already defined." spec)))
         (existing
          (bug "~S should be on the list ~S."
@@ -2070,10 +2066,12 @@ bootstrapping.
         (t
          (pushnew spec *!early-generic-functions* :test #'equal)
          (make-early-gf spec lambda-list lambda-list-p nil
-                        argument-precedence-order source-location))))
+                        argument-precedence-order source-location
+                        documentation))))
 
 (defun make-early-gf (spec &optional lambda-list lambda-list-p
-                      function argument-precedence-order source-location)
+                      function argument-precedence-order source-location
+                      documentation)
   (let ((fin (allocate-standard-funcallable-instance
               *sgf-wrapper* *sgf-slots-init*)))
     (set-funcallable-instance-function
@@ -2089,10 +2087,10 @@ bootstrapping.
                          has not been set." fin)))))
     (setf (gdefinition spec) fin)
     (!bootstrap-set-slot 'standard-generic-function fin 'name spec)
-    (!bootstrap-set-slot 'standard-generic-function
-                         fin
-                         'source
-                         source-location)
+    (!bootstrap-set-slot 'standard-generic-function fin
+                         'source source-location)
+    (!bootstrap-set-slot 'standard-generic-function fin
+                         '%documentation documentation)
     (set-fun-name fin spec)
     (let ((arg-info (make-arg-info)))
       (setf (early-gf-arg-info fin) arg-info)
@@ -2268,7 +2266,8 @@ bootstrapping.
             arg-info)))
 
 (defun early-make-a-method (class qualifiers arglist specializers initargs doc
-                            &key slot-name object-class method-class-function)
+                            &key slot-name object-class method-class-function
+                            definition-source)
   (let ((parsed ())
         (unparsed ()))
     ;; Figure out whether we got class objects or class names as the
@@ -2309,13 +2308,15 @@ bootstrapping.
                         initargs doc)
                   (when slot-name
                     (list :slot-name slot-name :object-class object-class
-                          :method-class-function method-class-function))))))
+                          :method-class-function method-class-function))
+                  (list :definition-source definition-source)))))
       (initialize-method-function initargs result)
       result)))
 
 (defun real-make-a-method
        (class qualifiers lambda-list specializers initargs doc
-        &rest args &key slot-name object-class method-class-function)
+        &rest args &key slot-name object-class method-class-function
+        definition-source)
   (if method-class-function
       (let* ((object-class (if (classp object-class) object-class
                                (find-class object-class)))
@@ -2331,6 +2332,7 @@ bootstrapping.
           (apply #'make-instance
                  (apply method-class-function object-class slot-definition
                         initargs)
+                 :definition-source definition-source
                  initargs)))
       (apply #'make-instance class :qualifiers qualifiers
              :lambda-list lambda-list :specializers specializers
@@ -2389,7 +2391,9 @@ bootstrapping.
   (setf (fifth (fifth early-method)) new-value))
 
 (defun early-add-named-method (generic-function-name qualifiers
-                               specializers arglist &rest initargs)
+                               specializers arglist &rest initargs
+                               &key documentation definition-source
+                               &allow-other-keys)
   (let* (;; we don't need to deal with the :generic-function-class
          ;; argument here because the default,
          ;; STANDARD-GENERIC-FUNCTION, is right for all early generic
@@ -2403,7 +2407,8 @@ bootstrapping.
     (setf (getf (getf initargs 'plist) :name)
           (make-method-spec gf qualifiers specializers))
     (let ((new (make-a-method 'standard-method qualifiers arglist
-                              specializers initargs ())))
+                              specializers initargs documentation
+                              :definition-source definition-source)))
       (when existing (remove-method gf existing))
       (add-method gf new))))
 
@@ -2674,13 +2679,18 @@ bootstrapping.
 ;;; walker stuff was only used for implementing stuff like that; maybe
 ;;; it's not needed any more? Hunt down what it was used for and see.
 
+(defun extract-the (form)
+  (cond ((and (consp form) (eq (car form) 'the))
+         (aver (proper-list-of-length-p 3))
+         (third form))
+        (t
+         form)))
+
 (defmacro with-slots (slots instance &body body)
   (let ((in (gensym)))
     `(let ((,in ,instance))
        (declare (ignorable ,in))
-       ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
-                             (third instance)
-                             instance)))
+       ,@(let ((instance (extract-the instance)))
            (and (symbolp instance)
                 `((declare (%variable-rebinding ,in ,instance)))))
        ,in
@@ -2702,9 +2712,7 @@ bootstrapping.
   (let ((in (gensym)))
     `(let ((,in ,instance))
        (declare (ignorable ,in))
-       ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
-                             (third instance)
-                             instance)))
+       ,@(let ((instance (extract-the instance)))
            (and (symbolp instance)
                 `((declare (%variable-rebinding ,in ,instance)))))
        ,in