1.0.31.9: some PCL micro-optimizations

 * Make *BOOT-STATE* a global variable and rename it **BOOT-STATE**.

 * Make various *S?-FOO-INDEX* variables constants, and rename them
   +S?-FOO-INDEX+.

 * Special love for SAFE-METHOD-FOO functions: store standard method
   class list in a global variable, use EQ for membership testing, and
   use STD-INSTANCE-SLOTS instead of GET-SLOTS (if the method has one
   of the standard classes, we know it is a standard instance.)

 Low-lying Nutrient Poor Fruit 'R Us.

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 11dfa03..e9eb7a6 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -353,7 +353,7 @@ bootstrapping.
 
 
 (defun prototypes-for-make-method-lambda (name)
-  (if (not (eq *boot-state* 'complete))
+  (if (not (eq **boot-state** 'complete))
       (values nil nil)
       (let ((gf? (and (fboundp name)
                       (gdefinition name))))
@@ -379,7 +379,7 @@ bootstrapping.
 (defun method-prototype-for-gf (name)
   (let ((gf? (and (fboundp name)
                   (gdefinition name))))
-    (cond ((neq *boot-state* 'complete) nil)
+    (cond ((neq **boot-state** 'complete) nil)
           ((or (null gf?)
                (not (generic-function-p gf?)))          ; Someone else MIGHT
                                                         ; error at load time.
@@ -754,7 +754,7 @@ bootstrapping.
   (declare (ignore env proto-gf proto-method))
   (flet ((parse (name)
            (cond
-             ((and (eq *boot-state* 'complete)
+             ((and (eq **boot-state** 'complete)
                    (specializerp name))
               name)
              ((symbolp name) `(find-class ',name))
@@ -863,7 +863,7 @@ bootstrapping.
                  ;; cases by blacklisting them here. -- WHN 2001-01-19
                  (list 'slot-object #+nil (find-class 'slot-object)))
          '(ignorable))
-        ((not (eq *boot-state* 'complete))
+        ((not (eq **boot-state** 'complete))
          ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with
          ;; types which don't match their specializers. (Specifically,
          ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL
@@ -1549,7 +1549,7 @@ bootstrapping.
 (defun generic-function-name-p (name)
   (and (legal-fun-name-p name)
        (fboundp name)
-       (if (eq *boot-state* 'complete)
+       (if (eq **boot-state** 'complete)
            (standard-generic-function-p (gdefinition name))
            (funcallable-instance-p (gdefinition name)))))
 \f
@@ -1579,7 +1579,7 @@ bootstrapping.
 (defun load-defmethod-internal
     (method-class gf-spec qualifiers specializers lambda-list
                   initargs source-location)
-  (when (and (eq *boot-state* 'complete)
+  (when (and (eq **boot-state** 'complete)
              (fboundp gf-spec))
     (let* ((gf (fdefinition gf-spec))
            (method (and (generic-function-p gf)
@@ -1727,7 +1727,7 @@ bootstrapping.
   (let ((existing (and (fboundp fun-name)
                        (gdefinition fun-name))))
     (cond ((and existing
-                (eq *boot-state* 'complete)
+                (eq **boot-state** 'complete)
                 (null (generic-function-p existing)))
            (generic-clobbers-function fun-name)
            (fmakunbound fun-name)
@@ -1756,32 +1756,32 @@ bootstrapping.
                       +slot-unbound+))))
           (early-collect-inheritance 'standard-generic-function)))
 
-(defvar *sgf-method-class-index*
+(defconstant +sgf-method-class-index+
   (!bootstrap-slot-index 'standard-generic-function 'method-class))
 
 (defun early-gf-p (x)
   (and (fsc-instance-p x)
-       (eq (clos-slots-ref (get-slots x) *sgf-method-class-index*)
+       (eq (clos-slots-ref (get-slots x) +sgf-method-class-index+)
            +slot-unbound+)))
 
-(defvar *sgf-methods-index*
+(defconstant +sgf-methods-index+
   (!bootstrap-slot-index 'standard-generic-function 'methods))
 
 (defmacro early-gf-methods (gf)
-  `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*))
+  `(clos-slots-ref (get-slots ,gf) +sgf-methods-index+))
 
 (defun safe-generic-function-methods (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
-      (clos-slots-ref (get-slots generic-function) *sgf-methods-index*)
+      (clos-slots-ref (get-slots generic-function) +sgf-methods-index+)
       (generic-function-methods generic-function)))
 
-(defvar *sgf-arg-info-index*
+(defconstant +sgf-arg-info-index+
   (!bootstrap-slot-index 'standard-generic-function 'arg-info))
 
 (defmacro early-gf-arg-info (gf)
-  `(clos-slots-ref (get-slots ,gf) *sgf-arg-info-index*))
+  `(clos-slots-ref (get-slots ,gf) +sgf-arg-info-index+))
 
-(defvar *sgf-dfun-state-index*
+(defconstant +sgf-dfun-state-index+
   (!bootstrap-slot-index 'standard-generic-function 'dfun-state))
 
 (defstruct (arg-info
@@ -1827,10 +1827,10 @@ bootstrapping.
 
 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
                         argument-precedence-order)
-  (let* ((arg-info (if (eq *boot-state* 'complete)
+  (let* ((arg-info (if (eq **boot-state** 'complete)
                        (gf-arg-info gf)
                        (early-gf-arg-info gf)))
-         (methods (if (eq *boot-state* 'complete)
+         (methods (if (eq **boot-state** 'complete)
                       (generic-function-methods gf)
                       (early-gf-methods gf)))
          (was-valid-p (integerp (arg-info-number-optional arg-info)))
@@ -1909,21 +1909,19 @@ bootstrapping.
                    ~S."
                   gf-keywords)))))))
 
-(defvar *sm-specializers-index*
+(defconstant +sm-specializers-index+
   (!bootstrap-slot-index 'standard-method 'specializers))
-(defvar *sm-%function-index*
+(defconstant +sm-%function-index+
   (!bootstrap-slot-index 'standard-method '%function))
-(defvar *sm-qualifiers-index*
+(defconstant +sm-qualifiers-index+
   (!bootstrap-slot-index 'standard-method 'qualifiers))
-(defvar *sm-plist-index*
-  (!bootstrap-slot-index 'standard-method 'plist))
 
 ;;; FIXME: we don't actually need this; we could test for the exact
 ;;; class and deal with it as appropriate.  In fact we probably don't
 ;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
 ;;; the standard reader method for METHOD-SPECIALIZERS.  Probably.
-(dolist (s '(specializers %function plist))
-  (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
+(dolist (s '(specializers %function))
+  (aver (= (symbol-value (intern (format nil "+SM-~A-INDEX+" s)))
            (!bootstrap-slot-index 'standard-reader-method s)
            (!bootstrap-slot-index 'standard-writer-method s)
            (!bootstrap-slot-index 'standard-boundp-method s)
@@ -1931,34 +1929,31 @@ bootstrapping.
            (!bootstrap-slot-index 'global-writer-method s)
            (!bootstrap-slot-index 'global-boundp-method s))))
 
-(define-symbol-macro *standard-method-classes*
-  (list *the-class-standard-method* *the-class-standard-reader-method*
-        *the-class-standard-writer-method* *the-class-standard-boundp-method*
-        *the-class-global-reader-method* *the-class-global-writer-method*
-        *the-class-global-boundp-method*))
+(defvar *standard-method-class-names*
+  '(standard-method standard-reader-method
+    standard-writer-method standard-boundp-method
+    global-reader-method global-writer-method
+    global-boundp-method))
+
+(declaim (list **standard-method-classes**))
+(defglobal **standard-method-classes** nil)
 
 (defun safe-method-specializers (method)
-  (let ((standard-method-classes *standard-method-classes*)
-        (class (class-of method)))
-    (if (member class standard-method-classes)
-        (clos-slots-ref (get-slots method) *sm-specializers-index*)
-        (method-specializers method))))
+  (if (member (class-of method) **standard-method-classes** :test #'eq)
+      (clos-slots-ref (std-instance-slots method) +sm-specializers-index+)
+      (method-specializers method)))
 (defun safe-method-fast-function (method)
   (let ((mf (safe-method-function method)))
     (and (typep mf '%method-function)
          (%method-function-fast-function mf))))
 (defun safe-method-function (method)
-  (let ((standard-method-classes *standard-method-classes*)
-        (class (class-of method)))
-    (if (member class standard-method-classes)
-        (clos-slots-ref (get-slots method) *sm-%function-index*)
-        (method-function method))))
+  (if (member (class-of method) **standard-method-classes** :test #'eq)
+      (clos-slots-ref (std-instance-slots method) +sm-%function-index+)
+      (method-function method)))
 (defun safe-method-qualifiers (method)
-  (let ((standard-method-classes *standard-method-classes*)
-        (class (class-of method)))
-    (if (member class standard-method-classes)
-        (clos-slots-ref (get-slots method) *sm-qualifiers-index*)
-        (method-qualifiers method))))
+  (if (member (class-of method) **standard-method-classes** :test #'eq)
+      (clos-slots-ref (std-instance-slots method) +sm-qualifiers-index+)
+      (method-qualifiers method)))
 
 (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
   (let* ((existing-p (and methods (cdr methods) new-method))
@@ -1971,16 +1966,16 @@ bootstrapping.
                    nil)))
     (when (arg-info-valid-p arg-info)
       (dolist (method (if new-method (list new-method) methods))
-        (let* ((specializers (if (or (eq *boot-state* 'complete)
+        (let* ((specializers (if (or (eq **boot-state** 'complete)
                                      (not (consp method)))
                                  (safe-method-specializers method)
                                  (early-method-specializers method t)))
-               (class (if (or (eq *boot-state* 'complete) (not (consp method)))
+               (class (if (or (eq **boot-state** 'complete) (not (consp method)))
                           (class-of method)
                           (early-method-class method)))
                (new-type
                 (when (and class
-                           (or (not (eq *boot-state* 'complete))
+                           (or (not (eq **boot-state** 'complete))
                                (eq (generic-function-method-combination gf)
                                    *standard-method-combination*)))
                   (cond ((or (eq class *the-class-standard-reader-method*)
@@ -2008,7 +2003,7 @@ bootstrapping.
       (unless (gf-info-c-a-m-emf-std-p arg-info)
         (setf (gf-info-simple-accessor-type arg-info) t))))
   (unless was-valid-p
-    (let ((name (if (eq *boot-state* 'complete)
+    (let ((name (if (eq **boot-state** 'complete)
                     (generic-function-name gf)
                     (!early-gf-name gf))))
       (setf (gf-precompute-dfun-and-emf-p arg-info)
@@ -2029,7 +2024,7 @@ bootstrapping.
                         ;; remain.
                         (not (find #\Space (symbol-name symbol))))))))))
   (setf (gf-info-fast-mf-p arg-info)
-        (or (not (eq *boot-state* 'complete))
+        (or (not (eq **boot-state** 'complete))
             (let* ((method-class (generic-function-method-class gf))
                    (methods (compute-applicable-methods
                              #'make-method-lambda
@@ -2119,12 +2114,12 @@ bootstrapping.
 
 (defun safe-gf-dfun-state (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
-      (clos-slots-ref (get-slots generic-function) *sgf-dfun-state-index*)
+      (clos-slots-ref (fsc-instance-slots generic-function) +sgf-dfun-state-index+)
       (gf-dfun-state generic-function)))
 (defun (setf safe-gf-dfun-state) (new-value generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
-      (setf (clos-slots-ref (get-slots generic-function)
-                            *sgf-dfun-state-index*)
+      (setf (clos-slots-ref (fsc-instance-slots generic-function)
+                            +sgf-dfun-state-index+)
             new-value)
       (setf (gf-dfun-state generic-function) new-value)))
 
@@ -2133,44 +2128,44 @@ bootstrapping.
                        (list* dfun cache info)
                        dfun)))
     (cond
-      ((eq *boot-state* 'complete)
+      ((eq **boot-state** 'complete)
        ;; Check that we are under the lock.
        #+sb-thread
        (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf))))
        (setf (safe-gf-dfun-state gf) new-state))
       (t
-       (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
+       (setf (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+)
              new-state))))
   dfun)
 
 (defun gf-dfun-cache (gf)
-  (let ((state (if (eq *boot-state* 'complete)
+  (let ((state (if (eq **boot-state** 'complete)
                    (safe-gf-dfun-state gf)
-                   (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
+                   (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+))))
     (typecase state
       (function nil)
       (cons (cadr state)))))
 
 (defun gf-dfun-info (gf)
-  (let ((state (if (eq *boot-state* 'complete)
+  (let ((state (if (eq **boot-state** 'complete)
                    (safe-gf-dfun-state gf)
-                   (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
+                   (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+))))
     (typecase state
       (function nil)
       (cons (cddr state)))))
 
-(defvar *sgf-name-index*
+(defconstant +sgf-name-index+
   (!bootstrap-slot-index 'standard-generic-function 'name))
 
 (defun !early-gf-name (gf)
-  (clos-slots-ref (get-slots gf) *sgf-name-index*))
+  (clos-slots-ref (get-slots gf) +sgf-name-index+))
 
 (defun gf-lambda-list (gf)
-  (let ((arg-info (if (eq *boot-state* 'complete)
+  (let ((arg-info (if (eq **boot-state** 'complete)
                       (gf-arg-info gf)
                       (early-gf-arg-info gf))))
     (if (eq :no-lambda-list (arg-info-lambda-list arg-info))
-        (let ((methods (if (eq *boot-state* 'complete)
+        (let ((methods (if (eq **boot-state** 'complete)
                            (generic-function-methods gf)
                            (early-gf-methods gf))))
           (if (null methods)
@@ -2285,7 +2280,7 @@ bootstrapping.
 (defun safe-gf-arg-info (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
       (clos-slots-ref (fsc-instance-slots generic-function)
-                      *sgf-arg-info-index*)
+                      +sgf-arg-info-index+)
       (gf-arg-info generic-function)))
 
 ;;; FIXME: this function took on a slightly greater role than it
@@ -2721,7 +2716,7 @@ bootstrapping.
                      (cons (if (listp arg) (cadr arg) t) specializers)
                      (cons (if (listp arg) (car arg) arg) required)))))))
 \f
-(setq *boot-state* 'early)
+(setq **boot-state** 'early)
 \f
 ;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
 ;;; which used %WALKER stuff. That suggests to me that maybe the code

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 67df452..b0e3f3c 100644 (file)
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -235,6 +235,11 @@
                   class name class-eq-specializer-wrapper source
                   direct-supers direct-subclasses cpl wrapper))))))))
 
+    (setq **standard-method-classes**
+          (mapcar (lambda (name)
+                    (symbol-value (make-class-symbol name)))
+                  *standard-method-class-names*))
+
     (let* ((smc-class (find-class 'standard-method-combination))
            (smc-wrapper (!bootstrap-get-slot 'standard-class
                                              smc-class
@@ -576,7 +581,7 @@
   (let ((class (classoid-pcl-class classoid)))
     (cond (class
            (ensure-non-standard-class (class-name class) classoid class))
-          ((eq 'complete *boot-state*)
+          ((eq 'complete **boot-state**)
            (ensure-non-standard-class (classoid-name classoid) classoid)))))
 
 (pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*)
@@ -585,7 +590,7 @@
 ;;; FIXME: only needed during bootstrap
 (defun make-class-predicate (class name)
   (let* ((gf (ensure-generic-function name :lambda-list '(object)))
-         (mlist (if (eq *boot-state* 'complete)
+         (mlist (if (eq **boot-state** 'complete)
                     (early-gf-methods gf)
                     (generic-function-methods gf))))
     (unless mlist
@@ -682,7 +687,7 @@
 
       (%set-class-type-translation class name))))
 
-(setq *boot-state* 'braid)
+(setq **boot-state** 'braid)
 
 (defmethod no-applicable-method (generic-function &rest args)
   (error "~@<There is no applicable method for the generic function ~2I~_~S~

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 201620b..2f6a222 100644 (file)
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -105,7 +105,7 @@
   ;; or aren't to prevent the leaky next methods bug.
   (let* ((cm-args (cdr form))
          (fmf-p (and (null no-fmf-p)
-                     (or (not (eq *boot-state* 'complete))
+                     (or (not (eq **boot-state** 'complete))
                          (gf-fast-method-function-p generic-function))
                      (null (cddr cm-args))))
          (method (car cm-args))
@@ -225,7 +225,7 @@
           (error-p (or (eq (first effective-method) '%no-primary-method)
                        (eq (first effective-method) '%invalid-qualifiers)))
           (mc-args-p
-           (when (eq *boot-state* 'complete)
+           (when (eq **boot-state** 'complete)
              ;; Otherwise the METHOD-COMBINATION slot is not bound.
              (let ((combin (generic-function-method-combination gf)))
                (and (long-method-combination-p combin)

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index 5d79f0e..d7870b7 100644 (file)
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -53,7 +53,7 @@
           ;; DEFSTRUCT-P should be true if the class is defined
           ;; with a metaclass STRUCTURE-CLASS, so that a DEFSTRUCT
           ;; is compiled for the class.
-          (defstruct-p (and (eq *boot-state* 'complete)
+          (defstruct-p (and (eq **boot-state** 'complete)
                             (let ((mclass (find-class metaclass nil)))
                               (and mclass
                                    (*subtypep

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index c6908d6..777338a 100644 (file)
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -28,11 +28,11 @@
 ;;; build, of course, but they might happen if someone is experimenting
 ;;; and debugging, and it's probably worth complaining if they do,
 ;;; so we've left 'em in.)
-(when (eq *boot-state* 'complete)
+(when (eq **boot-state** 'complete)
   (error "Trying to load (or compile) PCL in an environment in which it~%~
           has already been loaded. This doesn't work, you will have to~%~
           get a fresh lisp (reboot) and then load PCL."))
-(when *boot-state*
+(when **boot-state**
   (cerror "Try loading (or compiling) PCL anyways."
           "Trying to load (or compile) PCL in an environment in which it~%~
            has already been partially loaded. This may not work, you may~%~
@@ -91,7 +91,7 @@
            (when (symbolp specl)
              ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
              (setq specl (find-class specl)))
-           (or (not (eq *boot-state* 'complete))
+           (or (not (eq **boot-state** 'complete))
                (specializerp specl)))
          (specializer-type specl))
         (t
@@ -130,7 +130,7 @@
                (let ((type (specializer-type class)))
                  (if (listp type) type `(,type)))
                `(,type))))
-        ((or (not (eq *boot-state* 'complete))
+        ((or (not (eq **boot-state** 'complete))
              (specializerp type))
          (specializer-type type))
         (t
@@ -158,7 +158,7 @@
 (defun *subtypep (type1 type2)
   (if (equal type1 type2)
       (values t t)
-      (if (eq *boot-state* 'early)
+      (if (eq **boot-state** 'early)
           (values (eq type1 type2) t)
           (let ((*in-precompute-effective-methods-p* t))
             (declare (special *in-precompute-effective-methods-p*))

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 37002f9..97bb828 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -196,7 +196,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
     (setf *standard-slot-locations* new)))
 
 (defun maybe-update-standard-slot-locations (class)
-  (when (and (eq *boot-state* 'complete)
+  (when (and (eq **boot-state** 'complete)
              (memq (class-name class) *standard-classes*))
     (compute-standard-slot-locations)))
 
@@ -529,7 +529,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                         (generic-function-methods gf)))
            (default '(unknown)))
       (and (null applyp)
-           (or (not (eq *boot-state* 'complete))
+           (or (not (eq **boot-state** 'complete))
                ;; If COMPUTE-APPLICABLE-METHODS is specialized, we
                ;; can't use this, of course, because we can't tell
                ;; which methods will be considered applicable.
@@ -550,7 +550,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
            ;; method has qualifiers, to make sure that emfs are really
            ;; method functions; see above.
            (dolist (method methods t)
-             (when (eq *boot-state* 'complete)
+             (when (eq **boot-state** 'complete)
                (when (or (some #'eql-specializer-p
                                (safe-method-specializers method))
                          (safe-method-qualifiers method))
@@ -589,7 +589,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
         (return t)))))
 
 (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
-  (when (eq *boot-state* 'complete)
+  (when (eq **boot-state** 'complete)
     (unless (or caching-p
                 (gf-requires-emf-keyword-checks gf)
                 ;; DISPATCH-DFUN-COST will error if it encounters a
@@ -762,10 +762,10 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
              (initial-dfun gf args))))
     (multiple-value-bind (dfun cache info)
         (cond
-          ((and (eq *boot-state* 'complete)
+          ((and (eq **boot-state** 'complete)
                 (not (finalize-specializers gf)))
            (values initial-dfun nil (initial-dfun-info)))
-          ((and (eq *boot-state* 'complete)
+          ((and (eq **boot-state** 'complete)
                 (compute-applicable-methods-emf-std-p gf))
            (let* ((caching-p (use-caching-dfun-p gf))
                   ;; KLUDGE: the only effect of this (when
@@ -1223,7 +1223,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
               (safe-method-qualifiers meth))
       (return-from accessor-values-internal (values nil nil))))
   (let* ((meth (car methods))
-         (early-p (not (eq *boot-state* 'complete)))
+         (early-p (not (eq **boot-state** 'complete)))
          (slot-name (when accessor-class
                       (if (consp meth)
                           (and (early-method-standard-accessor-p meth)
@@ -1261,7 +1261,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                      (generic-function-methods gf)))
         (all-index nil)
         (no-class-slots-p t)
-        (early-p (not (eq *boot-state* 'complete)))
+        (early-p (not (eq **boot-state** 'complete)))
         first second (size 0))
     (declare (fixnum size))
     ;; class -> {(specl slotd)}
@@ -1359,7 +1359,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                 precedence
                 (lambda (class1 class2 index)
                   (let* ((class (type-class (nth index types)))
-                         (cpl (if (eq *boot-state* 'complete)
+                         (cpl (if (eq **boot-state** 'complete)
                                   (class-precedence-list class)
                                   (early-class-precedence-list class))))
                     (if (memq class2 (memq class1 cpl))
@@ -1383,10 +1383,10 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
     (stable-sort methods #'sorter)))
 
 (defun order-specializers (specl1 specl2 index compare-classes-function)
-  (let ((type1 (if (eq *boot-state* 'complete)
+  (let ((type1 (if (eq **boot-state** 'complete)
                    (specializer-type specl1)
                    (!bootstrap-get-slot 'specializer specl1 '%type)))
-        (type2 (if (eq *boot-state* 'complete)
+        (type2 (if (eq **boot-state** 'complete)
                    (specializer-type specl2)
                    (!bootstrap-get-slot 'specializer specl2 '%type))))
     (cond ((eq specl1 specl2)
@@ -1476,7 +1476,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
               argument-precedence-order)))
 
 (defun cpl-or-nil (class)
-  (if (eq *boot-state* 'complete)
+  (if (eq **boot-state** 'complete)
       (progn
         ;; KLUDGE: why not use (slot-boundp class
         ;; 'class-precedence-list)?  Well, unfortunately, CPL-OR-NIL is
@@ -1619,8 +1619,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 
 (defun map-all-classes (fun &optional (root t))
   (let ((all-classes (make-hash-table :test 'eq))
-        (braid-p (or (eq *boot-state* 'braid)
-                     (eq *boot-state* 'complete))))
+        (braid-p (or (eq **boot-state** 'braid)
+                     (eq **boot-state** 'complete))))
     (labels ((do-class (class)
                (unless (gethash class all-classes)
                  (setf (gethash class all-classes) t)
@@ -1700,7 +1700,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                                             wrappers-p all-applicable-p
                                             all-sorted-p function-p)
   (if (and all-applicable-p all-sorted-p (not function-p))
-      (if (eq *boot-state* 'complete)
+      (if (eq **boot-state** 'complete)
           (let* ((combin (generic-function-method-combination gf))
                  (effective (compute-effective-method gf combin methods)))
             (make-effective-method-function1 gf effective method-alist-p
@@ -1723,7 +1723,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
 
 (defun methods-contain-eql-specializer-p (methods)
-  (and (eq *boot-state* 'complete)
+  (and (eq **boot-state** 'complete)
        (dolist (method methods nil)
          (when (dolist (spec (method-specializers method) nil)
                  (when (eql-specializer-p spec) (return t)))

diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp
index 20ec346..e544e0b 100644 (file)
--- a/src/pcl/fixup.lisp
+++ b/src/pcl/fixup.lisp
@@ -29,7 +29,7 @@
 (dolist (s '(condition function structure-object))
   (dohash ((k v) (classoid-subclasses (find-classoid s)))
     (find-class (classoid-name k))))
-(setq *boot-state* 'complete)
+(setq **boot-state** 'complete)
 
 (defun print-std-instance (instance stream depth)
   (declare (ignore depth))

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index a4c3dad..7e59506 100644 (file)
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -34,7 +34,7 @@
     (when class-default-initargs
       (setf initargs (default-initargs initargs class-default-initargs)))
     (when initargs
-      (when (and (eq *boot-state* 'complete)
+      (when (and (eq **boot-state** 'complete)
                  (not (getf initargs :allow-other-keys)))
         (let ((class-proto (class-prototype class)))
           (check-initargs-1

diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index 277416f..9de5763 100644 (file)
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -202,7 +202,6 @@
 (defun set-fun-name (fun new-name)
   #+sb-doc
   "Set the name of a compiled function object. Return the function."
-  (declare (special *boot-state* *the-class-standard-generic-function*))
   (when (valid-function-name-p fun)
     (setq fun (fdefinition fun)))
   (typecase fun
@@ -211,7 +210,7 @@
     (sb-eval:interpreted-function
      (setf (sb-eval:interpreted-function-name fun) new-name))
     (funcallable-instance ;; KLUDGE: probably a generic function...
-     (cond ((if (eq *boot-state* 'complete)
+     (cond ((if (eq **boot-state** 'complete)
                 (typep fun 'generic-function)
                 (eq (class-of fun) *the-class-standard-generic-function*))
             (setf (%funcallable-instance-info fun 2) new-name))

diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp
index 4a41a28..996e05f 100644 (file)
--- a/src/pcl/macros.lisp
+++ b/src/pcl/macros.lisp
@@ -110,10 +110,8 @@
 ;;; This DEFVAR was originally in defs.lisp, now moved here.
 ;;;
 ;;; Possible values are NIL, EARLY, BRAID, or COMPLETE.
-;;;
-;;; KLUDGE: This should probably become
-;;;   (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
-(defvar *boot-state* nil)
+(declaim (type (member nil early braid complete) **boot-state**))
+(defglobal **boot-state** nil)
 
 (/show "pcl/macros.lisp 187")
 
@@ -123,7 +121,7 @@
   (if (and (constantp symbol)
            (legal-class-name-p (setf symbol (constant-form-value symbol)))
            (constantp errorp)
-           (member *boot-state* '(braid complete)))
+           (member **boot-state** '(braid complete)))
       (let ((errorp (not (null (constant-form-value errorp))))
             (cell (make-symbol "CLASSOID-CELL")))
         `(let ((,cell (load-time-value (find-classoid-cell ',symbol :create t))))
@@ -148,14 +146,14 @@
            (let ((cell (find-classoid-cell name :create new-value)))
              (cond (new-value
                     (setf (classoid-cell-pcl-class cell) new-value)
-                    (when (eq *boot-state* 'complete)
+                    (when (eq **boot-state** 'complete)
                       (let ((classoid (class-classoid new-value)))
                         (setf (find-classoid name) classoid)
                         (%set-class-type-translation new-value classoid))))
                    (cell
                     (%clear-classoid name cell)))
-             (when (or (eq *boot-state* 'complete)
-                       (eq *boot-state* 'braid))
+             (when (or (eq **boot-state** 'complete)
+                       (eq **boot-state** 'braid))
                (update-ctors 'setf-find-class :class new-value :name name))
              new-value)))
         (t

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 4bc4f1e..30ceedd 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -370,7 +370,7 @@
 \f
 (defmethod generic-function-argument-precedence-order
     ((gf standard-generic-function))
-  (aver (eq *boot-state* 'complete))
+  (aver (eq **boot-state** 'complete))
   (loop with arg-info = (gf-arg-info gf)
         with lambda-list = (arg-info-lambda-list arg-info)
         for argument-position in (arg-info-precedence arg-info)
@@ -795,7 +795,7 @@
 (defvar *std-cam-methods* nil)
 
 (defun compute-applicable-methods-emf (generic-function)
-  (if (eq *boot-state* 'complete)
+  (if (eq **boot-state** 'complete)
       (let* ((cam (gdefinition 'compute-applicable-methods))
              (cam-methods (compute-applicable-methods-using-types
                            cam (list `(eql ,generic-function) t))))

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index c9fa220..df80a18 100644 (file)
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -471,7 +471,7 @@
     initargs))
 
 (defun make-std-writer-method-function (class-or-name slot-name)
-  (let* ((class (when (eq *boot-state* 'complete)
+  (let* ((class (when (eq **boot-state** 'complete)
                   (if (typep class-or-name 'class)
                       class-or-name
                       (find-class class-or-name nil))))
@@ -585,13 +585,13 @@
          (vector (make-array n :initial-element nil))
          (save-slot-location-p
           (or bootstrap
-              (when (eq 'complete *boot-state*)
+              (when (eq 'complete **boot-state**)
                 (let ((metaclass (class-of class)))
                   (or (eq metaclass *the-class-standard-class*)
                       (eq metaclass *the-class-funcallable-standard-class*))))))
          (save-type-check-function-p
           (unless bootstrap
-            (and (eq 'complete *boot-state*) (safe-p class)))))
+            (and (eq 'complete **boot-state**) (safe-p class)))))
     (flet ((add-to-vector (name slot)
              (declare (symbol name)
                       (optimize (sb-c::insert-array-bounds-checks 0)))
@@ -605,7 +605,7 @@
                                           (slot-definition-type-check-function slot))
                                         slot)
                             (svref vector index))))))
-      (if (eq 'complete *boot-state*)
+      (if (eq 'complete **boot-state**)
          (dolist (slot slots)
            (add-to-vector (slot-definition-name slot) slot))
          (dolist (slot slots)

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index b077674..b5d0e58 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -103,7 +103,7 @@
                       (find-slot-definition class name)))
          (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
     (multiple-value-bind (function std-p)
-        (if (eq *boot-state* 'complete)
+        (if (eq **boot-state** 'complete)
             (get-accessor-method-function gf type class slotd)
             (get-optimized-std-accessor-method-function class slotd type))
       (setf (slot-accessor-std-p slotd type) std-p)
@@ -353,7 +353,7 @@
       (without-package-locks
         (setf (find-class name) class))))
   ;; After boot (SETF FIND-CLASS) does this.
-  (unless (eq *boot-state* 'complete)
+  (unless (eq **boot-state** 'complete)
     (%set-class-type-translation class name))
   class)
 
@@ -367,7 +367,7 @@
       (without-package-locks
         (setf (find-class name) class))))
   ;; After boot (SETF FIND-CLASS) does this.
-  (unless (eq *boot-state* 'complete)
+  (unless (eq **boot-state** 'complete)
     (%set-class-type-translation class name))
   class)
 

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 606acba..d009221 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -81,7 +81,7 @@
       (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists)))))
 \f
 (defun optimize-slot-value-by-class-p (class slot-name type)
-  (or (not (eq *boot-state* 'complete))
+  (or (not (eq **boot-state** 'complete))
       (let ((slotd (find-slot-definition class slot-name)))
         (and slotd
              (slot-accessor-std-p slotd type)))))
@@ -155,7 +155,7 @@
                                                          parameter-or-nil
                                                          env)))
                      (class (find-class class-name nil)))
-                (when (or (not (eq *boot-state* 'complete))
+                (when (or (not (eq **boot-state** 'complete))
                           (and class (not (class-finalized-p class))))
                   (setq class nil))
                 (when (and class-name (not (eq class-name t)))
@@ -255,7 +255,7 @@
                                  new-value &optional safep)
   (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
         (parameter (if (consp sparameter) (car sparameter) sparameter)))
-    (if (and (eq *boot-state* 'complete)
+    (if (and (eq **boot-state** 'complete)
              (classp class)
              (memq *the-class-structure-object* (class-precedence-list class)))
         (let ((slotd (find-slot-definition class slot-name)))
@@ -301,7 +301,7 @@
   (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)
+    (and (eq **boot-state** 'complete)
          (standard-class-p class)
          (not (eq class *the-class-t*)) ; shouldn't happen, though.
          (let ((slotd (find-slot-definition class slot-name)))
@@ -311,7 +311,7 @@
   (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)
+    (and (eq **boot-state** 'complete)
          (standard-class-p class)
          (not (eq class *the-class-t*)) ; shouldn't happen, though.
          ;; FIXME: Is this really right? "Don't skip if there is

diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp
index 7abe628..9027877 100644 (file)
--- a/src/pcl/wrapper.lisp
+++ b/src/pcl/wrapper.lisp
@@ -244,7 +244,7 @@
         (built-in  (find-class 'built-in-class))
         (frc       (find-class 'forward-referenced-class)))
     (flet ((specializer->metatype (x)
-             (let* ((specializer-class (if (eq *boot-state* 'complete)
+             (let* ((specializer-class (if (eq **boot-state** 'complete)
                                            (specializer-class-or-nil x)
                                            x))
                    (meta-specializer (class-of specializer-class)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 769b0f6..849163d 100644 (file)
--- 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.31.8"
+"1.0.31.9"