X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=37873186dea5b818ab18322d7a616885dc414da9;hb=a4882e3023fdd5e777169a4cbede33605281173c;hp=7c307f0d0242699592ab074883f808d316fc1f7a;hpb=81ce38f2e03e4f569d7a95bb18efb25bb16fc269;p=sbcl.git

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 7c307f0..3787318 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -586,7 +586,7 @@
                  (when (and class-name (not (eq class-name t)))
                    (position parameter-or-nil slots :key #'car))))))
       (if (constantp form)
-          (let ((form (eval form)))
+          (let ((form (constant-form-value form)))
             (if (symbolp form)
                 form
                 *unspecific-arg*))
@@ -630,8 +630,9 @@
 ;;; It is safe for these two functions to be wrong. They just try to
 ;;; guess what the most likely case will be.
 (defun generate-fast-class-slot-access-p (class-form slot-name-form)
-  (let ((class (and (constantp class-form) (eval class-form)))
-        (slot-name (and (constantp slot-name-form) (eval slot-name-form))))
+  (let ((class (and (constantp class-form) (constant-form-value class-form)))
+        (slot-name (and (constantp slot-name-form)
+                        (constant-form-value slot-name-form))))
     (and (eq *boot-state* 'complete)
          (standard-class-p class)
          (not (eq class *the-class-t*)) ; shouldn't happen, though.
@@ -639,8 +640,9 @@
            (and slotd (eq :class (slot-definition-allocation slotd)))))))
 
 (defun skip-fast-slot-access-p (class-form slot-name-form type)
-  (let ((class (and (constantp class-form) (eval class-form)))
-        (slot-name (and (constantp slot-name-form) (eval slot-name-form))))
+  (let ((class (and (constantp class-form) (constant-form-value class-form)))
+        (slot-name (and (constantp slot-name-form)
+                        (constant-form-value slot-name-form))))
     (and (eq *boot-state* 'complete)
          (standard-class-p class)
          (not (eq class *the-class-t*)) ; shouldn't happen, though.
@@ -910,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
@@ -1097,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))))