From 1ca4f69009204caee2484161e6eb89fa6c5fd3f6 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 15 Sep 2009 11:07:38 +0000 Subject: [PATCH] 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. --- src/pcl/boot.lisp | 123 +++++++++++++++++++++++------------------------ src/pcl/braid.lisp | 11 +++-- src/pcl/combin.lisp | 4 +- src/pcl/defclass.lisp | 2 +- src/pcl/defs.lisp | 10 ++-- src/pcl/dfun.lisp | 32 ++++++------ src/pcl/fixup.lisp | 2 +- src/pcl/init.lisp | 2 +- src/pcl/low.lisp | 3 +- src/pcl/macros.lisp | 14 +++--- src/pcl/methods.lisp | 4 +- src/pcl/slots-boot.lisp | 8 +-- src/pcl/std-class.lisp | 6 +-- src/pcl/vector.lisp | 10 ++-- src/pcl/wrapper.lisp | 2 +- version.lisp-expr | 2 +- 16 files changed, 116 insertions(+), 119 deletions(-) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 11dfa03..e9eb7a6 100644 --- 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))))) @@ -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))))))) -(setq *boot-state* 'early) +(setq **boot-state** 'early) ;;; 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 --- 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 "~@ {(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 --- 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 --- 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 --- 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 --- 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 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -370,7 +370,7 @@ (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 --- 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 --- 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 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -81,7 +81,7 @@ (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists))))) (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 --- 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 --- 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" -- 1.7.10.4