0.9.13.6:

[sbcl.git] / src / pcl / vector.lisp

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index b29655f..3787318 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -912,20 +912,32 @@
        (declare (ignorable ,@(mapcar #'identity slot-vars)))
        ,@body)))
 
-;;; This gets used only when the default MAKE-METHOD-LAMBDA is
+;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is
 ;;; overridden.
-(defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
+(define-symbol-macro pv-env-environment overridden)
+
+(defmacro pv-env (&environment env
+                  (pv calls pv-table-symbol pv-parameters)
                   &rest forms)
-  `(let* ((.pv-table. ,pv-table-symbol)
-          (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
-          (,pv (car .pv-cell.))
-          (,calls (cdr .pv-cell.)))
-     (declare ,(make-pv-type-declaration pv))
-     (declare ,(make-calls-type-declaration calls))
-     ,@(when (symbolp pv-table-symbol)
-         `((declare (special ,pv-table-symbol))))
-     ,pv ,calls
-     ,@forms))
+  ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
+  ;; symbol-macrolet.
+  (if (eq (macroexpand 'pv-env-environment env) 'default)
+      `(let ((,pv (car .pv-cell.))
+             (,calls (cdr .pv-cell.)))
+         (declare ,(make-pv-type-declaration pv)
+                  ,(make-calls-type-declaration calls))
+         ,pv ,calls
+         ,@forms)
+      `(let* ((.pv-table. ,pv-table-symbol)
+              (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
+              (,pv (car .pv-cell.))
+              (,calls (cdr .pv-cell.)))
+         (declare ,(make-pv-type-declaration pv))
+         (declare ,(make-calls-type-declaration calls))
+         ,@(when (symbolp pv-table-symbol)
+                 `((declare (special ,pv-table-symbol))))
+         ,pv ,calls
+         ,@forms)))
 
 (defvar *non-var-declarations*
   ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
@@ -1099,24 +1111,13 @@
                   (list (cons 'fast-method (body-method-name body))))
           (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
           ;; body of the function
-          (declare (ignorable .pv-cell. .next-method-call.))
+          (declare (ignorable .pv-cell. .next-method-call.)
+                   (disable-package-locks pv-env-environment))
           ,@outer-decls
-          (declare (disable-package-locks pv-env))
-           (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
-                               &rest forms)
-                        (declare (ignore pv-table-symbol
-                                         pv-parameters))
-                        (declare (enable-package-locks pv-env))
-                        `(let ((,pv (car .pv-cell.))
-                               (,calls (cdr .pv-cell.)))
-                           (declare ,(make-pv-type-declaration pv)
-                                    ,(make-calls-type-declaration calls))
-                           ,pv ,calls
-                           ,@forms)))
-             (declare (enable-package-locks pv-env))
-             (fast-lexical-method-functions
-              (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
-                ,@(cdddr lmf-params))
+          (symbol-macrolet ((pv-env-environment default))
+            (fast-lexical-method-functions
+                (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
+                  ,@(cdddr lmf-params))
               ,@inner-decls
               ,@body-sans-decls)))
         ',initargs))))